LithosAnanake/capsules/fabric.4th

Block 4900
( fabric.4th -- Console drawing-fabric coordinate machinery )
( FABRIC.md item 4.3.3. 45-degree cavalier orthographic     )
( projection. Z is depth-into-screen, not height. Q48.16    )
( throughout. Raw pixel write (PLOT/FB-WIDTH/FB-HEIGHT) is  )
( C; this capsule is the FORTH-side policy on top of it.    )
46341 CONSTANT COS45  ( Q48.16 cos(45)=sin(45) ~= 0.70710678 )
VARIABLE ZD
: Z->DELTA ( z -- delta )
  Q.FROM-INT COS45 Q.* Q.TO-INT ;

Block 4901
( PROJECT: 3D Cartesian (x y z) -> 2D Cartesian (sx sy).    )
( Cavalier projection: depth pushes diagonally up-right.    )
: PROJECT ( x y z -- sx sy )
  Z->DELTA ZD !
  ZD @ +
  SWAP ZD @ +
  SWAP ;
( CART-Y: Cartesian Y (origin bottom, up positive) ->       )
( raster Y (origin top, down positive). The Y-flip.         )
: CART-Y ( cart-y -- raster-y )
  FB-HEIGHT 1- SWAP - ;

Block 4902
( CART-PLOT: full pipeline -- 3D Cartesian point to screen. )
: CART-PLOT ( x y z color -- )
  >R
  PROJECT
  CART-Y
  R>
  PLOT ;

Block 4903
( TO-RASTER: 3D Cartesian point -> raster (rx ry). Factored )
( out of CART-PLOT so LINE can reuse it for both endpoints  )
( -- the projection is linear, so projecting endpoints then )
( drawing 2D is equivalent to projecting every line point.  )
( Item 4.3.3b. CART-PLOT redefined in terms of it (same     )
( behavior, not a change).                                  )
: TO-RASTER ( x y z -- rx ry )
  PROJECT CART-Y ;
: CART-PLOT ( x y z color -- )
  >R TO-RASTER R> PLOT ;

Block 4904
( LINE: 3D Cartesian line segment, Bresenham in raster       )
( space (state in VARIABLEs; LINE-SETUP below).              )
VARIABLE LX  VARIABLE LY  VARIABLE LX2 VARIABLE LY2
VARIABLE LDX VARIABLE LDY VARIABLE LSX VARIABLE LSY
VARIABLE LERR VARIABLE LCOLOR VARIABLE LSTEPS
: LINE-SETUP ( x1 y1 z1 x2 y2 z2 color -- )
  LCOLOR !
  TO-RASTER LY2 ! LX2 !
  TO-RASTER LY ! LX !
  LX2 @ LX @ - ABS LDX !
  LY2 @ LY @ - ABS NEGATE LDY !
  LX @ LX2 @ < IF 1 ELSE -1 THEN LSX !
  LY @ LY2 @ < IF 1 ELSE -1 THEN LSY !
  LDX @ LDY @ + LERR ! 0 LSTEPS ! ;

Block 4905
( LINE-DONE?: true once current point reached target.        )
: LINE-DONE? ( -- flag )
  LX @ LX2 @ = LY @ LY2 @ = AND ;
( LINE-STUCK?: safety cap, width+height worst case.          )
: LINE-STUCK? ( -- flag )
  LSTEPS @ FB-WIDTH FB-HEIGHT + > ;
( LINE-STEP: one Bresenham step (no plot).                    )
: LINE-STEP ( -- )
  LERR @ 2*
  DUP LDY @ >= IF LERR @ LDY @ + LERR ! LX @ LSX @ + LX ! THEN
  DUP LDX @ <= IF LERR @ LDX @ + LERR ! LY @ LSY @ + LY ! THEN
  LSTEPS @ 1+ LSTEPS ! DROP ;

Block 4906
( LINE: draws the segment using the helpers above.           )
: LINE ( x1 y1 z1 x2 y2 z2 color -- )
  LINE-SETUP
  BEGIN
    LX @ LY @ LCOLOR @ PLOT
    LINE-DONE? 0= LINE-STUCK? 0= AND
  WHILE
    LINE-STEP
  REPEAT ;

Block 4907
( Shared state for CIRCLE/ARC/ELLIPSE. CIRC-PT: point on a  )
( circle of radius CRAD centered (CX,CY) at given angle.    )
VARIABLE CX VARIABLE CY VARIABLE CZ VARIABLE CRAD
VARIABLE CCOLOR VARIABLE PX VARIABLE PY
: CIRC-PT ( ang -- x y )
  DUP Q.SIN CRAD @ Q.FROM-INT Q.* Q.TO-INT CY @ +
  SWAP Q.COS CRAD @ Q.FROM-INT Q.* Q.TO-INT CX @ +
  SWAP ;

Block 4908
( CIRCLE: 36-segment polygon approximation, flat at z=cz.   )
: CIRCLE ( cx cy cz r color -- )
  CCOLOR ! CRAD ! CZ ! CY ! CX !
  0 CIRC-PT PY ! PX !
  36 0 DO
    PX @ PY @ CZ @
    I 1+ 11438 * CIRC-PT
    2DUP PY ! PX !
    CZ @ CCOLOR @
    LINE
  LOOP ;

Block 4909
( ARC: partial circle, start/end angles in Q48.16 radians,  )
( 18 segments. Reuses CIRC-PT/CX/CY/CZ/CRAD/CCOLOR/PX/PY.   )
VARIABLE ASTART VARIABLE AEND VARIABLE ASTEP
: ARC-SETUP ( cx cy cz r a0 a1 color -- )
  CCOLOR ! AEND ! ASTART !
  CRAD ! CZ ! CY ! CX !
  AEND @ ASTART @ - 18 / ASTEP !
  ASTART @ CIRC-PT PY ! PX ! ;

Block 4910
( ARC: draws the arc using ARC-SETUP above.                  )
: ARC ( cx cy cz r a0 a1 color -- )
  ARC-SETUP
  18 0 DO
    PX @ PY @ CZ @
    ASTART @ I 1+ ASTEP @ * +
    CIRC-PT
    2DUP PY ! PX !
    CZ @ CCOLOR @
    LINE
  LOOP ;

Block 4911
( ELLIPSE-PT: independent x/y radii, reuses CX/CY/CZ.       )
VARIABLE ERX VARIABLE ERY
: ELLIPSE-PT ( ang -- x y )
  DUP Q.SIN ERY @ Q.FROM-INT Q.* Q.TO-INT CY @ +
  SWAP Q.COS ERX @ Q.FROM-INT Q.* Q.TO-INT CX @ +
  SWAP ;

Block 4912
( ELLIPSE: 36-segment polygon, flat at z=cz.                 )
: ELLIPSE ( cx cy cz rx ry color -- )
  CCOLOR ! ERY ! ERX ! CZ ! CY ! CX !
  0 ELLIPSE-PT PY ! PX !
  36 0 DO
    PX @ PY @ CZ @
    I 1+ 11438 * ELLIPSE-PT
    2DUP PY ! PX !
    CZ @ CCOLOR @
    LINE
  LOOP ;

Block 4913
( CUBE: wireframe, 8 vertices via bit-coded corner index n  )
( (bit0=x, bit1=y, bit2=z; set=+CS, clear=-CS from center). )
VARIABLE CS
: VERT ( n -- x y z )
  DUP 1 AND IF CS @ ELSE CS @ NEGATE THEN CX @ +
  SWAP DUP 2 AND IF CS @ ELSE CS @ NEGATE THEN CY @ +
  SWAP DUP 4 AND IF CS @ ELSE CS @ NEGATE THEN CZ @ +
  SWAP DROP ;

Block 4914
( EDGE: draws one cube edge between vertex indices n1,n2.   )
VARIABLE EN2
: EDGE ( n1 n2 color -- )
  >R EN2 ! VERT EN2 @ VERT R> LINE ;

Block 4915
( CUBE: 12 edges -- 4 bottom, 4 top, 4 vertical.            )
: CUBE ( cx cy cz s color -- )
  CCOLOR ! CS ! CZ ! CY ! CX !
  0 1 CCOLOR @ EDGE  1 3 CCOLOR @ EDGE
  3 2 CCOLOR @ EDGE  2 0 CCOLOR @ EDGE
  4 5 CCOLOR @ EDGE  5 7 CCOLOR @ EDGE
  7 6 CCOLOR @ EDGE  6 4 CCOLOR @ EDGE
  0 4 CCOLOR @ EDGE  1 5 CCOLOR @ EDGE
  2 6 CCOLOR @ EDGE  3 7 CCOLOR @ EDGE ;

Block 4916
( EM-X/EM-Y: em-square (1000 units/em) -> CART-PLOT space.  )
( Item 4.3.6. GOX/GOY are the glyph's baseline-left anchor, )
( GSIZE the requested pixel size -- set by DRAW-GLYPH later )
( (item 4.3.6b), not yet built.                              )
1000 CONSTANT EM-UNITS
VARIABLE GOX  VARIABLE GOY  VARIABLE GSIZE  VARIABLE GCOLOR
: EM-X ( em-x -- cart-x )  GSIZE @ EM-UNITS */ GOX @ + ;
: EM-Y ( em-y -- cart-y )  GSIZE @ EM-UNITS */ GOY @ + ;

Block 4917
( G-LINE: one glyph stroke, em-square coords -> CART-PLOT.  )
VARIABLE GX1 VARIABLE GY1 VARIABLE GX2 VARIABLE GY2
: G-LINE ( gx1 gy1 gx2 gy2 -- )
  GY2 ! GX2 ! GY1 ! GX1 !
  GX1 @ EM-X  GY1 @ EM-Y  0
  GX2 @ EM-X  GY2 @ EM-Y  0
  GCOLOR @
  LINE ;

Block 4918
( UTF-8 lead-byte classification. Item 4.3.6a.               )
: UTF8-SEQ-LEN ( lead -- n )      ( 0 = invalid lead byte )
  DUP 128 < IF DROP 1 EXIT THEN
  DUP 224 AND 192 = IF DROP 2 EXIT THEN
  DUP 240 AND 224 = IF DROP 3 EXIT THEN
  DUP 248 AND 240 = IF DROP 4 EXIT THEN
  DROP 0 ;
: UTF8-CONT? ( byte -- flag )     ( true if 10xxxxxx )
  192 AND 128 = ;

Block 4919
( UTF-8 codepoint assembly, per byte-length. Item 4.3.6a.   )
VARIABLE UADDR VARIABLE ULEN VARIABLE ULEAD
VARIABLE USEQLEN VARIABLE UCP
: UTF8-ASSEMBLE-1 ( -- cp )  ULEAD @ ;
: UTF8-ASSEMBLE-2 ( -- cp )
  ULEAD @ 31 AND 6 LSHIFT
  UADDR @ 1+ C@ 63 AND OR ;
: UTF8-ASSEMBLE-3 ( -- cp )
  ULEAD @ 15 AND 12 LSHIFT
  UADDR @ 1+ C@ 63 AND 6 LSHIFT OR
  UADDR @ 2 + C@ 63 AND OR ;

Block 4920
( UTF8-ASSEMBLE-4 + DECODE-UTF8 dispatch. Item 4.3.6a.      )
: UTF8-ASSEMBLE-4 ( -- cp )
  ULEAD @ 7 AND 18 LSHIFT
  UADDR @ 1+ C@ 63 AND 12 LSHIFT OR
  UADDR @ 2 + C@ 63 AND 6 LSHIFT OR
  UADDR @ 3 + C@ 63 AND OR ;
: DECODE-UTF8 ( addr u -- codepoint addr' u' )
  ULEN ! UADDR !  UADDR @ C@ ULEAD !
  ULEAD @ UTF8-SEQ-LEN USEQLEN !
  USEQLEN @ 1 = IF UTF8-ASSEMBLE-1 UCP ! ELSE
  USEQLEN @ 2 = IF UTF8-ASSEMBLE-2 UCP ! ELSE
  USEQLEN @ 3 = IF UTF8-ASSEMBLE-3 UCP ! ELSE
  USEQLEN @ 4 = IF UTF8-ASSEMBLE-4 UCP ! ELSE
  65533 UCP ! 1 USEQLEN ! THEN THEN THEN THEN
  UCP @ UADDR @ USEQLEN @ + ULEN @ USEQLEN @ - ;

Block 4921
( 4.3.6b placeholder test glyphs -- one per dispatch bucket. )
( Minimal, NOT the real 113-glyph set (item 4.3.6c). Proves  )
( DISPATCH-GLYPH routes to the correct stroke word only.     )
: G-TEST-DIGIT    ( -- adv )  0 0 500 700 G-LINE  400 ;
: G-TEST-UPPER    ( -- adv )  0 0 600 700 G-LINE  600 ;
: G-TEST-LOWER    ( -- adv )  0 0 500 500 G-LINE  450 ;
: G-TEST-PUNCT    ( -- adv )  0 0 200 200 G-LINE  250 ;
: G-TEST-LATIN1   ( -- adv )  0 0 500 500 G-LINE  550 ;
: G-TEST-GENPUNCT ( -- adv )  0 0 1000 0 G-LINE  700 ;
: TOFU ( -- adv )
  100 0 100 700 G-LINE
  100 700 400 700 G-LINE
  400 700 400 0 G-LINE
  400 0 100 0 G-LINE
  500 ;

Block 4922
( Dispatch buckets 1/2/3 -- digit/upper/lower. Item 4.3.6b.  )
: DISPATCH-DIGIT ( codepoint -- adv )
  CASE 48 OF G-TEST-DIGIT ENDOF DROP TOFU ENDCASE ;
: DISPATCH-UPPER ( codepoint -- adv )
  CASE 65 OF G-TEST-UPPER ENDOF DROP TOFU ENDCASE ;
: DISPATCH-LOWER ( codepoint -- adv )
  CASE 97 OF G-TEST-LOWER ENDOF DROP TOFU ENDCASE ;

Block 4923
( Dispatch buckets 4/5/6 -- punct/latin1/genpunct. 4.3.6b.   )
: DISPATCH-ASCII-PUNCT ( codepoint -- adv )
  CASE 33 OF G-TEST-PUNCT ENDOF DROP TOFU ENDCASE ;
: DISPATCH-LATIN1 ( codepoint -- adv )
  CASE 176 OF G-TEST-LATIN1 ENDOF DROP TOFU ENDCASE ;
: DISPATCH-GENPUNCT ( codepoint -- adv )
  CASE 8212 OF G-TEST-GENPUNCT ENDOF DROP TOFU ENDCASE ;

Block 4924
( DISPATCH-GLYPH: codepoint -> bucket, via WITHIN. 4.3.6b.   )
: 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 ;