\ CIRKEL16-prg - an mei2026
\ for noForth t, uses: HX CH +TO FOR NEXT SHIELD V:

decimal
v: fresh vocabulary CIRKEL16
v: CIRKEL16 definitions

create tegel 16 dup * allot

: 4BITS ( x -- x' ) hx 0F and ;
: XY>HV ( x y -- h v )      \ cirkel -> tegel coordinaten
    4bits 8 xor swap
    4bits 8 xor swap ;
: HV>POS ( h v -- positie ) 4bits 4 lshift swap 4bits or ;
: 4BNEGATE ( x -- -x )      negate 4bits ;

: PLOT  ( h v -- ) hv>pos tegel + ch @ swap c! ;
: PLOT+ ( h v -- ) >r   \ h  r: v
    dup r@ 2dup plot 4bnegate plot      \ h,v & h,-v
    4bnegate
        r> 2dup plot 4bnegate plot ;    \ -h,v & -h,-v
: PLOT* ( h v -- ) 2dup plot+ swap plot+ ;

\ ------- cirkel plotten
: 2.S ( x y -- x y )    over 0 .r   ." ,"   dup . ;
0 value X   0 value Y
: OCTANT0 ( afwijking -- )
    begin x y
          2dup xy>hv plot*
          2.s                   \ optioneel
          - 1+ 0<               \ doorgaan?
    while     x 2* + 1+         \ afwO  = afw  + (x + x+1)
          dup y 2* - 1+         \ afwZO = afwO - (y + y-1)
          over abs over abs <   \ |afwO| < |afwZO| ?    \ kies de kleinste
          if   drop             \ kies Oost
          else nip -1 +to y     \ kies ZuidOost en verlaag y
          then 1 +to x          \ verhoog x altijd
    repeat drop ;

: (CK) ( straal -- ) \ plot een cirkel
    1 max 256 min to y
    0 to x
    0 octant0 ;

: WIS ( -- ) tegel 256 bl fill ;
: CK  ( straal -- ) wis (ck) ;

\ ------------ afdrukken
: PAGE ( -- ) 12 emit ;
0 value VERTI   0 value HORIZ
: FORMAAT ( horiz verti -- )
    6 min 1 max to verti
    10 min 1 max to horiz ;
: PEMIT ( c@ -- vlag )    space emit ;
: PTYPE ( a n -- )        for count pemit next drop ;
: .LAAG ( adr horiz -- )  for dup 16 ptype next c@ pemit ;
: .BAND ( -- )  tegel 16  for dup horiz cr .laag 16 + next drop ;
: .CK   ( -- ) page verti for .band next cr tegel horiz .laag cr ;

0 value WACHT 1500 to wacht
: INIT 10 6 formaat 1500 to wacht ;
init

\ ---------------------- demo-lus
: DEMO ( start-r -- ) 1 max 256 min
    begin dup ck .ck .s
          wacht ms 1+ stop?
    until drop ;

: 2DEMO ( start-r1 start-r2 -- ) 1 max 256 min
    begin over ck dup (ck) .ck .s
          wacht ms 1+ swap 1+ stop?
    until 2drop ;

v: fresh
shield CIRKEL16\
v: CIRKEL16
\ <><>