basically works, sort of
This commit is contained in:
parent
8d6fb7712f
commit
78f4e37598
75
kodiak.tal
75
kodiak.tal
|
|
@ -230,11 +230,14 @@
|
|||
@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 )
|
||||
#13 MUL .tableau ADD ( pos=t+idx*19^ )
|
||||
DUP #13 ADD SWP ( lim=pos+19^ pos^ )
|
||||
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 )
|
||||
|
|
@ -334,17 +337,17 @@
|
|||
;cursor .Screen/addr DEO2
|
||||
#43 .Screen/sprite DEO &skip JMP2r
|
||||
|
||||
( TODO: handle dealing more cards from stock )
|
||||
@on-click-down ( -> )
|
||||
.Mouse/state DEI ( state^ )
|
||||
.prev/mouse-state LDZ #ff EOR AND ( down^ )
|
||||
#01 AND ?&ok JMP2r &ok
|
||||
.dragging LDZ ?release
|
||||
maybe-select-stock ?&found
|
||||
maybe-select-stock ?&skip
|
||||
maybe-select-waste ?&found
|
||||
maybe-select-tableau ?&found
|
||||
( not found ) .dragging #05 initialize
|
||||
( 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
|
||||
|
|
@ -368,15 +371,18 @@
|
|||
&above-ace LDZk #01 SUB SWP STZ JMP2r
|
||||
|
||||
@valid-card-foundation ( below^ above^ -> bool^ )
|
||||
DUP2 #000f AND2 #0001 EQU2 ?&aces ( below^ above^ )
|
||||
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-alt-color ( below^ above^ -> bool^ )
|
||||
@valid-card-tableau ( below^ above^ -> bool^ )
|
||||
DUP2 #0f0f AND2 #000d EQU2 ?&king ( below^ above^ )
|
||||
#1010 OVR2 AND2 NEQ STH ( below^ above^ [suit-match^] )
|
||||
SWP INC EQU STHr AND JMP2r ( face-match&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 )
|
||||
|
|
@ -403,11 +409,37 @@
|
|||
#01 JMP2r ( 1^ )
|
||||
|
||||
@try-release-tableau ( -> bool^ )
|
||||
( TODO: for each column... )
|
||||
( 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 )
|
||||
&nope #00 JMP2r
|
||||
#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-held-cards-column ( col -> )
|
||||
|
||||
@release ( -> )
|
||||
clear-prev-hold ( )
|
||||
|
|
@ -425,7 +457,8 @@
|
|||
POP2 POPr !&done ( )
|
||||
|
||||
@find-top ( start^ size^ -> zp^ )
|
||||
OVR ADD SWP ( lim^ start^ )
|
||||
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
|
||||
|
||||
|
|
@ -437,9 +470,6 @@
|
|||
@top-column ( i^ -> zp^ )
|
||||
bot-column #13 !find-top
|
||||
|
||||
@max ( x^ y^ -> max[x,y]^ )
|
||||
LTHk JMP SWP NIP JMP2r
|
||||
|
||||
@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 )
|
||||
|
|
@ -448,7 +478,8 @@
|
|||
|
||||
@deal-from-stock
|
||||
.stock LDZk ?&deal POP !reshuffle-stock ( root^ )
|
||||
&deal DUP #34 find-top top-waste INC STH ( root^ src^ [dst^] )
|
||||
&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] )
|
||||
|
|
@ -460,11 +491,11 @@
|
|||
&done POP2 POPr JMP2r ( )
|
||||
|
||||
@maybe-select-stock ( -> bool^ )
|
||||
.Mouse/x DEI2 #0008 LTH2 ?&no1 ( ; x<8 )
|
||||
.Mouse/x DEI2 #0017 GTH2 ?&no1 ( ; x>=23 )
|
||||
.Mouse/y DEI2 #0020 GTH2 ?&no1 ( ; y>=32 )
|
||||
.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^ )
|
||||
&no2 POPr &no1 #00 JMP2r ( 0^ )
|
||||
&no #00 JMP2r ( 0^ )
|
||||
|
||||
@start-drag ( x* y* first^ last^ -> )
|
||||
DUP2 .held STZ2 ( x* y* first^ last^ ; held<-first,last )
|
||||
|
|
|
|||
Loading…
Reference in New Issue