mirror of
https://git.sr.ht/~crc_/retroforth
synced 2024-11-16 19:48:56 +01:00
75 lines
1.9 KiB
Forth
75 lines
1.9 KiB
Forth
~~~
|
|
:pixel (xyc-) #33 io:scan-for io:invoke ;
|
|
:get-pixel (xy-c) #34 io:scan-for io:invoke ;
|
|
:mouse (-xyb) #35 io:scan-for io:invoke ;
|
|
|
|
:hline (xyw-)
|
|
[ dup-pair #1 pixel &n:inc dip ] times drop-pair ;
|
|
|
|
:vline (xyh-)
|
|
[ dup-pair #1 pixel n:inc ] times drop-pair ;
|
|
|
|
:dline\ (xyl-)
|
|
[ dup-pair #1 pixel &n:inc bi@ ] times drop-pair ;
|
|
|
|
:dline/ (xyl-)
|
|
[ dup-pair #1 pixel &n:dec &n:inc bi* ] times drop-pair ;
|
|
|
|
'X var 'Y var 'H var 'W var
|
|
|
|
:rect (xyhw-) !W !H !Y !X
|
|
@X @Y @W hline @X @Y @H n:add @W hline
|
|
@X @Y @H vline @X @W n:add @Y @H vline ;
|
|
|
|
'XC var 'YC var 'X var 'Y var
|
|
|
|
:octant (xc,yc,x,y)
|
|
!Y !X !YC !XC
|
|
@XC @X n:add @YC @Y n:add #1 pixel
|
|
@XC @X n:sub @YC @Y n:add #1 pixel
|
|
@XC @X n:add @YC @Y n:sub #1 pixel
|
|
@XC @X n:sub @YC @Y n:sub #1 pixel
|
|
@XC @Y n:add @YC @X n:add #1 pixel
|
|
@XC @Y n:sub @YC @X n:add #1 pixel
|
|
@XC @Y n:add @YC @X n:sub #1 pixel
|
|
@XC @Y n:sub @YC @X n:sub #1 pixel ;
|
|
|
|
'XC var 'YC var 'X var 'Y var 'D var 'R var
|
|
|
|
:circle (xyr-)
|
|
!R !YC !XC #0 !X @R [ !Y ] [ !D ] bi
|
|
@XC @YC @X @Y octant
|
|
[ &X v:inc
|
|
@D n:strictly-positive?
|
|
[ &Y v:dec @X @Y n:sub @R n:mul #2 n:mul @D n:add !D ]
|
|
[ #2 @R n:mul @X n:mul @D n:add !D ] choose
|
|
@XC @YC @X @Y octant
|
|
@Y @X gteq? ] while ;
|
|
|
|
'X var 'Y var 'C var 'D var 'R var
|
|
|
|
:t:raise #0 !C ;
|
|
:t:lower #1 !C ;
|
|
|
|
:t:left [ &X v:dec ] !D ;
|
|
:t:right [ &X v:inc ] !D ;
|
|
:t:up [ &Y v:dec ] !D ;
|
|
:t:down [ &Y v:inc ] !D ;
|
|
:t:at (xy-) !Y !X ;
|
|
:t:forward (n-) [ @X @Y @C pixel @D call ] times ;
|
|
|
|
#320 #240 t:at t:lower t:right
|
|
|
|
:t:down-right [ &Y v:inc &X v:inc ] !D ;
|
|
:t:down-left [ &Y v:inc &X v:dec ] !D ;
|
|
:t:up-left [ &Y v:dec &X v:dec ] !D ;
|
|
:t:up-right [ &Y v:dec &X v:inc ] !D ;
|
|
|
|
'Rotations d:create #8 ,
|
|
&t:right , &t:down-right , &t:down ,
|
|
&t:down-left , &t:left , &t:up-left ,
|
|
&t:up , &t:up-right ,
|
|
|
|
:t:rotate
|
|
&R v:inc @R #8 eq? [ #0 !R ] if &Rotations @R a:fetch call ;
|
|
~~~
|