admin/LithosAnanake
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
bb84eba7e3c9301080f145ebdfe66dac798dbb48
LithosAnanake/capsules/font.4th
T
Robert Allan JamesandClaude Sonnet 5 2960989100 font.4th: TEXT entry point, UTF-8 string rendering (item 4.3.6f) 
Punch list §25 item 4.3.6f complete. TEXT ( c-addr u x y size color -- )
walks a UTF-8 byte string, decoding one codepoint at a time via
DECODE-UTF8, drawing each via DRAW-GLYPH, and accumulating the cursor
X by the glyph's em-advance scaled to pixels. Uses 2>R/2R> to stash
the DECODE-UTF8 remainder off the data stack while DRAW-GLYPH's args
are pushed.

Defined in font.4th, not fabric.4th, so its compiled DRAW-GLYPH call
binds to the real definition, not fabric.4th's 4.3.6b placeholder --
same early-binding constraint as DISPATCH-GLYPH itself.

Verified live: a string mixing ASCII, Latin-1 (degree sign), and
General Punctuation (em dash) renders correctly in one TEXT call with
proportional spacing, no overlap.

Three-arch acceptance boot clean, Stadium conservation unchanged.

Co-Authored-By: Claude Sonnet 5 <noreply@anthropic.com>
2026-08-09 20:46:55 -04:00

734 lines
17 KiB
Forth
Raw Blame History

Block 4925
( font.4th -- default v1 system font, 113 glyphs. Item 4.3.6c. )
( Grid: LEFT=100 RIGHT=450 BASE=0 TOP=700 MID=350 for caps/ )
( digits; x-height letters use 500, ascender 750, desc -250. )
( Genuinely round/curved parts use G-CIRCLE/G-ARC/G-ELLIPSE )
( (fabric.4th 5000-5002); straight strokes stay G-LINE. Not )
( every round-ish letter was converted -- only ones a single )
( circle/arc/ellipse renders cleanly without per-glyph angle )
( tuning (S/s/&/2/3/5/6/8/9 etc. stay blocky; see FABRIC.md). )
Block 4926
( Digit 0: ELLIPSE -- true oval, not a 6-line rectangle. )
: G-0 ( -- adv )
275 350 175 350 G-ELLIPSE
550 ;
( Digit 1: segments B C, unchanged )
: G-1 ( -- adv )
450 700 450 350 G-LINE
450 350 450 0 G-LINE
550 ;
Block 4927
( Digit 2: segments A B G E D )
: G-2 ( -- adv )
100 700 450 700 G-LINE
450 700 450 350 G-LINE
100 350 450 350 G-LINE
100 350 100 0 G-LINE
100 0 450 0 G-LINE
550 ;
( Digit 3: segments A B G C D )
: G-3 ( -- adv )
100 700 450 700 G-LINE
450 700 450 350 G-LINE
100 350 450 350 G-LINE
450 350 450 0 G-LINE
100 0 450 0 G-LINE
550 ;
Block 4928
( Digit 4: segments F G B C )
: G-4 ( -- adv )
100 700 100 350 G-LINE
100 350 450 350 G-LINE
450 700 450 350 G-LINE
450 350 450 0 G-LINE
550 ;
( Digit 5: segments A F G C D )
: G-5 ( -- adv )
100 700 450 700 G-LINE
100 700 100 350 G-LINE
100 350 450 350 G-LINE
450 350 450 0 G-LINE
100 0 450 0 G-LINE
550 ;
Block 4929
( Digit 6: segments A F G E D C )
: G-6 ( -- adv )
100 700 450 700 G-LINE
100 700 100 350 G-LINE
100 350 450 350 G-LINE
100 350 100 0 G-LINE
100 0 450 0 G-LINE
450 350 450 0 G-LINE
550 ;
( Digit 7: segments A B C )
: G-7 ( -- adv )
100 700 450 700 G-LINE
450 700 450 350 G-LINE
450 350 450 0 G-LINE
550 ;
Block 4930
( Digit 8: all seven segments )
: G-8 ( -- adv )
100 700 450 700 G-LINE
450 700 450 350 G-LINE
450 350 450 0 G-LINE
100 0 450 0 G-LINE
100 350 100 0 G-LINE
100 700 100 350 G-LINE
100 350 450 350 G-LINE
550 ;
Block 4931
( Digit 9: segments A B C D F G )
: G-9 ( -- adv )
100 700 450 700 G-LINE
450 700 450 350 G-LINE
450 350 450 0 G-LINE
100 0 450 0 G-LINE
100 700 100 350 G-LINE
100 350 450 350 G-LINE
550 ;
Block 4932
( Upper A-Z. Grid X0=100 X1=275 X2=450 Y0=0 Y1=350 )
( Y2=700, same as digits. Comments dropped after 4.3.6c )
( hit the 16-line block cap -- names are self-documenting. )
: G-A ( -- adv )
100 0 275 700 G-LINE
275 700 450 0 G-LINE
190 350 360 350 G-LINE
550 ;
: G-B ( -- adv )
100 0 100 700 G-LINE
100 700 400 700 G-LINE
400 700 400 350 G-LINE
100 350 400 350 G-LINE
400 350 400 0 G-LINE
100 0 400 0 G-LINE
550 ;
Block 4933
( C: ARC, 270 deg open at east (right). )
: G-C ( -- adv )
275 350 250 102944 411774 G-ARC
550 ;
( D: straight stem + ARC bowl (east bulge), )
( arc endpoints land exactly on stem ends. )
: G-D ( -- adv )
100 0 100 700 G-LINE
100 350 350 -102944 102944 G-ARC
550 ;
Block 4934
: G-E ( -- adv )
400 700 100 700 G-LINE
100 700 100 0 G-LINE
100 0 400 0 G-LINE
100 350 350 350 G-LINE
550 ;
: G-F ( -- adv )
100 0 100 700 G-LINE
100 700 400 700 G-LINE
100 350 350 350 G-LINE
550 ;
Block 4935
( G: same ARC as C, plus the inward bar. )
: G-G ( -- adv )
275 350 250 102944 411774 G-ARC
525 250 300 250 G-LINE
550 ;
: G-H ( -- adv )
100 0 100 700 G-LINE
450 0 450 700 G-LINE
100 350 450 350 G-LINE
550 ;
Block 4936
: G-I ( -- adv )
200 700 350 700 G-LINE
275 700 275 0 G-LINE
200 0 350 0 G-LINE
380 ;
: G-J ( -- adv )
350 700 350 100 G-LINE
350 100 275 0 G-LINE
275 0 150 50 G-LINE
480 ;
: G-K ( -- adv )
100 0 100 700 G-LINE
100 350 450 700 G-LINE
100 350 450 0 G-LINE
550 ;
Block 4937
: G-L ( -- adv )
100 700 100 0 G-LINE
100 0 400 0 G-LINE
500 ;
: G-M ( -- adv )
100 0 100 700 G-LINE
100 700 275 400 G-LINE
275 400 450 700 G-LINE
450 700 450 0 G-LINE
650 ;
: G-N ( -- adv )
100 0 100 700 G-LINE
100 700 450 0 G-LINE
450 0 450 700 G-LINE
550 ;
Block 4938
( O: ELLIPSE -- true oval. )
: G-O ( -- adv )
275 350 175 350 G-ELLIPSE
600 ;
: G-P ( -- adv )
100 0 100 700 G-LINE
100 700 400 700 G-LINE
400 700 400 350 G-LINE
400 350 100 350 G-LINE
550 ;
Block 4939
( Q: ELLIPSE, same as O, plus the tail. )
: G-Q ( -- adv )
275 350 175 350 G-ELLIPSE
320 150 480 -100 G-LINE
600 ;
: G-R ( -- adv )
100 0 100 700 G-LINE
100 700 400 700 G-LINE
400 700 400 350 G-LINE
400 350 100 350 G-LINE
100 350 450 0 G-LINE
550 ;
Block 4940
: G-S ( -- adv )
400 700 100 700 G-LINE
100 700 100 350 G-LINE
100 350 400 350 G-LINE
400 350 400 0 G-LINE
400 0 100 0 G-LINE
550 ;
: G-T ( -- adv )
100 700 450 700 G-LINE
275 700 275 0 G-LINE
550 ;
Block 4941
: G-U ( -- adv )
100 700 100 150 G-LINE
100 150 275 0 G-LINE
275 0 450 150 G-LINE
450 150 450 700 G-LINE
600 ;
: G-V ( -- adv )
100 700 275 0 G-LINE
275 0 450 700 G-LINE
550 ;
: G-W ( -- adv )
100 700 190 0 G-LINE
190 0 275 400 G-LINE
275 400 360 0 G-LINE
360 0 450 700 G-LINE
650 ;
Block 4942
: G-X ( -- adv )
100 700 450 0 G-LINE
100 0 450 700 G-LINE
550 ;
: G-Y ( -- adv )
100 700 275 350 G-LINE
450 700 275 350 G-LINE
275 350 275 0 G-LINE
550 ;
: G-Z ( -- adv )
100 700 450 700 G-LINE
450 700 100 0 G-LINE
100 0 450 0 G-LINE
550 ;
Block 4943
( Lower a-z. x-height grid X0=100 X1=250-275 X2=400, )
( Y0=0 base, YH=250, YX=500 x-height, ascend 750/desc -250. )
: G-a ( -- adv )
350 500 150 500 G-LINE
150 500 100 375 G-LINE
100 375 150 250 G-LINE
150 250 400 250 G-LINE
400 500 400 0 G-LINE
550 ;
: G-b ( -- adv )
100 750 100 0 G-LINE
100 250 250 -102944 102944 G-ARC
550 ;
Block 4944
( c: x-height ARC, same 270-open-east shape as C. )
: G-c ( -- adv )
275 250 200 102944 411774 G-ARC
500 ;
: G-d ( -- adv )
400 750 400 0 G-LINE
400 250 250 102944 308831 G-ARC
550 ;
Block 4945
( e: same ARC as c, plus the crossbar. )
: G-e ( -- adv )
275 250 200 102944 411774 G-ARC
120 260 430 260 G-LINE
550 ;
: G-f ( -- adv )
250 750 250 0 G-LINE
250 700 400 700 G-LINE
150 400 400 400 G-LINE
450 ;
Block 4946
: G-g ( -- adv )
150 500 400 500 G-LINE
400 500 400 -250 G-LINE
400 0 150 0 G-LINE
150 0 150 500 G-LINE
400 -250 250 -250 G-LINE
550 ;
: G-h ( -- adv )
100 750 100 0 G-LINE
100 500 400 500 G-LINE
400 500 400 0 G-LINE
550 ;
Block 4947
: G-i ( -- adv )
250 500 250 0 G-LINE
240 600 260 650 G-LINE
350 ;
: G-j ( -- adv )
275 500 275 -150 G-LINE
275 -150 150 -250 G-LINE
265 600 285 650 G-LINE
400 ;
: G-k ( -- adv )
100 750 100 0 G-LINE
100 250 400 500 G-LINE
100 250 400 0 G-LINE
550 ;
Block 4948
: G-l ( -- adv )
275 750 275 0 G-LINE
350 ;
: G-m ( -- adv )
100 0 100 500 G-LINE
100 500 250 500 G-LINE
250 500 250 0 G-LINE
250 500 400 500 G-LINE
400 500 400 0 G-LINE
650 ;
Block 4949
: G-n ( -- adv )
100 500 100 0 G-LINE
100 500 400 500 G-LINE
400 500 400 0 G-LINE
550 ;
( o: ELLIPSE -- true oval, x-height sized. )
: G-o ( -- adv )
275 250 125 250 G-ELLIPSE
500 ;
Block 4950
( p: descender stem + ARC bowl (east bulge). )
: G-p ( -- adv )
100 500 100 -250 G-LINE
100 250 250 -102944 102944 G-ARC
550 ;
( q: descender stem + ARC bowl (west bulge). )
: G-q ( -- adv )
400 500 400 -250 G-LINE
400 250 250 102944 308831 G-ARC
550 ;
Block 4951
: G-r ( -- adv )
100 500 100 0 G-LINE
100 500 300 500 G-LINE
300 500 350 450 G-LINE
400 ;
: G-s ( -- adv )
400 500 150 500 G-LINE
150 500 150 250 G-LINE
150 250 400 250 G-LINE
400 250 400 0 G-LINE
400 0 150 0 G-LINE
500 ;
Block 4952
: G-t ( -- adv )
250 650 250 100 G-LINE
250 100 400 0 G-LINE
150 400 400 400 G-LINE
400 ;
: G-u ( -- adv )
100 500 100 100 G-LINE
100 100 250 0 G-LINE
250 0 400 100 G-LINE
400 100 400 500 G-LINE
550 ;
Block 4953
: G-v ( -- adv )
100 500 250 0 G-LINE
250 0 400 500 G-LINE
500 ;
: G-w ( -- adv )
100 500 175 0 G-LINE
175 0 250 300 G-LINE
250 300 325 0 G-LINE
325 0 400 500 G-LINE
600 ;
Block 4954
: G-x ( -- adv )
100 500 400 0 G-LINE
100 0 400 500 G-LINE
500 ;
: G-y ( -- adv )
100 500 250 200 G-LINE
400 500 250 200 G-LINE
250 200 150 -250 G-LINE
500 ;
: G-z ( -- adv )
100 500 400 500 G-LINE
400 500 100 0 G-LINE
100 0 400 0 G-LINE
500 ;
Block 4955
( ASCII punctuation, scattered 32-47,58-64,91-96,123-126. )
: G-SPACE ( -- adv ) 300 ;
: G-BANG ( -- adv )
250 700 250 250 G-LINE
240 100 260 150 G-LINE
300 ;
: G-DQUOTE ( -- adv )
200 700 200 550 G-LINE
320 700 320 550 G-LINE
350 ;
Block 4956
: G-HASH ( -- adv )
180 700 180 0 G-LINE
340 700 340 0 G-LINE
80 500 420 500 G-LINE
80 200 420 200 G-LINE
500 ;
: G-DOLLAR ( -- adv )
350 650 150 650 G-LINE
150 650 150 400 G-LINE
150 400 350 400 G-LINE
350 400 350 150 G-LINE
350 150 150 150 G-LINE
250 750 250 50 G-LINE
550 ;
Block 4957
( PERCENT: 2 small CIRCLEs + the diagonal. )
: G-PERCENT ( -- adv )
100 700 400 0 G-LINE
150 550 50 G-CIRCLE
350 150 50 G-CIRCLE
550 ;
Block 4958
: G-AMP ( -- adv )
350 0 150 600 G-LINE
150 600 300 650 G-LINE
300 650 150 450 G-LINE
150 450 350 150 G-LINE
350 150 200 0 G-LINE
200 0 350 0 G-LINE
550 ;
: G-SQUOTE ( -- adv ) 260 700 260 550 G-LINE 300 ;
Block 4959
: G-LPAREN ( -- adv )
300 700 200 500 G-LINE
200 500 200 200 G-LINE
200 200 300 0 G-LINE
350 ;
: G-RPAREN ( -- adv )
200 700 300 500 G-LINE
300 500 300 200 G-LINE
300 200 200 0 G-LINE
350 ;
Block 4960
: G-STAR ( -- adv )
250 650 250 450 G-LINE
150 600 350 500 G-LINE
150 500 350 600 G-LINE
400 ;
: G-PLUS ( -- adv )
250 550 250 150 G-LINE
100 350 400 350 G-LINE
500 ;
: G-COMMA ( -- adv ) 250 50 200 -100 G-LINE 300 ;
Block 4961
: G-HYPHEN ( -- adv ) 150 350 350 350 G-LINE 400 ;
: G-PERIOD ( -- adv ) 250 25 25 G-CIRCLE 300 ;
: G-SLASH ( -- adv ) 150 0 400 700 G-LINE 450 ;
: G-COLON ( -- adv )
240 450 260 500 G-LINE
240 150 260 200 G-LINE
300 ;
Block 4962
: G-SEMI ( -- adv )
240 450 260 500 G-LINE
250 50 200 -100 G-LINE
300 ;
: G-LT ( -- adv )
350 600 150 350 G-LINE
150 350 350 100 G-LINE
500 ;
: G-EQ ( -- adv )
100 420 400 420 G-LINE
100 280 400 280 G-LINE
500 ;
Block 4963
: G-GT ( -- adv )
150 600 350 350 G-LINE
350 350 150 100 G-LINE
500 ;
: G-QMARK ( -- adv )
150 600 300 700 G-LINE
300 700 350 600 G-LINE
350 600 250 450 G-LINE
250 450 250 350 G-LINE
240 100 260 150 G-LINE
450 ;
Block 4964
( AT: outer box unchanged + a CIRCLE for the inner loop. )
: G-AT ( -- adv )
100 600 400 600 G-LINE
400 600 400 50 G-LINE
400 50 100 50 G-LINE
100 50 100 600 G-LINE
250 350 50 G-CIRCLE
600 ;
Block 4965
: G-LBRACKET ( -- adv )
300 700 200 700 G-LINE
200 700 200 0 G-LINE
200 0 300 0 G-LINE
350 ;
: G-BACKSLASH ( -- adv ) 150 700 400 0 G-LINE 450 ;
: G-RBRACKET ( -- adv )
200 700 300 700 G-LINE
300 700 300 0 G-LINE
300 0 200 0 G-LINE
350 ;
Block 4966
: G-CARET ( -- adv )
150 450 275 650 G-LINE
275 650 400 450 G-LINE
500 ;
: G-UNDERSCORE ( -- adv ) 100 -50 400 -50 G-LINE 500 ;
: G-BACKTICK ( -- adv ) 220 700 280 600 G-LINE 300 ;
Block 4967
: G-LBRACE ( -- adv )
280 700 220 650 G-LINE
220 650 220 400 G-LINE
220 400 150 350 G-LINE
220 350 220 100 G-LINE
220 100 280 0 G-LINE
350 ;
Block 4968
: G-RBRACE ( -- adv )
220 700 280 650 G-LINE
280 650 280 400 G-LINE
280 400 350 350 G-LINE
280 350 280 100 G-LINE
280 100 220 0 G-LINE
350 ;
: G-PIPE ( -- adv ) 250 700 250 -150 G-LINE 300 ;
Block 4969
: G-TILDE ( -- adv )
100 380 200 450 G-LINE
200 450 300 320 G-LINE
300 320 400 390 G-LINE
500 ;
Block 4970
( Latin-1 Supplement, 11 glyphs. codepoints per FABRIC.md )
( 27.6.4. DEGREE/CENT use curves; rest are line-only. )
: G-DEGREE ( -- adv ) 250 600 60 G-CIRCLE 350 ;
: G-CENT ( -- adv )
275 250 200 102944 411774 G-ARC
275 550 275 -50 G-LINE
500 ;
Block 4971
: G-COPYRIGHT ( -- adv )
250 350 200 G-CIRCLE
250 350 100 102944 411774 G-ARC
600 ;
: G-PLUSMINUS ( -- adv )
250 550 250 350 G-LINE
150 450 350 450 G-LINE
150 150 350 150 G-LINE
500 ;
Block 4972
: G-REGISTERED ( -- adv )
250 350 200 G-CIRCLE
200 280 200 420 G-LINE
200 420 280 420 G-LINE
280 420 280 350 G-LINE
280 350 200 350 G-LINE
200 350 280 280 G-LINE
600 ;
Block 4973
: G-MULT ( -- adv )
150 450 350 150 G-LINE
150 150 350 450 G-LINE
500 ;
: G-DIVIDE ( -- adv )
150 300 350 300 G-LINE
250 400 25 G-CIRCLE
250 200 25 G-CIRCLE
500 ;
Block 4974
: G-POUND ( -- adv )
200 600 200 150 G-LINE
200 600 280 650 G-LINE
120 350 320 350 G-LINE
120 150 320 150 G-LINE
550 ;
: G-SECTION ( -- adv )
300 600 150 600 G-LINE
150 600 150 450 G-LINE
150 450 300 450 G-LINE
300 450 300 350 G-LINE
300 350 150 350 G-LINE
150 350 150 200 G-LINE
150 200 300 200 G-LINE
500 ;
Block 4975
: G-PILCROW ( -- adv )
250 550 100 G-CIRCLE
300 650 300 50 G-LINE
200 650 200 450 G-LINE
500 ;
: G-NBSP ( -- adv ) 300 ;
Block 4976
( General Punctuation, 7 glyphs. codepoints per FABRIC.md )
( 27.6.4. ELLIPSIS uses three CIRCLEs, matching PERIOD. )
: G-LSQUOTE ( -- adv )
230 650 220 600 G-LINE
220 600 230 570 G-LINE
300 ;
: G-RSQUOTE ( -- adv )
220 650 230 600 G-LINE
230 600 220 570 G-LINE
300 ;
Block 4977
: G-LDQUOTE ( -- adv )
200 650 190 600 G-LINE
190 600 200 570 G-LINE
330 650 320 600 G-LINE
320 600 330 570 G-LINE
400 ;
: G-RDQUOTE ( -- adv )
190 650 200 600 G-LINE
200 600 190 570 G-LINE
320 650 330 600 G-LINE
330 600 320 570 G-LINE
400 ;
Block 4978
: G-ENDASH ( -- adv ) 150 350 350 350 G-LINE 500 ;
: G-EMDASH ( -- adv ) 100 350 450 350 G-LINE 600 ;
: G-ELLIPSIS ( -- adv )
150 25 25 G-CIRCLE
275 25 25 G-CIRCLE
400 25 25 G-CIRCLE
600 ;
Block 4979
( Real DISPATCH-DIGIT, replaces fabric.4th's placeholder. )
( Redefinition needed -- CASE binds early (FABRIC.md 27.6.5).)
: DISPATCH-DIGIT ( codepoint -- adv ) CASE
48 OF G-0 ENDOF 49 OF G-1 ENDOF 50 OF G-2 ENDOF
51 OF G-3 ENDOF 52 OF G-4 ENDOF 53 OF G-5 ENDOF
54 OF G-6 ENDOF 55 OF G-7 ENDOF 56 OF G-8 ENDOF
57 OF G-9 ENDOF
DROP TOFU ENDCASE ;
Block 4980
: DISPATCH-UPPER ( codepoint -- adv ) CASE
65 OF G-A ENDOF 66 OF G-B ENDOF 67 OF G-C ENDOF
68 OF G-D ENDOF 69 OF G-E ENDOF 70 OF G-F ENDOF
71 OF G-G ENDOF 72 OF G-H ENDOF 73 OF G-I ENDOF
74 OF G-J ENDOF 75 OF G-K ENDOF 76 OF G-L ENDOF
77 OF G-M ENDOF 78 OF G-N ENDOF 79 OF G-O ENDOF
80 OF G-P ENDOF 81 OF G-Q ENDOF 82 OF G-R ENDOF
83 OF G-S ENDOF 84 OF G-T ENDOF 85 OF G-U ENDOF
86 OF G-V ENDOF 87 OF G-W ENDOF 88 OF G-X ENDOF
89 OF G-Y ENDOF 90 OF G-Z ENDOF
DROP TOFU ENDCASE ;
Block 4981
: DISPATCH-LOWER ( codepoint -- adv ) CASE
97 OF G-a ENDOF 98 OF G-b ENDOF 99 OF G-c ENDOF
100 OF G-d ENDOF 101 OF G-e ENDOF 102 OF G-f ENDOF
103 OF G-g ENDOF 104 OF G-h ENDOF 105 OF G-i ENDOF
106 OF G-j ENDOF 107 OF G-k ENDOF 108 OF G-l ENDOF
109 OF G-m ENDOF 110 OF G-n ENDOF 111 OF G-o ENDOF
112 OF G-p ENDOF 113 OF G-q ENDOF 114 OF G-r ENDOF
115 OF G-s ENDOF 116 OF G-t ENDOF 117 OF G-u ENDOF
118 OF G-v ENDOF 119 OF G-w ENDOF 120 OF G-x ENDOF
121 OF G-y ENDOF 122 OF G-z ENDOF
DROP TOFU ENDCASE ;
Block 4982
: DISPATCH-ASCII-PUNCT ( codepoint -- adv ) CASE
32 OF G-SPACE ENDOF 33 OF G-BANG ENDOF 34 OF G-DQUOTE ENDOF
35 OF G-HASH ENDOF 36 OF G-DOLLAR ENDOF 37 OF G-PERCENT ENDOF
38 OF G-AMP ENDOF 39 OF G-SQUOTE ENDOF 40 OF G-LPAREN ENDOF
41 OF G-RPAREN ENDOF 42 OF G-STAR ENDOF 43 OF G-PLUS ENDOF
44 OF G-COMMA ENDOF 45 OF G-HYPHEN ENDOF 46 OF G-PERIOD ENDOF
47 OF G-SLASH ENDOF 58 OF G-COLON ENDOF 59 OF G-SEMI ENDOF
60 OF G-LT ENDOF 61 OF G-EQ ENDOF 62 OF G-GT ENDOF
63 OF G-QMARK ENDOF 64 OF G-AT ENDOF 91 OF G-LBRACKET ENDOF
92 OF G-BACKSLASH ENDOF 93 OF G-RBRACKET ENDOF
94 OF G-CARET ENDOF 95 OF G-UNDERSCORE ENDOF
96 OF G-BACKTICK ENDOF 123 OF G-LBRACE ENDOF
124 OF G-PIPE ENDOF 125 OF G-RBRACE ENDOF
126 OF G-TILDE ENDOF
DROP TOFU ENDCASE ;
Block 4983
: DISPATCH-LATIN1 ( codepoint -- adv ) CASE
176 OF G-DEGREE ENDOF 169 OF G-COPYRIGHT ENDOF
174 OF G-REGISTERED ENDOF 177 OF G-PLUSMINUS ENDOF
215 OF G-MULT ENDOF 247 OF G-DIVIDE ENDOF 162 OF G-CENT ENDOF
163 OF G-POUND ENDOF 167 OF G-SECTION ENDOF
182 OF G-PILCROW ENDOF 160 OF G-NBSP ENDOF
DROP TOFU ENDCASE ;
: DISPATCH-GENPUNCT ( codepoint -- adv ) CASE
8216 OF G-LSQUOTE ENDOF 8217 OF G-RSQUOTE ENDOF
8220 OF G-LDQUOTE ENDOF 8221 OF G-RDQUOTE ENDOF
8211 OF G-ENDASH ENDOF 8212 OF G-EMDASH ENDOF
8230 OF G-ELLIPSIS ENDOF
DROP TOFU ENDCASE ;
Block 4984
( Redefine DISPATCH-GLYPH/DRAW-GLYPH too -- they were also )
( compiled early in fabric.4th, calling the OLD DISPATCH-* )
( placeholders. Same body, now binds to the real ones above. )
: DISPATCH-GLYPH ( codepoint -- adv )
DUP 48 58 WITHIN IF DISPATCH-DIGIT EXIT THEN
DUP 65 91 WITHIN IF DISPATCH-UPPER EXIT THEN
DUP 97 123 WITHIN IF DISPATCH-LOWER EXIT THEN
DUP 32 127 WITHIN IF DISPATCH-ASCII-PUNCT EXIT THEN
DUP 160 256 WITHIN IF DISPATCH-LATIN1 EXIT THEN
DUP 8192 8304 WITHIN IF DISPATCH-GENPUNCT EXIT THEN
DROP TOFU ;
: DRAW-GLYPH ( codepoint x y size color -- adv )
GCOLOR ! GSIZE ! GOY ! GOX !
DISPATCH-GLYPH ;
Block 4985
( TEXT: 4.3.6f. Defined here, not fabric.4th -- binds to the )
( real DRAW-GLYPH above, not fabric.4th's placeholder. )
VARIABLE TX VARIABLE TY VARIABLE TSIZE VARIABLE TCOLOR
: TEXT ( c-addr u x y size color -- )
TCOLOR ! TSIZE ! TY ! TX !
BEGIN DUP 0> WHILE
DECODE-UTF8 2>R
TX @ TY @ TSIZE @ TCOLOR @ DRAW-GLYPH
TSIZE @ EM-UNITS */ TX @ + TX !
2R>
REPEAT
2DROP ;
Reference in New Issue View Git Blame Copy Permalink