package require Tk

set dir [file dirname [info script]]
set opts(delay,flood) 200
set opts(dateformat) {%Y-%m-%d %H:%M}
set opts(pipesDataFile) [file join $dir TkPipes-Data.tcl]
set opts(help) {
TkPipes
by Federico Ferri - 2008
https://wiki.tcl-lang.org/FF

Controls

p     - Pause
Space - Continue

Left click on the timer bar to start flood immediately

}

proc image_rotate {img angle img_dest} {
    set w [image width  $img]
    set h [image height $img]
    image create photo $img_dest
    switch -- $angle {
        90 {
            set buf {}
            $img_dest copy $img
            for {set i 0} {$i < $w} {incr i} {
                set rowbuf {}
                for {set j [expr {$h-1}]} {$j >= 0} {incr j -1} {
                    foreach {r g b} [$img_dest get $i $j] break
                    lappend rowbuf [format #%02x%02x%02x $r $g $b]
                }
                lappend buf $rowbuf
            }
            $img_dest config -width $h -height $w
            $img_dest put $buf
        }
        180 {
            $img_dest copy $img -subsample -1 -1
        }
        270 {
            image_rotate $img 180 ${img_dest}_tmp
            image_rotate ${img_dest}_tmp 90 $img_dest
            image delete ${img_dest}_tmp
        }
        flipx {
            $img_dest copy $img -subsample -1 1
        }
    }
}

proc load_tileset {diroff name q {destname {}} {flip 0}} {
    if {$destname == {}} {set destname $name}
    set dir {N E S W N E S W}
    for {set i 0} {$i < $q} {incr i} {
        if $flip {
            image create photo ${destname}_[lindex $dir $diroff]_${i}_tmp \
               -data [lindex $::data($name) $i]
            image_rotate ${destname}_[lindex $dir $diroff]_${i}_tmp flipx \
        ${destname}_[lindex $dir $diroff]_${i}
            image delete ${destname}_[lindex $dir $diroff]_${i}_tmp
        } else {
            image create photo ${destname}_[lindex $dir $diroff]_${i} \
                -data [lindex $::data($name) $i]
        }
        foreach {a n} {90 1 180 2 270 3} {
            image_rotate ${destname}_[lindex $dir $diroff]_${i} $a \
                ${destname}_[lindex $dir $diroff+$n]_${i}
        }
        puts -nonewline "."; flush stdout
    }
}

proc load_all {} {
     puts -nonewline "Loading"; flush stdout
     source $::opts(pipesDataFile)
     load_tileset 2 curve     5 curve_l
     load_tileset 2 curve     5 curve_r 1
     load_tileset 0 straight  5
     load_tileset 3 cross     9 cross_l 1
     foreach {im nlist} {sink {0} empty {0 1 2}} { foreach n $nlist {
     image create photo ${im}_$n -data [lindex $::data($im) $n]
     }}
     puts "OK"
}

proc check {blk src_dir} {
    if {[llength $blk] == 4} {
        # is a cross
        return [string map {N S S N E W W E} $src_dir]
    } elseif {[llength $blk] == 2} {
        # is either straight or curve
        set idx [lsearch -exact $blk $src_dir]
        if {$idx == -1} {return {}}
        return [lindex $blk [string map {0 1 1 0} $idx]]
    } else {
        puts "# [info level 0] WTF?"
    }
}

proc move {x y dir} {
    set delta [string map {N {0 -1} E {1 0} S {0 1} W {-1 0}} $dir]
    incr x [lindex $delta 0]
    incr y [lindex $delta 1]
    return [list $x $y]
}

proc board:create {w h} {
    set ::W $w
    set ::H $h
    set ::CS 64
    set pw [expr {$::CS*$::W}]
    set ph [expr {$::CS*$::H}]
    canvas .c -width $pw -height $ph
    for {set y 0} {$y < $h} {incr y} {
        for {set x 0} {$x < $w} {incr x} {
            .c create image [expr {1+$x*$::CS}] [expr {1+$y*$::CS}] \
                -anchor nw -image empty_0 -tags [list b_${x}_${y}]
            .c bind b_${x}_${y} <ButtonPress-1> "board:click $x $y"
        }
    }
    grid .c -row 0 -column 0 -rowspan 2
}

proc board:put {x y id {frame 0}} {
    .c create image [expr {1+$x*$::CS}] [expr {1+$y*$::CS}] \
        -image ${id}_${frame} -anchor nw -tags [list p_${x}_${y} pieces]
    if {$id != "empty"} {
        board:put $x $y empty 2
    }
}

proc board:showscore {x y s} {
     .c delete txt_${x}_${y}
     foreach {dx dy c} {0 -1 B 1 0 B 0 1 B -1 0 B 0 0 W} {
         .c create text \
             [expr {$dx+($x+0.5)*$::CS}] [expr {$dy+($y+0.5)*$::CS}] \
             -tags txt_${x}_${y} -text $s \
             -fill [string map {W white B black} $c]
     }
     for {set i 40} {$i < 500} {incr i 50} {
         after $i ".c move txt_${x}_${y} 0 -1"
     }
     after 1000 ".c delete txt_${x}_${y}"
     game:setscore $s
}

proc board:click {x y} {
     if {!$::ACTIVE} {return}
     timer:continue
     board:put $x $y $::piece
     set ::B($x:$y) [piece:getblk $::piece_t $::piece_d]
     set ::PT($x:$y) $::piece_t
     set ::PD($x:$y) $::piece_d
     set ::F($x:$y) 0
     preview:generate
     game:setscore -50
}

proc board:initlevel {l} {
     array unset ::B *
     array unset ::PT *
     array unset ::PD *
     array unset ::F *
     set ::sinkx [expr {int(rand()*($::W-1))}]
     set ::sinky [expr {int(rand()*($::H-1))}]
     .c delete pieces
     board:put $::sinkx $::sinky sink
     set ::B($::sinkx:$::sinky) [piece:getblk straight E]
     set ::PT($::sinkx:$::sinky) straight_W
     set ::PD($::sinkx:$::sinky) E
     set ::F($::sinkx:$::sinky) 0
     set ::LEVEL $l
     set ::ACTIVE 1
     set ::TIME [timer:totaltime]
     set ::timer_id [after 1 timer:tick]
     timer:continue
     set nblocks [lindex {0 4 1 3 2 4 4 4 4 4 4 4 4 4 4 4} $::LEVEL]
     for {set i 0} {$i < $nblocks} {incr i} {
         set blkx $::sinkx
         set blky $::sinky
         while {[expr {abs($blkx-$::sinkx)}] <= 1 &&
                [expr {abs($blky-$::sinky)}] <= 1} {
             set blkx [expr {int(rand()*($::W))}]
             set blky [expr {int(rand()*($::H))}]
         }
         board:put $blkx $blky empty 1
         set ::B($blkx:$blky) {}
         set ::F($blkx:$blky) -1
     }
}

proc board:pause {b} {
     if {$b && $::ACTIVE} {
         foreach {w h} [list [.c cget -width] [.c cget -height]] {break}
         .c create rectangle 1 1 $w $h -fill gray -tags gamepaused
         .c create text [expr {$w/2}] [expr {$h/2}] \
             -text "GAME PAUSED\n\nPress SPACE to continue" \
             -justify center -tags gamepaused
     } else {
         .c delete gamepaused
     }
}

proc piece:getblk {p d} {
     set m {}
     switch $p {
         cross_l - cross_r {return {N E S W}}
         curve_l {set m {N {N E} E {E S} S {S W} W {W N}}}
         curve_r {set m {N {N W} E {E N} S {S E} W {W S}}}
         straight {set m {N {N S} E {E W} S {N S} W {E W}}}
     }
     return [string map $m $d]
}

proc preview:create {} {
     set n 1
     canvas .p -width $::CS -height [expr {$::CS*$n}]
     grid .p -row 1 -column 1
     set ::ACTIVE 0
     set ::LEVEL 1
}

proc preview:generate {} {
     set pl {curve_l curve_l straight straight cross_l}
     set ::piece_t [lindex $pl [expr int(rand()*5)]]
     set ::piece_d [lindex {N E S W} [expr int(rand()*4)]]
     set ::piece ${::piece_t}_${::piece_d}
    .p delete p
    .p create image 1 1 -image ${::piece}_0 -anchor nw -tags p
}

proc flood {x y d} {
     foreach {x y} [move $x $y $d] {break}
     if {![info exists ::PT($x:$y)]} {set ::ACTIVE 0; return}
     if {$x < 0 || $y < 0 || $x >= $::W || $y >= $::H} {set ::ACTIVE 0; return}
     set src [string map {E W W E N S S N} $d]
     set out [check $::B($x:$y) $src]
     if {$out == {}} {set ::ACTIVE 0; return}
     set dir {N E S W N E S W}
     if {[regexp ^curve_l $::PT($x:$y)]} {
         if {$out == [lindex $dir [lsearch -exact $dir $src]+3]} {
             set ::PT($x:$y) {curve_r}
             set ::PD($x:$y) $src
         }
     } elseif {[regexp ^cross_l $::PT($x:$y)] && $::F($x:$y) > 0} {
         if {$::PD($x:$y) == [lindex $dir [lsearch -exact $dir $src]+1]} {
             set ::PD($x:$y) [lindex $dir [lsearch -exact $dir $::PD($x:$y)]+2]
         }
     } else {
         set ::PD($x:$y) $src
     }
     set limit 4
     if {[regexp {^cross_[lr]$} $::PT($x:$y)] && $::F($x:$y) > 0} {
         set limit 8
     }
     while {$::F($x:$y) < $limit} {
         incr ::F($x:$y)
         board:put $x $y $::PT($x:$y)_$::PD($x:$y) $::F($x:$y)
         update
         after $::opts(delay,flood)
     }
     if {$limit > 4} {
         game:setscore -300
         board:showscore $x $y +900
     } else {
         board:showscore $x $y +300
     }
     flood $x $y $out
}

proc timer:create {} {
     canvas .t -width 20 -height 287 -background black
     set y 6
     foreach col {G G G G G G G G Y Y Y Y R R} {
         .t create rectangle 6 $y 16 [incr y 15] \
             -fill [string map {G green Y yellow R red} $col] \
             -outline {} -tags tmclick
         incr y 5
     }
     .t create rectangle 0 0 20 287 -fill black -tags {time tmclick}
     bind .t <ButtonPress-1> {set ::TIME 0}
     grid .t -row 0 -column 1
}

proc timer:totaltime {} {
     return [expr {20+(9-$::LEVEL)*10}]
}

proc timer:tick {} {
     if {!$::PAUSED} {
         incr ::TIME -1
         if {$::TIME <= 0} {
             flood $::sinkx $::sinky E
             if {$::SCORE >= $::MINSCORE} {
                 game:nextleveldialog
             } else {
                 game:gameoverdialog
             }
             return
         }

         set h [expr {287-$::TIME*286.5/[timer:totaltime]}]
         .t coords time 0 0 20 $h
         if {$h > 200} {after 750 {.t coords time 0 0 20 287}}
     }
     set ::timer_id [after 1000 timer:tick]
}

proc timer:pause { } {
     set ::PAUSED 1
     board:pause 1
}

proc timer:continue { } {
     set ::PAUSED 0
     board:pause 0
}

proc game:new {} {
     catch {after cancel $::timer_id}
     set ::LEVEL 0
     set ::SCORE 0
     game:nextlevel
}

proc game:nextlevel {} {
     incr ::LEVEL
     set ::MINSCORE [game:minscore]
     board:initlevel $::LEVEL
     preview:generate
     game:setscore
     .sb.2 configure -text "Level: $::LEVEL     "
     .sb.3 configure -text "Score required to access next level: $::MINSCORE      "
}

proc game:createdialog { w title type } {
     set w .dialog_window
     catch {destroy $w}
     toplevel $w

     wm title $w $title
     wm withdraw $w

     bind $w <Escape> [list game:closedialog $w $type cancel]
     bind $w <Return> [list game:closedialog $w $type ok]
     bind $w <KP_Enter> [list game:closedialog $w $type ok]
     wm protocol $w WM_DELETE_WINDOW [list game:closedialog $w $type cancel]

     return $w
}

proc game:closedialog { w type action } {
     grab release $w
     switch $type {
         {levelfinished} {
             game:nextlevel
         }
     }
     destroy $w
}

proc game:showdialog { w } {
     tk::PlaceWindow $w widget .
     catch {tkwait visibility $w}
     catch {grab set $w} err
     if {$err ne ""} {
         tk_messageBox -message $err -type error
     }
     wm deiconify $w
}

proc game:gameoverdialog {} {
     set w [game:createdialog .dialog_window "Game Over" gameover]

     if {![info exists ::playername]} {
         catch {set ::playername $::env(USER)}
     }

     set i 1
     pack [label $w.l[incr i] -text "\nGame over!\n"]
     pack [button $w.b[incr i] -text "Ok" -default active -command "highscores:add \[$w.pn get]; destroy $w"] -side bottom
     pack [label $w.l[incr i] -text "Enter your name:"] \
      [entry $w.pn -text "" -textvariable ::playername] \
      -side left -padx 5 -pady 5

     game:showdialog $w
}

proc game:nextleveldialog {} {
     set w [game:createdialog .dialog_window "Level finished" levelfinished]

     set i 1
     pack [label $w.l[incr i] -text "Congratulations! Level completed\n"] -padx 5 -pady 5
     pack [button $w.b[incr i] -text "Next level" -default active -command "game:closedialog $w levelfinished ok"]

     game:showdialog $w
}

proc game:highscoresdialog {} {
     set w [game:createdialog .dialog_window "High scores" showhighscores]

     set i 1
     grid [label $w.l[incr i] -text "Hall of fame"] -columnspan 4
     grid [label $w.l[incr i] -text ""] -columnspan 4
     set row 3
     if [llength $::HIGHSCORES] {
         set HS [lreverse [lsort -integer -index 0 $::HIGHSCORES]]
         grid [label $w.h1 -text "  Score:  "] -row $row -column 0 -padx 5 -pady 5
         grid [label $w.h2 -text "  Level:  "] -row $row -column 1 -padx 5
         grid [label $w.h3 -text "  Name:   "] -row $row -column 2 -padx 5
         grid [label $w.h4 -text "  Date:   "] -row $row -column 3 -padx 5
         incr row
         for {set i 0} {$i < [llength $HS]} {incr i} {
             for {set j 0} {$j < 3} {incr j} {
                 grid [label $w.hs_${i}_${j} \
                    -text "  [lindex [lindex $HS $i] $j]  "] \
                    -row $row -column $j -padx 5
             }
             grid [label $w.hs_${i}_3 \
                 -text [concat "  " \
                     [clock format [lindex [lindex $HS $i] 3] \
                         -format $::opts(dateformat)] \
                     "  "]] \
                 -row $row -column 3
             incr row
         }
     } else {
         grid [label $w.l[incr i] -text "Empty"] -columnspan 4
     }
     game:showdialog $w
}

proc game:aboutdialog {} {
     set w [game:createdialog .dialog_window "About" about]
     wm resizable $w 0 0
     set f [frame $w.f]

     set i 1
     set e [string map {R ri O co Q de Z fe I it W ma L il} [email protected]]
     pack [label $f.l[incr i] -text "TkPipes\n"]
     pack [label $f.l[incr i] -text "by Federico Ferri <$e> - 2008"]
     pack [label $f.l[incr i] -text "https://wiki.tcl-lang.org/FF\n"]
     pack [button $f.b[incr i] -text "Cheers!" -default active -command "game:closedialog $w about ok"]

     pack $f -padx 5 -pady 5
     game:showdialog $w
}

proc game:helpdialog {} {
     set w [game:createdialog .dialog_window "Help" help]
     wm resizable $w 0 0
     set f [frame $w.f -relief sunken -borderwidth 1]

     scrollbar $f.hs -orient horizontal -command [list $f.t xview]
     scrollbar $f.vs -orient vertical   -command [list $f.t yview]
     text $f.t -height 14 -width 60  -relief flat \
           -background white \
           -xscrollcommand [list $f.hs set] \
           -yscrollcommand [list $f.vs set]

     grid $f.t  -row 0 -column 0
     grid $f.vs -row 0 -column 1 -sticky ns
     grid $f.hs -row 1 -column 0 -sticky ew

     $f.t insert end $::opts(help)

     pack $f -padx 5 -pady 5
     pack [button $w.b0 -text "  Ok  " -default active \
         -command "game:closedialog $w help ok"] \
         -side bottom -pady 5

     game:showdialog $w
}

proc game:setscore {{score {}}} {
     if {$score != {}} {
     if [regexp {^(\+|-)(.*)$} $score -> pm n] {
         set ::SCORE [expr $::SCORE$pm$n]} {set ::SCORE $score}
     }
     .sb.1 configure -text "Score: $::SCORE       "
}

proc game:minscore {} {
     set delta {5000 5000 7500 7500 9000 9000 17500 17500 26000
     35000 45000 50000 350 350 350 350 350}
     set r 0
     for {set i 0} {$i < $::LEVEL} {incr i} {incr r [lindex $delta $i]}
     return $r
}

proc highscores:load {} {
     set ::HIGHSCORES {}
     set f [file join $::env(HOME) .tkpipes]
     if [file exists $f] {source $f}
}

proc highscores:save {} {
     set HS [lreverse [lsort -integer -index 0 $::HIGHSCORES]]
     set fh [open [file join $::env(HOME) .tkpipes] w]
     set count 0
     puts $fh "set ::HIGHSCORES {"
     foreach line $HS {
         puts $fh " {[concat $line]}"
         incr count
         if {$count > 10} break
     }
     puts $fh "}"
     close $fh
}

proc highscores:add {name} {
     if {$name == {}} return
     lappend ::HIGHSCORES [list $::SCORE $::LEVEL $name [clock seconds]]
     highscores:save
}

wm title . "TkPipes"
menu .mb
. configure -menu .mb
menu .mb.game -tearoff 0
menu .mb.help -tearoff 0
.mb.game add command -label "New game" -command game:new
.mb.game add separator
.mb.game add command -label "High scores..." -command game:highscoresdialog
.mb.game add separator
.mb.game add command -label "Exit" -command exit
.mb add cascade -label "Game" -menu .mb.game

.mb.help add command -label "Help" -command game:helpdialog
.mb.help add separator
.mb.help add command -label "About..." -command game:aboutdialog
.mb add cascade -label "Help" -menu .mb.help

bind . <Key-p> [list timer:pause]
bind . <Key-space> [list timer:continue]

grid [frame .sb -relief sunken] -sticky nesw -row 99 -columnspan 99
grid [label .sb.1 -relief sunken] -in .sb -row 0 -column 0 -sticky ew
grid [label .sb.2 -relief sunken] -in .sb -row 0 -column 1 -sticky ew
grid [label .sb.3 -relief sunken] -in .sb -row 0 -column 2 -sticky ew

load_all
highscores:load
board:create 10 8
timer:create
preview:create