(**********************************************************************

:Program.    OFont (IMPLEMENTATION MODULE)

:Contents.   ersetzt Graphics.OpenFont, wobei dem Programmierer viel
:Contents    Arbeit abgenommen wird, z. Bsp. der gesamte Avail-Kram.

:Copyright.  Public Domain

:Author.     Thomas Ansorge

:Address.    Dinkelackerring 55, W-6730 Neustadt, Deutschland

:Language.   Modula-2

:Translator. M2Amiga V4.0 (deutsch)

:History.    Version 1.0 vom 22.06.1991

**********************************************************************)

IMPLEMENTATION MODULE OFont;

FROM Arts IMPORT Assert;

FROM DiskFontD IMPORT AvailFont, AvailFontHeader, AvailFontHeaderPtr,
                      AvailFontTypes, AvailFontsSet;

FROM DiskFontL IMPORT AvailFonts, OpenDiskFont;

IMPORT GD:GraphicsD;

IMPORT GL:GraphicsL;

FROM Heap IMPORT Largest, Allocate, Deallocate;

FROM String IMPORT Compare;

FROM SYSTEM IMPORT ADR, ADDRESS;

(* ----------------------------------------------------------------- *)

PROCEDURE OpenFont (Attr: GD.TextAttrPtr): GD.TextFontPtr;

   CONST (* Fehlermeldungen *)
         KeinFont       = "OpenFont: kann Font nicht finden!";
         Ladefehler     = "OpenFont: Ladefehler!";
         Speichermangel = "OpenFont: nicht genug Speicher!";

   TYPE String    = ARRAY [0..80] OF CHAR;
        StringPtr = POINTER TO String;

   VAR AFont   : POINTER TO AvailFont;
       Buffer  : AvailFontHeaderPtr; (* für AvailFonts *)
       BGroesse: LONGINT; (* Buffer für AvailFonts *)
       Font    : GD.TextFontPtr; (* der Font *)
       i       : CARDINAL;
       PToStr1,
       PToStr2 : POINTER TO ARRAY [0..30] OF CHAR; (* Fontnamen *)
       Ok      : LONGINT;

   (* -------------------------------------------------------------- *)

   BEGIN (* Funktion OpenFont *)

   Font := NIL;

   BGroesse := 1024;

   REPEAT
      IF Largest (FALSE) >= BGroesse THEN
         Allocate (Buffer, BGroesse);
      ELSE (* IF Largest *)
         Assert (FALSE, ADR (Speichermangel));
      END (* IF Largest *);

      Ok := AvailFonts (Buffer, BGroesse, AvailFontsSet {memory});

      IF Ok # 0 THEN
         Deallocate (Buffer);

         BGroesse := BGroesse + Ok;
      END (* IF Ok *);
   UNTIL Ok = 0;

   AFont := ADR (Buffer^);
   INC (AFont, SIZE (Buffer^.numEntries));

   i := 0;
   PToStr1 := AFont^.attr.name;
   PToStr2 := Attr^.name;

   WHILE (i < Buffer^.numEntries)
         AND NOT ((Compare (PToStr1^, PToStr2^) = 0)
                  AND (AFont^.attr.ySize = Attr^.ySize)) DO
      INC (i);

      IF i < Buffer^.numEntries THEN
         INC (AFont, SIZE (AFont^));
         PToStr1 := AFont^.attr.name;
      END (* IF i *);
   END (* WHILE (i *);

   IF i = Buffer^.numEntries THEN
      (* Font nicht im Speicher *)
      REPEAT
         Ok := AvailFonts (Buffer, BGroesse, AvailFontsSet {disk});

         IF Ok # 0 THEN
            Deallocate (Buffer);

            BGroesse := BGroesse + Ok;

            IF Largest (FALSE) >= BGroesse THEN
               Allocate (Buffer, BGroesse);
            ELSE (* IF Largest *)
               Assert (FALSE, ADR (Speichermangel));
            END (* IF Largest *);
         END (* IF Ok *);
      UNTIL Ok = 0;

      AFont := ADR (Buffer^);
      INC (AFont, SIZE (Buffer^.numEntries));

      i := 0;
      PToStr1 := AFont^.attr.name;

      WHILE (i < Buffer^.numEntries)
            AND NOT ((Compare (PToStr1^, PToStr2^) = 0)
                     AND (AFont^.attr.ySize = Attr^.ySize)) DO
         INC (i);

         IF i < Buffer^.numEntries THEN
            INC (AFont, SIZE (AFont^));
            PToStr1 := AFont^.attr.name;
         END (* IF i *);
      END (* WHILE (i *);

      Assert ((i < Buffer^.numEntries), ADR (KeinFont));

      Deallocate (Buffer);

      Font := OpenDiskFont (Attr);
   ELSE (* doch ROM-Font *)
      Deallocate (Buffer);

      Font := GL.OpenFont (Attr);
   END (* IF i = *);

   Assert (Font # NIL, ADR (Ladefehler));

   RETURN Font;
END OpenFont (* Funktion *);

(* ----------------------------------------------------------------- *)

END (* IMPLEMENTATION MODULE *) OFont.