Robert Allan JamesandClaude Sonnet 5
24d6b9e20e
Punch list §25 item 4.3.6a complete. capsules/fabric.4th blocks 4918-4920: UTF8-SEQ-LEN/UTF8-CONT? verbatim from §27.6.2, DECODE-UTF8 dispatching to four UTF8-ASSEMBLE-N helpers (1/2/3/4-byte). Factored into helpers after the single-word draft hit mkcapsule's real 64-char x 16-line block limit. Verified live on amd64: a 6-byte test buffer (ASCII + deg-sign + em-dash) decoded to 65/176/8212 across three sequential calls, exact match against hand-computed codepoints, buffer fully consumed. Three-arch acceptance boot clean, Stadium conservation unaffected. Co-Authored-By: Claude Sonnet 5 <noreply@anthropic.com>
242 lines
7.3 KiB
Forth
242 lines
7.3 KiB
Forth
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 @ - ;
|