Program WhichFont;

{
   Program d'exemple qui interroge AvailFonts() pour obtenir une liste
   des fontes disponibles et en dresser la liste, qui ouvre ensuite une
   fenêtre séparée et affiche la description des différents attributs
   qu'on peut appliquer aux fontes, en employant la fonte elle-même.
   Remarquez que toutes les fontes n'acceptent pas tous les attributs
   (garnet9, par exemple, n'accepte pas le souligné).

   Notez aussi, si vous lancez le programme, que toutes les fontes ne
   sont pas aisément lisibles dans les différents modes italiques, gras...
}

{$I "Include:Graphics/Graphics.i"}
{$I "Include:Graphics/Pens.i"}
{$I "Include:Libraries/DiskFont.i"}
{$I "Include:Intuition/Intuition.i"}
{$I "Include:Utils/StringLib.i"}
{$I "Include:Exec/Libraries.i"}
{$I "Include:Exec/Interrupts.i"}
{$I "Include:Graphics/RastPort.i"}
{$I "Include:Libraries/DOS.i"}

Const
    AFTABLESIZE = 2000;

Var
    af  : AvailFontPtr;
    afh : AvailFontsHeaderPtr;

    tf  : TextFontPtr;
    ta  : TextAttr;

Const
    nw : NewWindow = (
        10, 10,           { position de début (gauche, haut) }
        620,40,           { largeur, hauteur }
        -1,-1,            { couleur texte, couleur barre }
        CLOSEWINDOW_f,    { flags pour idcmp }
        WINDOWCLOSE + WINDOWDEPTH + WINDOWSIZING + WINDOWDRAG +
        SIMPLE_REFRESH + ACTIVATE + GIMMEZEROZERO,
                          { flags pour les gadgets de fenêtre }
        Nil,              { pointeur sur le 1er gadget utilisateur }
        Nil,              { pointeur sur le crochet utilisateur }
        "Text Font Test", { titre }
        Nil,              { pointeur sur l'écran de la fenêtre }
        Nil,              { pointeur sur la superbitmap }
        100,45,           { largeur, hauteur mini }
        640,200,          { largeur, hauteur maxi }
        WBENCHSCREEN_f);

Var
    w  : WindowPtr;
    rp : RastPortPtr;

Const
    text_styles : Array [0..6] of Short = (
        FS_NORMAL, FSF_UNDERLINED, FSF_ITALIC, FSF_BOLD,
        FSF_ITALIC + FSF_BOLD, FSF_BOLD + FSF_UNDERLINED,
        FSF_ITALIC + FSF_BOLD + FSF_UNDERLINED);

     text_desc : Array [0..6] of String = (
        " Normal Text", " Underlined", " Italicized", " Bold",
        " Bold Italics", " Bold Underlined",
        " Bold Italic Underlined");

    text_length : Array [0..6] of Short = (12, 11, 11, 5, 13, 16, 23);

    pointsize  : Array [0..31] of String = (
        " 0"," 1"," 2"," 3"," 4"," 5"," 6"," 7"," 8"," 9",
        "10","11","12","13","14","15","16","17","18","19",
        "20","21","22","23","24","25","26","27","28","29",
        "30","31");

Var
    fontname    : Array [0..40] of Char;
    dummy       : Array [0..100] of Char; { fourni pour le calcul de
                                            la longueur de la chaîne
                                            de caractères }
    outst       : Array [0..100] of Char;
                        { construire quelque chose à donner à Text;
                          cf. note dans le corps du programme sur les 
                          styles générés de manière algorithmique
                        }

var
    fonttypes   : Byte;
    i,j,k,m     : Integer;
    afsize      : Short;
    style       : Short;
    sEnd        : Short; { Position numérique de fin de la terminaison
                           de chaîne }
    styleresult : Short;

Procedure Leave(r : Integer);
begin
    Exit(20);
end;

Function IsCopy(af : AvailFontPtr) : Boolean;
begin
    IsCopy :=   (((af^.af_Attr.ta_Flags and FPF_REMOVED) <> 0) or
                ((af^.af_Attr.ta_Flags and FPF_REVPATH) <> 0) or
                (((af^.af_Type and AFF_MEMORY) <> 0) and
                ((af^.af_Attr.ta_Flags and FPF_DISKFONT) <> 0)));

       { ne rien faire si la fonte est supprimée ou si
         la fonte est prévue pour un rendu droite->gauche
         (un exemple simple écrit de gauche à droite) ou
         si la fonte sur la disquette et celle en mémoire
         vive, ne pas les lister deux fois. }

       { AvailFonts exécute un AddFont dans la liste du système;
         si on le lance deux fois, on obtient deux entrées, l'une
         "af_Type 1" qui dit que la fonte est résidente en mémoire
         et l'autre "af_Type 2" qui dit que la fonte se trouve sur
         la disquette. La troisième partie des instructions 'if'
         permet de leur dire séparément si l'on analyse la liste
         pour des éléments uniques; elle dit "si elle se trouve en
         mémoire et est en provenance de la disquette, alors ne
         pas la lister car on trouvera une autre entrée dans la
         table qui dit qu'elle n'est pas en mémoire mais sur la
         disquette". (Une autre tâche pourrait aussi bien employer
         la fonte, en provoquant le même résultat.)
        }
end;

Begin
    DiskFontBase := OpenLibrary("diskfont.library",0);
    if DiskFontBase = Nil then
        leave(-4);
    GfxBase := OpenLibrary("graphics.library",0);
    if GfxBase = Nil then
        leave(-3);

    tf := Nil;              { aucune fonte n'est actuellement sélectionnée }
    afsize := AFTABLESIZE;  { montrer la taille du tampon disponible }
    fonttypes := $ff;       { montrer tous les types defontes }

    w := OpenWindow(Adr(nw));
    if w <> nil then begin
        rp := w^.RPort;

        afh := AvailFontsHeaderPtr(AllocString(afsize));

        Move(rp, 10, 20);
        GText(rp, "Searching for fonts",19);
        j := AvailFonts(afh, afsize, fonttypes);

        for m := 0 to 1 do begin
            SetAPen(rp,1);

            if m = 0 then
                SetDrMd(rp,JAM1)
            else
                SetDrMd(rp,JAM1+INVERSVID);

        { maintenant imprimer une ligne pour informer de quelle fonte
                       et de quel style il s'agit }

            for j := 0 to Pred(afh^.afh_NumEntries) do begin
                af := Adr(afh^.afh_AF[j]);
                strcpy(String(Adr(FontName)), af^.af_Attr.ta_Name);
                     { copier le nom dans la partie incorporée au nom }
                       { ".font" existe déjà à la fin de celle-ci }
                ta.ta_Name := String(Adr(fontname));
                ta.ta_YSize := af^.af_Attr.ta_YSize;     { demander cette
                                                           taille }
                ta.ta_Style := af^.af_Attr.ta_Style;     { demander le style
                                                           prévu }
                ta.ta_Flags := FPF_ROMFONT + FPF_DISKFONT +
                                FPF_PROPORTIONAL + FPF_DESIGNED;
                { l'accepter quelle qu'elle soit sa provenance s'il existe }
                style := ta.ta_Style;

                if not IsCopy(af) then begin
                    tf := OpenDiskFont(Adr(ta));
                    if tf <> Nil then begin
                        SetFont(rp, tf);
                        for k := 0 to 6 do begin
                            style := text_styles[k];
                            styleresult := SetSoftStyle(rp,style,255);
                            SetRast(rp,0);  { effacer tout texte antérieur }
                            Move(rp,10,20); { descendre légèrement à partir
                                              du haut }
                            strcpy(Adr(outst), af^.af_Attr.ta_Name);
                            strcat(Adr(outst), "  ");
                            strcat(Adr(outst), PointSize[af^.af_Attr.ta_YSize]);
                            strcat(Adr(outst), " Points, ");
                            strcat(Adr(outst), text_desc[k]);
                            GText(rp,Adr(outst),strlen(Adr(outst)));
        {
          Il va falloir construire la chaîne de caractères
          avant de sortir le texte si ON GENERE LE STYLE DE
          MANIERE ALGORITHMIQUE, étant donné que les tables
          d'espacement et d'interlettrage se basent sur un
          texte de type 'vanilla' et non sur un style généré
          de manière algorithmique. Si on sort les caractères
          individuellement, il est possible que le rectangle
          qui renferme le caractère suivant empiète sur le
          bord de fin du caractère précédent.
        }

        { *****************************************************
          Cette méthode alternative, quand on est en INVERSVID,
          expose le problème décrit ci-dessus.

                        GText(rp,af^.af_Attr.taName,strlen(af^.af_Attr.taName));
                        GText(rp,"  ",2);
                        GText(rp,pointsize[af^.af_Attr.taYSize],2);
                        GText(rp," Points, ",9);

                        GText(rp,text_desc[k],text_length[k]);
          *****************************************************  }

                            Delay(40);  { utiliser la fonction de délai
                                          du DOS; indique les 60èmes de
                                          secondes   }
                            if GetMsg(w^.UserPort) <> Nil then begin
                                CloseFont(tf);
                                Forbid;
                                repeat; until GetMsg(w^.UserPort) = Nil;
                                CloseWindow(w);
                                Permit;
                                CloseLibrary(DiskfontBase);
                                CloseLibrary(GfxBase);
                                exit(0);
                            end;
                        end;
                        CloseFont(tf); { fermer l'ancienne fonte }

       { NOTE :
            Même si on a fermé une fonte, celle-ci reste en mémoire
            tant qu'on n'indiquera pas de charger une fonte avec un
            nom différent. Dans ce cas, n'importe quelle fonte (à
            l'exception du jeu de fontes 'topaz') qu'on aura fermée
            pourra libérer la zone de mémoire qu'elle occupe et il
            ne sera plus possible d'y avoir accès. Si l'on ferme une
            fonte pour pouvoir obtenir une taille différente, ceci
            NE provoque PAS un nouvel accès à la disquette.

         NOTEZ AUSSI :
             Le chargement d'une fonte charge TOUTES les tailles de
             la fonte présentes dans le répertoire de cette fonte !!!
        }
                    end;
                end;
            end;
        end;
        CloseWindow(w);
    end;
    CloseLibrary(DiskfontBase);
    CloseLibrary(GfxBase);
end.