ð#Syntax10.Scn.Fntp!p!MODULE FEFonts; (* jt 21.10.92 / mh 20.8.1994 *) 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; s := {}; WHILE (i >= 0) & (ch.raster[i] = {}) DO DEC(i) END ; k := i; WHILE k >= 0 DO s := s + ch.raster[k]; DEC(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 < 31) & (ch.raster[i] = {}) DO INC(i) END ; RETURN i MOD 32 END BottomLine; PROCEDURE LeftCol(VAR ch: Character): INTEGER; VAR i: INTEGER; s: SET; BEGIN s := {}; i := 0; WHILE i < 31 DO s := s + ch.raster[i]; INC(i) END ; i := 0; WHILE (i < 31) & ~(i IN s) DO INC(i) END ; RETURN i MOD 32 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 l := 0; WHILE l < F.ch[ch].h DO F.ch[ch].raster[l] := SYSTEM.LSH(F.ch[ch].raster[l], -x); INC(l) END ; INC(F.ch[ch].x, x) END ; IF y > 0 THEN l := 0; WHILE l < F.ch[ch].h - y DO F.ch[ch].raster[l] := F.ch[ch].raster[l + y]; INC(l) END ; WHILE l < F.ch[ch].h DO F.ch[ch].raster[l] := {}; INC(l) END ; INC(F.ch[ch].y, y) END ELSE IF x < 0 THEN l := 0; WHILE l < F.ch[ch].h DO F.ch[ch].raster[l] := SYSTEM.LSH(F.ch[ch].raster[l], -x); INC(l) END ; INC(F.ch[ch].x, x); x := 0 END ; IF y < 0 THEN l := F.ch[ch].h - y - 1; WHILE l >= -y DO F.ch[ch].raster[l] := F.ch[ch].raster[l + y]; DEC(l) END ; WHILE l >= 0 DO F.ch[ch].raster[l] := {}; DEC(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 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 NEW(F); 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); k := 0; WHILE k # NofRuns DO Files.ReadInt(R, beg); Files.ReadInt(R, end); l := beg; WHILE l < end DO F.ch[l].w := 1; INC(l) END ; INC(k) END ; k := 0; WHILE k < 256 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 ; INC(k) END ; k := 0; WHILE k < 256 DO IF Valid(F.ch[k]) THEN m := 0; linelen := (F.ch[k].w + 7) DIV 8; WHILE m < F.ch[k].h DO n := 0; s := {}; WHILE n < linelen 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 ; INC(n) END ; F.ch[k].raster[m] := s; INC(m) END END ; INC(k) END END END ; k := 0; WHILE k < 256 DO F.undo[k] := F.ch[k]; INC(k) END ; RETURN F END This; PROCEDURE Recalc (VAR set: CharSet; VAR nofRuns, height, minX, minY, maxX, maxY: INTEGER); VAR k: INTEGER; BEGIN k := 0; minX := MAX(INTEGER); minY := MAX(INTEGER); maxX := MIN(INTEGER); maxY := MIN(INTEGER); IF Valid(set[0]) THEN nofRuns := 1 ELSE nofRuns := 0 END ; WHILE k < 256 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 ; INC(k) 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 ; k := 0; WHILE k < 256 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 ; INC(k) END ; k := 0; WHILE k < 256 DO IF Valid(F.ch[k]) THEN m := 0; linelen := (F.ch[k].w + 7) DIV 8; WHILE m < F.ch[k].h DO n := 0; s := F.ch[k].raster[m]; WHILE n < linelen 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)); INC(n) END ; INC(m) END END ; INC(k) END ; Files.Register(f) END END Store; END FEFonts.