Syntax10.Scn.Fnt
ParcElems
Alloc
Syntax24b.Scn.Fnt
FoldElems
Syntax10b.Scn.Fnt
(* AMIGA  *)
MODULE Fonts; (* shml/cn 29-Dec-1992, 10-May-94 *)
IMPORT
		SYSTEM, Amiga, DiskFont := AmigaDiskFont, Display, E := AmigaExec, Files, G := AmigaGraphics;
CONST
 	FontFileId = 0DBX;
	Name* = ARRAY 32 OF CHAR;
	Font* = POINTER TO FontDesc;
	FontDesc* = RECORD
		name*: Name;
		height*, minX*, maxX*, minY*, maxY*: INTEGER;
		raster*: Display.Font;
		next: Font
	END;
	Default*, First: Font; nofFonts: INTEGER;
	Swap: ARRAY 256 OF CHAR;
PROCEDURE Cleanup;
	raster: Amiga.Font;
BEGIN
	IF Amiga.ChipMemPool=0 THEN
		WHILE First # NIL DO
			raster := SYSTEM.VAL(Amiga.Font, First.raster);
			IF (raster.data#0) & (raster.size#0) THEN E.FreeMem(raster.data, raster.size) END;
			First := First.next
		END
	ELSE
		First:=NIL
	END;
	Default := NIL
END Cleanup;
PROCEDURE ClearRaster(VAR raster:Amiga.Font);
	dummy: Amiga.CharInfo;
	i:INTEGER;
BEGIN
	dummy.dx:=0;
	dummy.x:=0;
	dummy.y:=0;
	dummy.w:=0;
	dummy.h:=0;
	dummy.modulo:=0;
	dummy.data:=0;
	dummy.offset:=0;
	FOR i:=0 TO 255 DO
		raster.info[i]:=dummy
	END;
	raster.data:=0;
	raster.size:=0
END ClearRaster;
PROCEDURE SearchFont(name:ARRAY OF CHAR):Font;
	f:Font;
BEGIN
	f:=First;
	LOOP
		IF f=NIL THEN EXIT END;
		IF name=f.name THEN EXIT END;
		f:=f.next
	END;
	RETURN f
END SearchFont;
PROCEDURE AmigaFont(name: ARRAY OF CHAR): Font;
	TextFontPtr=POINTER TO G.TextFont;
	font:Font;
	raster:Amiga.Font;
	tf:TextFontPtr;
	af:G.TextFontPtr;
	PROCEDURE DuplicateBlock(src:LONGINT; size:LONGINT):LONGINT;
		b:SHORTINT;
		dst:LONGINT;
		i:LONGINT;
	BEGIN
		IF Amiga.ChipMemPool#0 THEN
			dst:=E.AllocPooled(Amiga.ChipMemPool, size)
		ELSE
			dst:=E.AllocMem(size,{E.memChip})
		END;
		FOR i:=0 TO size-1 DO SYSTEM.GET(src+i,b); SYSTEM.PUT(dst+i,b) END;
		RETURN dst
	END DuplicateBlock;
	PROCEDURE OpenAmigaFont(name:ARRAY OF CHAR):G.TextFontPtr;
		fontName:ARRAY 32 OF CHAR;
		fontSize:INTEGER;
		fontStyles:SHORTINT;
		i,j:INTEGER;
		textAttr:G.TextAttr;
	BEGIN
		COPY(name,fontName);
		i:=0; WHILE fontName[i]#"." DO INC(i) END;
		INC(i); j:=i;
		fontSize:=0;
		WHILE ("0"<=fontName[i]) & (fontName[i]<="9") DO
			fontSize:=fontSize*10+ORD(fontName[i])-ORD("0"); INC(i)
		END;
		fontStyles:=0;
		LOOP
			CASE fontName[i] OF
			| "B","b": INC(fontStyles,2); INC(i)
			| "C","c": INC(fontStyles,64); INC(i)
			| "E","e": INC(fontStyles,8); INC(i)
			| "I","i": INC(fontStyles,4); INC(i)
			| "U","u": INC(fontStyles,1); INC(i)
			ELSE EXIT
			END
		END;
		fontName[j]:="f"; fontName[j+1]:="o"; fontName[j+2]:="n"; fontName[j+3]:="t";
		fontName[j+4]:=0X;
		textAttr.name:=SYSTEM.ADR(fontName);
		textAttr.ySize:=fontSize;
		textAttr.style:=fontStyles;
		textAttr.flags:=0;
		RETURN DiskFont.OpenDiskFont(textAttr)
	END OpenAmigaFont;
	PROCEDURE SetFontAndRaster(VAR font:Font; VAR raster:Amiga.Font; tf:TextFontPtr);
	TYPE
		Location=RECORD offset,width:INTEGER END;
		LocationArray=ARRAY 256 OF Location;
		LocationPtr=POINTER TO LocationArray;
		SpaceArray=ARRAY 256 OF INTEGER;
		SpacePtr=POINTER TO SpaceArray;
		KernArray=ARRAY 256 OF INTEGER;
		KernPtr=POINTER TO KernArray;
		ch:INTEGER;
		dx,x,y,w,h:SHORTINT;
		i:INTEGER;
		kern:KernPtr;
		loc:LocationPtr;
		minX,maxX:INTEGER;
		space:SpacePtr;
		li:LONGINT;
	BEGIN
		loc:=SYSTEM.VAL(LocationPtr, tf.charLoc);
		space:=SYSTEM.VAL(SpacePtr, tf.charSpace);
		kern:=SYSTEM.VAL(KernPtr, tf.charKern);
		y:=SHORT(tf.baseline-tf.ySize+1);
		h:=SHORT(tf.ySize);
		font.minY:=y;
		font.maxY:=y+h;
		minX:=MAX(INTEGER); maxX:=MIN(INTEGER);
		raster.size:=tf.modulo*h;
		raster.data:=DuplicateBlock(tf.charData,raster.size);
		FOR ch:=ORD(tf.loChar) TO ORD(tf.hiChar) DO
			i:=ch-ORD(tf.loChar);
			IF space#NIL THEN dx:=SHORT(space[i]) ELSE dx:=SHORT(tf.xSize) END;
			x:=0; IF kern#NIL THEN dx:=dx+SHORT(kern[i]); x:=SHORT(kern[i]); END;
			IF loc#NIL THEN w:=SHORT(loc[i].width) ELSE w:=SHORT(tf.xSize) END;
			IF x<minX THEN minX:=x END;
			IF x+w>maxX THEN maxX:=x+w END;
			raster.info[ch].dx:=dx;
			raster.info[ch].x:=x;
			raster.info[ch].y:=y;
			raster.info[ch].w:=w;
			raster.info[ch].h:=h;
			raster.info[ch].modulo:=tf.modulo;
			raster.info[ch].data:=raster.data;
			IF loc#NIL THEN raster.info[ch].offset:=loc[i].offset ELSE raster.info[ch].offset:=w*i END
		END;
		font.height:=h;
		font.minX:=minX;
		font.maxX:=maxX;
		font.raster:=SYSTEM.VAL(Display.Font,raster)
	END SetFontAndRaster;
BEGIN
	font:=Default;
	af:=OpenAmigaFont(name);
	tf:=SYSTEM.VAL(TextFontPtr, af);
	IF tf#NIL THEN
		NEW(raster);
		ClearRaster(raster);
		NEW(font);
		IF font=NIL THEN HALT(127) END;
		SetFontAndRaster(font,raster,tf);
		raster.amigaFont:=af;
		COPY(name,font.name);
		font.next:=First;
		First:=font;
		G.CloseFont(af)
	END;
	RETURN font
END AmigaFont;
PROCEDURE OberonFont(name: ARRAY OF CHAR): Font;
	RunRec=RECORD
		beg, end: INTEGER
	END;
	RunRecArray=ARRAY 16 OF RunRec;
	ch:CHAR;
	file:Files.File;
	font:Font;
	nOfRuns: INTEGER;
	raster: Amiga.Font;
	rider:Files.Rider;
	run:RunRecArray;
	PROCEDURE ReadShort(VAR r: Files.Rider; VAR x: SHORTINT);
		val: INTEGER;
	BEGIN
		Files.ReadInt(r, val); x := SHORT(val)
	END ReadShort;
	PROCEDURE ReadFontHeader(VAR r: Files.Rider; VAR f:Font; VAR nOfRuns:INTEGER; VAR run:RunRecArray);
		k:INTEGER;
	BEGIN
		Files.ReadInt(r,f.height);
		Files.ReadInt(r,f.minX);
		Files.ReadInt(r,f.maxX);
		Files.ReadInt(r,f.minY);
		Files.ReadInt(r,f.maxY);
		Files.ReadInt(r,nOfRuns);
		FOR k := 0 TO nOfRuns-1 DO
			Files.ReadInt(r,run[k].beg);
			Files.ReadInt(r,run[k].end)
		END
	END ReadFontHeader;
	PROCEDURE ReadRaster(VAR r:Files.Rider; VAR raster:Amiga.Font; VAR nOfRuns:INTEGER; VAR run:RunRecArray);
		a:LONGINT;
		j, bytesPerRow:LONGINT;
		i,k,m:INTEGER;
		nOfBytes:LONGINT;
	BEGIN
		nOfBytes:=0;
		FOR k:=0 TO nOfRuns-1 DO
			FOR m:=run[k].beg TO run[k].end-1 DO
				ReadShort(r,raster.info[m].dx);
				ReadShort(r,raster.info[m].x);
				ReadShort(r,raster.info[m].y);
				ReadShort(r,raster.info[m].w);
				ReadShort(r,raster.info[m].h);
				raster.info[m].modulo:=2*((raster.info[m].w+15) DIV 16);
				nOfBytes:=nOfBytes+raster.info[m].modulo*raster.info[m].h
			END
		END;
		IF Amiga.ChipMemPool#0 THEN
			raster.data:=E.AllocPooled(Amiga.ChipMemPool, nOfBytes)
		ELSE
			raster.data:=E.AllocMem(nOfBytes,{E.memChip})
		END;
		raster.size:=nOfBytes;
		a:=raster.data;
		FOR k:=0 TO nOfRuns-1 DO
			FOR m:=run[k].beg TO run[k].end-1 DO
				bytesPerRow:=(raster.info[m].w+7) DIV 8;
				raster.info[m].data:=a;
				raster.info[m].offset:=0;
				INC(a,LONG(raster.info[m].modulo)*(raster.info[m].h-1));
				FOR i:=1 TO raster.info[m].h DO
					FOR j:=1 TO bytesPerRow DO
						Files.Read(r,ch);
						SYSTEM.PUT(a,Swap[ORD(ch)]);
						INC(a)
					END;
					DEC(a,bytesPerRow+raster.info[m].modulo)
				END;
				a:=raster.info[m].data+raster.info[m].modulo*raster.info[m].h
			END
		END
	END ReadRaster;
BEGIN
	file:=Files.Old(name);
	IF file#NIL THEN
		Files.Set(rider,file,0); Files.Read(rider,ch);
		IF ch=FontFileId THEN
			Files.Read(rider,ch);	(*skip abstraction*)
			Files.Read(rider,ch);	(*skip family*)
			Files.Read(rider,ch);	(*skip variant*)
			NEW(font);
			ReadFontHeader(rider,font,nOfRuns,run);
			NEW(raster);
			ClearRaster(raster);
			ReadRaster(rider,raster,nOfRuns,run);
			raster.amigaFont:=0;
			font.raster:=SYSTEM.VAL(Display.Font,raster);
			COPY(name,font.name);
			font.next:=First;
			First:=font;
		ELSE
			font:=Default
		END
	ELSE
		font:=Default
	END;
	RETURN font
END OberonFont;
PROCEDURE This*(name: ARRAY OF CHAR):Font;(*
Load the named font, unless it is already loaded. Depending on the name, either an Oberon or an Amiga font is loaded.
If the font name terminates with .Scn.Fnt then the named file is loaded as an Oberon Font.
Otherwise, the name is assumed to be of the form fontname.size and split into its two components. Then the Amiga font with that name and size is loaded.
	font:Font;
	i:INTEGER;
BEGIN
	font:=SearchFont(name);
	IF font=NIL THEN
		i:=-1; REPEAT INC(i) UNTIL name[i] = 0X;
		IF (i >= 9) & (name[i-8] = ".") & (name[i-7] = "S") & (name[i-6] = "c") & (name[i-5] = "n") & (name[i-4] = ".")
				& (name[i-3] = "F") & (name[i-2] = "n") & (name[i-1] = "t") THEN font:=OberonFont(name)
		ELSE font:=AmigaFont(name)
		END
	END;
	RETURN font
END This;
PROCEDURE InitSwap;
	VAR i: INTEGER;
BEGIN
	FOR i:=0 TO 255 DO
		Swap[i]:=SYSTEM.VAL(CHAR, Amiga.SwapBits(CHR(i)))
END InitSwap;
BEGIN
	InitSwap;
	First:=NIL;
	nofFonts:=0;
	Default:=This("Syntax10.Scn.Fnt");
	Amiga.Assert(Default#NIL,"Default font not found");
	Amiga.TermProcedure(Cleanup)
END Fonts.