kodiak/cards.tal

( 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 )
(   ... )
(   0c: king of spades )
(   0d: ace of hearts )
(   0e: 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*] )
    &copy                             ( end* pos* [count* dst*] )
        LDA2k STH2kr STA2             ( end* pos* [count* dst*] ; pos<-dst )
        INC2 INC2 INC2r INC2r         ( end* pos+2* [count* dst+2*] )
        GTH2k ?&copy                  ( 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 ?&notfound      ( x* y* [limit* pos-4*] )
        !&loop                      ( x* y* [limit* pos-4*] )
    &notfound 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           ( ) )

@set-fg ( -> ) #40 ,set-sprite/layer STR JMP2r
@set-bg ( -> ) #00 ,set-sprite/layer STR JMP2r

@set-sprite ( byte^ -> )
    LIT [ &layer 00 ] ORA .Screen/sprite DEO JMP2r

@set-sprite-3x ( byte^ -> )
    ,set-sprite/layer LDR ORA .Screen/sprite DEOk DEOk DEO 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-spot-down ( -> )
    #16 .Screen/auto DEO        ( ; draw 2 tiles, increment x and addr )
(    ;masks #0080 ADD2 .Screen/addr DEO2 )
(    #02 set-sprite-3x )
    ;masks #0100 ADD2 .Screen/addr DEO2
    #8d set-sprite-3x
    JMP2r

( 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 set-sprite-3x )
    ;masks #0100 ADD2 .Screen/addr DEO2
    #86 set-sprite-3x ( TODO fixme )
    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 set-sprite-3x
    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 ?&not-j POP2 #0200 !&face
    &not-j #000b NEQ2 ?&not-q #0100 !&face
    &not-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* ) )
    #0100 MUL2 ;masks #0300 ADD2 ( idx* 128r* card+384* [q*] )
    ADD2 STH2r #0020 MUL2 ADD2  ( idx* a=card+384+128r+16q* )
    STH2k .Screen/addr DEO2     ( idx* [a*] )
(    #04 set-sprite      ( idx* [a*] ; draw top of card ) )
    #86 set-sprite      ( idx* [a*] ; draw top of card )
    find-middle-addr            ( mid* [a*] )
(    ;tiles SUB2 #01 SFT2 ;masks ADD2 )
    ;tiles SUB2 ;masks ADD2
    .Screen/addr DEO2           ( [a*] )
(    #04 set-sprite      ( [a*] ; draw middle of card ) )
    #86 set-sprite      ( [a*] ; draw middle of card )
(    STH2r DUP2 #0008 ADD2       ( a* a+8* ) )
    STH2r DUP2 #0010 ADD2       ( a* a+8* )

    ( TODO: does flipping also flip move direction now? )
    SWP2 #0008 .Screen/x DEI2 ADD2 .Screen/x DEO2
    .Screen/addr DEO2           ( )
    #01 .Screen/auto DEO        ( ; draw 1 tile, increment x )
(    #34 set-sprite      ( ; draw bottom left of card ) )
    #b6 set-sprite      ( ; draw bottom left of card )
    .Screen/addr DEO2           ( )
(    #34 set-sprite      ( ; draw bottom right of card ) )
    #b6 set-sprite      ( ; 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 set-sprite      ( idx* [a*] ; draw top of card )
    find-middle-addr            ( mid* [a*] )
    .Screen/addr DEO2           ( [a*] )
    #81 set-sprite      ( [a*] ; draw middle of card )
    STH2r DUP2 #0010 ADD2       ( a* a+16* )

    ( TODO: does flipping also flip move direction now? )
    SWP2 #0008 .Screen/x DEI2 ADD2 .Screen/x DEO2
    .Screen/addr DEO2           ( )
    #01 .Screen/auto DEO        ( ; draw 1 tile, increment x )
    #b1 set-sprite      ( ; draw bottom left of card )
    .Screen/addr DEO2           ( )
    #b1 set-sprite      ( ; 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 )
@rng-x $2
@rng-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 )

( each mask tile is 16 bytes: a 2-bit 8x8 image )
@masks ~mask2.tal