Subversion Repositories Kolibri OS

Rev

Rev 6647 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed

  1. (*
  2.     Copyright 2016, 2018 Anton Krotov
  3.  
  4.     This program is free software: you can redistribute it and/or modify
  5.     it under the terms of the GNU Lesser General Public License as published by
  6.     the Free Software Foundation, either version 3 of the License, or
  7.     (at your option) any later version.
  8.  
  9.     This program is distributed in the hope that it will be useful,
  10.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  11.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12.     GNU Lesser General Public License for more details.
  13.  
  14.     You should have received a copy of the GNU Lesser General Public License
  15.     along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16. *)
  17.  
  18. MODULE kfonts;
  19.  
  20. IMPORT sys := SYSTEM, File, KOSAPI;
  21.  
  22. CONST
  23.  
  24.   MIN_FONT_SIZE = 8;
  25.   MAX_FONT_SIZE = 46;
  26.  
  27.   bold            *=   1;
  28.   italic          *=   2;
  29.   underline       *=   4;
  30.   strike_through  *=   8;
  31.   smoothing       *=  16;
  32.   bpp32           *=  32;
  33.  
  34. TYPE
  35.  
  36.   Glyph = RECORD
  37.     base: INTEGER;
  38.     xsize, ysize: INTEGER;
  39.     width: INTEGER
  40.   END;
  41.  
  42.   TFont_desc = RECORD
  43.  
  44.     data, size, font, char_size, width, height, font_size, mem, mempos: INTEGER;
  45.     glyphs: ARRAY 4, 256 OF Glyph
  46.  
  47.   END;
  48.  
  49.   TFont* = POINTER TO TFont_desc;
  50.  
  51.  
  52. PROCEDURE [stdcall] zeromem(size, adr: INTEGER);
  53. BEGIN
  54.   sys.CODE(057H, 08BH, 07DH, 00CH, 08BH, 04DH, 008H, 033H, 0C0H, 09CH, 0FCH, 0F3H, 0ABH, 09DH, 05FH)
  55. END zeromem;
  56.  
  57. PROCEDURE pset(buf, x, y, color: INTEGER; bpp32: BOOLEAN);
  58. VAR xsize, ysize: INTEGER;
  59. BEGIN
  60.   sys.GET(buf, xsize);
  61.   sys.GET(buf + 4, ysize);
  62.   INC(buf, 8);
  63.   IF (0 <= x) & (x < xsize) & (0 <= y) & (y < ysize) THEN
  64.     IF bpp32 THEN
  65.       sys.PUT(buf + 4 * (xsize * y + x), color)
  66.     ELSE
  67.       sys.MOVE(sys.ADR(color), buf + 3 * (xsize * y + x), 3)
  68.     END
  69.   END
  70. END pset;
  71.  
  72. PROCEDURE pget(buf, x, y: INTEGER; bpp32: BOOLEAN): INTEGER;
  73. VAR xsize, ysize, color: INTEGER;
  74. BEGIN
  75.   sys.GET(buf, xsize);
  76.   sys.GET(buf + 4, ysize);
  77.   INC(buf, 8);
  78.   IF (0 <= x) & (x < xsize) & (0 <= y) & (y < ysize) THEN
  79.     IF bpp32 THEN
  80.       sys.GET(buf + 4 * (xsize * y + x), color)
  81.     ELSE
  82.       sys.MOVE(buf + 3 * (xsize * y + x), sys.ADR(color), 3)
  83.     END
  84.   END
  85.   RETURN color
  86. END pget;
  87.  
  88. PROCEDURE getrgb(color: INTEGER; VAR r, g, b: INTEGER);
  89. BEGIN
  90.   b := LSR(LSL(color, 24), 24);
  91.   g := LSR(LSL(color, 16), 24);
  92.   r := LSR(LSL(color,  8), 24);
  93. END getrgb;
  94.  
  95. PROCEDURE rgb(r, g, b: INTEGER): INTEGER;
  96.   RETURN b + LSL(g, 8) + LSL(r, 16)
  97. END rgb;
  98.  
  99. PROCEDURE create_glyph(VAR Font: TFont_desc; VAR glyph: Glyph; xsize, ysize: INTEGER);
  100. BEGIN
  101.   glyph.base := Font.mempos;
  102.   glyph.xsize := xsize;
  103.   glyph.ysize := ysize;
  104.   Font.mempos := Font.mempos + xsize * ysize
  105. END create_glyph;
  106.  
  107. PROCEDURE getpix(Font: TFont_desc; n, x, y, xsize: INTEGER): CHAR;
  108. VAR res: CHAR;
  109. BEGIN
  110.   sys.GET(Font.mem + n + x + y * xsize, res)
  111.   RETURN res
  112. END getpix;
  113.  
  114. PROCEDURE setpix(VAR Font: TFont_desc; n, x, y, xsize: INTEGER; c: CHAR);
  115. BEGIN
  116.   sys.PUT(Font.mem + n + x + y * xsize, c)
  117. END setpix;
  118.  
  119. PROCEDURE smooth(VAR Font: TFont_desc; n, xsize, ysize: INTEGER);
  120. VAR x, y: INTEGER;
  121. BEGIN
  122.   FOR y := 1 TO ysize - 1 DO
  123.     FOR x := 1 TO xsize - 1 DO
  124.       IF (getpix(Font, n, x, y, xsize) = 1X) & (getpix(Font, n, x - 1, y - 1, xsize) = 1X) &
  125.          (getpix(Font, n, x - 1, y, xsize) = 0X) & (getpix(Font, n, x, y - 1, xsize) = 0X) THEN
  126.         setpix(Font, n, x - 1, y, xsize, 2X);
  127.         setpix(Font, n, x, y - 1, xsize, 2X)
  128.       END;
  129.       IF (getpix(Font, n, x, y, xsize) = 0X) & (getpix(Font, n, x - 1, y - 1, xsize) = 0X) &
  130.          (getpix(Font, n, x - 1, y, xsize) = 1X) & (getpix(Font, n, x, y - 1, xsize) = 1X) THEN
  131.         setpix(Font, n, x, y, xsize, 2X);
  132.         setpix(Font, n, x - 1, y - 1, xsize, 2X)
  133.       END
  134.     END
  135.   END
  136. END smooth;
  137.  
  138. PROCEDURE _bold(VAR Font: TFont_desc; src, dst, src_xsize, dst_xsize, n: INTEGER);
  139. VAR i, j, k: INTEGER; pix: CHAR;
  140. BEGIN
  141.   FOR i := 0 TO src_xsize - 1 DO
  142.     FOR j := 0 TO Font.height - 1 DO
  143.       pix := getpix(Font, src, i, j, src_xsize);
  144.       IF pix = 1X THEN
  145.         FOR k := 0 TO n DO
  146.           setpix(Font, dst, i + k, j, dst_xsize, pix)
  147.         END
  148.       END
  149.     END
  150.   END
  151. END _bold;
  152.  
  153. PROCEDURE make_glyph(VAR Font: TFont_desc; c: INTEGER);
  154. VAR ptr, i, j, max, x, y: INTEGER; s: SET; eoc: BOOLEAN;
  155.     glyph: Glyph; pix: CHAR; bold_width: INTEGER;
  156. BEGIN
  157.   create_glyph(Font, glyph, Font.width, Font.height);
  158.   x := 0;
  159.   y := 0;
  160.   max := 0;
  161.   ptr := Font.font + Font.char_size * c;
  162.   eoc := FALSE;
  163.   REPEAT
  164.     sys.GET(ptr, s);
  165.     INC(ptr, 4);
  166.     FOR i := 0 TO 31 DO
  167.       IF ~eoc THEN
  168.         IF i IN s THEN
  169.           setpix(Font, glyph.base, x, y, Font.width, 1X);
  170.           IF x > max THEN
  171.             max := x
  172.           END
  173.         ELSE
  174.           setpix(Font, glyph.base, x, y, Font.width, 0X)
  175.         END
  176.       END;
  177.       INC(x);
  178.       IF x = Font.width THEN
  179.         x := 0;
  180.         INC(y);
  181.         eoc := eoc OR (y = Font.height)
  182.       END
  183.     END
  184.   UNTIL eoc;
  185.   IF max = 0 THEN
  186.     max := Font.width DIV 3
  187.   END;
  188.  
  189.   glyph.width := max;
  190.   smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
  191.   Font.glyphs[0, c] := glyph;
  192.  
  193.   bold_width := 1;
  194.  
  195.   create_glyph(Font, glyph, Font.width + bold_width, Font.height);
  196.   _bold(Font, Font.glyphs[0, c].base, glyph.base, Font.glyphs[0, c].xsize, glyph.xsize, bold_width);
  197.   smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
  198.   glyph.width := max + bold_width;
  199.   Font.glyphs[1, c] := glyph;
  200.  
  201.   create_glyph(Font, glyph, Font.width + (Font.height - 1) DIV 3, Font.height);
  202.   FOR i := 0 TO Font.glyphs[0, c].xsize - 1 DO
  203.     FOR j := 0 TO Font.height - 1 DO
  204.       pix := getpix(Font, Font.glyphs[0, c].base, i, j, Font.glyphs[0, c].xsize);
  205.       IF pix = 1X THEN
  206.         setpix(Font, glyph.base, i + (Font.height - 1 - j) DIV 3, j, glyph.xsize, pix)
  207.       END
  208.     END
  209.   END;
  210.   smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
  211.   glyph.width := max;
  212.   Font.glyphs[2, c] := glyph;
  213.  
  214.   create_glyph(Font, glyph, Font.width + (Font.height - 1) DIV 3 + bold_width, Font.height);
  215.   _bold(Font, Font.glyphs[2, c].base, glyph.base, Font.glyphs[2, c].xsize, glyph.xsize, bold_width);
  216.   smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
  217.   glyph.width := max + bold_width;
  218.   Font.glyphs[3, c] := glyph;
  219.  
  220. END make_glyph;
  221.  
  222. PROCEDURE OutChar(Font: TFont_desc; c: INTEGER; x, y: INTEGER; buf: INTEGER; bpp32, smoothing: BOOLEAN; color, style: INTEGER): INTEGER;
  223. VAR i, x0, y0, xsize, mem, xmax: INTEGER; r, g, b, r0, g0, b0: INTEGER; ch: CHAR; glyph: Glyph;
  224. BEGIN
  225.   x0 := x;
  226.   y0 := y;
  227.   style := style MOD 4;
  228.   glyph := Font.glyphs[style, c];
  229.   xsize := glyph.xsize;
  230.   xmax := x0 + xsize;
  231.   mem := Font.mem + glyph.base;
  232.   getrgb(color, r0, g0, b0);
  233.   FOR i := mem TO mem + xsize * Font.height - 1 DO
  234.     sys.GET(i, ch);
  235.     IF ch = 1X THEN
  236.       pset(buf, x, y, color, bpp32);
  237.     ELSIF (ch = 2X) & smoothing THEN
  238.       getrgb(pget(buf, x, y, bpp32), r, g, b);
  239.       r := (r * 3 + r0) DIV 4;
  240.       g := (g * 3 + g0) DIV 4;
  241.       b := (b * 3 + b0) DIV 4;
  242.       pset(buf, x, y, rgb(r, g, b), bpp32)
  243.     END;
  244.     INC(x);
  245.     IF x = xmax THEN
  246.       x := x0;
  247.       INC(y)
  248.     END
  249.   END
  250.   RETURN glyph.width
  251. END OutChar;
  252.  
  253. PROCEDURE hline(buf, x, y, width, color: INTEGER; bpp32: BOOLEAN);
  254. VAR i: INTEGER;
  255. BEGIN
  256.   FOR i := x TO x + width - 1 DO
  257.     pset(buf, i, y, color, bpp32)
  258.   END
  259. END hline;
  260.  
  261. PROCEDURE TextWidth*(Font: TFont; str, length, params: INTEGER): INTEGER;
  262. VAR res: INTEGER; c: CHAR;
  263. BEGIN
  264.   res := 0;
  265.   params := params MOD 4;
  266.   IF Font # NIL THEN
  267.     sys.GET(str, c);
  268.     WHILE (length > 0) OR (length = -1) & (c # 0X) DO
  269.       INC(str);
  270.       res := res + Font.glyphs[params, ORD(c)].width;
  271.       IF length > 0 THEN
  272.         DEC(length)
  273.       END;
  274.       IF length # 0 THEN
  275.         sys.GET(str, c)
  276.       END
  277.     END
  278.   END
  279.   RETURN res
  280. END TextWidth;
  281.  
  282. PROCEDURE TextHeight*(Font: TFont): INTEGER;
  283. VAR res: INTEGER;
  284. BEGIN
  285.   IF Font # NIL THEN
  286.     res := Font.height
  287.   ELSE
  288.     res := 0
  289.   END
  290.   RETURN res
  291. END TextHeight;
  292.  
  293. PROCEDURE TextClipLeft(Font: TFont; str, length, params: INTEGER; VAR x: INTEGER): INTEGER;
  294. VAR x1: INTEGER; c: CHAR;
  295. BEGIN
  296.   params := params MOD 4;
  297.   sys.GET(str, c);
  298.   WHILE (length > 0) OR (length = -1) & (c # 0X) DO
  299.     INC(str);
  300.     x1 := x;
  301.     x := x + Font.glyphs[params, ORD(c)].width;
  302.     IF x > 0 THEN
  303.       length := 0;
  304.     END;
  305.     IF length > 0 THEN
  306.       DEC(length)
  307.     END;
  308.     IF length # 0 THEN
  309.       sys.GET(str, c)
  310.     END
  311.   END;
  312.   x := x1
  313.   RETURN str - 1
  314. END TextClipLeft;
  315.  
  316. PROCEDURE TextOut*(Font: TFont; canvas, x, y, str, length, color, params: INTEGER);
  317. VAR width, xsize, ysize, str1, n: INTEGER; c: CHAR; bpp32, smoothing, underline, strike: BOOLEAN;
  318. BEGIN
  319.   IF Font # NIL THEN
  320.     sys.GET(canvas,     xsize);
  321.     sys.GET(canvas + 4, ysize);
  322.     IF (y <= -TextHeight(Font)) OR (y >= ysize) THEN
  323.       length := 0
  324.     END;
  325.     IF length # 0 THEN
  326.       smoothing := 4 IN BITS(params);
  327.       bpp32 := 5 IN BITS(params);
  328.       underline := 2 IN BITS(params);
  329.       strike := 3 IN BITS(params);
  330.       str1 := TextClipLeft(Font, str, length, params, x);
  331.       n := str1 - str;
  332.       str := str1;
  333.       IF length >= n THEN
  334.         length := length - n
  335.       END;
  336.       sys.GET(str, c)
  337.     END;
  338.     WHILE (length > 0) OR (length = -1) & (c # 0X) DO
  339.       INC(str);
  340.       width := OutChar(Font^, ORD(c), x, y, canvas, bpp32, smoothing, color, params);
  341.       IF strike THEN
  342.         hline(canvas, x + ORD(1 IN BITS(params)) * ((Font.height DIV 2) DIV 3), y + Font.height DIV 2, width + 2, color, bpp32)
  343.       END;
  344.       IF underline THEN
  345.         hline(canvas, x, y + Font.height - 1, width + 2, color, bpp32)
  346.       END;
  347.       x := x + width;
  348.       IF x > xsize THEN
  349.         length := 0
  350.       END;
  351.       IF length > 0 THEN
  352.         DEC(length)
  353.       END;
  354.       IF length # 0 THEN
  355.         sys.GET(str, c)
  356.       END
  357.     END
  358.   END
  359. END TextOut;
  360.  
  361. PROCEDURE SetSize*(_Font: TFont; font_size: INTEGER): BOOLEAN;
  362. VAR temp, offset, fsize, i, memsize, mem: INTEGER;
  363.     c: CHAR; Font, Font2: TFont_desc;
  364. BEGIN
  365.   offset := -1;
  366.   IF (MIN_FONT_SIZE <= font_size) & (font_size <= MAX_FONT_SIZE) & (_Font # NIL) THEN
  367.     Font := _Font^;
  368.     Font2 := Font;
  369.     temp := Font.data + (font_size - 8) * 4;
  370.     IF (Font.data <= temp) & (temp <= Font.size + Font.data - 4) THEN
  371.       sys.GET(temp, offset);
  372.       IF offset # -1 THEN
  373.         Font.font_size := font_size;
  374.         INC(offset, 156);
  375.         offset := offset + Font.data;
  376.         IF (Font.data <= offset) & (offset <= Font.size + Font.data - 4) THEN
  377.           sys.GET(offset, fsize);
  378.           IF fsize > 256 + 6 THEN
  379.             temp := offset + fsize - 1;
  380.             IF (Font.data <= temp) & (temp <= Font.size + Font.data - 1) THEN
  381.               sys.GET(temp, c);
  382.               IF c # 0X THEN
  383.                 Font.height := ORD(c);
  384.                 DEC(temp);
  385.                 sys.GET(temp, c);
  386.                 IF c # 0X THEN
  387.                   Font.width := ORD(c);
  388.                   DEC(fsize, 6);
  389.                   Font.char_size := fsize DIV 256;
  390.                   IF fsize MOD 256 # 0 THEN
  391.                     INC(Font.char_size)
  392.                   END;
  393.                   IF Font.char_size > 0 THEN
  394.                     Font.font := offset + 4;
  395.                     Font.mempos := 0;
  396.                     memsize := (Font.width + 10) * Font.height * 1024;
  397.                     mem := Font.mem;
  398.                     Font.mem := KOSAPI.sysfunc3(68, 12, memsize);
  399.                     IF Font.mem # 0 THEN
  400.                       IF mem # 0 THEN
  401.                         mem := KOSAPI.sysfunc3(68, 13, mem)
  402.                       END;
  403.                       zeromem(memsize DIV 4, Font.mem);
  404.                       FOR i := 0 TO 255 DO
  405.                         make_glyph(Font, i)
  406.                       END
  407.                     ELSE
  408.                       offset := -1
  409.                     END
  410.                   ELSE
  411.                     offset := -1
  412.                   END
  413.                 ELSE
  414.                   offset := -1
  415.                 END
  416.               ELSE
  417.                 offset := -1
  418.               END
  419.             ELSE
  420.               offset := -1
  421.             END
  422.           ELSE
  423.             offset := -1
  424.           END
  425.         ELSE
  426.           offset := -1
  427.         END
  428.       END;
  429.     ELSE
  430.       offset := -1
  431.     END;
  432.     IF offset # -1 THEN
  433.       _Font^ := Font
  434.     ELSE
  435.       _Font^ := Font2
  436.     END
  437.   END
  438.   RETURN offset # -1
  439. END SetSize;
  440.  
  441. PROCEDURE Enabled*(Font: TFont; font_size: INTEGER): BOOLEAN;
  442. VAR offset, temp: INTEGER;
  443. BEGIN
  444.   offset := -1;
  445.   IF (MIN_FONT_SIZE <= font_size) & (font_size <= MAX_FONT_SIZE) & (Font # NIL) THEN
  446.     temp := Font.data + (font_size - 8) * 4;
  447.     IF (Font.data <= temp) & (temp <= Font.size + Font.data - 4) THEN
  448.       sys.GET(temp, offset)
  449.     END
  450.   END
  451.   RETURN offset # -1
  452. END Enabled;
  453.  
  454. PROCEDURE Destroy*(VAR Font: TFont);
  455. BEGIN
  456.   IF Font # NIL THEN
  457.     IF Font.mem # 0 THEN
  458.       Font.mem := KOSAPI.sysfunc3(68, 13, Font.mem)
  459.     END;
  460.     IF Font.data # 0 THEN
  461.       Font.data := KOSAPI.sysfunc3(68, 13, Font.data)
  462.     END;
  463.     DISPOSE(Font)
  464.   END
  465. END Destroy;
  466.  
  467. PROCEDURE LoadFont*(file_name: ARRAY OF CHAR): TFont;
  468. VAR Font: TFont; data, size, n: INTEGER;
  469. BEGIN
  470.   data := File.Load(file_name, size);
  471.   IF (data # 0) & (size > 156) THEN
  472.     NEW(Font);
  473.     Font.data := data;
  474.     Font.size := size;
  475.     Font.font_size := 0;
  476.     n := MIN_FONT_SIZE;
  477.     WHILE ~SetSize(Font, n) & (n <= MAX_FONT_SIZE) DO
  478.       INC(n)
  479.     END;
  480.     IF Font.font_size = 0 THEN
  481.       Destroy(Font)
  482.     END
  483.   ELSE
  484.     IF data # 0 THEN
  485.       data := KOSAPI.sysfunc3(68, 13, data)
  486.     END;
  487.     Font := NIL
  488.   END
  489.   RETURN Font
  490. END LoadFont;
  491.  
  492. END kfonts.