home *** CD-ROM | disk | FTP | other *** search
/ AMIGA PD 1 / AMIGA-PD-1.iso / Programme_zum_Heft / Programmieren / Kurztests / PascalPCQ / Examples / WhichFont.p < prev    next >
Text File  |  1990-07-19  |  8KB  |  252 lines
  1. Program WhichFont;
  2.  
  3. {
  4.  sample program that asks AvailFonts() to make a list of the fonts
  5.  that are available and makes a list of them, then opens a separate
  6.  window and prints a description of the various attributes that can
  7.  be applied to the fonts, in the font itself.  Notice that not all
  8.  fonts accept all attributes (garnet9 for example, won't underline)
  9.  
  10.  Also note, if you run this, that not all fonts are as easily readable
  11.  in the various bold and italicized modes.... this rendering is done
  12.  in a fixed manner by software and the fonts were not necessarily
  13.  designed to accept it.  It is always best to have a font that has
  14.  been designed with a bold or italic characteristic built-in rather
  15.  than try to bold-ize or italicize and existing plain font.
  16. }
  17.  
  18. { Author:  Rob Peck  10/28/85  }
  19. { Converted to PCQ Pascal 2/7/90.  For how little it does, this
  20.   program sure does use a lot of include files... }
  21.  
  22. {$I "Include:Graphics/Graphics.i"}
  23. {$I "Include:Graphics/Text.i"}
  24. {$I "Include:Graphics/Pens.i"}
  25. {$I "Include:Libraries/DiskFont.i"}
  26. {$I "Include:Intuition/Intuition.i"}
  27. {$I "Include:Utils/StringLib.i"}
  28. {$I "Include:Exec/Libraries.i"}
  29. {$I "Include:Exec/Interrupts.i"}
  30. {$I "Include:Graphics/RastPort.i"}
  31. {$I "Include:Libraries/DOS.i"}
  32.  
  33. Const
  34.     AFTABLESIZE = 2000;
  35.  
  36. Var
  37.     af  : AvailFontPtr;
  38.     afh : AvailFontsHeaderPtr;
  39.  
  40.     tf  : TextFontPtr;
  41.     ta  : TextAttr;
  42.  
  43. Const
  44.     nw : NewWindow = (
  45.     10, 10,        { starting position (left,top) }
  46.     620,40,        { width, height }
  47.     -1,-1,          { detailpen, blockpen }
  48.     CLOSEWINDOW_f,  { flags for idcmp }
  49.     WINDOWCLOSE + WINDOWDEPTH + WINDOWSIZING + WINDOWDRAG +
  50.     SIMPLE_REFRESH + ACTIVATE + GIMMEZEROZERO,
  51.             { window gadget flags }
  52.     Nil,              { pointer to 1st user gadget }
  53.     Nil,           { pointer to user check }
  54.     "Text Font Test", { title }
  55.     Nil,           { pointer to window screen }
  56.     Nil,           { pointer to super bitmap }
  57.     100,45,         { min width, height }
  58.     640,200,        { max width, height }
  59.     WBENCHSCREEN_f);
  60.  
  61. Var
  62.     w  : WindowPtr;
  63.     rp : RastPortPtr;
  64.  
  65. Const
  66.     text_styles : Array [0..6] of Short = (
  67.     FS_NORMAL, FSF_UNDERLINED, FSF_ITALIC, FSF_BOLD, 
  68.     FSF_ITALIC + FSF_BOLD, FSF_BOLD + FSF_UNDERLINED,
  69.     FSF_ITALIC + FSF_BOLD + FSF_UNDERLINED);
  70.  
  71.      text_desc : Array [0..6] of String = (
  72.     " Normal Text", " Underlined", " Italicized", " Bold", 
  73.     " Bold Italics", " Bold Underlined", 
  74.     " Bold Italic Underlined");
  75.  
  76.     text_length : Array [0..6] of Short = (12, 11, 11, 5, 13, 16, 23);
  77.  
  78.     pointsize  : Array [0..31] of String = (
  79.     " 0"," 1"," 2"," 3"," 4"," 5"," 6"," 7"," 8"," 9",
  80.     "10","11","12","13","14","15","16","17","18","19",
  81.     "20","21","22","23","24","25","26","27","28","29",
  82.     "30","31");
  83.  
  84. Var
  85.     fontname    : Array [0..40] of Char;
  86.     dummy    : Array [0..100] of Char; { provided for string length calculation }
  87.     outst    : Array [0..100] of Char;
  88.             { build something to give to Text, see note in 
  89.                          the program body about algorithmically
  90.                          generated styles 
  91.                          }
  92.  
  93. var
  94.     fonttypes    : Byte;
  95.     i,j,k,m    : Integer;
  96.     afsize    : Short;
  97.     style    : Short;
  98.     sEnd    : Short; { Numerical position of end of string terminator }
  99.     styleresult : Short;
  100.  
  101. Procedure Leave(r : Integer);
  102. begin
  103.     Exit(20);
  104. end;
  105.  
  106. Function IsCopy(af : AvailFontPtr) : Boolean;
  107. begin
  108.     IsCopy :=     (((af^.af_Attr.ta_Flags and FPF_REMOVED) <> 0) or
  109.         ((af^.af_Attr.ta_Flags and FPF_REVPATH) <> 0) or
  110.         (((af^.af_Type and AFF_MEMORY) <> 0) and
  111.         ((af^.af_Attr.ta_Flags and FPF_DISKFONT) <> 0)));
  112.  
  113.        { do nothing if font is removed, or if
  114.      font designed to be rendered rt->left
  115.      (simple example writes left to right)
  116.      or if font both on disk and in ram, 
  117.      don't list it twice. }
  118.  
  119.        { AvailFonts performs an AddFont to the system list;
  120.      if run twice, you get two entries, one of "af_Type 1" saying
  121.      that the font is memory resident, and the other of "af_Type 2"
  122.      saying the font is disk-based.  The third part of the 
  123.      if-statement lets you tell them apart if you are scanning
  124.      the list for unique elements;  it says "if its in memory and
  125.      it is from disk, then don't list it because you'll find another
  126.      entry in the table that says it is not in memory, but is on disk.
  127.      (Another task might have been using the font as well, creating
  128.      the same effect).
  129.     }
  130. end;
  131.  
  132. Begin
  133.     DiskFontBase := OpenLibrary("diskfont.library",0);
  134.     if DiskFontBase = Nil then
  135.     leave(-4);
  136.     GfxBase := OpenLibrary("graphics.library",0);
  137.     if GfxBase = Nil then
  138.     leave(-3);
  139.  
  140.     tf := Nil;        { no font currently selected }
  141.     afsize := AFTABLESIZE;   { show how large a buffer is available }
  142.     fonttypes := $ff;       { show us all font types }
  143.  
  144.     w := OpenWindow(Adr(nw));
  145.     if w <> nil then begin
  146.     rp := w^.RPort;
  147.  
  148.     afh := AvailFontsHeaderPtr(AllocString(afsize));
  149.  
  150.     Move(rp, 10, 20);
  151.     GText(rp, "Searching for fonts",19);
  152.     j := AvailFonts(afh, afsize, fonttypes);
  153.  
  154.     for m := 0 to 1 do begin
  155.         SetAPen(rp,1);
  156.  
  157.         if m = 0 then
  158.         SetDrMd(rp,JAM1)
  159.         else
  160.         SetDrMd(rp,JAM1+INVERSVID);
  161.  
  162.         { now print a line that says what font and what style it is }
  163.  
  164.         for j := 0 to Pred(afh^.afh_NumEntries) do begin
  165.         af := Adr(afh^.afh_AF[j]);
  166.         strcpy(String(Adr(FontName)), af^.af_Attr.ta_Name);
  167.                         { copy name into build-name area }
  168.                         { already has ".font" onto end of it }
  169.         ta.ta_Name := String(Adr(fontname));
  170.         ta.ta_YSize := af^.af_Attr.ta_YSize;     { ask for this size }
  171.         ta.ta_Style := af^.af_Attr.ta_Style;     { ask for designed style }
  172.         ta.ta_Flags := FPF_ROMFONT + FPF_DISKFONT +
  173.                 FPF_PROPORTIONAL + FPF_DESIGNED;
  174.                 { accept it from anywhere it exists }
  175.         style := ta.ta_Style;
  176.  
  177.         if not IsCopy(af) then begin
  178.             tf := OpenDiskFont(Adr(ta));
  179.             if tf <> Nil then begin
  180.             SetFont(rp, tf);
  181.             for k := 0 to 6 do begin
  182.                 style := text_styles[k];
  183.                 styleresult := SetSoftStyle(rp,style,255);
  184.                 SetRast(rp,0);   { erase any previous text }
  185.                 Move(rp,10,20);  { move down a bit from the top }
  186.                 strcpy(Adr(outst), af^.af_Attr.ta_Name);
  187.                 strcat(Adr(outst), "  ");
  188.                 strcat(Adr(outst), PointSize[af^.af_Attr.ta_YSize]);
  189.                 strcat(Adr(outst), " Points, ");
  190.                 strcat(Adr(outst), text_desc[k]);
  191.                 GText(rp,Adr(outst),strlen(Adr(outst)));
  192.     {
  193.     Have to build the string before sending it out to
  194.     text IF ALGORITHMICALLY GENERATING THE STYLE since 
  195.     the kerning and spacing tables are based on the
  196.     vanilla text, and not the algorithmically generated
  197.     style.  If you send characters out individually,
  198.     it is possible that the enclosing rectangle of
  199.     a later character will chop off the trailing edge
  200.     of a preceding character 
  201.     }
  202.  
  203.     { ************************************************** 
  204.       This alternate method, when in INVERSVID, exhibits the
  205.       problem described above.
  206.  
  207.             GText(rp,af^.af_Attr.taName,strlen(af^.af_Attr.taName));
  208.             GText(rp,"  ",2);
  209.             GText(rp,pointsize[af^.af_Attr.taYSize],2);
  210.             GText(rp," Points, ",9);
  211.         
  212.             GText(rp,text_desc[k],text_length[k]);
  213.       **************************************************  } 
  214.  
  215.                 Delay(40);  { use the DOS time delay function 
  216.                       specifies 60ths of a second }
  217.                 if GetMsg(w^.UserPort) <> Nil then begin
  218.                 CloseFont(tf);
  219.                 Forbid;
  220.                 repeat until GetMsg(w^.UserPort) = Nil;
  221.                 CloseWindow(w);
  222.                 Permit;
  223.                 CloseLibrary(DiskfontBase);   
  224.                 CloseLibrary(GfxBase);
  225.                 exit(0);
  226.                 end;
  227.             end;
  228.             CloseFont(tf); { close the old one }
  229.  
  230.        { NOTE: 
  231.             Even though you close a font, it doesn't get unloaded
  232.             Memory unless a font with a different name is specified
  233.             for loading.  In this case, any font (except the topaz
  234.             set) which has been closed can have its memory area
  235.             freed and it will no longer be accessible.  If you close
  236.             a font to go to a different point-size, it will NOT cause
  237.             a disk-access.  
  238.        
  239.          ALSO NOTE:   
  240.              Loading a font loads ALL of the point
  241.              sizes contained in that font's directory!!!!
  242.         }
  243.             end;
  244.         end;
  245.         end;
  246.     end;
  247.     CloseWindow(w);
  248.     end;
  249.     CloseLibrary(DiskfontBase);   
  250.     CloseLibrary(GfxBase);
  251. end.
  252.