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

     $RCSfile: Fonts.mod $
  Description: Port of the Project Oberon Fonts module

   Created by: J. Gutknecht
    Ported by: fjc (Frank Copeland)
    $Revision: 1.2 $
      $Author: fjc $
        $Date: 1994/05/12 20:45:18 $

  Copyright © 1990-1993, ETH Zuerich
  Copyright © 1994, Frank Copeland.
  This file is part of the Oberon-A Library.
  See Oberon-A.doc for conditions of use and distribution.

  Log entries are at the end of the file.

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

MODULE Fonts;

(* P- allow non-portable code *)

IMPORT
  SYS := SYSTEM, T := Types, Exec, Gfx := Graphics, DF := DiskFont,
  Str := Strings;

TYPE

  Name * = ARRAY 32 OF CHAR;

  Font * = POINTER TO FontDesc;
  FontDesc * = RECORD
    name * : Name;
    height * : INTEGER;
    textAttr * : Gfx.TextAttrPtr;
    textFont * : Gfx.TextFontPtr;
    next : Font;
  END; (* FontDesc *)

VAR

  Default *, First : Font;
  nofFonts : INTEGER;
  OldCleanup : PROCEDURE (rc : LONGINT);

(*------------------------------------*)
(* $D- disable copying of open arrays *)

PROCEDURE This * (name : ARRAY OF CHAR) : Font;
(*
 *  Opens the font described by name and returns a descriptor for it.
 *  name is required to be in the common Amiga notation for fonts, namely:
 *
 *    <font name>/<font size>
 *
 *  For example: "topaz/8" refers to the size 8 version of the topaz font.
 *)

  VAR
    F : Font; fontName : Name; len, pos : LONGINT; size, i : INTEGER;
    ch : CHAR; textAttr : Gfx.TextAttrPtr; textFont : Gfx.TextFontPtr;

BEGIN (* This *)
  F := First; WHILE (F # NIL) & (name # F.name) DO F := F.next END;
  IF F = NIL THEN
    COPY (name, fontName);
    pos := Str.FindChar ("/", fontName, 0);
    IF pos >= 0 THEN
      len := Str.Length (fontName);
      IF len > (pos + 1) THEN
        i := SHORT (pos) + 1; size := 0; ch := fontName [i];
        WHILE (i < len) & (ch >= "0") & (ch <= "9") DO
          size := (size * 10) + (ORD (ch) - ORD ("0"));
          INC (i); ch := fontName [i]
        END; (* WHILE *)
        IF i = len THEN
          fontName [pos] := 0X; Str.Append (fontName, ".font");
          NEW (textAttr);
          SYS.NEW (textAttr.taName, Str.Length (fontName) + 1);
          COPY (fontName, textAttr.taName^);
          textAttr.taYSize := size;
          textAttr.taStyle := Gfx.fsNormal;
          textAttr.taFlags := {Gfx.fpDiskFont};
          textFont := DF.Base.OpenDiskFont (textAttr^);
          IF textFont # NIL THEN
            NEW (F);
            COPY (name, F.name); F.height := size;
            F.textAttr := textAttr; F.textFont := textFont;
            F.next := First; First := F
          ELSE
            SYS.DISPOSE (textAttr.taName); SYS.DISPOSE (textAttr);
            F := Default
          END; (* ELSE *)
        ELSE
          F := Default
        END; (* ELSE *)
      ELSE
        F := Default
      END; (* ELSE *)
    ELSE
      F := Default
    END; (* ELSE *)
  END; (* IF *)
  RETURN F
END This;

(*------------------------------------*)
PROCEDURE* Cleanup (rc : LONGINT);

  VAR F : Font;

BEGIN (* Cleanup *)
  F := First;
  WHILE F # Default DO
    IF F.textFont # NIL THEN Gfx.Base.CloseFont (F.textFont^) END;
    F := F.next
  END; (* WHILE *)
  IF OldCleanup # NIL THEN OldCleanup (rc) END
END Cleanup;

(*------------------------------------*)
PROCEDURE GetDefault ();

  VAR df : Gfx.TextFontPtr; ta : Gfx.TextAttrPtr;

BEGIN (* GetDefault *)
  df := Gfx.Base.DefaultFont;
  NEW (ta);
  ta.taName := df.lnName; ta.taYSize := df.tfYSize;
  ta.taStyle := df.tfStyle; ta.taFlags := df.tfFlags;
  NEW (Default);
  COPY (df.lnName^, Default.name); Default.height := df.tfYSize;
  Default.textAttr := ta; Default.textFont := df; Default.next := NIL;
END GetDefault;

BEGIN (* Fonts *)
  DF.OpenLib ();
  GetDefault ();
  First := Default; nofFonts := 1;
  SYS.SETCLEANUP (Cleanup, OldCleanup)
END Fonts.

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

  $Log: Fonts.mod $
  Revision 1.2  1994/05/12  20:45:18  fjc
  - Prepared for release

# Revision 1.1  1994/01/15  21:39:12  fjc
# Start of revision control
#
***************************************************************************)