kodiak/kodiak.tal

( deck.tal )

|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 hearts )
( - #3d king of spades )
( - #6c queen of hearts, face down )
( - #93 three of diamonds, held )

|0000

    @stock $34 ( draw pile - 52 bytes )
    @waste $18 ( face up pile - 24 bytes )
    @foundation $4 ( one per suit - 4 bytes, 4x1 )
    @tableau $85 ( the main board - 133 bytes, 7x19 )

    @prev-button $1
    @prev-mouse-state $1
    @prev-mouse-x $2
    @prev-mouse-y $2
    @card-is-held $1

|0100
    #2d8b .System/r DEO2
    #2d18 .System/g DEO2
    #2d14 .System/b DEO2

    #0100 .Screen/w DEO2
    #00c0 .Screen/h DEO2

    init-rng-from-datetime
    init-stock init-waste init-foundation
    shuffle-stock deal-tableau
    draw-background
    draw-stock draw-waste draw-foundation draw-tableau

    ;on-mouse .Mouse/vect DEO2
(    ;on-key .Controller/vect DEO2 )
    BRK

@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

@init-waste ( -> )
    #00 LITr -waste LITr 18 OVRr ADDr SWPr
    &loop DUP STHkr STZ INCr GTHkr STHr ?&loop
    POP POP2r JMP2r

@init-foundation
    #00 .foundation
    STZk INC STZk INC STZk INC STZk POP2
    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 ( -> )
    #33 LIT2r -tableau 00
    &loop STH2kr deal-column
          LIT2r 1301 ADD2r
          STHkr #07 LTH ?&loop
    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 )
    #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 )
    #01 SUB JMP2r                ( s-1^ )

@swap-c ( src^ dst^ -> )
    LDZk STH                    ( src^ dst^ [d^] )
    OVR LDZ                     ( src^ dst^ s^ [d^] )
    SWP STZ                     ( src^ [d^] ; dst<-s )
    STHr SWP                    ( d^ src^ )
    STZ JMP2r                   ( ; src<-d )

@draw-stock ( -> )
    #0008 ,&y STR2                          ( ; y0<-8 )
    .stock #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 POP2 POPr JMP2r                   ( )

@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<- )
        draw-c                        ( lim^ zp^ ; draw c )
    ,&x LDR2 #0008 ADD2 ,&x STR2      ( lim^ zp^ ; x<-x+8 )
    INC GTHk ?&loop                   ( lim^ zp+1^ )
    &done 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 JMP2r

@draw-column ( idx^ -> )
    #00 OVR #0018 MUL2 #0030 ADD2 ,&x STR2 ( idx^ ; x<-32+24*idx )
    #0024 ,&y STR2                         ( idx^ ; y<-32 )
    #13 MUL .tableau ADD                   ( pos=t+idx*19^ )
    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^ ; s/x<-x )
            LIT2 [ &y $2 ] .Screen/y DEO2  ( lim^ pos^ ; s/y<-y )
            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-mask-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 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

@on-mouse ( -> brk )
    on-move
    on-click-down
(    on-click-up )
    .Mouse/state DEI .prev-mouse-state STZ
    BRK

@mouse-dx ( -> dx* ) .Mouse/x DEI2 .prev-mouse-x LDZ2 SUB2 JMP2r
@mouse-dy ( -> dy* ) .Mouse/y DEI2 .prev-mouse-y LDZ2 SUB2 JMP2r

@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

@on-move ( -> )
    .Mouse/x DEI2 .prev-mouse-x LDZ2 NEQ2 ?&redraw
    .Mouse/y DEI2 .prev-mouse-y LDZ2 NEQ2 ?&redraw
    JMP2r
    &redraw ( #00 .Screen/auto DEO )
    !draw-mouse
(    clear-prev-mouse draw-curr-mouse JMP2r )

@draw-mouse ( -> )
    #00 .Screen/auto DEO
    clear-prev-mouse !draw-curr-mouse

@clear-prev-mouse ( -> )
    .prev-mouse-x LDZ2 .Screen/x DEO2
    .prev-mouse-y LDZ2 .Screen/y DEO2
    ;blank .Screen/addr 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
    ;cursor .Screen/addr DEO2
    #43 .Screen/sprite DEO JMP2r

@on-click-down ( -> )
    .Mouse/state DEI             ( state^ )
    .prev-mouse-state LDZ #ff EOR AND ( down^ )
    #01 AND ?{ JMP2r } !maybe-select-card

@maybe-select-card ( -> )
    .Mouse/x DEI2 .Mouse/y DEI2
    maybe-select-stock ?&done
    &done JMP2r

@top-stock ( -> zp^ )
    .stock #34 OVR ADD SWP
    &loop LDZk ?&ok !&done &ok INC GTHk ?&loop &done NIP #01 SUB JMP2r

@maybe-select-stock ( x* y* -> bool^ )
    top-stock STH                       ( [z^] )
    OVR2 #0008 LTH2 ?&no1               ( x* y* [z^] ; x<8 )
    SWP2 #0017 GTH2 ?&no2               ( y* [z^] ; x>=16 )
    #00 STHkr .stock SUB #03 SFT2       ( y* d* [z^] )
    SWP2 STH2                           ( d* [z^ y*] )
    #0020                               ( d* max=32-d* [z^ y*] )
    #0008 ROT2 SUB2                     ( max* min=8-d* [z^ y*] )
    STH2kr GTH2 ?&no3                   ( max* [z^ y*] )
    STH2r LTH2 ?&no4                    ( [z^] )
    STHr LDZk #80 EOR SWP STZ           ( ; z<-z^0x80 )
    draw-stock #01 JMP2r                ( 1^ )
    &no1 POP2 &no2 POP2 POPr #00 JMP2r  ( 0^ )
    &no3 POP2 POP2r &no4 POPr #00 JMP2r ( 0^ )

@on-click-up ( -> )
    .Mouse/state DEI #ff EOR    ( not-state^ )
    .prev-mouse-state LDZ AND        ( up^ )
    #01 AND ?{ JMP2r } JMP2r ( TODO: anything to do here? )

( @on-key ( -> brk )
    on-press on-release
    .Controller/button DEI .prev-button STZ
    BRK )

( @on-release ( -> )
    .Controller/button DEI #ff EOR ( not-button^ )
    .prev-button LDZ AND           ( release^ )
    DUP #00 EQU ?&skip
    DUP #08 AND ?&start
    &skip POP JMP2r
    &start POP !draw-cards )

( @on-press ( -> )
    .Controller/button DEI         ( button^ )
    .prev-button LDZ #ff EOR AND   ( press^ )
    DUP #00 EQU ?&skip
    DUP #01 AND ?&ctrl
    DUP #02 AND ?&alt
    DUP #04 AND ?&select
    DUP #08 AND ?&start
    &skip POP JMP2r
    &ctrl POP !try-to-flip
    &alt POP !flip-all-cards
    &select POP !randomize
    &start POP !reset )

~cards.tal