shanghai.tal

|00 @System     &vector $2 &wst      $1 &rst    $1 &eaddr  $2 &ecode  $1 &pad     $1 &r       $2 &g      $2 &b     $2 &debug  $1 &halt $1
|10 @Console    &vector $2 &read     $1 &pad    $5 &write  $1 &error  $1
|20 @Screen     &vector $2 &width    $2 &height $2 &auto   $1 &pad    $1 &x       $2 &y       $2 &addr   $2 &pixel $1 &sprite $1
|30 @Audio0     &vector $2 &position $2 &output $1 &pad    $3 &adsr   $2 &length  $2 &addr    $2 &volume $1 &pitch $1
|40 @Audio1     &vector $2 &position $2 &output $1 &pad    $3 &adsr   $2 &length  $2 &addr    $2 &volume $1 &pitch $1
|50 @Audio2     &vector $2 &position $2 &output $1 &pad    $3 &adsr   $2 &length  $2 &addr    $2 &volume $1 &pitch $1
|60 @Audio3     &vector $2 &position $2 &output $1 &pad    $3 &adsr   $2 &length  $2 &addr    $2 &volume $1 &pitch $1
|80 @Controller &vector $2 &button   $1 &key    $1 &func   $1
|90 @Mouse      &vector $2 &x        $2 &y      $2 &state  $1 &pad    $3 &scrollx $2 &scrolly $2
|a0 @File       &vector $2 &success  $2 &stat   $2 &delete $1 &append $1 &name    $2 &length  $2 &read   $2 &write $2
|b0 @File1      &vector $2 &success  $2 &stat   $2 &delete $1 &append $1 &name    $2 &length  $2 &read   $2 &write $2
|c0 @DateTime   &year   $2 &month    $1 &day    $1 &hour   $1 &minute $1 &second  $1 &dotw    $1 &doty   $2 &isdst $1

%Ext { #00 SWP }
%Mod { DIVk MUL SUB }
%Mod2 { DIV2k MUL2 SUB2 }
%Dbg { #01 .System/debug DEO }
%Gsx { .Screen/x DEI2 }
%Gsy { .Screen/y DEI2 }
%Ssx { .Screen/x DEO2 }
%Ssy { .Screen/y DEO2 }
%Ssa { .Screen/addr DEO2 }
%Spr { .Screen/sprite DEO }
%Sprr { .Screen/sprite DEOk DEO }
%Sprrr { .Screen/sprite DEOk DEOk DEO }
%Aut0 { #00 .Screen/auto DEO }
%Aut0ay { #06 .Screen/auto DEO }
%Aut1ay { #16 .Screen/auto DEO }
%Aut2ay { #26 .Screen/auto DEO }
%Aut1y { #12 .Screen/auto DEO }
%Ovrsb { ROTk NIP SWP } ( ss b -- ss b ss )
%Swpsb { ROT ROT } ( ss b -- b ss )

%Bd { ;board ADD2 LDA }

(
    !!! All numbers here are in hex. !!!

    Tiles are 10x18 pixels.
    The board is 20x10x5, accessed as board[z<<9 | y<<5 | x].

    The tiles are:

          01 02 03 04 05 06 07 08 09  dots
          0a 0b 0c 0d 0e 0f 10 11 12  bamboo
          13 14 15 16 17 18 19 1a 1b  chars
          1c 1d 1e 1f 20 21 22        honors
          23 24 25 26                 flowers
          27 28 29 2a                 seasons

    Tiles 01-22 match up with themselves: there's four of each.
    Tiles 23-26 and 27-2a match up freely with each other: there's one of each.
    Trick: When comparing tile IDs, if x>22 { x=x+1|3 }.

    Sprite address: @s-blank + 60*x.

    Tile x,y,z is rendered at [8*x+10, b*y-4*z+10]

    So mouse mx,my is tile  [ [mx-10]>>3, [[my-10+4*z]/b], z ]  for z=4..0
    ...also checking one tile left and one or two tiles up
)


( variables )

|0000
@i $2
@j $2
@mx $2
@my $2
@hovered $2 &old $2
@picked $2 &old $2

@pointer &x $2 &y $2

( program )

|0100 ( -> )
    #03ed .System/r DEO2
    #70e7 .System/g DEO2
    #6be7 .System/b DEO2
    ;load-theme JSR2
    #0110 .Screen/width DEO2
    #00e0 .Screen/height DEO2

    #1111 .Audio2/adsr DEO2
    #0100 .Audio2/length DEO2
    ;wave-sus2 .Audio2/addr DEO2
    #00 .Audio2/volume DEO
    #01 .Audio2/pitch DEO

    ;on-mouse .Mouse/vector DEO2
    ;prng-init JSR2
    ;new-game JSR2
    ;make-turtle JSR2
    ;example-text #0004 #0000 ;draw-text JSR2
    ;redraw-board JSR2
BRK

@example-text
    "matches: 20 00

@draw-text ( ptr* x* y* -- )
    Ssy Ssx Aut0ay
    &next
    LDAk ( ptr* ch )
    DUP ,&ok JCN
    POP POP2 JMP2r
    &ok ( ptr* ch )
    ;putchar JSR2
    INC2
    Gsx #0008 ADD2 Ssx
    ,&next JMP

@draw-number ( num x* y* -- )
    Ssy Ssx Aut0ay
    DUP #00 EQU #02 ADD ;text-color STA

    DUP #64 LTH ,&no-hundreds JCN
    DUP #64 DIV DUP #30 ADD ;putchar JSR2 #64 MUL SUB
    Gsx #0008 ADD2 Ssx
    &no-hundreds

    DUP #0a LTH ,&no-tens JCN
    DUP #0a DIV DUP #30 ADD ;putchar JSR2 #0a MUL SUB
    Gsx #0008 ADD2 Ssx
    &no-tens
    #30 ADD ;putchar JSR2

    Gsx #0008 ADD2 Ssx
    #20 ;putchar JSR2
JMP2r

@putchar ( ch -- )
    Ext #40 SFT2 ;font ADD2 Ssa
    LIT @text-color 02 Sprr
    Gsy #0010 SUB2 Ssy
JMP2r

@s1x1_mouse
    80c0 e0f0 c020 0000
@on-mouse
    ;s1x1_mouse Ssa Aut0
    .pointer/x LDZ2 Ssx
    .pointer/y LDZ2 Ssy
    #40 Spr
    .Mouse/x DEI2 DUP2 .pointer/x STZ2 Ssx
    .Mouse/y DEI2 DUP2 .pointer/y STZ2 Ssy
    #42 Spr

    .hovered LDZ2 .hovered/old STZ2
    .picked LDZ2 .picked/old STZ2

    .Mouse/x DEI2 .Mouse/y DEI2
    ;mouse-to-tile JSR2
    DUP2 ;is-free JSR2 ,&free JCN
    POP2
    #0000 .hovered STZ2
    ,&highlight JMP
&free
    .hovered STZ2
&highlight
    .Mouse/state DEI #00 EQU ,&not-pressed JCN
    .hovered LDZ2 .picked STZ2
    ;try-match JSR2

    &not-pressed

    .hovered LDZ2 .hovered/old LDZ2 EQU2
    .hovered LDZ2 .picked/old LDZ2 EQU2 ORA
    ,&no-on-hovered JCN
    .hovered LDZ2 #83 ;draw-tile-cover JSR2
    &no-on-hovered

    .picked LDZ2 .hovered/old LDZ2 EQU2
    .picked LDZ2 .picked/old LDZ2 EQU2 ORA
    ,&no-on-picked JCN
    .picked LDZ2 #83 ;draw-tile-cover JSR2
    &no-on-picked

    .hovered/old LDZ2 .hovered LDZ2 EQU2
    .hovered/old LDZ2 .picked LDZ2 EQU2 ORA
    ,&no-off-hovered JCN
    .hovered/old LDZ2 #81 ;draw-tile-cover JSR2
    &no-off-hovered

    .picked/old LDZ2 .hovered LDZ2 EQU2
    .picked/old LDZ2 .picked LDZ2 EQU2 ORA
    ,&no-off-picked JCN
    .picked/old LDZ2 #81 ;draw-tile-cover JSR2
    &no-off-picked

BRK

@try-match
    .picked LDZ2 .picked/old LDZ2 NEQ2 ,&ok JCN JMP2r &ok

    .picked LDZ2 ;board ADD2 LDA        DUP #23 LTH ,&h1 JCN INC #03 ORA &h1
    .picked/old LDZ2 ;board ADD2 LDA    DUP #23 LTH ,&h2 JCN INC #03 ORA &h2
    EQU ,&match JCN JMP2r &match

    #00 .picked LDZ2 ;board ADD2 STA
    #00 .picked/old LDZ2 ;board ADD2 STA
    .picked LDZ2 ;natural-draw-tile JSR2
    .picked/old LDZ2 ;natural-draw-tile JSR2

    #0000 .hovered STZ2
    #0000 .hovered/old STZ2
    #0000 .picked STZ2
    #0000 .picked/old STZ2

    #ff1f .Audio2/adsr DEO2
    #0100 .Audio2/length DEO2
    ;wave-sus2 .Audio2/addr DEO2
    #11 .Audio2/volume DEO
    ;prng JSR2 #0005 Mod2 NIP #07 MUL #03 DIV #10 ADD .Audio2/pitch DEO

    ( Play a sound: )
    #0105 .Audio0/adsr DEO2
    #0100 .Audio0/length DEO2
    ;wave-note .Audio0/addr DEO2
    #a6 .Audio0/volume DEO
    ;prng JSR2 #0005 Mod2 NIP #07 MUL #03 DIV #40 ADD .Audio0/pitch DEO

    #2105 .Audio1/adsr DEO2
    #0100 .Audio1/length DEO2
    ;wave-note .Audio1/addr DEO2
    #6a .Audio1/volume DEO
    ;prng JSR2 #0005 Mod2 NIP #07 MUL #03 DIV #4c ADD .Audio1/pitch DEO

    ;redraw-board JSR2
JMP2r

@match-array
    $30

@redraw-board
    ;turtle
    LIT2r 0000

    #0030
&next-clear
    #0001 SUB2
    DUP2 ;match-array ADD2 #00 ROT ROT STA
    ORAk ,&next-clear JCN
    POP2

&next-turtle-entry
    LDA2k ( turtle nxyz / i )
&next-tile
    ORAk ,&yes JCN  POP2 POP2 POP2r ,&draw-counter JMP  &yes
    DUP2 #0fff AND2 ( turtle nxyz xyz )
    DUP2 Bd #00 EQU ,&nah JCN
    DUP2 ;is-free JSR2 ( turtle nxyz xyz isfree )
    #00 EQU ,&not-free JCN
    ( turtle nxyz xyz )
    DUP2 Bd DUP #23 LTH ,&h1 JCN INC #03 ORA &h1
    Ext ;match-array ADD2
    LDAk INC ROT ROT STA

    &not-free
    #81 ;draw-tile JSR2 ( turtle nxyz ) ,&whatevs JMP &nah POP2 &whatevs
    #0ffe SUB2 ( turtle n-1,x+2,y,z )
    INC2r ( i++ )
    DUP2 #0fff GTH2 ,&next-tile JCN
    POP2
    INC2 INC2
    ,&next-turtle-entry JMP
&draw-counter
    #00
    #0030
&next-count
    #0001 SUB2
    DUP2 ;match-array ADD2 LDA #01 GTH ( total idx* ismatch )
    STH ROT STHr ADD ( idx* total+match )
    ROT ROT
    ORAk ,&next-count JCN
    POP2
    #0048 #0000 ;draw-number JSR2
JMP2r

@new-game
    ( Play a new-game-y sound: )
    #2209 .Audio0/adsr DEO2 #0100 .Audio0/length DEO2 ;wave-sus2 .Audio0/addr DEO2 #55 .Audio0/volume DEO #18 .Audio0/pitch DEO
    #020c .Audio1/adsr DEO2 #0100 .Audio1/length DEO2 ;wave-note .Audio1/addr DEO2 #84 .Audio1/volume DEO #30 .Audio1/pitch DEO
    #420c .Audio2/adsr DEO2 #0100 .Audio2/length DEO2 ;wave-note .Audio2/addr DEO2 #66 .Audio2/volume DEO #37 .Audio2/pitch DEO
    #820c .Audio3/adsr DEO2 #0100 .Audio3/length DEO2 ;wave-note .Audio3/addr DEO2 #48 .Audio3/volume DEO #3e .Audio3/pitch DEO

    ( Deal tiles into an array: )
    ;deal
    #01
&next-tile
    ( ptr* tile )
    DUP
    #23 LTH #03 MUL INC ( ptr* tile count )
&next-copy
    STH ROTk ROT STA STHr ( ptr* tile count )
    SWP2 INC2 SWP2 ( ptr* tile count )
    #01 SUB
    DUP ,&next-copy JCN POP
    INC
    DUP #2b LTH ,&next-tile JCN POP
    ;deal #0090 ;shuffle JSR2
JMP2r

@shuffle ( arr* len* -- ) ( Fisher-Yates shuffle )
    SWP2 STH2 ( len* )
&next-swap
    ;prng JSR2 OVR2 Mod2 ( i+1* j* )
    SWP2 #0001 SUB2 ( j* i* )
    .i STZ2 .j STZ2 ( )
    STH2rk .i LDZ2 ADD2 LDA ( arr[i] )
    STH2rk .j LDZ2 ADD2 LDA ( arr[i] arr[j] )
    STH2rk .i LDZ2 ADD2 STA ( arr[i] )
    STH2rk .j LDZ2 ADD2 STA ( )
    .i LDZ2 ( i* )
    ORAk ,&next-swap JCN
    POP2 POP2r
JMP2r

@make-turtle
    ;turtle
    LIT2r 0000
&next-turtle-entry
    LDA2k ( turtle nxyz / i )
&next-tile
    ORAk ,&yes JCN  POP2 POP2 POP2r JMP2r  &yes
    DUP2 #0fff AND2 ( turtle nxyz xyz )
    STH2rk ;deal ADD2 LDA ( turtle nxyz xyz t )
    Ovrsb ;board ADD2 STA ( turtle nxyz xyz )
    ( #81 ;draw-tile JSR2 ) POP2 ( turtle nxyz )
    #0ffe SUB2 ( turtle n-1,x+2,y,z )
    INC2r ( i++ )
    DUP2 #0fff GTH2 ,&next-tile JCN
    POP2
    INC2 INC2
    ,&next-turtle-entry JMP
@turtle
    ( Array of xyz|n<<12 )
    c002 8046 a084 c0c2 10e0 20fa c102 a144 8186 c1c2
    6248 6288 62c8 6308 6348 6388
    448a 44ca 450a 454a
    26cc 270c
    18ed
    0000 ( end )

@deal ( Filled and shuffled to generate the board )
    $90

@board ( board[z<<9 | y<<5 | x] = tile )
    $0a00

@natural-draw-tile ( xyz* -- )
    DUP2 .hovered LDZ2 EQU2
    Ovrsb .picked LDZ2 EQU2 ORA
    DUP ADD INC #80 ORA
@draw-tile ( xyz* col -- )
    ROT ROT ( col xyz* )
    STH2
    STH2rk ;board ADD2 LDA ( col tile -- )
    ( DUP ,&nonzero JCN  POP2r POP2 JMP2r  &nonzero )
    Ext #0060 MUL2 ;s-blank ADD2 Ssa ( col -- )
    STH2rk #001f AND2 #30 SFT2 #0010 ADD2 Ssx ( col -- )
    STH2rk #05 SFT2 #000f AND2 #000b MUL2 #0010 ADD2
    STH2rk #29 SFT2 SUB2 Ssy
    ( col -- )
    Aut1ay Sprrr ( -- )
    POP2r
JMP2r

@draw-tile-cover ( xyz* col -- )
    ( Early exit if zero )
    STH ORAk ,&non-zero JCN  POPr POP2 JMP2r  &non-zero STHr

    ROTk ROT ROT ;draw-tile JSR2
    POP ( xyz* )
    DUP2
    ( Redraw the whole column in front of xyz: )
    &next-y
    #0020 ADD2 ( y+=1 )
    #01ff AND2 ( z=0 )
    &next-z
    DUP2 ;board ADD2 LDA #00 EQU ,&nah JCN
    DUP2 ;natural-draw-tile JSR2 &nah
    #0200 ADD2 ( z++ )
    DUP2 #0a00 LTH2 ,&next-z JCN
    DUP2 #0be0 LTH2 ,&next-y JCN
    POP2

    #08ed EQU2 ,&is-top JCN
    #08ed Bd #00 EQU ,&is-top JCN
    #08ed ;natural-draw-tile JSR2
    &is-top
JMP2r

@is-free ( xyz* -- bool )
    ORAk ,&non-zero JCN POP2 #00 JMP2r &non-zero
    STH2

        STH2rk #0022 SUB2 Bd #00 GTH STH2rk #01ff AND2 #001f GTH2 AND
        STH2rk #0002 SUB2 Bd ORA
        STH2rk #001e ADD2 Bd ORA #00 EQU

        STH2rk #001e SUB2 Bd #00 GTH STH2rk #01ff AND2 #001f GTH2 AND
        STH2rk #0002 ADD2 Bd ORA
        STH2rk #0022 ADD2 Bd ORA #00 EQU
    ORA

            STH2rk #07ff GTH2

            STH2rk #0200 ADD2 Bd #00 EQU
            STH2r  #0600 LTH2 #08ed Bd #00 EQU ORA
        AND
    ORA
    AND
JMP2r

@mouse-to-tile ( mx* my* -- xyz* )
(
    Tile x,y,z is rendered at [8*x+10, b*y-4*z+10]

    So mouse mx,my is tile  [ [mx-10]>>3, [[my-10+4*z]/b], z ]  for z=4..0
    ...also checking one tile left and one or two tiles up
)
    .my STZ2 .mx STZ2

    #0004
    &next-z
    #0000
    &next-ty
    #0000
    &next-tx

    ( z* ty* tx* )
    ROT2k
    ( z* ty* tx* ty* tx* z* )
    STH2k ( save z* )
    .my LDZ2 #0010 SUB2 SWP2 #20 SFT2 ADD2
    ( z* ty* tx* ty* tx* my-10+4z )
    #000b DIV2 ROT2 SUB2
    ( z* ty* tx* tx* my-10+4z/b-ty )
    DUP2 #0010 LTH2 ,&ok-y JCN
    POP2 POP2r ,&no-tile JMP
    &ok-y

    #50 SFT2
    .mx LDZ2 #0010 SUB2 #03 SFT2 ROT2 SUB2
    ( z* ty* tx* my-10+4z/b-ty<<5 mx-10>>3-tx )
    ORA2 STH2r #90 SFT2 ( restore and use z* )
    ORA2
    ( z* ty* tx* i* )
    DUP2 ;board ADD2 LDA
    ( z* ty* tx* i* tile )
    #00 EQU ,&no-tile JCN

    ( z* ty* tx* i* )
    DUP2 #0800 LTH2 ( z* ty* tx* i* i<800 )
    Ovrsb #0200 ADD2 ;board ADD2 LDA #00 GTH AND ( z* ty* tz* i* blocked )
    ,&no-tile JCN

    ( return i*: )
    NIP2 NIP2 NIP2 JMP2r

    &no-tile
    POP2
    ( z* ty* tx* )

    INC2
    DUP2 #0002 NEQ2 ;&next-tx JCN2
    POP2
    INC2
    DUP2 #0002 NEQ2 ;&next-ty JCN2
    POP2
    #0001 SUB2
    DUP2 INC2 ORA ;&next-z JCN2
    POP2

    ( no tile found )
    #0000
JMP2r

@prng-init ( -- )

    ( seed )
    #00 .DateTime/second DEI
    #00 .DateTime/minute DEI #60 SFT2 EOR2
    #00 .DateTime/hour   DEI #c0 SFT2 EOR2 ,prng/x STR2
    #00 .DateTime/hour   DEI #04 SFT2
    #00 .DateTime/day    DEI #10 SFT2 EOR2
    #00 .DateTime/month  DEI #60 SFT2 EOR2
        .DateTime/year  DEI2 #a0 SFT2 EOR2 ,prng/y STR2

JMP2r

@prng ( -- number* )

    LIT2 &x $2
    DUP2 #50 SFT2 EOR2
    DUP2 #03 SFT2 EOR2
    LIT2 &y $2 DUP2 ,&x STR2
    DUP2 #01 SFT2 EOR2 EOR2
    ,&y STR2k POP

JMP2r

( theme )

@load-theme ( -- )

	;&path .File/name DEO2
	#0002 .File/length DEO2
	;&r .File/read DEO2
	;&g .File/read DEO2
	;&b .File/read DEO2
	.File/success DEI2 ORA #01 JCN JMP2r
	LIT2 &r $2 .System/r DEO2
	LIT2 &g $2 .System/g DEO2
	LIT2 &b $2 .System/b DEO2

JMP2r
	&path ".theme $1

~tiles.tal
~sus2.tal
~note.tal
~font.tal