home *** CD-ROM | disk | FTP | other *** search
/ Gold Fish 3 / goldfish_volume_3.bin / files / dev / obero / oberon-a / source / projectoberon / fonts.mod < prev    next >
Encoding:
Text File  |  1995-07-02  |  3.3 KB  |  120 lines
  1. (*************************************************************************
  2.  
  3.      $RCSfile: Fonts.mod $
  4.   Description: Port of the Project Oberon Fonts module.
  5.                Interface based on module Fonts for the Ceres Oberon
  6.                System, created by J. Gutknecht (JG 27.8.90).
  7.  
  8.    Created by: fjc (Frank Copeland)
  9.     $Revision: 1.14 $
  10.       $Author: fjc $
  11.         $Date: 1995/06/04 23:24:07 $
  12.  
  13.   Copyright © 1994-1995, Frank Copeland.
  14.   This file is part of the Oberon-A Library.
  15.   See Oberon-A.doc for conditions of use and distribution.
  16.  
  17. *************************************************************************)
  18.  
  19. <* STANDARD- *>
  20.  
  21. MODULE Fonts;
  22.  
  23. IMPORT
  24.   SYS := SYSTEM, Kernel, e := Exec, d := Dos, gfx := Graphics,
  25.   df := DiskFont, str := Strings, conv := Conversions, as := AmigaSupport,
  26.   Display;
  27.  
  28. TYPE
  29.  
  30.   Name * = ARRAY 32 OF CHAR;
  31.  
  32.   Font * = POINTER TO FontDesc;
  33.   FontDesc * = RECORD
  34.     name * : Name;
  35.     height*, minX*, maxX*, minY*, maxY*: INTEGER;
  36.     raster*: Display.Font;
  37.     next : Font;
  38.   END; (* FontDesc *)
  39.  
  40. VAR
  41.  
  42.   Default *, FontList : Font;
  43.  
  44. (*------------------------------------*)
  45. PROCEDURE This * (name : ARRAY OF CHAR) : Font;
  46.  
  47.   VAR
  48.     F : Font; attr : gfx.TextAttr; family, size : ARRAY 32 OF CHAR;
  49.     pathPart, filePart : e.LSTRPTR; height : LONGINT; tf : gfx.TextFontPtr;
  50.  
  51. <*$CopyArrays-*>
  52. BEGIN (* This *)
  53.   F := FontList; WHILE (F # NIL) & (name # F.name) DO F := F.next END;
  54.   IF F = NIL THEN
  55.     COPY (name, family); pathPart := d.PathPart (family); pathPart[0] := 0X;
  56.     IF family # "" THEN
  57.       filePart := d.FilePart (name); COPY (filePart^, size);
  58.       IF conv.StrToInt (size, 10, height) THEN
  59.         SYS.NEW (attr.name, str.Length (family) + 1);
  60.         ASSERT (attr.name # NIL, 98);
  61.         COPY (family, attr.name^);
  62.         attr.ySize := SHORT (height);
  63.         attr.flags := {}; attr.style := {};
  64.         tf := df.OpenDiskFont (attr);
  65.         IF tf # NIL THEN
  66.           NEW (F); ASSERT (F # NIL, 98);
  67.           NEW (F.raster); ASSERT (F.raster # NIL, 98);
  68.           COPY (name, F.name); F.height := tf.ySize;
  69.           F.minX := 0; F.maxX := tf.xSize;
  70.           F.minY := tf.baseline - tf.ySize; F.maxY := tf.baseline;
  71.           F.raster.textFont := tf;
  72.           F.next := FontList; FontList := F
  73.         ELSE
  74.           RETURN Default
  75.         END;
  76.       ELSE
  77.         RETURN Default
  78.       END;
  79.     ELSE
  80.       RETURN Default
  81.     END;
  82.   END;
  83.   RETURN F
  84. END This;
  85.  
  86. (*------------------------------------*)
  87. PROCEDURE GetDefault ();
  88.  
  89.   VAR defFont : gfx.TextFontPtr; ta : gfx.TextAttrPtr;
  90.  
  91. BEGIN (* GetDefault *)
  92.   defFont := as.scrFont;
  93.   NEW (Default); ASSERT (Default # NIL, 98);
  94.   NEW (Default.raster); ASSERT (Default.raster # NIL, 98);
  95.   Default.name := "Default"; Default.height := defFont.ySize;
  96.   Default.minX := 0; Default.maxX := defFont.xSize;
  97.   Default.minY := defFont.baseline - defFont.ySize;
  98.   Default.maxY := defFont.baseline;
  99.   Default.raster.textFont := defFont;
  100.   Default.next := FontList; FontList := Default
  101. END GetDefault;
  102.  
  103.  
  104. (*------------------------------------*)
  105. PROCEDURE* Cleanup ( VAR rc : LONGINT );
  106.  
  107.   VAR F : Font;
  108.  
  109. BEGIN (* Cleanup *)
  110.   F := FontList;
  111.   WHILE F # NIL DO
  112.     IF F.name # "Default" THEN gfx.CloseFont (F.raster.textFont) END;
  113.     F := F.next
  114.   END
  115. END Cleanup;
  116.  
  117. BEGIN
  118.   Kernel.SetCleanup (Cleanup); as.OpenDisplay; GetDefault
  119. END Fonts.
  120.