ðŸSyntax10.Scn.Fnt3õÿÿÿSÀÔStampElemsAlloc20 Jul 97:Syntax10b.Scn.Fnt       LX?1! º’w« '™1! 'fNd„Tž3©¤Ï x ¦Tl"MODULE FEFonts; (* jt 21.10.92 / mh 20.8.1994 / cn *) IMPORT SYSTEM,Files; CONST FontFileId = 0DBX; updateChar* = 0; updateDot* = 1; moveXY* = 2; moveDx* = 3; updateFontMetrics* = 4; TYPE Character* = RECORD dx, x, y, w, h: INTEGER; raster: ARRAY 32 OF SET END; Font* = POINTER TO FontDesc; Notifier* = PROCEDURE (F: Font; op, ch, i, j: INTEGER); CharSet = ARRAY 256 OF Character; FontDesc* = RECORD name*: ARRAY 32 OF CHAR; abstraction, family, variant: CHAR; height*, minX*, maxX*, minY*, maxY*: INTEGER; ch: CharSet; undo: CharSet; notify*: Notifier; END; PROCEDURE GetMetric* (F: Font; ch: INTEGER; VAR dx, x, y, w, h: INTEGER); BEGIN dx := F.ch[ch].dx; x := F.ch[ch].x; y := F.ch[ch].y; w := F.ch[ch].w; h := F.ch[ch].h END GetMetric; PROCEDURE MoveXY* (F: Font; ch, dx, dy: INTEGER); BEGIN INC(F.ch[ch].x, dx); INC(F.ch[ch].y, dy); F.notify(F, moveXY, ch, dx, dy) END MoveXY; PROCEDURE MoveDx* (F: Font; ch, dx: INTEGER); BEGIN INC(F.ch[ch].dx, dx); F.notify(F, moveDx, ch, dx, 0) END MoveDx; PROCEDURE GetDot* (F: Font; ch, i, j: INTEGER; VAR val: BOOLEAN); VAR x, y: INTEGER; BEGIN x := i - F.ch[ch].x; y := j - F.ch[ch].y; IF (x < 0) OR (x > 31) OR (y < 0) OR (y > 31) THEN val := FALSE ELSE val := x IN F.ch[ch].raster[y] END END GetDot; PROCEDURE GetBox(VAR ch: Character); VAR s: SET; i, j, k: INTEGER; BEGIN i := 31; WHILE (i >= 0) & (ch.raster[i] = {}) DO DEC(i); END ; s := {}; FOR k := i TO 0 BY -1 DO s := s + ch.raster[k]; END ; j := 31; WHILE (j >= 0) & ~(j IN s) DO DEC(j); END ; ch.h:=i+1; ch.w:=j+1; END GetBox; PROCEDURE BottomLine(VAR ch:Character):INTEGER; VAR i:INTEGER; BEGIN i:=0; WHILE (i<32) & (ch.raster[i]={}) DO INC(i); END; (* Search non-empty line *) RETURN i MOD 32; (* in case no one found 32 MOD 32=>0 *) END BottomLine; PROCEDURE LeftCol(VAR ch:Character):INTEGER; VAR i:INTEGER; s:SET; BEGIN s:={}; FOR i:=0 TO 31 DO s:=s+ch.raster[i]; END; (* Union of all rows *) i:=0; WHILE (i<32) & ~(i IN s) DO INC(i);END; (* Search first element in set *) RETURN i MOD 32; (* in case no one found 32 MOD 32=>0 *) END LeftCol; PROCEDURE SetDot*(F:Font; ch,i,j:INTEGER; val:BOOLEAN); VAR x,y,l:INTEGER; BEGIN x:=i-F.ch[ch].x; y:=j-F.ch[ch].y; IF (x<32) & (F.ch[ch].w-32<=x) & (y<32) & (F.ch[ch].h-32<=y) THEN IF (~val) & ((x = 0) OR (y = 0)) THEN EXCL(F.ch[ch].raster[y],x); x:=LeftCol(F.ch[ch]); y:=BottomLine(F.ch[ch]); IF x>0 THEN FOR l := 0 TO F.ch[ch].h-1 DO F.ch[ch].raster[l] := SYSTEM.LSH(F.ch[ch].raster[l], -x); END; INC(F.ch[ch].x, x) END; IF y>0 THEN FOR l:=0 TO F.ch[ch].h-y-1 DO F.ch[ch].raster[l]:=F.ch[ch].raster[l+y]; END; FOR l:=F.ch[ch].h-y TO F.ch[ch].h-1 DO F.ch[ch].raster[l]:={}; END; INC(F.ch[ch].y, y) END ELSE IF x < 0 THEN FOR l := 0 TO F.ch[ch].h-1 DO F.ch[ch].raster[l] := SYSTEM.LSH(F.ch[ch].raster[l], -x); END; INC(F.ch[ch].x, x); x := 0 END; IF y < 0 THEN FOR l:=F.ch[ch].h-y-1 TO -y BY -1 DO F.ch[ch].raster[l] := F.ch[ch].raster[l + y]; END; FOR l:=-y TO 0 BY -1 DO F.ch[ch].raster[l] := {}; END; INC(F.ch[ch].y, y); y := 0 END; IF val THEN INCL(F.ch[ch].raster[y], x) ELSE EXCL(F.ch[ch].raster[y], x) END; END; GetBox(F.ch[ch]); F.notify(F,updateDot,ch,i,j) END END SetDot; PROCEDURE GetChar* (F: Font; ch: INTEGER; VAR char: Character); BEGIN char := F.ch[ch]; END GetChar; PROCEDURE SetChar* (F: Font; ch: INTEGER; char: Character); BEGIN F.ch[ch] := char; F.notify(F, updateChar, ch, 0, 0) END SetChar; PROCEDURE Commit* (F: Font; ch: INTEGER); BEGIN F.undo[ch] := F.ch[ch]; END Commit; PROCEDURE Undo* (F: Font; ch: INTEGER); BEGIN F.ch[ch] := F.undo[ch]; F.notify(F, updateChar, ch, 0, 0) END Undo; PROCEDURE Valid(VAR ch: Character): BOOLEAN; BEGIN RETURN (ch.w # 0) OR (ch.dx # 0) END Valid; PROCEDURE New*():Font; (* Remove all characters. *) VAR f:Font; k,l:INTEGER; BEGIN NEW(f); COPY("Empty.Scn.Fnt",f.name); f.abstraction:=0X; f.family:="X"; f.variant:=" "; f.height:=0; f.minX:=0; f.maxX:=0;f.minY:=0; f.maxY:=0; FOR k:=0 TO 255 DO f.ch[k].dx:=0; f.ch[k].x:=0; f.ch[k].y:=0; f.ch[k].w:=0; f.ch[k].h:=0; FOR l:=0 TO 31 DO f.ch[k].raster[l]:={}; END; f.undo[k]:=f.ch[k]; END; f.notify:=NIL; RETURN f; END New; PROCEDURE This*(name:ARRAY OF CHAR): Font; VAR f: Files.File; R: Files.Rider; ch: CHAR; F: Font; NofRuns, l, k, m, n, o, p, beg, end, linelen: INTEGER; s: SET; BEGIN F := NIL; f := Files.Old(name); IF f # NIL THEN Files.Set(R, f, 0); Files.Read(R, ch); IF ch = FontFileId THEN F:=New(); COPY(name, F.name); Files.Read(R, F.abstraction); Files.Read(R, F.family); Files.Read(R, F.variant); 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, beg); Files.ReadInt(R, end); FOR l:=beg TO end-1 DO F.ch[l].w := 1; END; END; FOR k := 0 TO 255 DO IF F.ch[k].w>0 THEN Files.ReadInt(R, F.ch[k].dx); Files.ReadInt(R, F.ch[k].x); Files.ReadInt(R, F.ch[k].y); Files.ReadInt(R, F.ch[k].w); Files.ReadInt(R, F.ch[k].h); END; END; FOR k := 0 TO 255 DO IF Valid(F.ch[k]) THEN linelen := (F.ch[k].w + 7) DIV 8; FOR m:=0 TO F.ch[k].h-1 DO s := {}; FOR n:=0 TO linelen-1 DO Files.Read(R, ch); o := ORD(ch); p := 0; WHILE o # 0 DO IF ODD(o) THEN INCL(s, n * 8 + p) END; o := o DIV 2; INC(p) END; END; F.ch[k].raster[m] := s; END END; END END; FOR k:=0 TO 255 DO F.undo[k] := F.ch[k]; END; END; RETURN F END This; PROCEDURE Recalc (VAR set: CharSet; VAR nofRuns, height, minX, minY, maxX, maxY: INTEGER); VAR k: INTEGER; BEGIN minX := MAX(INTEGER); minY := MAX(INTEGER); maxX := MIN(INTEGER); maxY := MIN(INTEGER); IF Valid(set[0]) THEN nofRuns := 1 ELSE nofRuns := 0 END ; FOR k:=0 TO 255 DO IF Valid(set[k]) THEN IF set[k].x < minX THEN minX := set[k].x END ; IF set[k].y < minY THEN minY := set[k].y END ; IF set[k].x + set[k].w > maxX THEN maxX := set[k].x + set[k].w END ; IF set[k].y + set[k].h > maxY THEN maxY := set[k].y + set[k].h END ; END; IF (k < 255) & (~Valid(set[k])) & Valid(set[k+1]) THEN INC(nofRuns) END ; END; height := maxY - minY END Recalc; PROCEDURE UpdateMetrics* (F: Font); VAR VAR nofRuns, height, minX, minY, maxX, maxY: INTEGER; BEGIN Recalc(F.ch, nofRuns, height, minX, minY, maxX, maxY); IF (minX # F.minX) OR (maxX # F.maxX) OR (minY # F.minY) OR (maxY # F.maxY) THEN F.minX := minX; F.maxX := maxX; F.minY := minY; F.maxY := maxY; F.notify(F, updateFontMetrics, 0, 0, 0); END; END UpdateMetrics; PROCEDURE SetHeight* (F: Font; height: INTEGER); BEGIN IF height # F.height THEN F.height := height; F.notify(F, updateFontMetrics, 0, 0, 0); END END SetHeight; PROCEDURE Store* (name: ARRAY OF CHAR; F: Font); VAR f: Files.File; R: Files.Rider; s: SET; NofRuns, height, minX, minY, maxX, maxY, k, m, n, o, p, linelen: INTEGER; BEGIN Recalc(F.ch, NofRuns, height, minX, minY, maxX, maxY); IF (minX # F.minX) OR (maxX # F.maxX) OR (minY # F.minY) OR (maxY # F.maxY) THEN F.minX := minX; F.maxX := maxX; F.minY := minY; F.maxY := maxY; END; f := Files.New(name); IF f # NIL THEN Files.Set(R, f, 0); Files.Write(R, FontFileId); Files.Write(R, F.abstraction); Files.Write(R, F.family); Files.Write(R, F.variant); Files.WriteInt(R, F.height); Files.WriteInt(R, minX); Files.WriteInt(R, maxX); Files.WriteInt(R, minY); Files.WriteInt(R, maxY); Files.WriteInt(R, NofRuns); k := 0; WHILE k < 256 DO IF Valid(F.ch[k]) THEN Files.WriteInt(R, k); WHILE (k < 256) & Valid(F.ch[k]) DO INC(k) END; Files.WriteInt(R, k); ELSE INC(k) END; END; FOR k:=0 TO 255 DO IF Valid(F.ch[k]) THEN Files.WriteInt(R, F.ch[k].dx); Files.WriteInt(R, F.ch[k].x); Files.WriteInt(R, F.ch[k].y); Files.WriteInt(R, F.ch[k].w); Files.WriteInt(R, F.ch[k].h); END; END; FOR k:=0 TO 255 DO IF Valid(F.ch[k]) THEN linelen := (F.ch[k].w + 7) DIV 8; FOR m:=0 TO F.ch[k].h-1 DO s := F.ch[k].raster[m]; FOR n:=0 TO linelen-1 DO p := 7; o := 0; WHILE p >= 0 DO o := o * 2; IF (n * 8 + p) IN s THEN o := o + 1 END; DEC(p) END; Files.Write(R, CHR(o)); END; END END; END; Files.Register(f) END END Store; END FEFonts.