634 lines
24 KiB
Tal
634 lines
24 KiB
Tal
( kodiak.tal )
|
|
|
|
( TODO )
|
|
( * restart/quit game button )
|
|
( * automatically moving safe cards to foundation? )
|
|
( * music? )
|
|
( * save game file? stats? )
|
|
( * animations? flash stock when clicked? )
|
|
( * sometimes movement feels stutter-y )
|
|
( * automatically keeping @auto up-to-date is arguably better than recalculating )
|
|
|
|
|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 spades )
|
|
( - #3d king of hearts )
|
|
( - #6c queen of hearts, face down )
|
|
( - #93 three of diamonds, held )
|
|
|
|
( zero page - currently using 232 of 256 bytes )
|
|
|0000
|
|
@stock $34 ( draw pile - 52 bytes, 24 bytes at start )
|
|
@waste $18 ( face up pile - 24 bytes )
|
|
@foundation $4 ( one per suit - 4 bytes, 4x1 )
|
|
@tableau $85 ( the main board - 133 bytes, 7x19 )
|
|
@held $2 ( first and last card in held stack )
|
|
@dragging [ $1 ( are we dragging? )
|
|
&x $2 ( x-coord for start of drag )
|
|
&y $2 ] ( y-coord for start of drag )
|
|
@prev [ &button $1 ( previous button press )
|
|
&mouse-state $1 ( previous mouse state )
|
|
&mouse-x $2 ( previous x-coordinate )
|
|
&mouse-y $2 ] ( previous y-coordinate )
|
|
@auto $4 ( sorted foundation for auto-move: C D S H )
|
|
|
|
|0100
|
|
|
|
( colors: gold, white, red, black )
|
|
#bd82 .System/r DEO2
|
|
#8d12 .System/g DEO2
|
|
#4d12 .System/b DEO2
|
|
|
|
( 256x192 )
|
|
#0100 .Screen/w DEO2
|
|
#00c0 .Screen/h DEO2
|
|
|
|
reset BRK
|
|
|
|
@reset
|
|
init-rng-from-datetime
|
|
init-stock
|
|
.waste #18 initialize
|
|
.foundation #04 initialize
|
|
.tableau #85 initialize
|
|
.held #02 initialize
|
|
.dragging #05 initialize
|
|
.prev #06 initialize
|
|
|
|
shuffle-stock
|
|
deal-tableau
|
|
draw
|
|
|
|
;on-mouse .Mouse/vect DEO2
|
|
;on-key .Controller/vect DEO2
|
|
JMP2r
|
|
|
|
@dump-byte ( byte^ -- )
|
|
DUP #04 SFT ,&hex JSR #0f AND ,&hex JMP
|
|
&hex #30 ADD DUP #39 GTH #27 MUL ADD .Console/w DEO
|
|
JMP2r
|
|
|
|
@dump-mem ( start^ size^ -> )
|
|
OVR ADD SWP ( lim^ start^ )
|
|
LDZk dump-byte INC ( lim^ start+1^ )
|
|
&loop GTHk ?&ok POP2 #0a .Console/w DEO JMP2r ( lim^ pos^ )
|
|
&ok #20 .Console/w DEO LDZk dump-byte INC !&loop ( lim^ pos+1^ )
|
|
|
|
@dump-state ( -> )
|
|
|
|
,&count LDR2 INC2 ,&count STR2
|
|
|
|
LIT "d .Console/w DEO
|
|
LIT "u .Console/w DEO
|
|
LIT "m .Console/w DEO
|
|
LIT "p .Console/w DEO
|
|
#20 .Console/w DEO
|
|
LIT2 [ &count $2 ]
|
|
SWP dump-byte dump-byte
|
|
#0a .Console/w DEO
|
|
|
|
.stock #18 dump-mem
|
|
.stock #18 ADD #1c dump-mem
|
|
#0a .Console/w DEO
|
|
.waste #18 dump-mem
|
|
#0a .Console/w DEO
|
|
.foundation #04 dump-mem
|
|
#0a .Console/w DEO
|
|
|
|
.tableau
|
|
DUP #13 dump-mem #13 ADD
|
|
DUP #13 dump-mem #13 ADD
|
|
DUP #13 dump-mem #13 ADD
|
|
DUP #13 dump-mem #13 ADD
|
|
DUP #13 dump-mem #13 ADD
|
|
DUP #13 dump-mem #13 ADD
|
|
#13 dump-mem
|
|
#0a .Console/w DEO
|
|
|
|
.held #02 dump-mem
|
|
.dragging #05 dump-mem
|
|
.prev #06 dump-mem
|
|
.auto #04 dump-mem
|
|
LIT "- .Console/w DEOk DEOk DEOk DEOk DEO
|
|
#0a .Console/w DEO
|
|
JMP2r
|
|
|
|
@draw ( -> )
|
|
draw-background
|
|
draw-stock
|
|
draw-waste
|
|
draw-foundation
|
|
draw-tableau
|
|
!draw-curr-mouse
|
|
|
|
@initialize ( start^ count^ -> )
|
|
OVR ADD SWP STH2 #00 ( 0^ [lim=start+count^ start^] )
|
|
&loop DUP STHkr STZ INCr GTHkr STHr ?&loop ( 0^ [lim^ pos^] )
|
|
POP POP2r JMP2r ( )
|
|
|
|
@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
|
|
|
|
@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 ( -> )
|
|
top-stock LIT2r -tableau 00 ( top^ [tab^ 0^] )
|
|
&loop STH2kr deal-column ( top2^ [tab^ c^] )
|
|
LIT2r 1301 ADD2r ( top2^ [tab+19^ c+1^] )
|
|
STHkr #07 LTH ?&loop ( top2^ [tab+19^ c+1^] )
|
|
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 )
|
|
#00 OVR STZ ( d^ s^ [-c^] ; s<-0 )
|
|
#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 )
|
|
#00 OVR STZ ( s^ ; s<-0 )
|
|
#01 SUB JMP2r ( s-1^ )
|
|
|
|
@draw-stock ( -> )
|
|
.stock LDZk #00 EQU ?&empty ( stock^ )
|
|
#0008 ,&y STR2 ( ; y0<-8 )
|
|
#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 POP POP2 POPr JMP2r ( )
|
|
&empty POP #0008 DUP2 ( 8* 8* )
|
|
.Screen/x DEO2 .Screen/y DEO2 ( ; x<-8, y<-8 )
|
|
#00 maybe-draw-c 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<- )
|
|
DUP #80 AND ?&done ( lim^ zp^ c^ )
|
|
draw-c ( lim^ zp^ ; draw c )
|
|
,&x LDR2 #0008 ADD2 ,&x STR2 ( lim^ zp^ ; x<-x+8 )
|
|
INC GTHk ?&loop ( lim^ zp+1^ )
|
|
&done POP POP2 JMP2r ( )
|
|
|
|
( TODO: handle held cards in foundation by drawing one lower, or blank if ace held )
|
|
@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 POP2 JMP2r
|
|
|
|
@column-x ( idx^ -> x* )
|
|
#00 SWP #0018 MUL2 #0030 ADD2 JMP2r
|
|
|
|
@column-y ( col^ -> y* )
|
|
bot-column DUP #13 find-top SWP SUB
|
|
#00 SWP #0008 MUL2 #0024 ADD2 JMP2r
|
|
|
|
@draw-column ( idx^ -> )
|
|
DUP column-x ,&x STR2 ( idx^ ; x<-32+24*idx )
|
|
#0024 ,&y STR2 ( idx^ ; y<-32 )
|
|
bot-column 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^ c^ ; s/x<-x )
|
|
LIT2 [ &y $2 ] .Screen/y DEO2 ( lim^ pos^ c^ ; s/y<-y )
|
|
DUP #80 AND ?&done ( lim^ pos^ c^ )
|
|
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-spot-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 #3f AND 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 ?<
|
|
DUP #31 LTH #03 MUL ADD #24 SUB JMP2r
|
|
< 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
|
|
|
|
@on-move ( -> )
|
|
.Mouse/x DEI2 .prev/mouse-x LDZ2 NEQ2 ?draw-mouse
|
|
.Mouse/y DEI2 .prev/mouse-y LDZ2 NEQ2 ?draw-mouse
|
|
JMP2r
|
|
|
|
@draw-mouse ( -> )
|
|
#00 .Screen/auto DEO
|
|
clear-prev-hold clear-prev-mouse
|
|
draw-curr-hold !draw-curr-mouse
|
|
|
|
@clear-prev-hold ( -> )
|
|
.dragging LDZ ?{ JMP2r } ( )
|
|
#12 .Screen/auto DEO ( ; draw 2 tiles, increment x )
|
|
;blank .Screen/addr DEO2 ( ; erase )
|
|
.dragging/x LDZ2 .prev/mouse-x LDZ2 ADD2 STH2 ( [x*] )
|
|
.dragging/y LDZ2 .prev/mouse-y LDZ2 ADD2 STH2 ( [x* y*] )
|
|
.held LDZ2 #02 ADD SWP ( last+2^ first^ [x* y*] )
|
|
&loop LTHk ?&done ( last+2^ pos^ [x* y*] )
|
|
STH2kr .Screen/y DEO2 ( last+2^ pos^ [x* y*] ; s/y<-y )
|
|
OVR2r STH2r .Screen/x DEO2 ( last+2^ pos^ [x* y*] ; s/x<-x )
|
|
#41 .Screen/sprite DEO ( last+2^ pos^ [x* y*] ; erase )
|
|
INC LIT2r 0008 ADD2r !&loop ( last+2^ pos+1^ [x* y+8*] )
|
|
&done POP2 POP2r POP2r JMP2r ( )
|
|
|
|
@curr-drag-x ( -> x* )
|
|
.Mouse/x DEI2 .dragging/x LDZ2 ADD2 JMP2r
|
|
|
|
@curr-drag-y ( -> x* )
|
|
.Mouse/y DEI2 .dragging/y LDZ2 ADD2 JMP2r
|
|
|
|
@draw-curr-hold ( -> )
|
|
.dragging LDZ ?{ JMP2r }
|
|
set-fg
|
|
curr-drag-x STH2 ( [x*] )
|
|
curr-drag-y STH2 ( [x* y*] )
|
|
.held LDZ2 SWP ( last^ first^ [x* y*] )
|
|
&loop LTHk ?&done ( last^ pos^ [x* y*] )
|
|
STH2kr .Screen/y DEO2 ( last^ pos^ [x* y*] ; s/y<-y )
|
|
OVR2r STH2r .Screen/x DEO2 ( last^ pos^ [x* y*] ; s/x<-x )
|
|
LDZk draw-c ( last^ pos^ [x* y*] ; draw )
|
|
INC LIT2r 0008 ADD2r !&loop ( last^ pos+1^ [x* y+8*] )
|
|
&done POP2 POP2r POP2r !set-bg ( )
|
|
|
|
@clear-prev-mouse ( -> )
|
|
#00 .Screen/auto DEO
|
|
;blank .Screen/addr DEO2
|
|
.prev/mouse-x LDZ2 .Screen/x DEO2
|
|
.prev/mouse-y LDZ2 .Screen/y 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
|
|
.dragging LDZ ?&skip
|
|
;cursor .Screen/addr DEO2
|
|
#43 .Screen/sprite DEO &skip JMP2r
|
|
|
|
@on-click-down ( -> )
|
|
.Mouse/state DEI ( state^ )
|
|
.prev/mouse-state LDZ #ff EOR AND ( down^ )
|
|
#01 AND ?&ok JMP2r &ok
|
|
maybe-select-stock ?&skip
|
|
maybe-select-waste ?&found
|
|
maybe-select-tableau ?&found
|
|
( not found ) .dragging #05 !initialize
|
|
&found clear-prev-mouse !draw-curr-hold
|
|
&skip JMP2r
|
|
|
|
@distance ( a* b* -> max[a,b]-min[a,b]* )
|
|
GTH2k JMP SWP2 SUB2 JMP2r
|
|
|
|
@card-overlap ( x1* y1* x2* y2* -> bool^ )
|
|
STH2 ROT2 distance SWP2 STH2r distance ( dx* dy* )
|
|
#0018 LTH2 STH #0010 LTH2 STHr AND JMP2r ( dy<24&dx<16^ )
|
|
|
|
@held-xy ( -> x* y* )
|
|
curr-drag-x !curr-drag-y
|
|
|
|
( search waste and tableau for held cards )
|
|
@remove-card ( z^ -> )
|
|
DUP .foundation LTH ?&zero ( z^ ; waste, just zero )
|
|
DUP .tableau LTH ?&from-foundation ( z^ )
|
|
DUP .tableau SUB #13 DIVk MUL SUB ( z^ (z-tab)%19^ )
|
|
?&from-non-empty-col ( z^ )
|
|
&zero #00 SWP STZ JMP2r
|
|
&from-foundation LDZ #0f #01 GTH ?&above-ace !&zero
|
|
&from-non-empty-col #00 OVR STZ #01 SUB LDZk #bf AND SWP STZ JMP2r
|
|
&above-ace LDZk #01 SUB SWP STZ JMP2r
|
|
|
|
@valid-card-foundation ( below^ above^ -> bool^ )
|
|
DUP2 #0f0f AND2 #0001 EQU2 ?&aces ( below^ above^ )
|
|
#3030 OVR2 AND2 EQU STH ( below^ above^ [suit-match^] )
|
|
#0f0f AND2 SWP INC EQU ( face-match^ [suit-match^] )
|
|
STHr AND JMP2r ( match^ )
|
|
&aces POP2 #01 JMP2r ( 1^ )
|
|
|
|
@valid-card-tableau ( below^ above^ -> bool^ )
|
|
DUP2 #0f0f AND2 #000d EQU2 ?&king ( below^ above^ )
|
|
#1010 OVR2 AND2 NEQ STH ( below^ above^ [suit-match^] )
|
|
#0f0f AND2 INC EQU ( face-match^ [suit-match^] )
|
|
STHr AND JMP2r ( match^ )
|
|
&king POP2 #01 JMP2r ( 1^ )
|
|
|
|
@try-release-foundation ( -> bool^ )
|
|
.held LDZ2 NEQ ?&nope ( ; stack can only have one card )
|
|
held-xy ( hx* hy* )
|
|
#0030 ,&y STR2 ( hx* hy* ; y<-48 )
|
|
LIT2r 0400 ( hx* hy* [4^ 0^] )
|
|
&loop ( hx* hy* [lim^ i^] )
|
|
OVR2 OVR2 ( hx* hy* hx* hy* [lim^ i^] )
|
|
#0008 LIT2 [ &y $2 ] ( hx* hy* hx* hy* x* y* [lim^ i^] )
|
|
card-overlap ?&found ( hx* hy* [lim^ i^] ) ( POP2 POP2 POP2 POP2 )
|
|
,&y LDR2 #0020 ADD2 ,&y STR2 ( hx* hy* [lim^ i^] ; y<-y+32 )
|
|
INCr GTHkr STHr ?&loop ( hx* hy* [lim^ i+1^] )
|
|
POP2r POP2 POP2 &nope #00 JMP2r ( 0^ )
|
|
&found ( hx* hy* [lim^ i^] )
|
|
POP2 POP2 NIPr STHr ( i^ )
|
|
.foundation ADD ( z^ )
|
|
LDZk .held LDZ LDZ ( z^ below^ above^ )
|
|
valid-card-foundation ?&match ( z^ )
|
|
POP #00 JMP2r ( 0^ )
|
|
&match ( z^ )
|
|
.held LDZ LDZ #7f AND SWP STZ ( ; z<-held )
|
|
.held LDZ remove-card ( ; remove held from prev position )
|
|
#0000 .held STZ2 ( ; remove holding status )
|
|
#01 JMP2r ( 1^ )
|
|
|
|
@try-release-tableau ( -> bool^ )
|
|
#0700 &loop
|
|
DUP try-release-column ?&success
|
|
INC GTHk ?&loop POP2 #00 JMP2r
|
|
&success #01 JMP2r
|
|
|
|
( TODO: check if bottom of stack intersects with top card of column )
|
|
( TODO: check if bottom of stack is compatible with top of column )
|
|
( TODO: place stack, clear prev, and return #01 if ok )
|
|
@try-release-column ( col^ -> bool^ )
|
|
STHk column-x
|
|
STHkr column-y ( x0* y* [col^] )
|
|
held-xy card-overlap ?&found ( [col^] )
|
|
POPr #00 JMP2r ( 0^ )
|
|
&found ( [col^] )
|
|
STHkr top-column LDZ ( under^ [col^] )
|
|
.held LDZ LDZ ( under^ over^ [col^] )
|
|
valid-card-tableau ?&ok ( ok^ [col^] )
|
|
POPr #00 JMP2r ( 0^ ; TODO )
|
|
&ok STHr top-column ( top^ )
|
|
inc-unless-empty STH ( [dst^] ; inc unless column is empty )
|
|
.held LDZ2 INC SWP ( lim^ src^ [dst^] )
|
|
&loop LDZk #7f AND STHkr STZ ( lim^ src^ [dst^] ; dst<-src )
|
|
DUP remove-card ( lim^ src^ [dst^] ; remove card )
|
|
INC INCr GTHk ?&loop ( lim^ src+1^ [dst+1^] )
|
|
#0000 .held STZ2 draw
|
|
POP2 POPr #01 JMP2r ( 1^ )
|
|
|
|
@inc-unless-empty ( zp^ -> zp1^ )
|
|
LDZk #00 EQU JMP INC JMP2r
|
|
|
|
@release ( -> )
|
|
clear-prev-hold ( )
|
|
try-release-foundation ?&done ( )
|
|
try-release-tableau ?&done ( )
|
|
.held LDZ2 SWP ( last^ first^ )
|
|
&loop DUP LDZk #80 EOR SWP STZ ( last^ pos^ ; pos<-c^0x80 )
|
|
INC LTHk #00 EQU ?&loop POP2 ( )
|
|
&done .dragging #05 initialize ( )
|
|
#0000 .held STZ2 !draw ( )
|
|
.held LDZ2 SWP LITr 00 ( last^ first^ [zero^] )
|
|
&loop2 STHkr OVR STZ ( last^ pos^ [zero^] ; pos<-zero )
|
|
INC LTHk #00 EQU ?&loop2 ( last^ pos+1^ [zero^] )
|
|
POP2 POPr !&done ( )
|
|
|
|
@find-top ( start^ size^ -> zp^ )
|
|
OVR LDZ ?&non-empty POP JMP2r
|
|
&non-empty OVR ADD SWP ( lim^ start^ )
|
|
&loop LDZk ?&ok !&done &ok INC GTHk ?&loop
|
|
&done NIP #01 SUB JMP2r
|
|
|
|
@top-stock ( -> zp^ ) .stock #34 !find-top
|
|
@top-waste ( -> zp^ ) .waste #18 !find-top
|
|
|
|
@bot-column ( i^ -> zp^ )
|
|
#13 MUL .tableau ADD JMP2r
|
|
@top-column ( i^ -> zp^ )
|
|
bot-column #13 !find-top
|
|
|
|
@reshuffle-stock
|
|
.waste DUP #18 find-top LITr -stock ( root^ src^ [dst^] )
|
|
&loop LDZk #40 EOR STHkr STZ #00 OVR STZ ( root^ src^ [dst^] ; dst<-src, src<-0 )
|
|
#01 SUB INCr GTHk #00 EQU ?&loop ( root^ src-1^ [dst+1^] )
|
|
POP2 #00 STHr STZ JMP2r ( ; ensure stock ends with 00 )
|
|
|
|
@deal-from-stock
|
|
.stock LDZk ?&deal POP !reshuffle-stock ( root^ )
|
|
&deal DUP #34 find-top top-waste ( root^ src^ w^ )
|
|
inc-unless-empty STH ( root^ src^ [dst^] )
|
|
|
|
LDZk #40 EOR STHkr STZ #00 OVR STZ ( root^ src^ [dst^] ; dst<-src, src<-0 )
|
|
EQUk ?&done #01 SUB INCr ( root^ src-1^ [dst+1] )
|
|
|
|
LDZk #40 EOR STHkr STZ #00 OVR STZ ( root^ src-1^ [dst+1^] ; dst+1<-src-1, src-1<-0 )
|
|
EQUk ?&done #01 SUB INCr ( root^ src-2^ [dst+2] )
|
|
|
|
LDZk #40 EOR STHkr STZ #00 OVR STZ ( root^ src-2^ [dst+2^] ; dst+2<-src-2, src-2<-0 )
|
|
&done POP2 POPr JMP2r ( )
|
|
|
|
@maybe-select-stock ( -> bool^ )
|
|
.Mouse/x DEI2 #0008 LTH2 ?&no ( ; x<8 )
|
|
.Mouse/x DEI2 #0017 GTH2 ?&no ( ; x>=23 )
|
|
.Mouse/y DEI2 #0020 GTH2 ?&no ( ; y>=32 )
|
|
deal-from-stock draw #01 JMP2r ( 1^ )
|
|
&no #00 JMP2r ( 0^ )
|
|
|
|
@start-drag ( x* y* first^ last^ -> )
|
|
DUP2 .held STZ2 ( x* y* first^ last^ ; held<-first,last )
|
|
SWP ( x* y* last^ first^ )
|
|
&loop LTHk ?&done ( x* y* last^ z^ )
|
|
DUP LDZk #80 EOR SWP STZ ( x* y* last^ z^ ; z<-q )
|
|
INC !&loop ( x* y* last^ z+1^ )
|
|
&done POP2 ( x* y* )
|
|
.Mouse/y DEI2 SUB2 .dragging/y STZ2
|
|
.Mouse/x DEI2 SUB2 .dragging/x STZ2
|
|
#01 .dragging STZ JMP2r ( )
|
|
|
|
@maybe-select-waste ( -> bool^ )
|
|
.Mouse/y DEI2 #0008 LTH2 ?&no1 ( )
|
|
.Mouse/y DEI2 #0020 GTH2 ?&no1 ( )
|
|
top-waste STHk #00 EQU ?&no2 ( [t^] )
|
|
#001c #00 STHkr .waste SUB #0008 MUL2 ADD2 ( w=0x1c+8*index* [t^ w*] )
|
|
DUP2 ,&dx STR2 ( w* [t^ w*] ; dx<-w )
|
|
.Mouse/x DEI2 GTH2 ?&no2 ( [t^ w*] )
|
|
#002c #00 STHkr .waste SUB #0008 MUL2 ADD2 ( 0x2c+8*index* [t^ w*] )
|
|
.Mouse/x DEI2 LTH2 ?&no2 ( [t^] )
|
|
LIT2 [ &dx $2 ] #0008 STHr DUP ( dx* dy=8* t^ t^ )
|
|
start-drag draw #01 JMP2r ( 1^ )
|
|
&no2 POP2r POPr &no1 #00 JMP2r ( 0^ )
|
|
|
|
( TODO: handle empty column )
|
|
@maybe-select-tableau ( -> bool^ )
|
|
.Mouse/y DEI2 #0024 LTH2 ?&no1 ( )
|
|
.Mouse/x DEI2 #0030 LTH2 ?&no1 ( )
|
|
.Mouse/x DEI2 #00cf GTH2 ?&no1 ( )
|
|
#0040 LIT2r 0700 ( 64* [7^ 0^] )
|
|
&loop ( x* [lim^ i^] )
|
|
.Mouse/x DEI2 OVR2 LTH2 ?&col ( x* [lim^ i^] )
|
|
#0008 ADD2 ( y1=y+8* [lim^ i^] )
|
|
.Mouse/x DEI2 OVR2 LTH2 ?&no2 ( y1* [lim^ i^] )
|
|
#0010 ADD2 ( y2=y1+16* [lim^ i^] )
|
|
INCr GTHkr STHr ?&loop ( y2 [lim i+1^] )
|
|
&no2 POP2 POP2r &no1 #00 JMP2r ( 0^ )
|
|
&col ( x* [lim^ i^] )
|
|
POP2 NIPr STHr !maybe-select-column ( bool^ )
|
|
|
|
@maybe-select-column ( i^ -> bool^ )
|
|
.Mouse/y DEI2 #0024 LTH2 ?&no ( i^ )
|
|
DUP top-column OVR bot-column ( i^ top^ bot^ )
|
|
LIT2r 0001 ( i^ top^ bot^ [1*] )
|
|
&loop ( i^ top^ row^ [n*] )
|
|
GTHk ?&next !&done ( i^ top^ row^ [n*] )
|
|
&next ( i^ top^ row^ [n*] )
|
|
.Mouse/y DEI2 ( i^ top^ row^ y* [n*] )
|
|
STH2kr #0008 MUL2 #0024 ADD2 ( i^ top^ row^ y* lim=36+8n* [n*] )
|
|
LTH2 ?&match INC INC2r !&loop ( i^ top^ row+1^ [n+1*] )
|
|
&done ( i^ top^ row^ [n*] )
|
|
.Mouse/y DEI2 ( i^ top^ row^ y* [n*] )
|
|
STH2kr #0008 MUL2 #0034 ADD2 ( i^ top^ row^ y* lim=52+8n* [n*] )
|
|
LTH2 ?&match ( i^ top^ row^ [n*] )
|
|
POP2r POP2 &no POP #00 JMP2r ( 0^ )
|
|
&match ( i^ top^ row^ [n*] )
|
|
LDZk #00 EQU ?&cancel ( i^ top^ row^ [n*] )
|
|
LDZk #40 AND ?&cancel ( i^ top^ row^ [n*] )
|
|
STH2 SWP2r column-x ( x* [top^ row^ n*] )
|
|
STH2r #0008 MUL2 #001c ADD2 ( x* y=28+8n* [top^ row^] )
|
|
STH2r SWP ( x* y* row^ top^ )
|
|
start-drag draw #01 JMP2r ( 1^ )
|
|
&cancel ( i^ top^ row^ [n*] )
|
|
POP2 POP POP2r #00 JMP2r ( 0^ )
|
|
|
|
@min ( x^ y^ -> min[x,y]^ )
|
|
LTHk JMP SWP POP JMP2r
|
|
|
|
@check-auto ( card^ -> ok^ )
|
|
DUP #30 AND ( card^ suit^ )
|
|
#04 SFT .auto ADD LDZ INC ( card^ base+1^ )
|
|
OVR #0f AND EQU ?&ok ( card^ ; base+1=face? )
|
|
POP #00 JMP2r ( 0^ )
|
|
&ok DUP #30 AND ( card^ suit^ )
|
|
#04 SFT INC #03 AND ( card^ alt1^ )
|
|
INCk INC #03 AND ( card^ alt1^ alt2^ )
|
|
.auto ADD LDZ SWP ( card^ face2^ alt1^ )
|
|
.auto ADD LDZ min ( card^ min-face^ )
|
|
INC INC INC SWP #0f AND ( min-face+3^ face^ )
|
|
GTH JMP2r ( min-face+3>face^ )
|
|
|
|
@auto-move-col ( col^ -> ok^ )
|
|
DUP top-column LDZ ( col^ card^ )
|
|
DUP check-auto ?&ok !&done ( col^ card^ )
|
|
&ok auto-dest STH top-column ( src^ [dst^] )
|
|
LDZk STHr STZ remove-card #01 JMP2r ( 1^ )
|
|
&done POP2 #00 JMP2r ( 0^ )
|
|
|
|
@auto-dest ( card^ -> dst^ )
|
|
DUP #0f AND #01 EQU ?&aces ( card^ )
|
|
#30 AND STH ( [suit^] )
|
|
.foundation #04 OVR ADD SWP ( lim^ start^ [suit^] )
|
|
&loop LDZk #30 AND STHkr EQU ?&ok ( lim^ zp^ [suit^] )
|
|
INC GTHk ?&loop ( lim^ zp+1^ [suit^] )
|
|
&ok POPr NIP JMP2r ( zp^ )
|
|
&aces ( card^ )
|
|
POP .foundation #04 OVR ADD SWP ( lim^ start^ )
|
|
&loop2 LDZk ?&next NIP JMP2r ( zp^ )
|
|
&next INC GTHk ?&loop2 ( lim^ zp+1^ )
|
|
|
|
@auto-move ( -> )
|
|
prepare-auto #0700 ( lim^ col0^ )
|
|
&loop DUP auto-move-col ?&found INC GTHk ?&loop ( lim^ col+1^ )
|
|
POP2 draw JMP2r ( ; FIXME )
|
|
&found POP2 !auto-move ( )
|
|
|
|
@prepare-auto ( -> )
|
|
.auto #04 initialize ( ; reset auto )
|
|
.foundation #04 OVR ADD SWP ( lim^ start^ )
|
|
&loop LDZk update-auto ( lim^ pos^ )
|
|
INC GTHk ?&loop ( lim^ pos+1^ )
|
|
POP2 JMP2r ()
|
|
|
|
@update-auto ( card^ -> )
|
|
DUP ?&ok POP JMP2r ( )
|
|
&ok DUP #30 AND ( card^ suit^ )
|
|
#04 SFT .auto ADD ( card^ zp^ )
|
|
SWP #0f AND SWP STZ JMP2r ( ; zp<-face )
|
|
|
|
@on-click-up ( -> )
|
|
.Mouse/state DEI #ff EOR ( not-state^ )
|
|
.prev/mouse-state LDZ AND ( up^ )
|
|
#01 AND ?&ok JMP2r &ok
|
|
.dragging LDZ ?release
|
|
JMP2r
|
|
|
|
@on-key ( -> brk )
|
|
on-press
|
|
.Controller/button DEI .prev/button STZ
|
|
BRK
|
|
|
|
@on-release ( -> )
|
|
JMP2r
|
|
|
|
@on-press ( -> )
|
|
.Controller/key DEI #0d EQU ?dump-state ( ; 0x0d: return )
|
|
.Controller/key DEI #1b EQU ?reset ( ; 0x1b: esc )
|
|
.Controller/key DEI #20 EQU ?auto-move ( ; 0x20: space )
|
|
JMP2r
|
|
|
|
~cards.tal
|