| 0,0 → 1,478 |
|---|
| (* |
| Copyright 2016 Anton Krotov |
| |
| This program is free software: you can redistribute it and/or modify |
| it under the terms of the GNU Lesser General Public License as published by |
| the Free Software Foundation, either version 3 of the License, or |
| (at your option) any later version. |
| |
| This program is distributed in the hope that it will be useful, |
| but WITHOUT ANY WARRANTY; without even the implied warranty of |
| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| GNU Lesser General Public License for more details. |
| |
| You should have received a copy of the GNU Lesser General Public License |
| along with this program. If not, see <http://www.gnu.org/licenses/>. |
| *) |
| |
| MODULE kfonts; |
| |
| IMPORT sys := SYSTEM; |
| |
| CONST |
| |
| MIN_FONT_SIZE = 8; |
| MAX_FONT_SIZE = 46; |
| |
| bold *= 1; |
| italic *= 2; |
| underline *= 4; |
| strike_through *= 8; |
| smoothing *= 16; |
| bpp32 *= 32; |
| |
| TYPE |
| |
| Glyph = RECORD |
| base: INTEGER; |
| xsize, ysize: INTEGER; |
| width: INTEGER |
| END; |
| |
| TFont_desc = RECORD |
| |
| data, size, font, char_size, width, height, font_size, mem, mempos: INTEGER; |
| glyphs: ARRAY 4, 256 OF Glyph |
| |
| END; |
| |
| TFont* = POINTER TO TFont_desc; |
| |
| |
| PROCEDURE [stdcall] LoadFile(file_name: INTEGER; VAR size: INTEGER): INTEGER; |
| BEGIN |
| sys.CODE("53"); (* push ebx *) |
| sys.CODE("6A44"); (* push 68 *) |
| sys.CODE("58"); (* pop eax *) |
| sys.CODE("6A1B"); (* push 27 *) |
| sys.CODE("5B"); (* pop ebx *) |
| sys.CODE("8B4D08"); (* mov ecx, [ebp + 08h] *) |
| sys.CODE("CD40"); (* int 40h *) |
| sys.CODE("8B4D0C"); (* mov ecx, [ebp + 0Ch] *) |
| sys.CODE("8911"); (* mov [ecx], edx *) |
| sys.CODE("5B"); (* pop ebx *) |
| sys.CODE("C9"); (* leave *) |
| sys.CODE("C20800"); (* ret 08h *) |
| RETURN 0 |
| END LoadFile; |
| |
| PROCEDURE [stdcall] sysfunc3(arg1, arg2, arg3: INTEGER): INTEGER; |
| BEGIN |
| sys.CODE("53"); (* push ebx *) |
| sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) |
| sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *) |
| sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *) |
| sys.CODE("CD40"); (* int 40h *) |
| sys.CODE("5B"); (* pop ebx *) |
| sys.CODE("C9"); (* leave *) |
| sys.CODE("C20C00"); (* ret 0Ch *) |
| RETURN 0 |
| END sysfunc3; |
| |
| PROCEDURE [stdcall] zeromem(size, adr: INTEGER); |
| BEGIN |
| sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F") |
| END zeromem; |
| |
| PROCEDURE pset(buf, x, y, color: INTEGER; bpp32: BOOLEAN); |
| VAR xsize, ysize: INTEGER; |
| BEGIN |
| sys.GET(buf, xsize); |
| sys.GET(buf + 4, ysize); |
| INC(buf, 8); |
| IF (0 <= x) & (x < xsize) & (0 <= y) & (y < ysize) THEN |
| IF bpp32 THEN |
| sys.PUT(buf + 4 * (xsize * y + x), color) |
| ELSE |
| sys.MOVE(sys.ADR(color), buf + 3 * (xsize * y + x), 3) |
| END |
| END |
| END pset; |
| |
| PROCEDURE pget(buf, x, y: INTEGER; bpp32: BOOLEAN): INTEGER; |
| VAR xsize, ysize, color: INTEGER; |
| BEGIN |
| sys.GET(buf, xsize); |
| sys.GET(buf + 4, ysize); |
| INC(buf, 8); |
| IF (0 <= x) & (x < xsize) & (0 <= y) & (y < ysize) THEN |
| IF bpp32 THEN |
| sys.GET(buf + 4 * (xsize * y + x), color) |
| ELSE |
| sys.MOVE(buf + 3 * (xsize * y + x), sys.ADR(color), 3) |
| END |
| END |
| RETURN color |
| END pget; |
| |
| PROCEDURE getrgb(color: INTEGER; VAR r, g, b: INTEGER); |
| BEGIN |
| b := LSR(LSL(color, 24), 24); |
| g := LSR(LSL(color, 16), 24); |
| r := LSR(LSL(color, 8), 24); |
| END getrgb; |
| |
| PROCEDURE rgb(r, g, b: INTEGER): INTEGER; |
| RETURN b + LSL(g, 8) + LSL(r, 16) |
| END rgb; |
| |
| PROCEDURE create_glyph(VAR Font: TFont_desc; VAR glyph: Glyph; xsize, ysize: INTEGER); |
| VAR res: INTEGER; |
| BEGIN |
| glyph.base := Font.mempos; |
| glyph.xsize := xsize; |
| glyph.ysize := ysize; |
| Font.mempos := Font.mempos + xsize * ysize |
| END create_glyph; |
| |
| PROCEDURE getpix(Font: TFont_desc; n, x, y, xsize: INTEGER): CHAR; |
| VAR res: CHAR; |
| BEGIN |
| sys.GET(Font.mem + n + x + y * xsize, res) |
| RETURN res |
| END getpix; |
| |
| PROCEDURE setpix(VAR Font: TFont_desc; n, x, y, xsize: INTEGER; c: CHAR); |
| BEGIN |
| sys.PUT(Font.mem + n + x + y * xsize, c) |
| END setpix; |
| |
| PROCEDURE smooth(VAR Font: TFont_desc; n, xsize, ysize: INTEGER); |
| VAR x, y: INTEGER; |
| BEGIN |
| FOR y := 1 TO ysize - 1 DO |
| FOR x := 1 TO xsize - 1 DO |
| IF (getpix(Font, n, x, y, xsize) = 1X) & (getpix(Font, n, x - 1, y - 1, xsize) = 1X) & |
| (getpix(Font, n, x - 1, y, xsize) = 0X) & (getpix(Font, n, x, y - 1, xsize) = 0X) THEN |
| setpix(Font, n, x - 1, y, xsize, 2X); |
| setpix(Font, n, x, y - 1, xsize, 2X) |
| END; |
| IF (getpix(Font, n, x, y, xsize) = 0X) & (getpix(Font, n, x - 1, y - 1, xsize) = 0X) & |
| (getpix(Font, n, x - 1, y, xsize) = 1X) & (getpix(Font, n, x, y - 1, xsize) = 1X) THEN |
| setpix(Font, n, x, y, xsize, 2X); |
| setpix(Font, n, x - 1, y - 1, xsize, 2X) |
| END |
| END |
| END |
| END smooth; |
| |
| PROCEDURE _bold(VAR Font: TFont_desc; src, dst, src_xsize, dst_xsize, n: INTEGER); |
| VAR i, j, k: INTEGER; pix: CHAR; |
| BEGIN |
| FOR i := 0 TO src_xsize - 1 DO |
| FOR j := 0 TO Font.height - 1 DO |
| pix := getpix(Font, src, i, j, src_xsize); |
| IF pix = 1X THEN |
| FOR k := 0 TO n DO |
| setpix(Font, dst, i + k, j, dst_xsize, pix) |
| END |
| END |
| END |
| END |
| END _bold; |
| |
| PROCEDURE make_glyph(VAR Font: TFont_desc; c: INTEGER); |
| VAR ptr, i, j, max, x, y: INTEGER; s: SET; eoc: BOOLEAN; |
| glyph: Glyph; pix: CHAR; bold_width: INTEGER; |
| BEGIN |
| create_glyph(Font, glyph, Font.width, Font.height); |
| x := 0; |
| y := 0; |
| max := 0; |
| ptr := Font.font + Font.char_size * c; |
| eoc := FALSE; |
| REPEAT |
| sys.GET(ptr, s); |
| INC(ptr, 4); |
| FOR i := 0 TO 31 DO |
| IF ~eoc THEN |
| IF i IN s THEN |
| setpix(Font, glyph.base, x, y, Font.width, 1X); |
| IF x > max THEN |
| max := x |
| END |
| ELSE |
| setpix(Font, glyph.base, x, y, Font.width, 0X) |
| END |
| END; |
| INC(x); |
| IF x = Font.width THEN |
| x := 0; |
| INC(y); |
| eoc := eoc OR (y = Font.height) |
| END |
| END |
| UNTIL eoc; |
| IF max = 0 THEN |
| max := Font.width DIV 3 |
| END; |
| |
| glyph.width := max; |
| smooth(Font, glyph.base, glyph.xsize, glyph.ysize); |
| Font.glyphs[0, c] := glyph; |
| |
| bold_width := 1; |
| |
| create_glyph(Font, glyph, Font.width + bold_width, Font.height); |
| _bold(Font, Font.glyphs[0, c].base, glyph.base, Font.glyphs[0, c].xsize, glyph.xsize, bold_width); |
| smooth(Font, glyph.base, glyph.xsize, glyph.ysize); |
| glyph.width := max + bold_width; |
| Font.glyphs[1, c] := glyph; |
| |
| create_glyph(Font, glyph, Font.width + (Font.height - 1) DIV 3, Font.height); |
| FOR i := 0 TO Font.glyphs[0, c].xsize - 1 DO |
| FOR j := 0 TO Font.height - 1 DO |
| pix := getpix(Font, Font.glyphs[0, c].base, i, j, Font.glyphs[0, c].xsize); |
| IF pix = 1X THEN |
| setpix(Font, glyph.base, i + (Font.height - 1 - j) DIV 3, j, glyph.xsize, pix) |
| END |
| END |
| END; |
| smooth(Font, glyph.base, glyph.xsize, glyph.ysize); |
| glyph.width := max; |
| Font.glyphs[2, c] := glyph; |
| |
| create_glyph(Font, glyph, Font.width + (Font.height - 1) DIV 3 + bold_width, Font.height); |
| _bold(Font, Font.glyphs[2, c].base, glyph.base, Font.glyphs[2, c].xsize, glyph.xsize, bold_width); |
| smooth(Font, glyph.base, glyph.xsize, glyph.ysize); |
| glyph.width := max + bold_width; |
| Font.glyphs[3, c] := glyph; |
| |
| END make_glyph; |
| |
| PROCEDURE OutChar(Font: TFont_desc; c: INTEGER; x, y: INTEGER; buf: INTEGER; bpp32, smoothing: BOOLEAN; color, style: INTEGER): INTEGER; |
| VAR i, x0, y0, xsize, mem, xmax: INTEGER; r, g, b, r0, g0, b0: INTEGER; ch: CHAR; glyph: Glyph; |
| BEGIN |
| x0 := x; |
| y0 := y; |
| style := style MOD 4; |
| glyph := Font.glyphs[style, c]; |
| xsize := glyph.xsize; |
| xmax := x0 + xsize; |
| mem := Font.mem + glyph.base; |
| FOR i := mem TO mem + xsize * Font.height - 1 DO |
| sys.GET(i, ch); |
| IF ch = 1X THEN |
| pset(buf, x, y, color, bpp32) |
| ELSIF (ch = 2X) & smoothing THEN |
| getrgb(pget(buf, x, y, bpp32), r, g, b); |
| getrgb(color, r0, g0, b0); |
| r := (r * 3 + r0) DIV 4; |
| g := (g * 3 + g0) DIV 4; |
| b := (b * 3 + b0) DIV 4; |
| pset(buf, x, y, rgb(r, g, b), bpp32) |
| END; |
| INC(x); |
| IF x = xmax THEN |
| x := x0; |
| INC(y) |
| END |
| END |
| RETURN glyph.width |
| END OutChar; |
| |
| PROCEDURE hline(buf, x, y, width, color: INTEGER; bpp32: BOOLEAN); |
| VAR i: INTEGER; |
| BEGIN |
| FOR i := x TO x + width - 1 DO |
| pset(buf, i, y, color, bpp32) |
| END |
| END hline; |
| |
| PROCEDURE TextOut*(Font: TFont; canvas, x, y, str, length, color, params: INTEGER); |
| VAR width: INTEGER; c: CHAR; bpp32, smoothing: BOOLEAN; |
| BEGIN |
| IF Font # NIL THEN |
| smoothing := 4 IN BITS(params); |
| bpp32 := 5 IN BITS(params); |
| sys.GET(str, c); |
| WHILE (length > 0) OR (length = -1) & (c # 0X) DO |
| INC(str); |
| width := OutChar(Font^, ORD(c), x, y, canvas, bpp32, smoothing, color, params); |
| IF 3 IN BITS(params) THEN |
| hline(canvas, x + ORD(1 IN BITS(params)) * ((Font.height DIV 2) DIV 3), y + Font.height DIV 2, width, color, bpp32) |
| END; |
| IF 2 IN BITS(params) THEN |
| hline(canvas, x, y + Font.height - 1, width, color, bpp32) |
| END; |
| x := x + width; |
| IF length > 0 THEN |
| DEC(length) |
| END; |
| sys.GET(str, c) |
| END |
| END |
| END TextOut; |
| |
| PROCEDURE TextWidth*(Font: TFont; str, length, params: INTEGER): INTEGER; |
| VAR res: INTEGER; c: CHAR; |
| BEGIN |
| res := 0; |
| params := params MOD 4; |
| IF Font # NIL THEN |
| sys.GET(str, c); |
| WHILE (length > 0) OR (length = -1) & (c # 0X) DO |
| INC(str); |
| res := res + Font.glyphs[params, ORD(c)].width; |
| IF length > 0 THEN |
| DEC(length) |
| END; |
| sys.GET(str, c) |
| END |
| END |
| RETURN res |
| END TextWidth; |
| |
| PROCEDURE TextHeight*(Font: TFont): INTEGER; |
| VAR res: INTEGER; |
| BEGIN |
| IF Font # NIL THEN |
| res := Font.height |
| ELSE |
| res := 0 |
| END |
| RETURN res |
| END TextHeight; |
| |
| PROCEDURE SetSize*(_Font: TFont; font_size: INTEGER): BOOLEAN; |
| VAR temp, offset, fsize, i, memsize, mem: INTEGER; |
| c: CHAR; Font, Font2: TFont_desc; |
| BEGIN |
| offset := -1; |
| IF (MIN_FONT_SIZE <= font_size) & (font_size <= MAX_FONT_SIZE) & (_Font # NIL) THEN |
| Font := _Font^; |
| Font2 := Font; |
| temp := Font.data + (font_size - 8) * 4; |
| IF (Font.data <= temp) & (temp <= Font.size + Font.data - 4) THEN |
| sys.GET(temp, offset); |
| IF offset # -1 THEN |
| Font.font_size := font_size; |
| INC(offset, 156); |
| offset := offset + Font.data; |
| IF (Font.data <= offset) & (offset <= Font.size + Font.data - 4) THEN |
| sys.GET(offset, fsize); |
| IF fsize > 256 + 6 THEN |
| temp := offset + fsize - 1; |
| IF (Font.data <= temp) & (temp <= Font.size + Font.data - 1) THEN |
| sys.GET(temp, c); |
| IF c # 0X THEN |
| Font.height := ORD(c); |
| DEC(temp); |
| sys.GET(temp, c); |
| IF c # 0X THEN |
| Font.width := ORD(c); |
| DEC(fsize, 6); |
| Font.char_size := fsize DIV 256; |
| IF fsize MOD 256 # 0 THEN |
| INC(Font.char_size) |
| END; |
| IF Font.char_size > 0 THEN |
| Font.font := offset + 4; |
| Font.mempos := 0; |
| memsize := (Font.width + 10) * Font.height * 1024; |
| mem := Font.mem; |
| Font.mem := sysfunc3(68, 12, memsize); |
| IF Font.mem # 0 THEN |
| IF mem # 0 THEN |
| mem := sysfunc3(68, 13, mem) |
| END; |
| zeromem(memsize DIV 4, Font.mem); |
| FOR i := 0 TO 255 DO |
| make_glyph(Font, i) |
| END |
| ELSE |
| offset := -1 |
| END |
| ELSE |
| offset := -1 |
| END |
| ELSE |
| offset := -1 |
| END |
| ELSE |
| offset := -1 |
| END |
| ELSE |
| offset := -1 |
| END |
| ELSE |
| offset := -1 |
| END |
| ELSE |
| offset := -1 |
| END |
| END; |
| ELSE |
| offset := -1 |
| END; |
| IF offset # -1 THEN |
| _Font^ := Font |
| ELSE |
| _Font^ := Font2 |
| END |
| END |
| RETURN offset # -1 |
| END SetSize; |
| |
| PROCEDURE Enabled*(Font: TFont; font_size: INTEGER): BOOLEAN; |
| VAR offset, temp: INTEGER; |
| BEGIN |
| offset := -1; |
| IF (MIN_FONT_SIZE <= font_size) & (font_size <= MAX_FONT_SIZE) & (Font # NIL) THEN |
| temp := Font.data + (font_size - 8) * 4; |
| IF (Font.data <= temp) & (temp <= Font.size + Font.data - 4) THEN |
| sys.GET(temp, offset) |
| END |
| END |
| RETURN offset # -1 |
| END Enabled; |
| |
| PROCEDURE Destroy*(VAR Font: TFont); |
| BEGIN |
| IF Font # NIL THEN |
| IF Font.mem # 0 THEN |
| Font.mem := sysfunc3(68, 13, Font.mem) |
| END; |
| IF Font.data # 0 THEN |
| Font.data := sysfunc3(68, 13, Font.data) |
| END; |
| DISPOSE(Font) |
| END |
| END Destroy; |
| |
| PROCEDURE LoadFont*(file_name: ARRAY OF CHAR): TFont; |
| VAR Font: TFont; data, size, n: INTEGER; |
| BEGIN |
| data := LoadFile(sys.ADR(file_name[0]), size); |
| IF (data # 0) & (size > 156) THEN |
| NEW(Font); |
| Font.data := data; |
| Font.size := size; |
| Font.font_size := 0; |
| n := MIN_FONT_SIZE; |
| WHILE ~SetSize(Font, n) & (n <= MAX_FONT_SIZE) DO |
| INC(n) |
| END; |
| IF Font.font_size = 0 THEN |
| Destroy(Font) |
| END |
| ELSE |
| IF data # 0 THEN |
| data := sysfunc3(68, 13, data) |
| END; |
| Font := NIL |
| END |
| RETURN Font |
| END LoadFont; |
| |
| END kfonts. |