factor out shared card logic
This commit is contained in:
parent
0d2a1985fa
commit
95a36d6ca1
|
|
@ -0,0 +1,412 @@
|
|||
( cards.tal )
|
||||
|
||||
( CARD LAYOUT )
|
||||
( )
|
||||
( cards are stored as 16-bit values. )
|
||||
( the high byte holds the flags. )
|
||||
( the low byte holds the card id. )
|
||||
( )
|
||||
( FLAGS )
|
||||
( bit 1: flipping, #80 face down, #00 face up )
|
||||
( bits 2-6: unused )
|
||||
( bits 7-8: rotation, #00 north, #01 east, #02 south, #03 west )
|
||||
( )
|
||||
( IDENTIFIER )
|
||||
( 00: ace of spades )
|
||||
( 01: two of spades )
|
||||
( ... )
|
||||
( 0b: king of spades )
|
||||
( 0c: ace of hearts )
|
||||
( 0d: two of hearts )
|
||||
( ... )
|
||||
( 19: king of hearts )
|
||||
( 1a: ace of diamonds )
|
||||
( 1b: two of diamonds )
|
||||
( ... )
|
||||
( 26: king of diamonds )
|
||||
( 27: ace of clubs )
|
||||
( 28: two of clubs )
|
||||
( 33: king of clubs )
|
||||
|
||||
( BUG: stack is growing, maybe redraw-all ? )
|
||||
|
||||
( TODO: move piles )
|
||||
( TODO: shuffle deck only )
|
||||
( TODO: try out rounded corners )
|
||||
( - face down can use white as transparent )
|
||||
( - face up black cards use red as transparent )
|
||||
( - face up red cards use black as transparent )
|
||||
( TODO: optional snap-to-grid setting? )
|
||||
|
||||
( ROTATION )
|
||||
( N 00 to E 01: dx=+0 dy=+8 )
|
||||
( 01 to 02: dx=+0 dy=+0 )
|
||||
( 02 to 03: dx=-8 dy=+0 )
|
||||
( 03 to 00: dx=+8 dy=-8 )
|
||||
( will require unhardcoding bounding boxes )
|
||||
|
||||
( BUG: try moving the "whole deck" and get into a weird state )
|
||||
|
||||
@move-card ( card* dx^ dy^ -> )
|
||||
SWP SWP2 STH2 INC2r INC2r ( dy^ dx^ [card+2*] )
|
||||
STH2kr LDA ADD STH2kr STA INC2r ( dy^ [card+3*] ; card.x+=dx )
|
||||
STH2kr LDA ADD STH2r STA JMP2r ( ; card.y+=dy )
|
||||
|
||||
( put all cards face down, and stack them )
|
||||
( in a single deck in the middle of the screen )
|
||||
@reset ( -> )
|
||||
all-cards-face-down
|
||||
shuffle ( FIXME )
|
||||
#08 #18 stack-cards
|
||||
draw-background
|
||||
!draw-cards
|
||||
|
||||
( f: addr* -> )
|
||||
@for-all-cards ( f* -> )
|
||||
STH2 ;cards/end ;cards ( limit* start* [f*] )
|
||||
&loop DUP2 STH2kr JSR2 ( limit* pos* [f*] )
|
||||
#0004 ADD2 GTH2k ?&loop ( limit* pos+4* [f*] )
|
||||
POP2 POP2 POP2r JMP2r ( )
|
||||
|
||||
@all-cards-face-down ( -> )
|
||||
;turn-card-face-down !for-all-cards
|
||||
|
||||
@stack-cards ( x^ y^ -> )
|
||||
,stack-card/y STR ,stack-card/x STR #00 ,stack-card/c STR
|
||||
;stack-card !for-all-cards
|
||||
|
||||
@stack-card ( addr* -> )
|
||||
INC2 INC2 STH2 ( [addr+2*] )
|
||||
LIT [ &x $1 ] STH2kr STA INC2r ( [addr+3] ; addr+2<-x )
|
||||
LIT [ &y $1 ] STH2r STA ( ; addr+3<-y )
|
||||
LIT [ &c $1 ] ?&skip
|
||||
,&y LDR #01 SUB ,&y STR
|
||||
&skip ,&c LDR INC #03 AND ,&c STR JMP2r
|
||||
|
||||
@flip-all-cards ( -> )
|
||||
;cards/end ;cards ( limit* start* )
|
||||
&loop DUP2 flip-card ( limit* pos* )
|
||||
#0004 ADD2 GTH2k ?&loop ( limit* pos+4* )
|
||||
POP2 POP2 !draw-cards ( )
|
||||
|
||||
@shuffle ( -> )
|
||||
;cards/last ;cards ( last* start* )
|
||||
&loop ( last* pos* )
|
||||
SUB2k #02 SFT2 INC2 ( last* pos* n=[last-pos]/4+1* )
|
||||
random SWP2 ( last* pos* r* n* )
|
||||
DIV2k MUL2 SUB2 ( last* pos* i=r%n* )
|
||||
#20 SFT2 OVR2 ADD2 ( last* pos* alt=pos+4i* )
|
||||
LDA2k ,&c STR2 ( last* pos* alt* ; c<-alt )
|
||||
STH2 LDA2k STH2r STA2 STH2 ( last* [pos*] ; alt<-pos )
|
||||
LIT2 [ &c $2 ] STH2kr STA2 ( last* [pos*] )
|
||||
STH2r #0004 ADD2 ( last* pos+4* )
|
||||
GTH2k ?&loop ( last* pos+4* )
|
||||
POP2 POP2 JMP2r ( )
|
||||
|
||||
@try-to-flip ( -> )
|
||||
find-mouse-over-card
|
||||
ORAk ?&found POP2 JMP2r
|
||||
&found flip-card !draw-cards
|
||||
|
||||
@flip-card ( addr* -> )
|
||||
LDA2k #8000 EOR2 SWP2 STA2 JMP2r
|
||||
|
||||
@turn-card-face-down ( addr* -> )
|
||||
LDA2k #8000 ORA2 SWP2 STA2 JMP2r
|
||||
|
||||
@turn-card-face-up ( addr* -> )
|
||||
LDA2k #7fff AND2 SWP2 STA2 JMP2r
|
||||
|
||||
@randomize ( -> )
|
||||
init-cards
|
||||
draw-background
|
||||
!draw-cards
|
||||
|
||||
@mod ( n* d* -> n%d* )
|
||||
DIV2k MUL2 SUB2 JMP2r
|
||||
|
||||
@init-cards ( -> )
|
||||
#0034 #0000 ( limit* 0* )
|
||||
&loop ( limit* c* )
|
||||
;cards OVR2 ( limit* c* cards* c* )
|
||||
#0004 MUL2 ADD2 ( limit* c* addr=cards+4c* )
|
||||
INC2 STAk ( limit* c* addr+1* ; addr+1<-c )
|
||||
INC2 STH2 ( limit* c* [addr+2*] )
|
||||
random #00f0 mod NIP ( limit* c* x^ [addr+2*] )
|
||||
STH2kr STA INC2r ( limit* c* [addr+3*] ; addr+2<-x )
|
||||
random #00a8 mod NIP ( limit* c* y^ [addr+3*] )
|
||||
STH2r STA ( limit* c* ; addr+3<-y )
|
||||
INC2 GTH2k ?&loop ( limit* c+1* )
|
||||
POP2 POP2 JMP2r
|
||||
|
||||
@raise-card ( addr* -> )
|
||||
DUP2 ;cards/last EQU2 ?&skip ( addr* )
|
||||
LDA2k ,&card STR2 INC2 INC2 ( addr+2* )
|
||||
LDA2k ,&xy STR2 #0002 SUB2 ( addr-2* )
|
||||
;cards/end SWP2 ( end* pos* )
|
||||
&loop ( end* pos* )
|
||||
STH2k #0004 ADD2 LDA2 ( end* n* [pos*] )
|
||||
STH2kr STA2 ( end* [pos*] ; pos<-n )
|
||||
STH2r INC2 INC2 ( end pos+2* )
|
||||
GTH2k ?&loop ( end* pos+2* )
|
||||
POP2 POP2 LIT2r :cards/last ( [last*] )
|
||||
LIT2 [ &card $2 ] ( c* [last*] )
|
||||
STH2kr STA2 INC2r INC2r ( [last+2*] ; last<-c )
|
||||
LIT2 [ &xy $2 ] ( xy* [last+2*] )
|
||||
STH2r STA2 JMP2r ( ; last+2<-xy )
|
||||
&skip POP2 JMP2r ( )
|
||||
|
||||
( raises card at addr and everything it lifts )
|
||||
@raise-cards ( addr* -> count^ )
|
||||
#0004 ,&d STR2 ( ; d<-4 )
|
||||
;raise-cards/buf ;raise-cards/pos STA2 ( addr* ; pos<-buf[0] )
|
||||
DUP2 raise-cards/enqueue STH2 ( addr* [pos*] ; buf[0]<-addr )
|
||||
;cards/end SWP2 #0004 ADD2 ( limit* addr+4* [pos*] )
|
||||
&loop ( limit* addr* [pos*] )
|
||||
STH2kr OVR2 card-lifts ?&lift ( limit* addr* [pos*] )
|
||||
STH2k LIT2r [ &d $2 ] SUB2r ( limit* addr* [pos* addr-d*] )
|
||||
LDA2k STH2kr STA2 ( limit* addr* [pos* addr-d*] ; copy 1-2 )
|
||||
INC2 INC2 INC2r INC2r ( limit* addr+2* [pos* addr-d+2*] )
|
||||
LDA2k STH2r STA2 INC2 INC2 ( limit* addr+4* [pos*] ; copy 3-4 )
|
||||
GTH2k ?&loop !&done ( limit* addr+4* [pos*] )
|
||||
&lift ( limit* addr* [pos*] )
|
||||
,&d LDR2 #0004 ADD2 ,&d STR2 ( limit* addr* [pos*] ; d<-d+4 )
|
||||
DUP2 ( limit* addr* addr* )
|
||||
raise-cards/enqueue POP2 ( limit* addr* [pos*] )
|
||||
#0004 ADD2 GTH2k ?&loop ( limit* addr+4* [pos*] )
|
||||
&done ( limit* limit* [pos*] )
|
||||
POP2 POP2r ( limit* )
|
||||
,&d LDR2 SUB2 STH2 ( [dst=limit-d*] )
|
||||
,&pos LDR2 ;raise-cards/buf ( end* buf* [dst*] )
|
||||
SUB2k #02 SFT2 STH2 SWP2r ( end* buf* [count* dst*] )
|
||||
© ( end* pos* [count* dst*] )
|
||||
LDA2k STH2kr STA2 ( end* pos* [count* dst*] ; pos<-dst )
|
||||
INC2 INC2 INC2r INC2r ( end* pos+2* [count* dst+2*] )
|
||||
GTH2k ?© ( end* pos+2* [count* dst+2*] )
|
||||
POP2 POP2 POP2r ( [count*] )
|
||||
NIPr STHr JMP2r ( count^ )
|
||||
&enqueue ( c* -> pos* )
|
||||
,&pos LDR2 STH2 LDA2k STH2kr STA2 ( c* [pos*] ; buf[pos]<-c )
|
||||
INC2 INC2 INC2kr INC2r ( c+2* [pos* pos+2*] )
|
||||
LDA2 STH2kr STA2 INC2r INC2r ( [pos* pos+4*] ; buf[pos+2]<-c+2 )
|
||||
STH2r ,&pos STR2 STH2r JMP2r ( pos* ; pos<-pos+4 )
|
||||
[ &pos $2 &buf $cc ]
|
||||
|
||||
@abs-within ( x^ y^ d^ -> abs[x-y] <= d^ )
|
||||
STH SUB STHkr ADD ( x-y+d^ [d^] )
|
||||
STHr DUP ADD INC LTH JMP2r ( x-y+d<2d+1^ )
|
||||
|
||||
@card-overlaps ( a* b* -> ok^ )
|
||||
INC2 INC2 LDA2 STH2 ( a* [bx^ by^] )
|
||||
INC2 INC2 LDA2 ( ax^ ay^ [bx^ by^] )
|
||||
STHr #17 abs-within SWP ( ay-by<16^ ax^ [bx^] )
|
||||
STHr #0f abs-within AND ( ay-by<16&ax-bx<24^ )
|
||||
JMP2r
|
||||
|
||||
( returns true if the card below lifts the card above )
|
||||
@card-lifts ( below* above* -> bool^ )
|
||||
GTH2k ?&no !card-overlaps &no POP2 POP2 #00 JMP2r
|
||||
|
||||
@find-mouse-over-card ( -> addr* )
|
||||
.Mouse/x DEI2 .Mouse/y DEI2 !find-card
|
||||
|
||||
( returns top card at coords, or 0000 if no card. )
|
||||
@find-card ( x* y* -> addr* )
|
||||
LIT2r :cards LIT2r :cards/last ( x* y* [limit* first*] )
|
||||
&loop ( x* y* [limit* pos*] )
|
||||
OVR2 OVR2 STH2kr ( x* y* x* y* pos* [limit* pos*] )
|
||||
intersects ?&done ( x* y* [limit* pos*] )
|
||||
LIT2r 0004 SUB2r ( x* y* [limit* pos-4*] )
|
||||
GTH2kr STHr ?¬found ( x* y* [limit* pos-4*] )
|
||||
!&loop ( x* y* [limit* pos-4*] )
|
||||
¬found POP2r LIT2r 0000 ( x* y* [limit* 0*] )
|
||||
&done ( x* y* [limit* addr*] )
|
||||
POP2 POP2 STH2r POP2r JMP2r ( addr* )
|
||||
|
||||
( returns true if the given card x,y coordinates )
|
||||
( intersect the rectangle of the given card. )
|
||||
( cards are 16 pixels wide and 24 pixels tall. )
|
||||
( so the result is: )
|
||||
( cx <= x < cx+16 && cy <= y < cy+24 )
|
||||
@intersects ( x* y* card* -> bool^ )
|
||||
ROT2 STH2 LITr 00 ( y* card* [x* 0^] )
|
||||
#0002 ADD2 LDAk STH SUB2r ( y* card+2* [x-cx*] )
|
||||
LIT2r 0010 LTH2r STHr ?&x-ok ( y* card+2* )
|
||||
POP2 POP2 #00 JMP2r ( 0^ )
|
||||
&x-ok ( y* card+2* )
|
||||
LITr 00 INC2 LDA STH STH2r ( y* cy* )
|
||||
SUB2 #0018 LTH2 JMP2r ( ok^ )
|
||||
|
||||
@draw-cards
|
||||
;draw-card !draw-all-cards
|
||||
|
||||
@held-end-offset ( -> offset* )
|
||||
;cards/end #00 .card-is-held LDZ #0004 MUL2 SUB2 JMP2r
|
||||
|
||||
( TODO: if the top card is being "held" then we )
|
||||
( should not draw that here, because it will be )
|
||||
( drawn in the foreground using a mask. )
|
||||
@draw-all-cards ( draw* -> )
|
||||
,&draw STR2 ( )
|
||||
held-end-offset STH2 ( [limit*] )
|
||||
LIT2r :cards ( [limit* pos*] )
|
||||
&loop ( [limit* pos*] )
|
||||
STH2kr LDA2 INC2r INC2r ( card* [limit* pos+2*] )
|
||||
#00 STH2kr LDA INC2r ( card* x* [limit* pos+3*] )
|
||||
#00 STH2kr LDA INC2r ( card* x* y* [limit* pos+4*] )
|
||||
LIT2 [ &draw $2 ] JSR2 ( [limit* pos+4] )
|
||||
GTH2kr STHr ?&loop ( [limit* pos+4] )
|
||||
POP2r POP2r ( )
|
||||
LIT2r :cards/end ( [limit*] )
|
||||
held-end-offset STH2 ( [limit* offset*] )
|
||||
&mloop ( [limit* pos*] )
|
||||
STH2kr LDA2 INC2r INC2r ( card* [limit* pos+2*] )
|
||||
#00 STH2kr LDA INC2r ( card* x* [limit* pos+3*] )
|
||||
#00 STH2kr LDA INC2r ( card* x* y* [limit* pos+4*] )
|
||||
draw-mask ( [limit* pos+4] )
|
||||
GTH2kr STHr ?&mloop ( [limit* pos+4] )
|
||||
POP2r POP2r JMP2r ( )
|
||||
|
||||
@draw-background ( -> )
|
||||
#f2 .Screen/auto DEO
|
||||
;tiles #0200 ADD2 .Screen/addr DEO2
|
||||
#0080 .Screen/x DEO2
|
||||
draw-background/twice
|
||||
#0000 .Screen/x DEO2
|
||||
&twice
|
||||
#0000 .Screen/y DEO2
|
||||
#81 .Screen/sprite
|
||||
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
|
||||
|
||||
@draw-mask ( idx* x* y* -> )
|
||||
.Screen/y DEO2 .Screen/x DEO2
|
||||
OVR #80 LTH ?draw-mask-up POP2 !draw-mask-down
|
||||
|
||||
@draw-card ( idx* x* y* -> )
|
||||
.Screen/y DEO2 .Screen/x DEO2
|
||||
OVR #80 LTH ?draw-face-up POP2 !draw-face-down
|
||||
|
||||
( assumes x/y already set )
|
||||
@draw-mask-down ( -> )
|
||||
#16 .Screen/auto DEO ( ; draw 2 tiles, increment x and addr )
|
||||
;masks #0080 ADD2 .Screen/addr DEO2
|
||||
#04 .Screen/sprite DEOk DEOk DEO
|
||||
JMP2r
|
||||
|
||||
( assumes x/y already set )
|
||||
@draw-face-down ( -> )
|
||||
#16 .Screen/auto DEO ( ; draw 2 tiles, increment x and addr )
|
||||
;tiles #0100 ADD2 .Screen/addr DEO2
|
||||
#81 .Screen/sprite DEOk DEOk DEO
|
||||
JMP2r
|
||||
|
||||
@card-is-black ( idx* -> bool^ )
|
||||
#000c DIV2
|
||||
@q-is-black ( q* -> bool^ )
|
||||
NIP #01 SUB #fe AND JMP2r ( [q-1]&fe )
|
||||
|
||||
@card-is-red ( idx* -> bool^ )
|
||||
#000c DIV2
|
||||
@q-is-red ( q* -> bool^ )
|
||||
NIP #03 MUL #02 AND JMP2r ( [q*3]&2 )
|
||||
|
||||
@find-middle-addr ( idx* -> addr* )
|
||||
#000d DIV2k STH2k MUL2 SUB2 ( r* [q*] )
|
||||
DUP2 #000a LTH2 ?&normal
|
||||
DUP2 #000a NEQ2 ?¬-j POP2 #0200 !&face
|
||||
¬-j #000b NEQ2 ?¬-q #0100 !&face
|
||||
¬-q #0000
|
||||
&face ;tiles ADD2 #00c0 ADD2
|
||||
STH2r card-is-red ?&is-red JMP2r
|
||||
&is-red #0020 ADD2 JMP2r
|
||||
&normal POP2 POP2r ;tiles #0020 ADD2 JMP2r
|
||||
|
||||
( assumes x/y already set )
|
||||
@draw-mask-up ( idx* -> )
|
||||
#16 .Screen/auto DEO ( ; draw 2 tiles, increment x and addr )
|
||||
#00ff AND2 ( idx* ; remove rotation/flip info for now )
|
||||
DUP2 ( idx* idx* )
|
||||
#000d DIV2k STH2k MUL2 SUB2 ( idx* r* [q*] )
|
||||
#0080 MUL2 ;masks #0180 ADD2 ( idx* 128r* card+384* [q*] )
|
||||
ADD2 STH2r #0010 MUL2 ADD2 ( idx* a=card+384+128r+16q* )
|
||||
STH2k .Screen/addr DEO2 ( idx* [a*] )
|
||||
#04 .Screen/sprite DEO ( idx* [a*] ; draw top of card )
|
||||
find-middle-addr ( mid* [a*] )
|
||||
;tiles SUB2 #01 SFT2 ;masks ADD2
|
||||
.Screen/addr DEO2 ( [a*] )
|
||||
#04 .Screen/sprite DEO ( [a*] ; draw middle of card )
|
||||
STH2r DUP2 #0008 ADD2 ( a* a+8* )
|
||||
.Screen/addr DEO2 ( )
|
||||
#01 .Screen/auto DEO ( ; draw 1 tile, increment x )
|
||||
#34 .Screen/sprite DEO ( ; draw bottom left of card )
|
||||
.Screen/addr DEO2 ( )
|
||||
#34 .Screen/sprite DEO ( ; draw bottom right of card )
|
||||
JMP2r
|
||||
|
||||
( assumes x/y already set )
|
||||
@draw-face-up ( idx* -> )
|
||||
#16 .Screen/auto DEO ( ; draw 2 tiles, increment x and addr )
|
||||
#00ff AND2 ( idx* ; remove rotation/flip info for now )
|
||||
DUP2 ( idx* idx* )
|
||||
#000d DIV2k STH2k MUL2 SUB2 ( idx* r* [q*] )
|
||||
#0100 MUL2 ;tiles #0300 ADD2 ( idx* 256r* card+768* [q*] )
|
||||
ADD2 STH2r #0020 MUL2 ADD2 ( idx* a=card+768+256r+32q* )
|
||||
STH2k .Screen/addr DEO2 ( idx* [a*] )
|
||||
#81 .Screen/sprite DEO ( idx* [a*] ; draw top of card )
|
||||
find-middle-addr ( mid* [a*] )
|
||||
.Screen/addr DEO2 ( [a*] )
|
||||
#81 .Screen/sprite DEO ( [a*] ; draw middle of card )
|
||||
STH2r DUP2 #0010 ADD2 ( a* a+16* )
|
||||
.Screen/addr DEO2 ( )
|
||||
#01 .Screen/auto DEO ( ; draw 1 tile, increment x )
|
||||
#b1 .Screen/sprite DEO ( ; draw bottom left of card )
|
||||
.Screen/addr DEO2 ( )
|
||||
#b1 .Screen/sprite DEO ( ; draw bottom right of card )
|
||||
JMP2r
|
||||
|
||||
@init-rng-from-datetime ( -> )
|
||||
#00 .DateTime/dow #5180 MUL2
|
||||
#00 .DateTime/hr DEI #0e10 MUL2 ADD2
|
||||
#00 .DateTime/min DEI #003c MUL2 ADD2
|
||||
#00 .DateTime/sec DEI ADD2 ( s* )
|
||||
DUP2 .DateTime/doy DEI2 MUL2 ( s* sdoy* )
|
||||
( fall-through )
|
||||
|
||||
@init-rng ( x* y* -> )
|
||||
#0001 ROT2 OVR2 ( y* 1* x* 1* )
|
||||
ORA2 ;rng/x STA2 ( y* 1* )
|
||||
ORA2 ;rng/x STA2 JMP2r ( )
|
||||
|
||||
@random ( -> x* )
|
||||
;rng/x LDA2 DUP2 #50 SFT2 EOR2 ( t=x^[x<<5]* )
|
||||
;rng/y LDA2 DUP2 ;rng/x STA2 ( t* y* ; x<-y )
|
||||
DUP2 #01 SFT2 EOR2 ( t* u=y^[y>>1]* )
|
||||
SWP2 DUP2 #03 SFT2 EOR2 ( u* v=t^[t>>3]* )
|
||||
EOR2 DUP2 ;rng/y STA2 JMP2r ( u^v* ; y<-u^v )
|
||||
|
||||
( 52 cards x 4 bytes per card = 208 bytes )
|
||||
( each card has: )
|
||||
( )
|
||||
( - byte 1: flags )
|
||||
( - byte 2: card suit/value )
|
||||
( - byte 3: x position )
|
||||
( - byte 4: y position )
|
||||
( )
|
||||
( confusingly the "top" card is actually at the end )
|
||||
( this ends up being convenient for coding but is a )
|
||||
( bit confusing to think about )
|
||||
@cards $0cc &last $4 &end
|
||||
|
||||
@cursor 80c0 e0f0 f8e0 1000
|
||||
@cursox 7f3f 1f0f 071f efff
|
||||
@blank 0000 0000 0000 0000
|
||||
|
||||
@rng &x $2 &y $2
|
||||
|
||||
( each tile is 16 bytes: a 2-bit 8x8 image )
|
||||
@tiles ~card-sprites.tal
|
||||
|
||||
( each mask tile is 8 bytes: a 1-bit 8x8 image )
|
||||
@masks ~mask-sprites.tal
|
||||
363
deck.tal
363
deck.tal
|
|
@ -57,7 +57,6 @@
|
|||
( BUG: try moving the "whole deck" and get into a weird state )
|
||||
|
||||
|0000
|
||||
@rng [ &x $2 &y $2 ]
|
||||
@prev-button $1
|
||||
@prev-mouse-state $1
|
||||
@prev-mouse-x $2
|
||||
|
|
@ -96,11 +95,6 @@
|
|||
@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
|
||||
|
||||
@move-card ( card* dx^ dy^ -> )
|
||||
SWP SWP2 STH2 INC2r INC2r ( dy^ dx^ [card+2*] )
|
||||
STH2kr LDA ADD STH2kr STA INC2r ( dy^ [card+3*] ; card.x+=dx )
|
||||
STH2kr LDA ADD STH2r STA JMP2r ( ; card.y+=dy )
|
||||
|
||||
@on-move ( -> )
|
||||
.Mouse/x DEI2 .prev-mouse-x LDZ2 NEQ2 ?&redraw
|
||||
.Mouse/y DEI2 .prev-mouse-y LDZ2 NEQ2 ?&redraw
|
||||
|
|
@ -187,359 +181,4 @@
|
|||
&select POP !randomize
|
||||
&start POP !reset
|
||||
|
||||
( put all cards face down, and stack them )
|
||||
( in a single deck in the middle of the screen )
|
||||
@reset ( -> )
|
||||
all-cards-face-down
|
||||
shuffle ( FIXME )
|
||||
#08 #18 stack-cards
|
||||
draw-background
|
||||
!draw-cards
|
||||
|
||||
( f: addr* -> )
|
||||
@for-all-cards ( f* -> )
|
||||
STH2 ;cards/end ;cards ( limit* start* [f*] )
|
||||
&loop DUP2 STH2kr JSR2 ( limit* pos* [f*] )
|
||||
#0004 ADD2 GTH2k ?&loop ( limit* pos+4* [f*] )
|
||||
POP2 POP2 POP2r JMP2r ( )
|
||||
|
||||
@all-cards-face-down ( -> )
|
||||
;turn-card-face-down !for-all-cards
|
||||
|
||||
@stack-cards ( x^ y^ -> )
|
||||
,stack-card/y STR ,stack-card/x STR #00 ,stack-card/c STR
|
||||
;stack-card !for-all-cards
|
||||
|
||||
@stack-card ( addr* -> )
|
||||
INC2 INC2 STH2 ( [addr+2*] )
|
||||
LIT [ &x $1 ] STH2kr STA INC2r ( [addr+3] ; addr+2<-x )
|
||||
LIT [ &y $1 ] STH2r STA ( ; addr+3<-y )
|
||||
LIT [ &c $1 ] ?&skip
|
||||
,&y LDR #01 SUB ,&y STR
|
||||
&skip ,&c LDR INC #03 AND ,&c STR JMP2r
|
||||
|
||||
@flip-all-cards ( -> )
|
||||
;cards/end ;cards ( limit* start* )
|
||||
&loop DUP2 flip-card ( limit* pos* )
|
||||
#0004 ADD2 GTH2k ?&loop ( limit* pos+4* )
|
||||
POP2 POP2 !draw-cards ( )
|
||||
|
||||
@shuffle ( -> )
|
||||
;cards/last ;cards ( last* start* )
|
||||
&loop ( last* pos* )
|
||||
SUB2k #02 SFT2 INC2 ( last* pos* n=[last-pos]/4+1* )
|
||||
random SWP2 ( last* pos* r* n* )
|
||||
DIV2k MUL2 SUB2 ( last* pos* i=r%n* )
|
||||
#20 SFT2 OVR2 ADD2 ( last* pos* alt=pos+4i* )
|
||||
LDA2k ,&c STR2 ( last* pos* alt* ; c<-alt )
|
||||
STH2 LDA2k STH2r STA2 STH2 ( last* [pos*] ; alt<-pos )
|
||||
LIT2 [ &c $2 ] STH2kr STA2 ( last* [pos*] )
|
||||
STH2r #0004 ADD2 ( last* pos+4* )
|
||||
GTH2k ?&loop ( last* pos+4* )
|
||||
POP2 POP2 JMP2r ( )
|
||||
|
||||
@try-to-flip ( -> )
|
||||
find-mouse-over-card
|
||||
ORAk ?&found POP2 JMP2r
|
||||
&found flip-card !draw-cards
|
||||
|
||||
@flip-card ( addr* -> )
|
||||
LDA2k #8000 EOR2 SWP2 STA2 JMP2r
|
||||
|
||||
@turn-card-face-down ( addr* -> )
|
||||
LDA2k #8000 ORA2 SWP2 STA2 JMP2r
|
||||
|
||||
@turn-card-face-up ( addr* -> )
|
||||
LDA2k #7fff AND2 SWP2 STA2 JMP2r
|
||||
|
||||
@randomize ( -> )
|
||||
init-cards
|
||||
draw-background
|
||||
!draw-cards
|
||||
|
||||
@mod ( n* d* -> n%d* )
|
||||
DIV2k MUL2 SUB2 JMP2r
|
||||
|
||||
@init-cards ( -> )
|
||||
#0034 #0000 ( limit* 0* )
|
||||
&loop ( limit* c* )
|
||||
;cards OVR2 ( limit* c* cards* c* )
|
||||
#0004 MUL2 ADD2 ( limit* c* addr=cards+4c* )
|
||||
INC2 STAk ( limit* c* addr+1* ; addr+1<-c )
|
||||
INC2 STH2 ( limit* c* [addr+2*] )
|
||||
random #00f0 mod NIP ( limit* c* x^ [addr+2*] )
|
||||
STH2kr STA INC2r ( limit* c* [addr+3*] ; addr+2<-x )
|
||||
random #00a8 mod NIP ( limit* c* y^ [addr+3*] )
|
||||
STH2r STA ( limit* c* ; addr+3<-y )
|
||||
INC2 GTH2k ?&loop ( limit* c+1* )
|
||||
POP2 POP2 JMP2r
|
||||
|
||||
@raise-card ( addr* -> )
|
||||
DUP2 ;cards/last EQU2 ?&skip ( addr* )
|
||||
LDA2k ,&card STR2 INC2 INC2 ( addr+2* )
|
||||
LDA2k ,&xy STR2 #0002 SUB2 ( addr-2* )
|
||||
;cards/end SWP2 ( end* pos* )
|
||||
&loop ( end* pos* )
|
||||
STH2k #0004 ADD2 LDA2 ( end* n* [pos*] )
|
||||
STH2kr STA2 ( end* [pos*] ; pos<-n )
|
||||
STH2r INC2 INC2 ( end pos+2* )
|
||||
GTH2k ?&loop ( end* pos+2* )
|
||||
POP2 POP2 LIT2r :cards/last ( [last*] )
|
||||
LIT2 [ &card $2 ] ( c* [last*] )
|
||||
STH2kr STA2 INC2r INC2r ( [last+2*] ; last<-c )
|
||||
LIT2 [ &xy $2 ] ( xy* [last+2*] )
|
||||
STH2r STA2 JMP2r ( ; last+2<-xy )
|
||||
&skip POP2 JMP2r ( )
|
||||
|
||||
( raises card at addr and everything it lifts )
|
||||
@raise-cards ( addr* -> count^ )
|
||||
#0004 ,&d STR2 ( ; d<-4 )
|
||||
;raise-cards/buf ;raise-cards/pos STA2 ( addr* ; pos<-buf[0] )
|
||||
DUP2 raise-cards/enqueue STH2 ( addr* [pos*] ; buf[0]<-addr )
|
||||
;cards/end SWP2 #0004 ADD2 ( limit* addr+4* [pos*] )
|
||||
&loop ( limit* addr* [pos*] )
|
||||
STH2kr OVR2 card-lifts ?&lift ( limit* addr* [pos*] )
|
||||
STH2k LIT2r [ &d $2 ] SUB2r ( limit* addr* [pos* addr-d*] )
|
||||
LDA2k STH2kr STA2 ( limit* addr* [pos* addr-d*] ; copy 1-2 )
|
||||
INC2 INC2 INC2r INC2r ( limit* addr+2* [pos* addr-d+2*] )
|
||||
LDA2k STH2r STA2 INC2 INC2 ( limit* addr+4* [pos*] ; copy 3-4 )
|
||||
GTH2k ?&loop !&done ( limit* addr+4* [pos*] )
|
||||
&lift ( limit* addr* [pos*] )
|
||||
,&d LDR2 #0004 ADD2 ,&d STR2 ( limit* addr* [pos*] ; d<-d+4 )
|
||||
DUP2 ( limit* addr* addr* )
|
||||
raise-cards/enqueue POP2 ( limit* addr* [pos*] )
|
||||
#0004 ADD2 GTH2k ?&loop ( limit* addr+4* [pos*] )
|
||||
&done ( limit* limit* [pos*] )
|
||||
POP2 POP2r ( limit* )
|
||||
,&d LDR2 SUB2 STH2 ( [dst=limit-d*] )
|
||||
,&pos LDR2 ;raise-cards/buf ( end* buf* [dst*] )
|
||||
SUB2k #02 SFT2 STH2 SWP2r ( end* buf* [count* dst*] )
|
||||
© ( end* pos* [count* dst*] )
|
||||
LDA2k STH2kr STA2 ( end* pos* [count* dst*] ; pos<-dst )
|
||||
INC2 INC2 INC2r INC2r ( end* pos+2* [count* dst+2*] )
|
||||
GTH2k ?© ( end* pos+2* [count* dst+2*] )
|
||||
POP2 POP2 POP2r ( [count*] )
|
||||
NIPr STHr JMP2r ( count^ )
|
||||
&enqueue ( c* -> pos* )
|
||||
,&pos LDR2 STH2 LDA2k STH2kr STA2 ( c* [pos*] ; buf[pos]<-c )
|
||||
INC2 INC2 INC2kr INC2r ( c+2* [pos* pos+2*] )
|
||||
LDA2 STH2kr STA2 INC2r INC2r ( [pos* pos+4*] ; buf[pos+2]<-c+2 )
|
||||
STH2r ,&pos STR2 STH2r JMP2r ( pos* ; pos<-pos+4 )
|
||||
[ &pos $2 &buf $cc ]
|
||||
|
||||
@abs-within ( x^ y^ d^ -> abs[x-y] <= d^ )
|
||||
STH SUB STHkr ADD ( x-y+d^ [d^] )
|
||||
STHr DUP ADD INC LTH JMP2r ( x-y+d<2d+1^ )
|
||||
|
||||
@card-overlaps ( a* b* -> ok^ )
|
||||
INC2 INC2 LDA2 STH2 ( a* [bx^ by^] )
|
||||
INC2 INC2 LDA2 ( ax^ ay^ [bx^ by^] )
|
||||
STHr #17 abs-within SWP ( ay-by<16^ ax^ [bx^] )
|
||||
STHr #0f abs-within AND ( ay-by<16&ax-bx<24^ )
|
||||
JMP2r
|
||||
|
||||
( returns true if the card below lifts the card above )
|
||||
@card-lifts ( below* above* -> bool^ )
|
||||
GTH2k ?&no !card-overlaps &no POP2 POP2 #00 JMP2r
|
||||
|
||||
@find-mouse-over-card ( -> addr* )
|
||||
.Mouse/x DEI2 .Mouse/y DEI2 !find-card
|
||||
|
||||
( returns top card at coords, or 0000 if no card. )
|
||||
@find-card ( x* y* -> addr* )
|
||||
LIT2r :cards LIT2r :cards/last ( x* y* [limit* first*] )
|
||||
&loop ( x* y* [limit* pos*] )
|
||||
OVR2 OVR2 STH2kr ( x* y* x* y* pos* [limit* pos*] )
|
||||
intersects ?&done ( x* y* [limit* pos*] )
|
||||
LIT2r 0004 SUB2r ( x* y* [limit* pos-4*] )
|
||||
GTH2kr STHr ?¬found ( x* y* [limit* pos-4*] )
|
||||
!&loop ( x* y* [limit* pos-4*] )
|
||||
¬found POP2r LIT2r 0000 ( x* y* [limit* 0*] )
|
||||
&done ( x* y* [limit* addr*] )
|
||||
POP2 POP2 STH2r POP2r JMP2r ( addr* )
|
||||
|
||||
( returns true if the given card x,y coordinates )
|
||||
( intersect the rectangle of the given card. )
|
||||
( cards are 16 pixels wide and 24 pixels tall. )
|
||||
( so the result is: )
|
||||
( cx <= x < cx+16 && cy <= y < cy+24 )
|
||||
@intersects ( x* y* card* -> bool^ )
|
||||
ROT2 STH2 LITr 00 ( y* card* [x* 0^] )
|
||||
#0002 ADD2 LDAk STH SUB2r ( y* card+2* [x-cx*] )
|
||||
LIT2r 0010 LTH2r STHr ?&x-ok ( y* card+2* )
|
||||
POP2 POP2 #00 JMP2r ( 0^ )
|
||||
&x-ok ( y* card+2* )
|
||||
LITr 00 INC2 LDA STH STH2r ( y* cy* )
|
||||
SUB2 #0018 LTH2 JMP2r ( ok^ )
|
||||
|
||||
@draw-cards
|
||||
;draw-card !draw-all-cards
|
||||
|
||||
@held-end-offset ( -> offset* )
|
||||
;cards/end #00 .card-is-held LDZ #0004 MUL2 SUB2 JMP2r
|
||||
|
||||
( TODO: if the top card is being "held" then we )
|
||||
( should not draw that here, because it will be )
|
||||
( drawn in the foreground using a mask. )
|
||||
@draw-all-cards ( draw* -> )
|
||||
,&draw STR2 ( )
|
||||
held-end-offset STH2 ( [limit*] )
|
||||
LIT2r :cards ( [limit* pos*] )
|
||||
&loop ( [limit* pos*] )
|
||||
STH2kr LDA2 INC2r INC2r ( card* [limit* pos+2*] )
|
||||
#00 STH2kr LDA INC2r ( card* x* [limit* pos+3*] )
|
||||
#00 STH2kr LDA INC2r ( card* x* y* [limit* pos+4*] )
|
||||
LIT2 [ &draw $2 ] JSR2 ( [limit* pos+4] )
|
||||
GTH2kr STHr ?&loop ( [limit* pos+4] )
|
||||
POP2r POP2r ( )
|
||||
LIT2r :cards/end ( [limit*] )
|
||||
held-end-offset STH2 ( [limit* offset*] )
|
||||
&mloop ( [limit* pos*] )
|
||||
STH2kr LDA2 INC2r INC2r ( card* [limit* pos+2*] )
|
||||
#00 STH2kr LDA INC2r ( card* x* [limit* pos+3*] )
|
||||
#00 STH2kr LDA INC2r ( card* x* y* [limit* pos+4*] )
|
||||
draw-mask ( [limit* pos+4] )
|
||||
GTH2kr STHr ?&mloop ( [limit* pos+4] )
|
||||
POP2r POP2r JMP2r ( )
|
||||
|
||||
@draw-background ( -> )
|
||||
#f2 .Screen/auto DEO
|
||||
;tiles #0200 ADD2 .Screen/addr DEO2
|
||||
#0080 .Screen/x DEO2
|
||||
draw-background/twice
|
||||
#0000 .Screen/x DEO2
|
||||
&twice
|
||||
#0000 .Screen/y DEO2
|
||||
#81 .Screen/sprite
|
||||
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
|
||||
|
||||
@draw-mask ( idx* x* y* -> )
|
||||
.Screen/y DEO2 .Screen/x DEO2
|
||||
OVR #80 LTH ?draw-mask-up POP2 !draw-mask-down
|
||||
|
||||
@draw-card ( idx* x* y* -> )
|
||||
.Screen/y DEO2 .Screen/x DEO2
|
||||
OVR #80 LTH ?draw-face-up POP2 !draw-face-down
|
||||
|
||||
( assumes x/y already set )
|
||||
@draw-mask-down ( -> )
|
||||
#16 .Screen/auto DEO ( ; draw 2 tiles, increment x and addr )
|
||||
;masks #0080 ADD2 .Screen/addr DEO2
|
||||
#04 .Screen/sprite DEOk DEOk DEO
|
||||
JMP2r
|
||||
|
||||
( assumes x/y already set )
|
||||
@draw-face-down ( -> )
|
||||
#16 .Screen/auto DEO ( ; draw 2 tiles, increment x and addr )
|
||||
;tiles #0100 ADD2 .Screen/addr DEO2
|
||||
#81 .Screen/sprite DEOk DEOk DEO
|
||||
JMP2r
|
||||
|
||||
@card-is-black ( idx* -> bool^ )
|
||||
#000c DIV2
|
||||
@q-is-black ( q* -> bool^ )
|
||||
NIP #01 SUB #fe AND JMP2r ( [q-1]&fe )
|
||||
|
||||
@card-is-red ( idx* -> bool^ )
|
||||
#000c DIV2
|
||||
@q-is-red ( q* -> bool^ )
|
||||
NIP #03 MUL #02 AND JMP2r ( [q*3]&2 )
|
||||
|
||||
@find-middle-addr ( idx* -> addr* )
|
||||
#000d DIV2k STH2k MUL2 SUB2 ( r* [q*] )
|
||||
DUP2 #000a LTH2 ?&normal
|
||||
DUP2 #000a NEQ2 ?¬-j POP2 #0200 !&face
|
||||
¬-j #000b NEQ2 ?¬-q #0100 !&face
|
||||
¬-q #0000
|
||||
&face ;tiles ADD2 #00c0 ADD2
|
||||
STH2r card-is-red ?&is-red JMP2r
|
||||
&is-red #0020 ADD2 JMP2r
|
||||
&normal POP2 POP2r ;tiles #0020 ADD2 JMP2r
|
||||
|
||||
( assumes x/y already set )
|
||||
@draw-mask-up ( idx* -> )
|
||||
#16 .Screen/auto DEO ( ; draw 2 tiles, increment x and addr )
|
||||
#00ff AND2 ( idx* ; remove rotation/flip info for now )
|
||||
DUP2 ( idx* idx* )
|
||||
#000d DIV2k STH2k MUL2 SUB2 ( idx* r* [q*] )
|
||||
#0080 MUL2 ;masks #0180 ADD2 ( idx* 128r* card+384* [q*] )
|
||||
ADD2 STH2r #0010 MUL2 ADD2 ( idx* a=card+384+128r+16q* )
|
||||
STH2k .Screen/addr DEO2 ( idx* [a*] )
|
||||
#04 .Screen/sprite DEO ( idx* [a*] ; draw top of card )
|
||||
find-middle-addr ( mid* [a*] )
|
||||
;tiles SUB2 #01 SFT2 ;masks ADD2
|
||||
.Screen/addr DEO2 ( [a*] )
|
||||
#04 .Screen/sprite DEO ( [a*] ; draw middle of card )
|
||||
STH2r DUP2 #0008 ADD2 ( a* a+8* )
|
||||
.Screen/addr DEO2 ( )
|
||||
#01 .Screen/auto DEO ( ; draw 1 tile, increment x )
|
||||
#34 .Screen/sprite DEO ( ; draw bottom left of card )
|
||||
.Screen/addr DEO2 ( )
|
||||
#34 .Screen/sprite DEO ( ; draw bottom right of card )
|
||||
JMP2r
|
||||
|
||||
( assumes x/y already set )
|
||||
@draw-face-up ( idx* -> )
|
||||
#16 .Screen/auto DEO ( ; draw 2 tiles, increment x and addr )
|
||||
#00ff AND2 ( idx* ; remove rotation/flip info for now )
|
||||
DUP2 ( idx* idx* )
|
||||
#000d DIV2k STH2k MUL2 SUB2 ( idx* r* [q*] )
|
||||
#0100 MUL2 ;tiles #0300 ADD2 ( idx* 256r* card+768* [q*] )
|
||||
ADD2 STH2r #0020 MUL2 ADD2 ( idx* a=card+768+256r+32q* )
|
||||
STH2k .Screen/addr DEO2 ( idx* [a*] )
|
||||
#81 .Screen/sprite DEO ( idx* [a*] ; draw top of card )
|
||||
find-middle-addr ( mid* [a*] )
|
||||
.Screen/addr DEO2 ( [a*] )
|
||||
#81 .Screen/sprite DEO ( [a*] ; draw middle of card )
|
||||
STH2r DUP2 #0010 ADD2 ( a* a+16* )
|
||||
.Screen/addr DEO2 ( )
|
||||
#01 .Screen/auto DEO ( ; draw 1 tile, increment x )
|
||||
#b1 .Screen/sprite DEO ( ; draw bottom left of card )
|
||||
.Screen/addr DEO2 ( )
|
||||
#b1 .Screen/sprite DEO ( ; draw bottom right of card )
|
||||
JMP2r
|
||||
|
||||
@init-rng-from-datetime ( -> )
|
||||
#00 .DateTime/dow #5180 MUL2
|
||||
#00 .DateTime/hr DEI #0e10 MUL2 ADD2
|
||||
#00 .DateTime/min DEI #003c MUL2 ADD2
|
||||
#00 .DateTime/sec DEI ADD2 ( s* )
|
||||
DUP2 .DateTime/doy DEI2 MUL2 ( s* sdoy* )
|
||||
( fall-through )
|
||||
|
||||
@init-rng ( x* y* -> )
|
||||
#0001 ROT2 OVR2 ( y* 1* x* 1* )
|
||||
ORA2 .rng/x STZ2 ( y* 1* )
|
||||
ORA2 .rng/x STZ2 JMP2r ( )
|
||||
|
||||
@random ( -> x* )
|
||||
.rng/x LDZ2 DUP2 #50 SFT2 EOR2 ( t=x^[x<<5]* )
|
||||
.rng/y LDZ2 DUP2 .rng/x STZ2 ( t* y* ; x<-y )
|
||||
DUP2 #01 SFT2 EOR2 ( t* u=y^[y>>1]* )
|
||||
SWP2 DUP2 #03 SFT2 EOR2 ( u* v=t^[t>>3]* )
|
||||
EOR2 DUP2 .rng/y STZ2 JMP2r ( u^v* ; y<-u^v )
|
||||
|
||||
( 52 cards x 4 bytes per card = 208 bytes )
|
||||
( each card has: )
|
||||
( )
|
||||
( - byte 1: flags )
|
||||
( - byte 2: card suit/value )
|
||||
( - byte 3: x position )
|
||||
( - byte 4: y position )
|
||||
( )
|
||||
( confusingly the "top" card is actually at the end )
|
||||
( this ends up being convenient for coding but is a )
|
||||
( bit confusing to think about )
|
||||
@cards $0cc &last $4 &end
|
||||
|
||||
@cursor 80c0 e0f0 f8e0 1000
|
||||
@cursox 7f3f 1f0f 071f efff
|
||||
@blank 0000 0000 0000 0000
|
||||
|
||||
( each tile is 16 bytes: a 2-bit 8x8 image )
|
||||
@tiles ~card-sprites.tal
|
||||
|
||||
( each mask tile is 8 bytes: a 1-bit 8x8 image )
|
||||
@masks ~mask-sprites.tal
|
||||
~cards.tal
|
||||
|
|
|
|||
Loading…
Reference in New Issue