d6
/
kodiak
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases 5 Wiki Activity

renamed to kodiak, commented out unused code

This commit is contained in:
~d6 2024-07-12 22:42:41 -04:00
parent f2998aef21
commit d4ab9ccd47
2 changed files with 329 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

123
cards.tal
View File

@ -47,49 +47,49 @@
( BUG: try moving the "whole deck" and get into a weird state ) ( BUG: try moving the "whole deck" and get into a weird state )
@move-card ( card* dx^ dy^ -> ) ( @move-card ( card* dx^ dy^ -> )
SWP SWP2 STH2 INC2r INC2r ( dy^ dx^ [card+2*] ) SWP SWP2 STH2 INC2r INC2r ( dy^ dx^ [card+2*] )
STH2kr LDA ADD STH2kr STA INC2r ( dy^ [card+3*] ; card.x+=dx ) STH2kr LDA ADD STH2kr STA INC2r ( dy^ [card+3*] ; card.x+=dx )
STH2kr LDA ADD STH2r STA JMP2r ( ; card.y+=dy ) STH2kr LDA ADD STH2r STA JMP2r ( ; card.y+=dy ) )
( put all cards face down, and stack them ) ( put all cards face down, and stack them )
( in a single deck in the middle of the screen ) ( in a single deck in the middle of the screen )
@reset ( -> ) ( @reset ( -> )
all-cards-face-down all-cards-face-down
shuffle ( FIXME ) shuffle ( FIXME )
#08 #18 stack-cards #08 #18 stack-cards
draw-background draw-background
!draw-cards !draw-cards )
( f: addr* -> ) ( f: addr* -> )
@for-all-cards ( f* -> ) ( @for-all-cards ( f* -> )
STH2 ;cards/end ;cards ( limit* start* [f*] ) STH2 ;cards/end ;cards ( limit* start* [f*] )
&loop DUP2 STH2kr JSR2 ( limit* pos* [f*] ) &loop DUP2 STH2kr JSR2 ( limit* pos* [f*] )
#0004 ADD2 GTH2k ?&loop ( limit* pos+4* [f*] ) #0004 ADD2 GTH2k ?&loop ( limit* pos+4* [f*] )
POP2 POP2 POP2r JMP2r ( ) POP2 POP2 POP2r JMP2r ( ) )
@all-cards-face-down ( -> ) ( @all-cards-face-down ( -> )
;turn-card-face-down !for-all-cards ;turn-card-face-down !for-all-cards )
@stack-cards ( x^ y^ -> ) ( @stack-cards ( x^ y^ -> )
,stack-card/y STR ,stack-card/x STR #00 ,stack-card/c STR ,stack-card/y STR ,stack-card/x STR #00 ,stack-card/c STR
;stack-card !for-all-cards ;stack-card !for-all-cards )
@stack-card ( addr* -> ) ( @stack-card ( addr* -> )
INC2 INC2 STH2 ( [addr+2*] ) INC2 INC2 STH2 ( [addr+2*] )
LIT [ &x $1 ] STH2kr STA INC2r ( [addr+3] ; addr+2<-x ) LIT [ &x $1 ] STH2kr STA INC2r ( [addr+3] ; addr+2<-x )
LIT [ &y $1 ] STH2r STA ( ; addr+3<-y ) LIT [ &y $1 ] STH2r STA ( ; addr+3<-y )
LIT [ &c $1 ] ?&skip LIT [ &c $1 ] ?&skip
,&y LDR #01 SUB ,&y STR ,&y LDR #01 SUB ,&y STR
&skip ,&c LDR INC #03 AND ,&c STR JMP2r &skip ,&c LDR INC #03 AND ,&c STR JMP2r )
@flip-all-cards ( -> ) ( @flip-all-cards ( -> )
;cards/end ;cards ( limit* start* ) ;cards/end ;cards ( limit* start* )
&loop DUP2 flip-card ( limit* pos* ) &loop DUP2 flip-card ( limit* pos* )
#0004 ADD2 GTH2k ?&loop ( limit* pos+4* ) #0004 ADD2 GTH2k ?&loop ( limit* pos+4* )
POP2 POP2 !draw-cards ( ) POP2 POP2 !draw-cards ( ) )
@shuffle ( -> ) ( @shuffle ( -> )
;cards/last ;cards ( last* start* ) ;cards/last ;cards ( last* start* )
&loop ( last* pos* ) &loop ( last* pos* )
SUB2k #02 SFT2 INC2 ( last* pos* n=[last-pos]/4+1* ) SUB2k #02 SFT2 INC2 ( last* pos* n=[last-pos]/4+1* )
@ -101,31 +101,31 @@
LIT2 [ &c $2 ] STH2kr STA2 ( last* [pos*] ) LIT2 [ &c $2 ] STH2kr STA2 ( last* [pos*] )
STH2r #0004 ADD2 ( last* pos+4* ) STH2r #0004 ADD2 ( last* pos+4* )
GTH2k ?&loop ( last* pos+4* ) GTH2k ?&loop ( last* pos+4* )
POP2 POP2 JMP2r ( ) POP2 POP2 JMP2r ( ) )
@try-to-flip ( -> ) ( @try-to-flip ( -> )
find-mouse-over-card find-mouse-over-card
ORAk ?&found POP2 JMP2r ORAk ?&found POP2 JMP2r
&found flip-card !draw-cards &found flip-card !draw-cards )
@flip-card ( addr* -> ) ( @flip-card ( addr* -> )
LDA2k #8000 EOR2 SWP2 STA2 JMP2r LDA2k #8000 EOR2 SWP2 STA2 JMP2r )
@turn-card-face-down ( addr* -> ) ( @turn-card-face-down ( addr* -> )
LDA2k #8000 ORA2 SWP2 STA2 JMP2r LDA2k #8000 ORA2 SWP2 STA2 JMP2r )
@turn-card-face-up ( addr* -> ) ( @turn-card-face-up ( addr* -> )
LDA2k #7fff AND2 SWP2 STA2 JMP2r LDA2k #7fff AND2 SWP2 STA2 JMP2r )
@randomize ( -> ) ( @randomize ( -> )
init-cards init-cards
draw-background draw-background
!draw-cards !draw-cards )
@mod ( n* d* -> n%d* ) ( @mod ( n* d* -> n%d* )
DIV2k MUL2 SUB2 JMP2r DIV2k MUL2 SUB2 JMP2r )
@init-cards ( -> ) ( @init-cards ( -> )
#0034 #0000 ( limit* 0* ) #0034 #0000 ( limit* 0* )
&loop ( limit* c* ) &loop ( limit* c* )
;cards OVR2 ( limit* c* cards* c* ) ;cards OVR2 ( limit* c* cards* c* )
@ -137,9 +137,9 @@
random #00a8 mod NIP ( limit* c* y^ [addr+3*] ) random #00a8 mod NIP ( limit* c* y^ [addr+3*] )
STH2r STA ( limit* c* ; addr+3<-y ) STH2r STA ( limit* c* ; addr+3<-y )
INC2 GTH2k ?&loop ( limit* c+1* ) INC2 GTH2k ?&loop ( limit* c+1* )
POP2 POP2 JMP2r POP2 POP2 JMP2r )
@raise-card ( addr* -> ) ( @raise-card ( addr* -> )
DUP2 ;cards/last EQU2 ?&skip ( addr* ) DUP2 ;cards/last EQU2 ?&skip ( addr* )
LDA2k ,&card STR2 INC2 INC2 ( addr+2* ) LDA2k ,&card STR2 INC2 INC2 ( addr+2* )
LDA2k ,&xy STR2 #0002 SUB2 ( addr-2* ) LDA2k ,&xy STR2 #0002 SUB2 ( addr-2* )
@ -154,10 +154,10 @@
STH2kr STA2 INC2r INC2r ( [last+2*] ; last<-c ) STH2kr STA2 INC2r INC2r ( [last+2*] ; last<-c )
LIT2 [ &xy $2 ] ( xy* [last+2*] ) LIT2 [ &xy $2 ] ( xy* [last+2*] )
STH2r STA2 JMP2r ( ; last+2<-xy ) STH2r STA2 JMP2r ( ; last+2<-xy )
&skip POP2 JMP2r ( ) &skip POP2 JMP2r ( ) )
( raises card at addr and everything it lifts ) ( raises card at addr and everything it lifts )
@raise-cards ( addr* -> count^ ) ( @raise-cards ( addr* -> count^ )
#0004 ,&d STR2 ( ; d<-4 ) #0004 ,&d STR2 ( ; d<-4 )
;raise-cards/buf ;raise-cards/pos STA2 ( addr* ; pos<-buf[0] ) ;raise-cards/buf ;raise-cards/pos STA2 ( addr* ; pos<-buf[0] )
DUP2 raise-cards/enqueue STH2 ( addr* [pos*] ; buf[0]<-addr ) DUP2 raise-cards/enqueue STH2 ( addr* [pos*] ; buf[0]<-addr )
@ -190,27 +190,27 @@
INC2 INC2 INC2kr INC2r ( c+2* [pos* pos+2*] ) INC2 INC2 INC2kr INC2r ( c+2* [pos* pos+2*] )
LDA2 STH2kr STA2 INC2r INC2r ( [pos* pos+4*] ; buf[pos+2]<-c+2 ) LDA2 STH2kr STA2 INC2r INC2r ( [pos* pos+4*] ; buf[pos+2]<-c+2 )
STH2r ,&pos STR2 STH2r JMP2r ( pos* ; pos<-pos+4 ) STH2r ,&pos STR2 STH2r JMP2r ( pos* ; pos<-pos+4 )
[ &pos $2 &buf $cc ] [ &pos $2 &buf $cc ] )
@abs-within ( x^ y^ d^ -> abs[x-y] <= d^ ) ( @abs-within ( x^ y^ d^ -> abs[x-y] <= d^ )
STH SUB STHkr ADD ( x-y+d^ [d^] ) STH SUB STHkr ADD ( x-y+d^ [d^] )
STHr DUP ADD INC LTH JMP2r ( x-y+d<2d+1^ ) STHr DUP ADD INC LTH JMP2r ( x-y+d<2d+1^ ) )
@card-overlaps ( a* b* -> ok^ ) ( @card-overlaps ( a* b* -> ok^ )
INC2 INC2 LDA2 STH2 ( a* [bx^ by^] ) INC2 INC2 LDA2 STH2 ( a* [bx^ by^] )
INC2 INC2 LDA2 ( ax^ ay^ [bx^ by^] ) INC2 INC2 LDA2 ( ax^ ay^ [bx^ by^] )
STHr #17 abs-within SWP ( ay-by<16^ ax^ [bx^] ) STHr #17 abs-within SWP ( ay-by<16^ ax^ [bx^] )
STHr #0f abs-within AND ( ay-by<16&ax-bx<24^ ) STHr #0f abs-within AND ( ay-by<16&ax-bx<24^ )
JMP2r JMP2r )
( returns true if the card below lifts the card above ) ( returns true if the card below lifts the card above )
@card-lifts ( below* above* -> bool^ ) ( @card-lifts ( below* above* -> bool^ )
GTH2k ?&no !card-overlaps &no POP2 POP2 #00 JMP2r GTH2k ?&no !card-overlaps &no POP2 POP2 #00 JMP2r )
@find-mouse-over-card ( -> addr* ) ( @find-mouse-over-card ( -> addr* )
.Mouse/x DEI2 .Mouse/y DEI2 !find-card .Mouse/x DEI2 .Mouse/y DEI2 !find-card )
( returns top card at coords, or 0000 if no card. ) ( ( returns top card at coords, or 0000 if no card. )
@find-card ( x* y* -> addr* ) @find-card ( x* y* -> addr* )
LIT2r =cards LIT2r =cards/last ( x* y* [limit* first*] ) LIT2r =cards LIT2r =cards/last ( x* y* [limit* first*] )
&loop ( x* y* [limit* pos*] ) &loop ( x* y* [limit* pos*] )
@ -221,32 +221,32 @@
!&loop ( x* y* [limit* pos-4*] ) !&loop ( x* y* [limit* pos-4*] )
&notfound POP2r LIT2r 0000 ( x* y* [limit* 0*] ) &notfound POP2r LIT2r 0000 ( x* y* [limit* 0*] )
&done ( x* y* [limit* addr*] ) &done ( x* y* [limit* addr*] )
POP2 POP2 STH2r POP2r JMP2r ( addr* ) POP2 POP2 STH2r POP2r JMP2r ( addr* ) )
( returns true if the given card x,y coordinates ) ( returns true if the given card x,y coordinates )
( intersect the rectangle of the given card. ) ( intersect the rectangle of the given card. )
( cards are 16 pixels wide and 24 pixels tall. ) ( cards are 16 pixels wide and 24 pixels tall. )
( so the result is: ) ( so the result is: )
( cx <= x < cx+16 && cy <= y < cy+24 ) ( cx <= x < cx+16 && cy <= y < cy+24 )
@intersects ( x* y* card* -> bool^ ) ( @intersects ( x* y* card* -> bool^ )
ROT2 STH2 LITr 00 ( y* card* [x* 0^] ) ROT2 STH2 LITr 00 ( y* card* [x* 0^] )
#0002 ADD2 LDAk STH SUB2r ( y* card+2* [x-cx*] ) #0002 ADD2 LDAk STH SUB2r ( y* card+2* [x-cx*] )
LIT2r 0010 LTH2r STHr ?&x-ok ( y* card+2* ) LIT2r 0010 LTH2r STHr ?&x-ok ( y* card+2* )
POP2 POP2 #00 JMP2r ( 0^ ) POP2 POP2 #00 JMP2r ( 0^ )
&x-ok ( y* card+2* ) &x-ok ( y* card+2* )
LITr 00 INC2 LDA STH STH2r ( y* cy* ) LITr 00 INC2 LDA STH STH2r ( y* cy* )
SUB2 #0018 LTH2 JMP2r ( ok^ ) SUB2 #0018 LTH2 JMP2r ( ok^ ) )
@draw-cards ( @draw-cards
;draw-card !draw-all-cards ;draw-card !draw-all-cards )
@held-end-offset ( -> offset* ) ( @held-end-offset ( -> offset* )
;cards/end #00 .card-is-held LDZ #0004 MUL2 SUB2 JMP2r ;cards/end #00 .card-is-held LDZ #0004 MUL2 SUB2 JMP2r )
( TODO: if the top card is being "held" then we ) ( TODO: if the top card is being "held" then we )
( should not draw that here, because it will be ) ( should not draw that here, because it will be )
( drawn in the foreground using a mask. ) ( drawn in the foreground using a mask. )
@draw-all-cards ( draw* -> ) ( @draw-all-cards ( draw* -> )
,&draw STR2 ( ) ,&draw STR2 ( )
held-end-offset STH2 ( [limit*] ) held-end-offset STH2 ( [limit*] )
LIT2r =cards ( [limit* pos*] ) LIT2r =cards ( [limit* pos*] )
@ -265,7 +265,7 @@
#00 STH2kr LDA INC2r ( card* x* y* [limit* pos+4*] ) #00 STH2kr LDA INC2r ( card* x* y* [limit* pos+4*] )
draw-mask ( [limit* pos+4] ) draw-mask ( [limit* pos+4] )
GTH2kr STHr ?&mloop ( [limit* pos+4] ) GTH2kr STHr ?&mloop ( [limit* pos+4] )
POP2r POP2r JMP2r ( ) POP2r POP2r JMP2r ( ) )
@draw-background ( -> ) @draw-background ( -> )
#f2 .Screen/auto DEO #f2 .Screen/auto DEO
@ -280,13 +280,13 @@
DEOk DEOk DEOk DEOk DEOk DEOk DEOk DEOk DEOk DEOk DEOk DEOk DEOk DEOk DEOk DEOk
DEOk DEOk DEOk DEOk DEOk DEOk DEOk DEO JMP2r DEOk DEOk DEOk DEOk DEOk DEOk DEOk DEO JMP2r
@draw-mask ( idx* x* y* -> ) ( @draw-mask ( idx* x* y* -> )
.Screen/y DEO2 .Screen/x DEO2 .Screen/y DEO2 .Screen/x DEO2
OVR #80 LTH ?draw-mask-up POP2 !draw-mask-down OVR #80 LTH ?draw-mask-up POP2 !draw-mask-down )
@draw-card ( idx* x* y* -> ) ( @draw-card ( idx* x* y* -> )
.Screen/y DEO2 .Screen/x DEO2 .Screen/y DEO2 .Screen/x DEO2
OVR #80 LTH ?draw-face-up POP2 !draw-face-down OVR #80 LTH ?draw-face-up POP2 !draw-face-down )
( assumes x/y already set ) ( assumes x/y already set )
@draw-mask-down ( -> ) @draw-mask-down ( -> )
@ -302,14 +302,14 @@
#81 .Screen/sprite DEOk DEOk DEO #81 .Screen/sprite DEOk DEOk DEO
JMP2r JMP2r
@card-is-black ( idx* -> bool^ ) ( @card-is-black ( idx* -> bool^ )
#000c DIV2 #000c DIV2
@q-is-black ( q* -> bool^ ) @q-is-black ( q* -> bool^ )
NIP #01 SUB #fe AND JMP2r ( [q-1]&fe ) NIP #01 SUB #fe AND JMP2r ( [q-1]&fe ) )
@card-is-red ( idx* -> bool^ ) @card-is-red ( idx* -> bool^ )
#000c DIV2 #000c DIV2
@q-is-red ( q* -> bool^ ) ( @q-is-red ( q* -> bool^ ) )
NIP #03 MUL #02 AND JMP2r ( [q*3]&2 ) NIP #03 MUL #02 AND JMP2r ( [q*3]&2 )
@find-middle-addr ( idx* -> addr* ) @find-middle-addr ( idx* -> addr* )
@ -379,8 +379,7 @@
#00 .DateTime/sec DEI ADD2 ( s* ) #00 .DateTime/sec DEI ADD2 ( s* )
DUP2 .DateTime/doy DEI2 MUL2 ( s* sdoy* ) DUP2 .DateTime/doy DEI2 MUL2 ( s* sdoy* )
( fall-through ) ( fall-through )
( @init-rng ( x* y* -> ) )
@init-rng ( x* y* -> )
#0001 ROT2 OVR2 ( y* 1* x* 1* ) #0001 ROT2 OVR2 ( y* 1* x* 1* )
ORA2 ;rng/x STA2 ( y* 1* ) ORA2 ;rng/x STA2 ( y* 1* )
ORA2 ;rng/x STA2 JMP2r ( ) ORA2 ;rng/x STA2 JMP2r ( )
@ -403,7 +402,7 @@
( confusingly the "top" card is actually at the end ) ( confusingly the "top" card is actually at the end )
( this ends up being convenient for coding but is a ) ( this ends up being convenient for coding but is a )
( bit confusing to think about ) ( bit confusing to think about )
@cards $0cc &last $4 &end ( @cards $0cc &last $4 &end )
@cursor 80c0 e0f0 f8e0 1000 @cursor 80c0 e0f0 f8e0 1000
@cursox 7f3f 1f0f 071f efff @cursox 7f3f 1f0f 071f efff

268
kodiak.tal Normal file
View File

@ -0,0 +1,268 @@
( deck.tal )
|00 @System [ &vect $2 &expansion $2 &title $2 &metadata $2 &r $2 &g $2 &b $2 ]
|10 @Console [ &vect $2 &r $1 &exec $2 &mode $1 &dead $1 &exit $1 &w $1 ]
|20 @Screen [ &vect $2 &w $2 &h $2 &auto $1 &pad $1 &x $2 &y $2 &addr $2 &px $1 &sprite $1 ]
|80 @Controller [ &vect $2 &button $1 &key $1 &fn $1 ]
|90 @Mouse [ &vect $2 &x $2 &y $2 &state $1 &pad $3 &scrollx $2 &scrolly $2 ]
|a0 @File1 [ &vect $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
|b0 @File2 [ &vect $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
|c0 @DateTime [ &y $2 &m $1 &d $1 &hr $1 &min $1 &sec $1 &dow $1 &doy $2 &isdst $1 ]
( 1 byte per card )
( #01 ace ... #0d king )
( #00 club #10 diamond #20 spade #30 heart )
( #00 face up, #40 face down )
( #00 normal #80 held )
( examples: )
( - #00 no card )
( - #01 ace of clubs )
( - #1a ten of diamonds )
( - #24 four of hearts )
( - #3d king of spades )
( - #6c queen of hearts, face down )
( - #93 three of diamonds, held )
|0000
@stock $34 ( draw pile - 52 bytes )
@waste $18 ( face up pile - 24 bytes )
@foundation $4 ( one per suit - 4 bytes, 4x1 )
@tableau $85 ( the main board - 133 bytes, 7x19 )
@prev-button $1
@prev-mouse-state $1
@prev-mouse-x $2
@prev-mouse-y $2
@card-is-held $1
|0100
#2d8b .System/r DEO2
#2d18 .System/g DEO2
#2d14 .System/b DEO2
#0100 .Screen/w DEO2
#00c0 .Screen/h DEO2
init-rng-from-datetime
init-stock init-waste init-foundation
shuffle-stock deal-tableau
draw-background
draw-stock draw-waste draw-foundation draw-tableau
;on-mouse .Mouse/vect DEO2
( ;on-key .Controller/vect DEO2 )
BRK
@init-stock ( -> )
LITr -stock #8000 #4e41
&outer DUP2
&inner DUP STHkr STZ INC INCr GTHk ?&inner
POP2 #1010 ADD2 GTH2k ?&outer
POP2 POP2 POPr JMP2r
@init-waste ( -> )
#00 LITr -waste LITr 18 OVRr ADDr SWPr
&loop DUP STHkr STZ INCr GTHkr STHr ?&loop
POP POP2r JMP2r
@init-foundation
#00 .foundation
STZk INC STZk INC STZk INC STZk POP2
JMP2r
@shuffle-stock ( -> )
.stock #33 OVR ADD SWP ( last^ start^ )
&loop ( last^ pos^ )
SUBk INC #00 SWP ( last^ pos^ n=last-pos+1* )
random SWP2 ( last^ pos^ r* n* )
DIV2k MUL2 SUB2 NIP ( last^ pos^ i=r%n^ )
OVR ADD LDZk ,&c STR ( last^ pos^ alt=pos+i^ ; c<-alt )
STH LDZk STHr STZ STH ( last^ [pos^] ; alt<-pos )
LIT [ &c $1 ] STHkr STZ ( last^ [pos^] ; pos<-c )
STHr INC GTHk ?&loop ( last^ pos+1^ )
POP2 JMP2r ( )
@deal-tableau ( -> )
#33 LIT2r -tableau 00
&loop STH2kr deal-column
LIT2r 1301 ADD2r
STHkr #07 LTH ?&loop
POP2r POP JMP2r
@deal-column ( src^ dst^ count^ -> src2^ )
#00 SWP SUB STH SWP ( dst^ src^ [-count^] )
&loop STHkr ?&ok !&done ( d^ s^ [-c^] )
&ok DUP2 LDZ SWP STZ ( d^ s^ [-c^] ; d<-s|64 )
#01 SUB SWP INC SWP ( d+1^ s-1^ [-c^] )
INCr !&loop ( d+1^ s-1^ [-c+1^] )
&done POPr SWP ( s^ d^)
OVR LDZ #bf AND SWP STZ ( s^ ; d<-s )
#01 SUB JMP2r ( s-1^ )
@swap-c ( src^ dst^ -> )
LDZk STH ( src^ dst^ [d^] )
OVR LDZ ( src^ dst^ s^ [d^] )
SWP STZ ( src^ [d^] ; dst<-s )
STHr SWP ( d^ src^ )
STZ JMP2r ( ; src<-d )
@draw-stock ( -> )
#0008 ,&y STR2 ( ; y0<-8 )
.stock #34 OVR ADD SWP LITr 01 ( stock+52 stock^ [n^] )
&loop LDZk DUP ?&ok !&done ( lim^ zp^ c^ [n^] )
&ok ( lim^ zp^ c^ [n^] )
#0008 .Screen/x DEO2 ( lim^ zp^ c^ [n^] ; x<-8 )
LIT2 [ &y $2 ] .Screen/y DEO2 ( lim^ zp^ c^ [n^] ; y<- )
draw-c STHkr ?&skip ( lim^ zp^ [n^] ; draw c )
,&y LDR2 #0001 SUB2 ,&y STR2 ( lim^ zp^ [n^] ; y<-y-1 )
&skip INC INCr LITr 07 ANDr GTHk ?&loop ( lim^ zp+1^ [(n+1)%8] )
&done POP2 POPr JMP2r ( )
@draw-waste ( -> )
#001c ,&x STR2 ( ; x0<-28 )
.waste #18 OVR ADD SWP ( waste+24^ waste^ )
&loop LDZk DUP ?&ok !&done ( lim^ zp^ c^ )
&ok ( lim^ zp^ c^ )
#0008 .Screen/y DEO2 ( lim^ zp^ c^ ; y<-8 )
LIT2 [ &x $2 ] .Screen/x DEO2 ( lim^ zp^ c^ ; x<- )
draw-c ( lim^ zp^ ; draw c )
,&x LDR2 #0008 ADD2 ,&x STR2 ( lim^ zp^ ; x<-x+8 )
INC GTHk ?&loop ( lim^ zp+1^ )
&done POP2 JMP2r ( )
@draw-foundation ( -> )
#0030 ,&y STR2 ( ; y0<-48 )
.foundation #04 OVR ADD SWP ( lim^ zp^ )
&loop ( lim^ zp^ )
#0008 .Screen/x DEO2 ( lim^ zp^ ; x<-8 )
LIT2 [ &y $2 ] .Screen/y DEO2 ( lim^ zp^ ; y<- )
LDZk maybe-draw-c ( lim^ zp^ ; draw )
,&y LDR2 #0020 ADD2 ,&y STR2 ( lim^ zp^ ; y<-y+32 )
INC GTHk ?&loop ( lim^ zp+1^ )
POP2 JMP2r ( )
@draw-tableau
#0700 &loop DUP draw-column INC GTHk ?&loop JMP2r
@draw-column ( idx^ -> )
#00 OVR #0018 MUL2 #0030 ADD2 ,&x STR2 ( idx^ ; x<-32+24*idx )
#0024 ,&y STR2 ( idx^ ; y<-32 )
#13 MUL .tableau ADD ( pos=t+idx*19^ )
DUP #13 ADD SWP ( lim=pos+19^ pos^ )
&loop ( lim^ pos^ )
LDZk DUP ?&ok !&done ( lim^ pos^ c^ )
&ok LIT2 [ &x $2 ] .Screen/x DEO2 ( lim^ pos^ ; s/x<-x )
LIT2 [ &y $2 ] .Screen/y DEO2 ( lim^ pos^ ; s/y<-y )
draw-c INC ( lim^ pos+1^ )
,&y LDR2 #0008 ADD2 ,&y STR2 ( lim^ pos+1^ )
GTHk ?&loop ( lim^ pos+1^ )
&done POP POP2 JMP2r ( )
@maybe-draw-c
DUP ?{ POP !draw-mask-down } !draw-c
( assumes x/y already set )
@draw-c ( card^ -> )
DUP #40 LTH ?&norm
DUP #80 LTH ?&down
DUP #c0 LTH ?&held
POP !draw-mask-down
&norm adjust-c !draw-face-up
&down POP !draw-face-down
&held adjust-c !draw-mask-up
( we map from our sparse, logical card format )
( to the dense, tile position card location )
( clubs: #01 -> #27 ... #0d -> #33 )
( diamonds: #11 -> #1a ... #1d -> #26 )
( spades: #21 -> #00 ... #2d -> #0c )
( hearts: #31 -> #0d ... #3d -> #19 )
@adjust-c ( card^ -> idx* )
#00 SWP
DUP #21 LTH ?&lt
DUP #31 LTH #03 MUL ADD #24 SUB JMP2r
&lt DUP #11 LTH #1d MUL ADD #09 ADD JMP2r
@on-mouse ( -> brk )
on-move
( on-click-down )
( on-click-up )
.Mouse/state DEI .prev-mouse-state STZ
BRK
@mouse-dx ( -> dx* ) .Mouse/x DEI2 .prev-mouse-x LDZ2 SUB2 JMP2r
@mouse-dy ( -> dy* ) .Mouse/y DEI2 .prev-mouse-y LDZ2 SUB2 JMP2r
@mouse-dx8 ( -> dx^ ) .Mouse/x DEI2 .prev-mouse-x LDZ2 SUB2 NIP JMP2r
@mouse-dy8 ( -> dy^ ) .Mouse/y DEI2 .prev-mouse-y LDZ2 SUB2 NIP JMP2r
@on-move ( -> )
.Mouse/x DEI2 .prev-mouse-x LDZ2 NEQ2 ?&redraw
.Mouse/y DEI2 .prev-mouse-y LDZ2 NEQ2 ?&redraw
JMP2r
&redraw #00 .Screen/auto DEO
clear-prev-mouse draw-curr-mouse JMP2r
@clear-prev-mouse ( -> )
.prev-mouse-x LDZ2 .Screen/x DEO2
.prev-mouse-y LDZ2 .Screen/y DEO2
;blank .Screen/addr DEO2
#41 .Screen/sprite DEO JMP2r
@draw-curr-mouse ( -> )
.Mouse/x DEI2 DUP2 .prev-mouse-x STZ2 .Screen/x DEO2
.Mouse/y DEI2 DUP2 .prev-mouse-y STZ2 .Screen/y DEO2
;cursor .Screen/addr DEO2
#43 .Screen/sprite DEO JMP2r
@on-click-down ( -> )
.Mouse/state DEI ( state^ )
.prev-mouse-state LDZ #ff EOR AND ( down^ )
#01 AND ( TODO: support more than one button )
?&click JMP2r ( TODO: check particular button )
&click
( find-mouse-over-card
ORAk ?&found POP2 JMP2r
&found
raise-cards .card-is-held STZ
!draw-cards ) JMP2r
@on-click-up ( -> )
.Mouse/state DEI #ff EOR ( not-state^ )
.prev-mouse-state LDZ AND ( up^ )
#01 AND ( TODO: support more than one button )
?&unclick JMP2r ( TODO: check particular button )
&unclick
( #00 .card-is-held STZ
draw-background draw-cards )
JMP2r
( @on-key ( -> brk )
on-press on-release
.Controller/button DEI .prev-button STZ
BRK )
( @on-release ( -> )
.Controller/button DEI #ff EOR ( not-button^ )
.prev-button LDZ AND ( release^ )
DUP #00 EQU ?&skip
DUP #08 AND ?&start
&skip POP JMP2r
&start POP !draw-cards )
( @on-press ( -> )
.Controller/button DEI ( button^ )
.prev-button LDZ #ff EOR AND ( press^ )
DUP #00 EQU ?&skip
DUP #01 AND ?&ctrl
DUP #02 AND ?&alt
DUP #04 AND ?&select
DUP #08 AND ?&start
&skip POP JMP2r
&ctrl POP !try-to-flip
&alt POP !flip-all-cards
&select POP !randomize
&start POP !reset )
~cards.tal