kodiak/kodiak.tal

( kodiak.tal )

( TODO )
( * restart/quit game button )
( * automatically moving safe cards to foundation? )
( * make bear react to moving cards )
( * move cards back from 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 )
    @frame $1               ( frame counter; cycles 0-255 continually )
    @move [ &src $1         ( card starting address )
            &dst $1         ( card destination address after move )
            &time $1        ( time spent moving, 0-15 frames )
            &x0 $2          ( starting x coord )
            &y0 $2          ( starting y coord )
            &x1 $2          ( ending x coord )
            &y1 $2 ]        ( ending y coord )

|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
    .auto #04 initialize
    .frame #01 initialize
    .move #0a initialize

    shuffle-stock
    deal-tableau
    draw

    ;on-mouse .Mouse/vect DEO2
    ;on-key .Controller/vect DEO2
    ;on-refresh .Screen/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
    .move #0a dump-mem

    LIT "- .Console/w DEOk DEOk DEOk DEOk DEO
    #0a .Console/w DEO JMP2r

@draw ( -> )
    draw-background
    draw-decorations
    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-bear-head ( x* y* head* -> )
    .Screen/addr DEO2                 ( x* y* ; s/addr<-head )
    .Screen/y DEO2                    ( y* x* ; s/y<- )
    .Screen/x DEO2                    ( y* x* ; s/x<- )
    #16 .Screen/auto DEO              ( y* x* ; s/auto<-0x16 )
    #80 .Screen/sprite DEOk DEO JMP2r ( y* x* ; draw 2x2 tiles )

@draw-bear ( x* y* head* -> )
    STH2 OVR2 OVR2 STH2r draw-bear-head    ( x* y* )
    ;sprites #0140 ADD2 .Screen/addr DEO2  ( x* y* ; s/addr<-body )
    #0010 ADD2 .Screen/y DEO2              ( x* ; s/y<-y+16 )
    #0008 SUB2 .Screen/x DEO2              ( ; s/x<-x-8 )
    #36 .Screen/auto DEO                   ( ; s/auto<-0x36 )
    #80 .Screen/sprite DEOk DEOk DEO JMP2r ( ; draw 4x3 tiles )

@draw-decorations ( -> )
    #00e8 #0098 ;sprites !draw-bear

@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                   ( )

@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              ( )

@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 ( col^ -> 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 ?&lt
        DUP #31 LTH #03 MUL ADD #24 SUB JMP2r
    &lt DUP #11 LTH #1d MUL ADD #09 ADD JMP2r

@stock-pos ( card^ -> x* y* )
    #00 SWP #0008 SWP2 .stock SUB ( x=8* i* )
    #03 SFT2 #fff8 SUB2 JMP2r     ( x*, y=8-i/8* )

@waste-pos ( card^ -> x* y* )
    #00 SWP .waste SUB #30 SFT2 ( 8i* )
    #001c ADD2 #0008 JMP2r      ( x=28+8i* y=8* )

@foundation-pos ( card^ -> x* y* )
    #00 SWP #0008 SWP2 .foundation SUB   ( x=8* i* )
    #50 SFT2 #0020 ADD2 #0008 SWP2 JMP2r ( x*, y=48+32i* )

@tableau-pos ( card^ -> x* y* )
    STHk #13 DIV STHk column-x                ( x* [card^ col^] )
    #00 STH2r #13 MUL SUB #30 SFT2            ( x* 8pos* )
    #0024 ADD2 JMP2r                          ( x* y=36+8pos* )

@card-pos-xy ( card^ -> x* y* )
    #00 SWP .stock
    #33 ADD GTHk ?{ POP !stock-pos }
    #18 ADD GTHk ?{ POP !waste-pos }
    #04 ADD GTHk ?{ POP !foundation-pos }
    #85 ADD GTHk ?{ POP !tableau-pos }
    POP2 #010e DEO #0000 #0000 JMP2r ( ; error, x=0, y=0 )

( we expect 0 <= time <= 16 )
@move-pos-xy ( -> x* y* )
    #00 .move/time LDZ                     ( t* )
    .move/x1 LDZ2 .move/x0 LDZ2 STH2k SUB2 ( dx* [x0*] )
    OVR2 MUL2 #04 SFT2 STH2r ADD2 SWP2     ( x=x0+[dx*t/16]* t* )
    .move/y1 LDZ2 .move/y0 LDZ2 STH2k SUB2 ( x* t* dy* [y0*] )
    MUL2 #04 SFT2 STH2r ADD2 JMP2r         ( x* y=y0+[dy*t/16]* )

@start-move ( src^ dst^ -> )
    DUP card-pos-xy                           ( src^ dst^ x1* y1* )
    .move/y1 STZ2 .move/x1 STZ2 .move/dst STZ ( src^ )
    DUP card-pos-xy                           ( src^ x0* y* )
    .move/y0 STZ2 .move/x0 STZ2 .move/src STZ ( )
    #00 .move/time STZ !update-move           ( )

@update-move ( -> )
    move-pos-xy                      ( x* y* )
    .Screen/y DEO2 .Screen/x DEO2    ( ; set x,y )
    ;blank .Screen/addr DEO2         ( ; use blank tile )
    #12 .Screen/auto DEO             ( ; draw 2, inc x )
    #41 .Screen/sprite DEOk DEOk DEO ( ; erase three rows )
    .move/time LDZ #0f GTH ?end-move ( ; are we done? )
    .move/time LDZk INC SWP STZ      ( ; time<-time+1 )
    move-pos-xy                      ( x* y* )
    .Screen/y DEO2 .Screen/x DEO2    ( ; set x,y )
    .move/src LDZ LDZ !draw-c        ( ; draw card )

@end-move ( -> )
    .move/src LDZ STH LDZ       ( card^ [src^] )
    .move/dst LDZ STZ           ( [src^] ; dst<-card )
    STHr remove-card            ( ; remove card, flip, etc. )
    .move #0b initialize        ( ; zero out move )
    post-move draw              ( ; finish move and draw )
    !auto-move                  ( ; start another auto move maybe? )

@on-refresh ( -> brk )
    .move/src LDZ #00 EQU ?{ update-move }
    on-refresh-bear             ( ; possibly refresh bear )
    .frame LDZk INC SWP STZ     ( ; increment frame counter )
    BRK

@on-refresh-bear ( -> )
    .frame LDZ
    DUP #e8 NEQ ?{ ;sprites #0040 ADD2 !&update }
    DUP #f0 NEQ ?{ ;sprites #0080 ADD2 !&update }
    DUP #f8 NEQ ?{ ;sprites #0040 ADD2 !&update }
    DUP #00 NEQ ?{ ;sprites !&update }
    JMP2r
    &update .Screen/addr DEO2   ( ; s/addr<-addr )
    #0098 .Screen/y DEO2        ( ; s/x<-0x98 )
    #00e8 .Screen/x DEO2        ( ; s/y<-0xe8 )
    #16 .Screen/auto DEO        ( ; draw 2 tiles, inc addr and y )
    #80 .Screen/sprite DEO      ( ; draw it! )
    JMP2r

@on-mouse ( -> brk )
    on-move
    .move/src LDZ ?&skip
    on-click-down
    on-click-up
    &skip .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
    ( TODO: maybe-select-foundation )
    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 )
        post-move #01 JMP2r           ( 1^ )

@try-release-tableau ( -> bool^ )
    #0700 &loop
        DUP try-release-column ?&success
        INC GTHk ?&loop POP2 #00 JMP2r
    &success post-move #01 JMP2r

@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      ( [col^] )
    POPr #00 JMP2r               ( 0^ )
    &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^ )

@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 post-move !draw                            ( x; 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 )

@post-move ( -> )
    JMP2r

@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

@sprites ~sprites.tal