ð¡Syntax10.Scn.Fnt^üÿÿÿÀÔ°­MarkElemsAlloc§H–üÿÿÿÀÔ°­¨HâüÿÿÿÀÔ°­©H”üÿÿÿÀÔ°­ªH­üÿÿÿÀÔ°­«HüüÿÿÿÀÔ°­¬H‡üÿÿÿÀÔ°­­H1üÿÿÿÀÔ°­®HüÿÿÿÀÔ°­¯HÛüÿÿÿÀÔ°­°H‘üÿÿÿÀÔ°­±H§üÿÿÿÀÔ°­²HPÀÿÿÿ€8ÀÔFoldElemsNew#Syntax10.Scn.FntTTFontInstaller was successfulÿÿÿÿ€8ÀÔiüÿÿÿÀÔ°­³H"ÿÿÿÿ€8ÀÔ‹üÿÿÿÀÔ°­´H5ÿÿÿÿ€8ÀÔvÿÿÿÿ€8ÀÔ üÿÿÿÀÔ°­µHÿÿÿÿ€8ÀÔ#ÿÿÿÿ€8ÀÔ]Òÿÿÿ€8ÀÔ#Syntax10.Scn.Fnt initialize F~Æÿÿÿ€8ÀÔ#Syntax10.Scn.Fntread font data from fileàßÿÿÿÿ€8ÀÔÍÿÿÿ€8ÀÔ#Syntax10.Scn.Fntuse TrueType font„ÿÿÿÿ€8ÀÔÿÿÿÿ€8ÀÔÿÿÿÿ€8ÀÔ üÿÿÿÀÔ°­¶H ÿÿÿÿ€8ÀÔ>ÿÿÿÿ€8ÀÔ üÿÿÿÀÔ°­·Hÿÿÿÿ€8ÀÔÿÿÿÿ€8ÀÔ?=MODULE Fonts; (* JG 27.8.90 / MH 2.2.94 *)(*CM 22.07.94, CS 16.7.96 *) IMPORT SYSTEM, Kernel, Registry, (*C := Console,*) Win32, Display, Directories, Files, Strings; CONST FontFileId = 0DBX; TrueType = 2; DefFontName = "Syntax10.Scn.Fnt"; (* overridden by the registry entry "System" "DefaultFont" *) WinFontExt = ".FON"; bold = Win32.Bold; italics = Win32.Italics; TYPE Name* = ARRAY 32 OF CHAR; Font* = POINTER TO FontDesc; FontDesc* = RECORD name*: Name; height*, minX*, maxX*, minY*, maxY*: INTEGER; raster*: Display.Font; resName: ARRAY 128 OF CHAR; next: Font; END ; LPLOGFONT = POINTER TO LOGFONT; LOGFONT = RECORD height, width, escapement, orientation, weight: LONGINT; italic, underline, strikeout: SHORTINT; charset: SHORTINT; outprec, clipprec: SHORTINT; quality: SHORTINT; pitchAndFamily: SHORTINT; facename: ARRAY 32 OF CHAR; END ; LPTEXTMETRIC = POINTER TO TEXTMETRIC; TEXTMETRIC = RECORD height, ascent, descent: LONGINT; intLead, extLead: LONGINT; avgCharWidth, maxCharWidth: LONGINT; weight, overhang: LONGINT; aspectX, aspectY: LONGINT; firstCh, lastCh, defaultCh, breakCh: CHAR; italic, underlined, struckout: SHORTINT; pitchAndFamily, charset: SHORTINT; END ; EnumFontsProc = PROCEDURE (f: LPLOGFONT; tm: LPTEXTMETRIC; type: SET; F: Font): LONGINT; VAR Default*, First: Font; T: ARRAY 256 OF CHAR; (* translation table *) WinExt: ARRAY 8 OF CHAR; fontName, fontPath: ARRAY 128 OF CHAR; (* global variables for callback function initiated by SearchFile *) mod: LONGINT; AddFontResource: PROCEDURE (fileName: LONGINT): LONGINT; RemoveFontResource: PROCEDURE (fileName: LONGINT); EnumFonts: PROCEDURE (hdc: LONGINT; faceName: LONGINT; callback: EnumFontsProc; F: Font); EnumFontFamilies: PROCEDURE (hdc: LONGINT; familiy: LONGINT; callback: EnumFontsProc; F: Font); CreateFontIndirect: PROCEDURE (logfont: LPLOGFONT): LONGINT; GetTextMetrics: PROCEDURE (hdc: LONGINT; lptm: LONGINT): BOOLEAN; GetCharABCWidths: PROCEDURE (hdc, firstCh, lastCh, lpABC: LONGINT); MessageBox: PROCEDURE (hwnd, text, caption, style: LONGINT): LONGINT; PROCEDURE Finalize (f: SYSTEM.PTR); VAR f0: Win32.Font; bitmap: LONGINT; BEGIN WITH f: Font DO f0 := SYSTEM.VAL(Win32.Font, f.raster); bitmap := f0.metrics[65].p.bitmap; IF bitmap # 0 THEN Win32.DeleteObject(bitmap) END ; IF f0.hfont # 0 THEN Win32.DeleteObject(f0.hfont); IF f.resName # "" THEN RemoveFontResource(SYSTEM.ADR(f.resName)) END ; f0.hfont := 0; END ; END END Finalize; PROCEDURE matches (s1, s2: ARRAY OF CHAR): BOOLEAN; VAR i: INTEGER; BEGIN i := 0; WHILE s1[i] # 0X DO IF CAP(s1[i]) # CAP(s2[i]) THEN RETURN FALSE END ; INC(i) END ; RETURN (s2[i] = 0X) OR (s2[i] = " "); END matches; PROCEDURE RasterFontInstaller (f: LPLOGFONT; tm: LPTEXTMETRIC; type: SET; F: Font): LONGINT; VAR EBX, ESI, EDI: LONGINT; font: Win32.Font; BEGIN SYSTEM.GETREG(3, EBX); SYSTEM.GETREG(6, ESI); SYSTEM.GETREG(7, EDI); font := SYSTEM.VAL(Win32.Font, F.raster); font.hfont := CreateFontIndirect(f); SYSTEM.PUTREG(3, EBX); SYSTEM.PUTREG(6, ESI); SYSTEM.PUTREG(7, EDI); RETURN 0; END RasterFontInstaller; PROCEDURE TTFontInstaller (f: LPLOGFONT; tm: LPTEXTMETRIC; type: SET; F: Font): LONGINT; VAR EBX, ESI, EDI, res: LONGINT; font: Win32.Font; BEGIN SYSTEM.GETREG(3, EBX); SYSTEM.GETREG(6, ESI); SYSTEM.GETREG(7, EDI); res := 1; IF TrueType IN type THEN font := SYSTEM.VAL(Win32.Font, F.raster); IF (font.family = f.facename) & ((italics IN font.style) = (f.italic # 0)) & ((bold IN font.style) = (f.weight > 400)) THEN f.height := -ENTIER(font.size * 1.27); (* CS, 16.7.96: 1 mm = 36000 units, 1 point was defined as 10000 units, 1 inch = 25.4 mm, 1 point = 1/72 inch => 1 point should be 1/72 * 25.4 * 36000 units = 12700 units, so we have to multiply size by 1.27 *) (* IF font.size <= 10 THEN DEC(f.height) END ; no longer needed *) f.width := 0; res := 0; font.hfont := CreateFontIndirect(f); END ; END ; SYSTEM.PUTREG(3, EBX); SYSTEM.PUTREG(6, ESI); SYSTEM.PUTREG(7, EDI); RETURN res; END TTFontInstaller; PROCEDURE TTFontFamiliyHandler (f: LPLOGFONT; tm: LPTEXTMETRIC; type: SET; F: Font): LONGINT; VAR EBX, ESI, EDI, res: LONGINT; font: Win32.Font; BEGIN SYSTEM.GETREG(3, EBX); SYSTEM.GETREG(6, ESI); SYSTEM.GETREG(7, EDI); res := 1; IF TrueType IN type THEN font := SYSTEM.VAL(Win32.Font, F.raster); IF matches(font.family, f.facename) THEN COPY(f.facename, font.family); res := 0 END ; END ; SYSTEM.PUTREG(3, EBX); SYSTEM.PUTREG(6, ESI); SYSTEM.PUTREG(7, EDI); RETURN res; END TTFontFamiliyHandler; PROCEDURE BuildWinName (VAR name, resName, faceName: ARRAY OF CHAR); VAR i, j, k: INTEGER; BEGIN (* faceName in Windows raster font is Oberon font name *) i := 0; j := 0; WHILE name[i] # 0X DO IF name[i] = "/" THEN j := 0 ELSE faceName[j] := name[i]; INC(j) END ; INC(i) END ; faceName[j] := 0X; (* resName = name of font ressource file *) i := 0; j := 0; WHILE ("A" <= CAP(name[i])) & (CAP(name[i]) <= "Z") DO IF i < 5 THEN resName[j] := CAP(name[i]); INC(j) END ; INC(i) END ; IF ("0" <= name[i]) & (name[i] <= "9") THEN resName[j] := name[i]; INC(i); INC(j); IF ("0" <= name[i]) & (name[i] <= "9") THEN resName[j] := name[i]; INC(i); INC(j); END ; END ; IF ("A" <= CAP(name[i])) & (CAP(name[i]) <= "Z") THEN resName[j] := CAP(name[i]); INC(j) END ; i := 0; WHILE WinExt[i] # 0X DO resName[j] := WinExt[i]; INC(i); INC(j) END ; resName[j] := 0X; END BuildWinName; PROCEDURE ParseName (VAR name, family: ARRAY OF CHAR; VAR size: LONGINT; VAR style: SET); VAR i: INTEGER; BEGIN size := 0; style := {}; i := 0; WHILE (name[i] > "9") OR (name[i] = " ") DO family[i] := name[i]; INC(i) END ; family[i] := 0X; WHILE ("0" <= name[i]) & (name[i] <= "9") DO size := 10*size + (ORD(name[i]) - ORD("0")); INC(i) END ; WHILE (name[i] # 0X) & (name[i] # ".") DO CASE CAP(name[i]) OF | "I": INCL(style, italics) | "B": INCL(style, bold) | "M": style := style + {italics, bold} ELSE END ; INC(i) END END ParseName; PROCEDURE SF (d: Directories.Directory; name: ARRAY OF CHAR; isDir: BOOLEAN; VAR continue: BOOLEAN); VAR i, j: INTEGER; dosName: ARRAY 32 OF CHAR; BEGIN IF name = fontName THEN i := 0; WHILE d.path[i] # 0X DO fontPath[i] := d.path[i]; INC(i) END ; IF (i > 0) & (d.path[i - 1] # Directories.delimiter) THEN fontPath[i] := Directories.delimiter; INC(i) END ; j := 0; WHILE dosName[j] # 0X DO fontPath[i] := dosName[j]; INC(i); INC(j) END ; fontPath[i] := 0X; continue := FALSE END END SF; PROCEDURE SFiles (path: ARRAY OF CHAR; VAR continue: BOOLEAN); VAR d: Directories.Directory; BEGIN d := Directories.This(path); Directories.Enumerate(d, SF); IF fontPath # "" THEN continue := FALSE END END SFiles; PROCEDURE SearchFile (VAR name, fullname: ARRAY OF CHAR); VAR pathNo: LONGINT; i, j: INTEGER; dir: Directories.Directory; BEGIN fontPath := ""; COPY(name, fontName); dir := Directories.Current(); Directories.Enumerate(dir, SF); IF fontPath = "" THEN Directories.EnumeratePaths(SFiles); IF fontPath = "" THEN dir := Directories.Startup(); Directories.Enumerate(dir, SF); END END ; COPY(fontPath, fullname); IF fullname[0] # 0X THEN (* a path has been found, append 'name' *) i := 0; WHILE fullname[i] # 0X DO INC(i) END; j := 0; WHILE name[j] # 0X DO fullname[i] := name[j]; INC(i); INC(j) END; fullname[i] := 0X END END SearchFile; PROCEDURE InitWindowsFont (F: Font; name: ARRAY OF CHAR); VAR raster: Win32.Font; resName: ARRAY 32 OF CHAR; faceName: Name; fullname: ARRAY 128 OF CHAR; BEGIN raster := SYSTEM.VAL(Win32.Font, F.raster); raster.hfont := 0; raster.oberon := TRUE; ParseName(F.name, raster.family, raster.size, raster.style); BuildWinName(name, resName, faceName); (*C.Str(" => "); C.Str(resName);*) SearchFile(resName, fullname); IF fullname[0] # 0X (*dir # NIL*) THEN COPY(fullname, F.resName); IF AddFontResource(SYSTEM.ADR(fullname)) > 0 THEN EnumFonts(Win32.hdcDisp, SYSTEM.ADR(faceName), RasterFontInstaller, F); ELSE raster.hfont := 0; END ; END ; END InitWindowsFont; PROCEDURE ThisTTFont (name, subst: ARRAY OF CHAR): Font; (*CM 22.07.94 *) VAR F: Font; raster: Win32.Font; tm: TEXTMETRIC; abc: RECORD a, b, c: LONGINT END ; oldfont, i: LONGINT; done: BOOLEAN; minX, maxX: INTEGER; BEGIN NEW(F); Kernel.RegisterObject(F, Finalize); NEW(raster); F.raster := SYSTEM.VAL(Display.Font, raster); COPY(name, F.name); raster.oberon := FALSE; ParseName(subst, raster.family, raster.size, raster.style); (*CM 22.07.94 *) EnumFontFamilies(Win32.hdcDisp, 0, TTFontFamiliyHandler, F); EnumFontFamilies(Win32.hdcDisp, SYSTEM.ADR(raster.family), TTFontInstaller, F); IF raster.hfont # 0 THEN oldfont := Win32.SelectObject(Win32.hdcDisp, raster.hfont); done := GetTextMetrics(Win32.hdcDisp, SYSTEM.ADR(tm)); F.height := SHORT(tm.height); (* F.minX := 0; F.maxX := F.minX + SHORT(tm.maxCharWidth); *) F.minY := -SHORT(tm.descent); F.maxY := SHORT(tm.ascent); F.resName := ""; i := 0; minX := MAX(INTEGER); maxX := MIN(INTEGER); WHILE i < 256 DO IF (ORD(tm.firstCh) <= i) & (i <= ORD(tm.lastCh)) THEN GetCharABCWidths(Win32.hdcDisp, i, i, SYSTEM.ADR(abc)) ELSE abc.a := 0; abc.b := 0; abc.c := 0; END ; raster.metrics[i].dx := SHORT(abc.a + abc.b + abc.c); IF raster.metrics[i].dx > maxX THEN maxX := raster.metrics[i].dx END ; IF raster.metrics[i].dx < minX THEN minX := raster.metrics[i].dx END ; raster.metrics[i].x := SHORT(abc.a); raster.metrics[i].y := -SHORT(tm.descent); raster.metrics[i].p.w := SHORT(abc.b); raster.metrics[i].p.h := SHORT(tm.height); raster.metrics[i].p.bitmap := 0; INC(i); END ; F.minX := minX; F.maxX := maxX; oldfont := Win32.SelectObject(Win32.hdcDisp, oldfont); RETURN F; ELSE RETURN NIL END ; END ThisTTFont; PROCEDURE This* (name: ARRAY OF CHAR): Font; TYPE RunRec = RECORD beg, end: INTEGER END ; BoxRec = RECORD dx, x, y, w, h: INTEGER END ; VAR subst: ARRAY 64 OF CHAR; F: Font; raster: Win32.Font; f: Files.File; R: Files.Rider; bitmap, RasterBase, b, n, a: LONGINT; bitmapX: LONGINT; (* x-offset into the bitmap, in pixels *) patternDX: LONGINT; (* width of a character pattern in bytes *) bitmapW: LONGINT; (* width of the entire font bitmap, in bytes *) bitmapH: LONGINT; (* height of the font bitmap, in pixels *) nofRuns, nofBoxes: INTEGER; k, l, m, w, h: INTEGER; ch: CHAR; run: ARRAY 16 OF RunRec; box: ARRAY 256 OF BoxRec; list, count: LONGINT; PROCEDURE MapFont (from: ARRAY OF CHAR; VAR to: ARRAY OF CHAR); BEGIN Registry.Get("Fontmap", from, to); IF Registry.res # Registry.Done THEN COPY(from, to) END END MapFont;  PROCEDURE DummyCh (m: INTEGER); VAR raster: Win32.Font; BEGIN raster := SYSTEM.VAL(Win32.Font, F.raster); raster.metrics[m].dx := 0; raster.metrics[m].x := 0; raster.metrics[m].y := 0; raster.metrics[m].p.x := 0; raster.metrics[m].p.y := 0; raster.metrics[m].p.w := 0; raster.metrics[m].p.h := 0 END DummyCh; BEGIN F := First; WHILE (F # NIL) & (F.name # name) DO F := F.next END ; IF F = NIL THEN  MapFont(name, subst); f := Files.Old(subst); (*C.Ln; C.Str("Fonts.This("); C.Str(subst); C.Str(")");*) IF f # NIL THEN  Files.Set(R, f, 0); Files.Read(R, ch); IF ch = FontFileId THEN Files.Read(R, ch); Files.Read(R, ch); Files.Read(R, ch); (* abstraction, family, variant *) NEW(F); Kernel.RegisterObject(F, Finalize); NEW(raster); F.raster := SYSTEM.VAL(Display.Font, raster); COPY(name, F.name); InitWindowsFont(F, subst); 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); nofBoxes := 0; k := 0; WHILE k # nofRuns DO Files.ReadInt(R, run[k].beg); Files.ReadInt(R, run[k].end); nofBoxes := nofBoxes + run[k].end - run[k].beg; INC(k); END ; bitmapW := 0; l := 0; WHILE l # nofBoxes DO Files.ReadInt(R, box[l].dx); Files.ReadInt(R, box[l].x); Files.ReadInt(R, box[l].y); Files.ReadInt(R, box[l].w); Files.ReadInt(R, box[l].h); bitmapW := bitmapW + (box[l].w + 7) DIV 8; INC(l); END ; bitmapW := bitmapW + (-bitmapW) MOD 4; bitmapH := F.maxY - F.minY; SYSTEM.NEW(SYSTEM.VAL(Font, RasterBase), bitmapW * bitmapH); (* temporary *) bitmapX := 0; k := 0; l := 0; m := 0; WHILE k < nofRuns DO WHILE m < run[k].beg DO DummyCh(m); INC(m) END ; WHILE m < run[k].end DO raster.metrics[m].dx := box[l].dx; raster.metrics[m].x := box[l].x; raster.metrics[m].y := box[l].y; raster.metrics[m].p.x := bitmapX; raster.metrics[m].p.y := 0; w := box[l].w; raster.metrics[m].p.w := w; h := box[l].h; raster.metrics[m].p.h := h; patternDX := (w + 7) DIV 8; n := patternDX * h; (* number of bytes for the character pattern *) a := RasterBase + bitmapX DIV 8; b := 0; WHILE b < n DO Files.Read(R, ch); SYSTEM.PUT(a + (h - 1 - (b DIV patternDX)) * bitmapW + (b MOD patternDX), T[ORD(ch)]); INC(b); END ; INC(l); INC(m); INC(bitmapX, 8*patternDX) END ; INC(k); END ; WHILE m < 256 DO DummyCh(m); INC(m) END ; bitmap := Win32.CreateBitmap(8*bitmapW, bitmapH, 1, 1, RasterBase); m := 0; WHILE m < 256 DO raster.metrics[m].p.bitmap := bitmap; INC(m) END ; F.next := First; First := F; END ELSE  F := ThisTTFont(name, subst); (*CM 22.07.94 *) IF F # NIL THEN F.next := First; First := F ELSE F := Default END END END ; RETURN F END This;  PROCEDURE SetDefault; VAR default: ARRAY 64 OF CHAR; dummy: LONGINT; errorStr: ARRAY 128 OF CHAR; BEGIN Registry.Get("System", "DefaultFont", default); Default := NIL; IF Registry.res = Registry.Done THEN Default := This(default) ELSE Default := This(DefFontName) END ; IF Default = NIL THEN COPY("Cannot find default font '", errorStr); Strings.Append(default, errorStr); Strings.Append("', using system default.", errorStr); dummy := MessageBox(0, SYSTEM.ADR(errorStr), SYSTEM.ADR("Error in Module Fonts"), 10010H); Default := This(DefFontName); IF Default = NIL THEN COPY("Default font '", errorStr); Strings.Append(DefFontName, errorStr); Strings.Append("' corrupt.", errorStr); dummy := MessageBox(0, SYSTEM.ADR(errorStr), SYSTEM.ADR("Error in Module Fonts"), 10010H); Win32.Exit(1) END END END SetDefault;  PROCEDURE Init; VAR i, k, bit, val: INTEGER; adr: LONGINT; andpos: INTEGER; ch: CHAR; BEGIN i := 0; WHILE i < 256 DO k := i; bit := 0; val := 0; WHILE bit < 8 DO val := val * 2; IF ODD(k) THEN INC(val) END ; k := k DIV 2; INC(bit); END ; T[i] := CHR(val); INC(i); END ; END Init; BEGIN mod := Kernel.LoadLibrary("GDI32"); Kernel.GetAdr(mod, "AddFontResourceA", SYSTEM.VAL(LONGINT, AddFontResource)); Kernel.GetAdr(mod, "RemoveFontResourceA", SYSTEM.VAL(LONGINT, RemoveFontResource)); Kernel.GetAdr(mod, "EnumFontsA", SYSTEM.VAL(LONGINT, EnumFonts)); Kernel.GetAdr(mod, "EnumFontFamiliesA", SYSTEM.VAL(LONGINT, EnumFontFamilies)); Kernel.GetAdr(mod, "CreateFontIndirectA", SYSTEM.VAL(LONGINT, CreateFontIndirect)); Kernel.GetAdr(mod, "GetTextMetricsA", SYSTEM.VAL(LONGINT, GetTextMetrics)); Kernel.GetAdr(mod, "GetCharABCWidthsA", SYSTEM.VAL(LONGINT, GetCharABCWidths)); mod := Kernel.LoadLibrary("User32"); Kernel.GetAdr(mod, "MessageBoxA", SYSTEM.VAL(LONGINT, MessageBox)); First := NIL; WinExt := WinFontExt; Init; SetDefault END Fonts.