(*------------------------------------------------------------------------------
    Project	: FontList
    Module	: FontList.mod
    Author	: Robert Brandner (rb)
    Address	: Schillerstr. 3 / A-8280 Fürstenfeld / AUSTRIA / EUROPE
    Copyright	: Public Domain
    Language	: Modula-II (M2Amiga V4.0d)
    History	: V0.1 24-Mar 91, rb
    History	: V0.5 25-Mar 91, rb Ausgabe auf unsichtbare Bitmap
    History	: V0.6 22-Aug 91, rb Anpassung an V4.0
    Contents	: Liste aller Fonts in FONTS: mit Schriftprobe ausdrucken.
------------------------------------------------------------------------------*)

(*$ StackChk    := FALSE *)
(*$ RangeChk    := FALSE *)
(*$ OverflowChk := FALSE *)
(*$ ReturnChk   := FALSE *)
(*$ LongAlign   := FALSE *) (* make this TRUE for MC680x0, x>1 *)
(*$ Volatile	:= FALSE *)
(*$ LargeVars   := FALSE *)
(*$ StackParms  := FALSE *)

MODULE FontList;

FROM DosD         IMPORT sharedLock,FileInfoBlock,FileLockPtr,
		         FileHandlePtr,newFile;
FROM DosL         IMPORT Lock,UnLock,Examine,ExNext,Open,Close,Write;
FROM Arts         IMPORT Terminate;
FROM SYSTEM       IMPORT ADR;
FROM String       IMPORT Copy,Concat,Length;
FROM Conversions  IMPORT StrToVal;
FROM GraphicsD	  IMPORT TextAttr,TextFontPtr,normalFont,FontFlags,FontFlagSet,
			 RastPortPtr,RastPort,ColorMapPtr,BitMap,
			 ViewModeSet;
FROM GraphicsL	  IMPORT SetFont,CloseFont,SetRGB4CM,SetRast,Move,Text,SetAPen,
			 InitRastPort,InitBitMap,AllocRaster,FreeRaster,
			 GetColorMap;
FROM DiskFontL	  IMPORT OpenDiskFont;
FROM HardCopy	  IMPORT DumpRPort;
FROM Printer      IMPORT Error,SpecialSet;
FROM Terminal     IMPORT WriteString,WriteLn;

CONST TITLE="\[1mFontList V0.6\[0m  © '91 Robert Brandner";
      TEXT="AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZzÄÖöÜü";
      FLAGS=FontFlagSet{romFont,diskFont,proportional,designed};
      PRTERROR="Can't open PRT:";
      BMERROR="No memory for Bitplane.";
      F1ERROR="FONTS: not found.";
      F2ERROR="FONTS: assigned to file.";

VAR lock, lock2 : FileLockPtr;
    (*$ LongAlign := TRUE *)	 (* Dos braucht Variablen an Langwortgrenzen! *)
    info,info2  : FileInfoBlock;
    (*$ POP LongAlign *)
    ok, prtok   : BOOLEAN;
    Path, FName : ARRAY[0..99] OF CHAR;
    size, max   : LONGINT;
    rp	        : RastPort;
    bm	        : BitMap;
    cm	        : ColorMapPtr;
    ta          : TextAttr;
    font        : TextFontPtr;
    prterr      : Error;
    printer     : FileHandlePtr;
    newline     : ARRAY[0..0] OF CHAR;

(*------------------------------------------------------------------------------
    String auf Drucker ausgeben. (Drucker wird jedesmal wieder ge-
    schlossen, da es sonst zu Kollisionen mit DumpRPort kommt.
------------------------------------------------------------------------------*)

PROCEDURE Print(txt:ARRAY OF CHAR);
VAR act:LONGINT;
BEGIN
  printer:=Open(ADR("PRT:"),newFile);   	(* Printer als File öffnen.   *)
  IF printer=NIL THEN
    WriteString(PRTERROR); WriteLn;		(* melden, daß Printer nicht  *)
    Terminate;					(* geöffnet werden konnte.    *)
  END;
  (*$ StackParms := TRUE *)
  act:=Write(printer,ADR(txt),Length(txt)); 	(* Text ausgeben 	      *)
  (* POP StackParms *)
  WriteString(txt); 				(* gleichen Text auf Screen   *)
  Close(printer); printer:=NIL;			(* Printer schließen.         *)
END Print;

(*--- Anzeigen des Fonts <FName>.font, in Größe <max>. -----------------------*)

PROCEDURE ShowFont;
BEGIN
  Concat(FName,".font");	  	(* Fontnamen ergänzen	 	      *)
  WITH ta DO			  	(* TextAttr-Struktur füllen 	      *)
    name:=ADR(FName);		  	(* Fontname 			      *)
    ySize:=max;			  	(* Fonthöhe 			      *)
    style:=normalFont;		 	(* normale Schriftart	 	      *)
    flags:=FLAGS;		  	(* wenn möglich, prop. und designed   *)
  END;
  font:=OpenDiskFont(ADR(ta));    	(* Font öffnen		  	      *)
  IF font#NIL THEN		  	(* erfolgreich geöffnet               *)
    SetRast(ADR(rp),0);		  	(* Screen löschen		      *)
    SetFont(ADR(rp),font);	  	(* neuen Font verwenden	              *)
    Move(ADR(rp),5,5+rp.txBaseline);
    Text(ADR(rp),ADR(TEXT),58);   	(* Test-Text auf Bitmap ausgeben      *)
    CloseFont(font);		  	(* Font wieder schließen              *)
    font:=NIL;
    prtok:=DumpRPort(ADR(rp),cm,ViewModeSet{},0,0,960,rp.txHeight+10,
    		     960,rp.txHeight+10,SpecialSet{},prterr);
  ELSE
    Print("Couldn't open"); 	  	(* melden, daß Font nicht geöffnet    *)
    Print(newline);	 	  	(* werden konnte.		      *)
  END;
END ShowFont;

(*------------------------------------------------------------------------------
    Durchsuchen des FONTS:Fontname Directorys. Einträge sollten Files
    sein, und als Namen die Größe haben (8,9,11,...).
------------------------------------------------------------------------------*)

PROCEDURE ScanSizes(Path:ARRAY OF CHAR);
VAR ok,signed,err:BOOLEAN;
BEGIN
  signed:=FALSE;
  max:=1;
  lock2:=Lock(ADR(Path),sharedLock);
  IF lock2=NIL THEN RETURN END;            	(* kann nicht zugreifen.      *)
  ok:=Examine(lock2,ADR(info2));
  REPEAT			           	(* Ganzes Dir. durchsuchen    *)
    ok:=ExNext(lock2,ADR(info2));
    IF ok THEN
      IF info2.dirEntryType<0 THEN         	(* Ein File gefunden.         *)
        StrToVal(info2.fileName,size,      	(* in Zahl umwandeln, zum     *)
                 signed,10,err);	   	(* Größenvergleich            *)
        IF size>max THEN                   	(* max. Größe zu späteren     *)
          max:=size;                       	(* Öffnen des Fonts merken    *)
        END;
        Print(info2.fileName); 	    	   	(* Alle Fontgrößen            *)
        Print(", ");		   	   	(* ausgeben.		      *)
      END;
    END;
  UNTIL NOT ok;
  UnLock(lock2); lock2:=NIL;
  Print(newline);
  ShowFont;				   	(* Font in Grafik ausgeben    *)
END ScanSizes;

(*------------------------------------------------------------------------------
    Durchsuchen des FONTS: Directorys. Gefundene Directorys weiter
    durchsuchen, sie sollten die versch. Größen enthalten.
------------------------------------------------------------------------------*)

PROCEDURE ScanFonts;
VAR NewPath:ARRAY[0..99] OF CHAR;
BEGIN
  REPEAT				   	(* ganzes Dir. durchsuchen    *)
    ok:=ExNext(lock,ADR(info));
    IF ok THEN
      IF info.dirEntryType>0 THEN          	(* ein Directory gefunden.    *)
        Copy(NewPath,Path);  		   	(* Neuen Pfad                 *)
        Concat(NewPath,info.fileName);     	(* zusammenbauen.             *)
        Copy(FName,info.fileName);	   	(* Fontnamen merken.          *)
        Print(newline);
        Print("Font  : ");
        Print(FName); Print(newline);
        Print("Sizes : ");
        ScanSizes(NewPath);                	(* Directory durchsuchen.     *)
      END;
    END;
  UNTIL NOT ok;
END ScanFonts;

(*------------------------------------------------------------------------------
    Öffnen einer unsichtbaren Bitmap, und einrichten eines Rastports,
    sowie einer Colormap für diese Bitmap.
------------------------------------------------------------------------------*)

PROCEDURE MakeBitMap;
BEGIN
  InitBitMap(bm,1,960,200); 	   	      (* 960 Pixels Druckerbreite     *)
  InitRastPort(rp);
  rp.bitMap:=ADR(bm);		              (* Rastport und BMap verbinden. *)
  bm.planes[0]:=AllocRaster(960,200);         (* Bitplane anfordern.	      *)
  IF bm.planes[0]=NIL THEN
    WriteString(BMERROR); WriteLn;            (* melden, wenn keine Bitplane  *)
    Terminate;                                (* bekommen, und abbrechen.     *)
  END;
  cm:=GetColorMap(2);		              (* Colormap anfordern	      *)
  SetRGB4CM(cm,0,0FH,0FH,0FH);                (* Hintergrund weiß.	      *)
  SetRGB4CM(cm,1,00H,00H,00H);	              (* Schriftfarbe schwarz.	      *)
  SetAPen(ADR(rp),1);
END MakeBitMap;

BEGIN
  WriteString(TITLE); WriteLn;
  Path:="FONTS:";
  newline[0]:=CHAR(10);
  lock:=Lock(ADR(Path),sharedLock);
  IF lock=NIL THEN
    WriteString(F1ERROR);WriteLn;               	(* FONTS: nicht da    *)
    Terminate;
  END;
  ok:=Examine(lock,ADR(info));
  IF info.dirEntryType<0 THEN
    WriteString(F2ERROR);WriteLn;	        	(* FONTS: ist auf ein *)
    Terminate;                                  	(* File assigned.     *)
  END;
  MakeBitMap;						(* Bitmap erzeugen.   *)
  ScanFonts;
  WriteString("Ready");WriteLn;
CLOSE
  IF lock#NIL THEN UnLock(lock) END;
  IF lock2#NIL THEN UnLock(lock2) END;
  IF font#NIL THEN CloseFont(font) END;
  IF printer#NIL THEN Close(printer) END;
  IF bm.planes[0]#NIL THEN FreeRaster(bm.planes[0],960,200) END;
END FontList.