kodiak/kodiak.tal

( kodiak.tal )

( TODO )
( * 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 ]
|30 @Audio0     [ &vect $2 &pos $2 &out $1 &dur $2 &pad $1 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $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 [ &card $1        ( card to move )
            &dst $1         ( card destination address after move )
            &time $2        ( time spent moving, 0-15 frames;  )
            &max-time $2    ( max time for this move, 16 frames )
            &x0 $2          ( starting x coord )
            &y0 $2          ( starting y coord )
            &x1 $2          ( ending x coord )
            &y1 $2 ]        ( ending y coord )
    @audio [ $1             ( is audio enabled? )
             &pos $2 ]      ( position in music )

|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

    ( set up vectors )
    ;on-mouse .Mouse/vect DEO2
    ;on-key .Controller/vect DEO2
    ;on-refresh .Screen/vect DEO2
    ;on-audio .Audio0/vect DEO2

    ( set up music )
    #0000 .audio/pos STZ2      ( ; music position )
    #0231 .Audio0/adsr DEO2     ( ; 6/15 second )
    #00a0 .Audio0/dur DEO2
    #0008 .Audio0/len DEO2      ( ; 2 bytes long )
    ;square .Audio0/addr DEO2   ( ; square wave )
    #77 .Audio0/vol DEO         ( ; about 50% volume )

    ( once testing is over should this default to off? )
    start-audio

    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 #0e initialize

    shuffle-stock
    deal-tableau
    ( TODO: clear foreground )
    draw
    auto-move
    JMP2r

@quit ( -> brk )
    #010f DEO BRK ( TODO: save game? save stats? )

@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 #0e dump-mem

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

@draw ( -> )
    draw-background
    draw-buttons
    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-button ( x* y* addr* -> )
    .Screen/addr DEO2
    .Screen/y DEO2
    .Screen/x DEO2
    #36 .Screen/auto DEO
    #8a .Screen/sprite DEO JMP2r

@restart-button-addr ( -> addr* )
    game-won ?&won ;restart-button JMP2r
    &won ;new-game-button JMP2r

@audio-button-addr ( -> addr* )
    .audio LDZ ?&on ;audio-off-button JMP2r
    &on ;audio-on-button JMP2r

@draw-buttons ( -> )
    #0008 #00b4 restart-button-addr draw-button
    #0030 #00b4 ;quit-button draw-button
    #0058 #00b4 audio-button-addr draw-button
    #0080 #00b4 ;about-button draw-button
    JMP2r

@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* )
    .foundation SUB #00 SWP #0008 SWP2 ( x=8* i* )
    #50 SFT2 #0030 ADD2 JMP2r          ( x*, y=48+32i* )

@tableau-pos ( card^ -> x* y* )
    .tableau SUB 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* )
    .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 )

( divides n by d with rounding )
@sdiv ( n* d* -> n/d* )
    STH2 DUP2 #8000 LTH2 ?&non-neg
    #ffff MUL2 STH2kr #01 SFT2 ADD2 STH2r DIV2 #ffff MUL2 JMP2r
    &non-neg STH2kr #01 SFT2 ADD2 STH2r DIV2 JMP2r

@scale ( n1* n0* -> [t*dn]/m+n0* )
    STH2k SUB2 .move/time LDZ2 MUL2           ( dn*t* [n0*] )
    .move/max-time LDZ2 sdiv STH2r ADD2 JMP2r ( [dn*t]/m+n0* )

@move-pos-xy ( -> x* y* )
    .move/x1 LDZ2 .move/x0 LDZ2 scale
    .move/y1 LDZ2 .move/y0 LDZ2 !scale

@max ( x* y* -> max* )
    GTH2k JMP SWP2 POP2 JMP2r

@dist ( a* b* -> |a-b|* )
    GTH2k JMP SWP2 SUB2 JMP2r

@move-duration ( -> duration* )
    .move/x1 LDZ2 .move/x0 LDZ2 dist ( dx* )
    .move/y1 LDZ2 .move/y0 LDZ2 dist ( dx* dy* )
    max #03 SFT2 JMP2r               ( max[dx,dy]/8* )

@start-move ( src^ dst^ -> )
    DUP card-pos-xy               ( src^ dst^ x1* y1* )
    .move/y1 STZ2 .move/x1 STZ2   ( src^ dst^ )
    .move/dst STZ                 ( src^ ; write dst )
    DUP card-pos-xy               ( src^ x0* y* )
    .move/y0 STZ2 .move/x0 STZ2   ( src^ )
    LDZk .move/card STZ           ( src^ ; write card )
    #0000 .move/time STZ2         ( )
    move-duration .move/max-time STZ2 ( )
    !remove-card                  ( )

( from column 0: )
( 00 90 00 44 00 08 00 20 )
@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 LDZ2                  ( t* )
    .move/max-time LDZ2              ( t* max-t* )
    LTH2 ?{ !end-move }              ( ; continue if t < max-t )
    .move/time LDZ2k INC ROT STZ2    ( ; time<-time+1 )
    move-pos-xy                      ( x* y* )
    .Screen/y DEO2 .Screen/x DEO2    ( ; set x,y )
    .move/card LDZ                   ( card^ )
    set-fg draw-c !set-bg            ( ; draw card )

@end-move ( -> )
    .move/card LDZ              ( card^ [src^] )
    .move/dst LDZ STZ           ( [src^] ; dst<-card )
    .move #0e initialize        ( ; zero out move )
    post-move !draw             ( ; finish move and draw )

@stop-audio ( -> )
    #00 .audio STZ #00 .Audio0/pitch DEO JMP2r

@start-audio ( -> )
    #0000 .audio/pos #01 .audio STZ STZ2 !play-audio

@play-audio ( -> )
    .audio/pos LDZ2             ( pos* )
    ;music OVR2 ADD2 LDA        ( pos* pitch^ )
    .Audio0/pitch DEO           ( pos* )
    ( TODO: compute this dynamically using `;music/end ;music INC2 SUB2` )
    INC2 #003f AND2             (  )
    .audio/pos STZ2 JMP2r       (  )

@on-audio ( -> brk )
    .audio LDZ ?{ BRK } play-audio BRK

@on-refresh ( -> brk )
    .move/card 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 ?{ POP ;sprites #0040 ADD2 !&update }
    DUP #f0 NEQ ?{ POP ;sprites #0080 ADD2 !&update }
    DUP #f8 NEQ ?{ POP ;sprites #0040 ADD2 !&update }
    DUP #00 NEQ ?{ POP ;sprites !&update }
    POP 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/card 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-button ?&skip
    maybe-select-stock ?&skip
    maybe-select-waste ?&found
    ( TODO: maybe-select-foundation )
    maybe-select-tableau ?&found
    ( not found, end drag ) .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^ )

@maybe-select-button ( -> bool^ )
    .Mouse/y DEI2
    DUP2 #00b4 LTH2 ?&no
    DUP2 #00bb GTH2 ?&no
    POP2 .Mouse/x DEI2
    DUP2 #0008 LTH2 ?&no
    DUP2 #0028 LTH2 ?&restart
    DUP2 #0030 LTH2 ?&no
    DUP2 #0050 LTH2 ?&quit
    DUP2 #0058 LTH2 ?&no
    DUP2 #0078 LTH2 ?&audio
    DUP2 #0080 LTH2 ?&no
    DUP2 #00a0 LTH2 ?&about
    &no POP2 #00 JMP2r
    &restart POP2 reset #01 JMP2r
    &quit POP2 quit #01 JMP2r
    &audio POP2 toggle-audio #01 JMP2r
    &about POP2 #010e DEO #01 JMP2r

@game-won ( -> bool^ )
    .foundation #04 OVR ADD SWP  ( lim^ start^ )
    &loop                        ( lim^ pos^ )
        LDZk #0f AND #0d NEQ ?&no ( lim^ pos^ )
        INC GTHk ?&loop          ( lim^ pos+1^ )
        POP2 #01 JMP2r           ( 1^ )
    &no POP2 #00 JMP2r           ( 0^ )

@toggle-audio ( -> )
    .audio LDZ ?&disable
    start-audio !&done
    &disable stop-audio
    &done !draw-buttons

@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^] )
    STHr start-move     (  )
(    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 JMP2r &found POP2 !draw                    ( )

@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 ( -> )
    auto-move game-won ?draw-buttons 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

@restart-button
    7f ff ff ff ff ff ff 7f 7f ce d5 cc d5 d6 ff 7f
    ff ff ff ff ff ff ff ff ff 62 df 67 fb 47 ff ff
    ff ff ff ff ff ff ff ff ff 36 6a 62 6a 6a ff ff
    fe ff ff ff ff ff ff fe fe 63 b7 77 b7 b7 ff fe

@quit-button
    7f ff ff ff ff ff ff 7f 7f ff ff ff ff ff ff 7f
    ff ff ff ff ff ff ff ff ff cd b5 b5 b5 cc f7 ff
    ff ff ff ff ff ff ff ff ff 51 5b 5b 5b 5b ff ff
    fe ff ff ff ff ff ff fe fe ff ff ff ff ff ff fe

@audio-off-button
    7f ff ff ff ff ff ff 7f 7f da aa 8a aa a8 ff 7f
    ff ff ff ff ff ff ff ff ff 9b aa aa aa 9b ff ff
    ff ff ff ff ff ff ff ff ff 3e d5 dd d5 3e ff ff
    fe ff ff ff ff ff ff fe fe c9 5b 49 5b db ff fe

@audio-on-button
    7f ff ff ff ff ff ff 7f 7f da aa 8a aa a8 ff 7f
    ff ff ff ff ff ff ff ff ff 9b aa aa aa 9b ff ff
    ff ff ff ff ff ff ff ff ff 3e d5 dd d5 3e ff ff
    fe ff ff ff ff ff ff fe fe cf 57 57 57 d7 ff fe

@about-button
    7f ff ff ff ff ff ff 7f 7f fe fd fc fd fd ff 7f
    ff ff ff ff ff ff ff ff ff ce 55 4d 55 4e ff ff
    ff ff ff ff ff ff ff ff ff d4 56 56 56 c6 ff ff
    fe ff ff ff ff ff ff fe fe 7f ff ff ff ff ff fe

@new-game-button
    7f ff ff ff ff ff ff 7f 7f 99 ab a9 ab a9 ff 7f
    ff ff ff ff ff ff ff ff ff 57 56 56 56 af ff ff
    ff ff ff ff ff ff ff ff ff 37 ea a2 aa 2a ff ff
    fe ff ff ff ff ff ff fe fe 59 ab a9 ab a9 ff fe

@square ff ff ff ff ff 00 00 00

( C  C# D  D# E  F  F# G  G# A  A# B  )
(    01 02 03 04 05 06 07 08 09 0a 0b )
( 0c 0d 0e 0f 10 11 12 13 14 15 16 17 )
( 18 19 1a 1b 1c 1d 1e 1f 20 21 22 23 )
( 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f )
( 30 31 32 33 34 35 36 37 38 39 3a 3b )
( 3c 3d 3e 3f 40 41 42 43 44 45 46 47 )
( 48 49 4a 4b 4c 4d 4e 4f 50 51 52 53 )
( 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f )
( 60 61 62 63 64 65 66 67 68 69 6a 6b )
( 6c 6d 6e 6f 70 71 72 73 74 75 76 77 )
( 78 79 7a 7b 7c 7d 7e 7f             )

@music
    18 18 1a 1b 1f 24 1a 1b 18 18 1a 1b 1f 24 1a 1b
    18 18 1a 1b 1f 24 1a 1b 18 18 1a 1b 1f 24 1a 1b
    20 20 22 24 2b 2c 22 24 20 20 22 24 2b 2c 22 24
    1f 1f 20 22 29 2b 20 22 1f 1f 20 22 29 2b 20 22