#!/usr/bin/tclsh
# bigdog.tcl - "BIG DOG": a winged bulldog flying through pipes, drawn
# straight into the brintOS wasm32 DRM framebuffer at /dev/fb0.
#
# Tcl rather than Python because python3 is 78 MB and the wasm32 loader
# refuses it ("File too large"); tclsh is 13 MB and loads fine.
#
# Scanout is a8b8g8r8 -- memory order R,G,B,A. A row is `stride` bytes but
# only the first w*4 are visible, so each row is written with its own seek
# instead of padding out to the full carve width.

# The playfield is drawn into the TOP-LEFT of whatever mode the display is
# in -- the browser sizes the canvas, and rendering 1920x1080 from a script
# would be hopeless. Only these rows and columns are touched.
set W      [expr {[llength $argv] > 0 ? [lindex $argv 0] : 320}]
set H      [expr {[llength $argv] > 1 ? [lindex $argv 1] : 240}]

# Stride is a property of the carve, not of the mode, so read it rather than
# assume it. Falls back to the 1920-wide default carve.
set STRIDE 7680
if {[llength $argv] > 2} {
    set STRIDE [lindex $argv 2]
} elseif {[catch {set sh [open /sys/class/graphics/fb0/stride r]}] == 0} {
    set v [string trim [read $sh]] ; close $sh
    if {[string is integer -strict $v] && $v > 0} { set STRIDE $v }
}
set FRAMES [expr {[llength $argv] > 3 ? [lindex $argv 3] : 1000000}]

# /dev/fb0 presents XRGB8888 to userspace even though the scanout carve is
# named a8b8g8r8, so the byte that reaches the R lane is written third.
proc rgba {r g b} { return [binary format c* [list $b $g $r 255]] }

set SKY      [rgba 110 194 224]
set SKY_DEEP [rgba  83 168 201]
set GROUND   [rgba 201 169 107]
set GRASS    [rgba 106 168  79]
set PIPE     [rgba  76 158  63]
set PIPE_DK  [rgba  55 118  45]
set FUR      [rgba 200 146  78]
set FUR_DK   [rgba 162 113  56]
set MUZZLE   [rgba 240 226 203]
set NOSE     [rgba  43  34  30]
set EYE      [rgba  26  26  26]
set EYE_W    [rgba 255 255 255]
set COLLAR   [rgba 192  57  59]
set STUD     [rgba 232 200  90]
set WING     [rgba 250 250 242]
set WING_DK  [rgba 210 214 222]
set INK      [rgba 255 255 255]

set GROUND_H [expr {max(10, $H/10)}]
set PIPE_W   [expr {max(14, $W/14)}]
set GAP      [expr {max(46, $H*4/10)}]

# 3x5 font, only the glyphs "BIG DOG" and the score need
array set FONT {
    0 {### #.# #.# #.# ###}
    1 {.#. ##. .#. .#. ###}
    2 {### ..# ### #.. ###}
    3 {### ..# ### ..# ###}
    4 {#.# #.# ### ..# ..#}
    5 {### #.. ### ..# ###}
    6 {### #.. ### #.# ###}
    7 {### ..# ..# ..# ..#}
    8 {### #.# ### #.# ###}
    9 {### #.# ### ..# ###}
    B {##. #.# ##. #.# ##.}
    I {### .#. .#. .#. ###}
    G {### #.. #.# #.# ###}
    D {##. #.# #.# #.# ##.}
    O {### #.# #.# #.# ###}
    A {.#. #.# ### #.# #.#}
    M {#.# ### ### #.# #.#}
    E {### #.. ##. #.. ###}
    V {#.# #.# #.# #.# .#.}
    R {##. #.# ##. #.# #.#}
    " " {... ... ... ... ...}
}

# ---- the frame buffer, one row string per scanline -------------------------
set rows {}

# The sky gradient never changes, so build it ONCE and copy the list each
# frame. Tcl lists are copy-on-write, so this is close to free: only the rows
# a rect actually touches get duplicated. Recomputing the gradient per frame
# was ~240 rows of float maths and 76,800 pixel writes for a static backdrop,
# and it dominated the frame time.
set BG {}
for {set y 0} {$y < $H} {incr y} {
    set t [expr {double($y) / ($H - 1)}]
    # B,G,R,A -- same lane order as rgba above, not R,G,B
    set c [binary format c* [list \
        [expr {int(224 + (201 - 224) * $t)}] \
        [expr {int(194 + (168 - 194) * $t)}] \
        [expr {int(110 + (83  - 110) * $t)}] 255]]
    lappend BG [string repeat $c $W]
}

proc newframe {} {
    global rows BG
    set rows $BG
}

# Blit a filled rectangle by splicing spans into the affected rows.
proc rect {x y w h colour} {
    global rows W H
    set x0 [expr {max(0, int($x))}]
    set y0 [expr {max(0, int($y))}]
    set x1 [expr {min($W, int($x + $w))}]
    set y1 [expr {min($H, int($y + $h))}]
    if {$x1 <= $x0 || $y1 <= $y0} { return }
    set span [string repeat $colour [expr {$x1 - $x0}]]
    set b0 [expr {$x0 * 4}]
    set b1 [expr {$x1 * 4 - 1}]
    for {set yy $y0} {$yy < $y1} {incr yy} {
        set r [lindex $rows $yy]
        lset rows $yy [string replace $r $b0 $b1 $span]
    }
}

proc text {s x y scale colour} {
    global FONT
    set i 0
    foreach ch [split $s ""] {
        if {[info exists FONT($ch)]} {
            set gy 0
            foreach line $FONT($ch) {
                set gx 0
                foreach cell [split $line ""] {
                    if {$cell eq "#"} {
                        rect [expr {$x + $i*4*$scale + $gx*$scale}] \
                             [expr {$y + $gy*$scale}] $scale $scale $colour
                    }
                    incr gx
                }
                incr gy
            }
        }
        incr i
    }
}

proc draw_dog {cx cy wingup} {
    global FUR FUR_DK MUZZLE NOSE EYE EYE_W COLLAR STUD WING WING_DK
    # wings, behind the body
    if {$wingup} {
        rect [expr {$cx-12}] [expr {$cy-16}] 9 5 $WING
        rect [expr {$cx-3}]  [expr {$cy-12}] 9 4 $WING
        rect [expr {$cx-12}] [expr {$cy-11}] 9 2 $WING_DK
    } else {
        rect [expr {$cx-13}] [expr {$cy+2}] 10 5 $WING
        rect [expr {$cx-4}]  [expr {$cy-1}]  9 4 $WING
        rect [expr {$cx-13}] [expr {$cy+7}] 10 2 $WING_DK
    }
    # body
    rect [expr {$cx-11}] [expr {$cy-6}] 18 13 $FUR
    rect [expr {$cx-11}] [expr {$cy+4}] 18 3  $FUR_DK
    rect [expr {$cx-13}] [expr {$cy+1}] 3  4  $FUR_DK
    # broad head
    rect [expr {$cx+2}] [expr {$cy-11}] 14 14 $FUR
    rect [expr {$cx+2}] [expr {$cy-11}] 14 2  $FUR_DK
    # floppy ears
    rect [expr {$cx+1}]  [expr {$cy-12}] 4 7 $FUR_DK
    rect [expr {$cx+13}] [expr {$cy-12}] 4 7 $FUR_DK
    # jowls + nose
    rect [expr {$cx+5}]  [expr {$cy-3}] 11 6 $MUZZLE
    rect [expr {$cx+12}] [expr {$cy-2}] 4  3 $NOSE
    # eye
    rect [expr {$cx+6}] [expr {$cy-8}] 4 4 $EYE_W
    rect [expr {$cx+7}] [expr {$cy-7}] 2 2 $EYE
    # collar
    rect [expr {$cx+1}] [expr {$cy-1}] 3 8 $COLLAR
    rect [expr {$cx+1}] [expr {$cy+2}] 3 2 $STUD
}

# ---- main -----------------------------------------------------------------
set fb [open /dev/fb0 w]
fconfigure $fb -translation binary -buffering none

set dogx    [expr {$W/4}]
set dogy    [expr {$H/2.0}]
set vel     0.0
set pipes   {}
set spacing [expr {max(60, $W*3/5)}]
set nextp   40
set score   0
set seed    12345
set tick    0
set FLAPFILE "/home/.flap"
set lastflap ""
# Raw, unbuffered, no echo -- otherwise the console hands us whole lines and
# paints the keypresses over the playfield.
catch {exec /bin/stty raw -echo -icanon min 0 time 0 < /dev/tty 2>/dev/null}
set STDIN_OK 1
if {[catch {fconfigure stdin -blocking 0 -translation binary}]} { set STDIN_OK 0 }
set AUTO [expr {[llength $argv] > 4 ? [lindex $argv 4] : 1}]
catch {set fh [open $FLAPFILE r] ; set lastflap [string trim [read $fh]] ; close $fh}

while {$tick < $FRAMES} {
    set seed [expr {($seed * 1103515245 + 12345) & 0x7fffffff}]
    if {$nextp <= 0} {
        set span [expr {max(1, $H - $GROUND_H - $GAP - 50)}]
        lappend pipes [list $W [expr {$GROUND_H + 20 + ($seed % $span)}]]
        set nextp $spacing
    }
    incr nextp -3

    # Two input routes, because the same script runs in two places. In the
    # browser the console pane delivers keystrokes on stdin; headless, the
    # host writes a counter into /home/.flap and we notice it change.
    # stdin is only a keyboard when we were started from a console. Launched
    # over the control channel it is a closed pipe, and reading it throws
    # "I/O error" -- which used to kill the game outright. Try once, and if it
    # is not readable, fall back to the flap file for the rest of the run.
    if {$STDIN_OK} {
        if {[catch {
            while {[set k [read stdin 1]] ne ""} {
                if {$k eq " " || $k eq "w" || $k eq "\r" || $k eq "\n"} { set vel -5.2 }
                if {$k eq "q"} { set tick $FRAMES ; break }
            }
        }]} { set STDIN_OK 0 }
    }
    if {[catch {set fh [open $FLAPFILE r]} err] == 0} {
        set nowflap [string trim [read $fh]]
        close $fh
        if {$nowflap ne $lastflap} { set lastflap $nowflap ; set vel -5.2 }
    }
    if {$AUTO && ($tick % 14 == 0)} { set vel -5.2 }
    if {$AUTO && $dogy > $H - $GROUND_H - 26} { set vel -5.2 }
    set wingup [expr {$vel < 0}]
    set vel  [expr {$vel + 0.55}]
    set dogy [expr {$dogy + $vel}]
    if {$dogy < 14} { set dogy 14 ; set vel 0.0 }
    set floor [expr {$H - $GROUND_H - 14}]
    if {$dogy > $floor} { set dogy $floor ; set vel 0.0 }

    set moved {}
    foreach p $pipes {
        set nx [expr {[lindex $p 0] - 3}]
        if {$nx + $PIPE_W < 0} { incr score } else { lappend moved [list $nx [lindex $p 1]] }
    }
    set pipes $moved

    # ---- collision -------------------------------------------------------
    # The dog's box is a little tighter than the sprite so near-misses read as
    # near-misses rather than as unfair hits.
    set dl [expr {$dogx - 9}]  ; set dr [expr {$dogx + 15}]
    set dt [expr {int($dogy) - 9}] ; set db [expr {int($dogy) + 6}]
    set hit 0
    foreach p $pipes {
        set px [lindex $p 0] ; set gt [lindex $p 1]
        if {$dr > $px && $dl < $px + $PIPE_W} {
            if {$dt < $gt || $db > $gt + $GAP} { set hit 1 ; break }
        }
    }
    if {$db >= $H - $GROUND_H} { set hit 1 }

    if {$hit} {
        # freeze on the frame that killed you, say so, then start over
        newframe
        foreach p $pipes {
            set px [lindex $p 0] ; set gt [lindex $p 1]
            rect $px 0 $PIPE_W $gt $PIPE
            rect [expr {$px-2}] [expr {$gt-12}] [expr {$PIPE_W+4}] 12 $PIPE_DK
            set low [expr {$gt + $GAP}]
            rect $px $low $PIPE_W [expr {$H - $low - $GROUND_H}] $PIPE
            rect [expr {$px-2}] $low [expr {$PIPE_W+4}] 12 $PIPE_DK
        }
        rect 0 [expr {$H-$GROUND_H}] $W $GROUND_H $GROUND
        rect 0 [expr {$H-$GROUND_H}] $W 4 $GRASS
        draw_dog $dogx [expr {int($dogy)}] 0
        set gs [expr {max(1, $H/60)}]
        set gw [expr {4*$gs*9}]
        rect [expr {($W-$gw)/2 - 6}] [expr {$H/2 - 12}] [expr {$gw+12}] [expr {5*$gs+16}] $PIPE_DK
        text "GAME OVER" [expr {($W-$gw)/2}] [expr {$H/2 - 4}] $gs $INK
        for {set y 0} {$y < $H} {incr y} {
            seek $fb [expr {$y * $STRIDE}] start
            puts -nonewline $fb [lindex $rows $y]
        }
        after 1500
        set dogy [expr {$H/2.0}] ; set vel 0.0
        set pipes {} ; set nextp 40 ; set score 0
        incr tick
        continue
    }

    newframe
    foreach p $pipes {
        set px [lindex $p 0] ; set gt [lindex $p 1]
        rect $px 0 $PIPE_W $gt $PIPE
        rect [expr {$px-2}] [expr {$gt-12}] [expr {$PIPE_W+4}] 12 $PIPE_DK
        set low [expr {$gt + $GAP}]
        rect $px $low $PIPE_W [expr {$H - $low - $GROUND_H}] $PIPE
        rect [expr {$px-2}] $low [expr {$PIPE_W+4}] 12 $PIPE_DK
    }
    rect 0 [expr {$H-$GROUND_H}] $W $GROUND_H $GROUND
    rect 0 [expr {$H-$GROUND_H}] $W 4 $GRASS

    draw_dog $dogx [expr {int($dogy)}] $wingup

    set s [expr {max(2, $H/110)}]
    text "BIG DOG" 8 8 $s $INK
    set sc [format %d $score]
    text $sc [expr {$W - 8 - 4*$s*[string length $sc]}] 8 $s $INK

    # one seek+write per visible row; the rest of the stride is off-screen
    for {set y 0} {$y < $H} {incr y} {
        seek $fb [expr {$y * $STRIDE}] start
        puts -nonewline $fb [lindex $rows $y]
    }
    incr tick
}

close $fb
catch {exec /bin/stty sane < /dev/tty 2>/dev/null}
puts "BIG DOG: $tick frames, score $score"