From 95a36d6ca14ec0cd9fc293ef29dd306a83518bb9 Mon Sep 17 00:00:00 2001 From: d6 Date: Thu, 8 Jun 2023 16:25:40 -0400 Subject: [PATCH] factor out shared card logic --- cards.tal | 412 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ deck.tal | 363 +---------------------------------------------- 2 files changed, 413 insertions(+), 362 deletions(-) create mode 100644 cards.tal diff --git a/cards.tal b/cards.tal new file mode 100644 index 0000000..f198e8a --- /dev/null +++ b/cards.tal @@ -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 diff --git a/deck.tal b/deck.tal index 0dfe9a3..6a7e155 100644 --- a/deck.tal +++ b/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