##+##########################################################################
 #
 # 15.tcl -- Plays and solve the classic 15 puzzle
 # by Keith Vetter, Dec 5 2005
 #
 # Solution algorithm taken from
 # http://www.javaonthebrain.com/java/puzz15/technical.html
 #
 
 package require Tk
 if {![catch {package require tile} version]} {
    if {$version >= 0.5} {
        catch {namespace import -force ::ttk::button}
    }
 }
 
 set S(font) Helvetica
 if {$tcl_platform(platform) eq "windows"} { set S(font) {Comic Sans MS}}
 font create numfont -family $::S(font) -size 22 -weight bold
 set S(sz) [font measure numfont "15 "]
 set S(w) [expr {4*$S(sz) + 1}]
 
 set S(state) playing
 set S(soln) {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 0}
 
 ##+##########################################################################
 #
 # DoDisplay -- puts up our display
 #
 proc DoDisplay {} {
    global S
 
    bind all <Key-F2> {console show}
    wm title . "15 Puzzle"
    canvas .c -width $S(w) -height $S(w) -highlightthickness 0 -bg gray75
    label .msg -textvariable S(msg) -bd 2 -relief ridge
    .msg configure  -font "[font actual [.msg cget -font]] -weight bold"
    option add *font [.msg cget -font]
 
    frame .buttons -bd 2 -relief ridge -pady 5
    button .new -text "New Board" -command NewBoard
    #style default My.TCheckbutton -bd 2 -relief raised
    #::ttk::checkbutton .solve -text " Solve " -variable S(solve) -style My.TCheckbutton
    button .solve -text "Solve" -command Solve
    button .about -text "About" -command About
 
    pack .c -side top -padx 5 -pady 5
    pack .msg -side top -fill x
    pack .buttons -side top -fill x
    #pack .new .solve -in .buttons -side left -expand 1 -pady 10 -padx 10 -fill y
    grid x .new x .solve x -in .buttons -sticky ew -row 0
    grid x x    x .about x -in .buttons -sticky ew -row 2
    grid rowconfigure .buttons 1 -minsize 5
    grid columnconfigure .buttons {1 3} -uniform a
    grid columnconfigure .buttons {0 2 4} -weight 1
 }
 ##+##########################################################################
 #
 # Draws the board in B
 #
 proc DrawNewBoard {} {
    global B
 
    .c delete all
    for {set row 0} {$row < 4} {incr row} {
        for {set col 0} {$col < 4} {incr col} {
            set r [TileRect $row $col]
            set xy [TileXY $row $col]
            set val $B($row,$col)
            set tag "tile$val"
 
            if {$B($row,$col) == 0} {
                .c create rect $r -width 1 -fill gray75 -tag $tag
            } else {
                .c create rect $r -width 1 -fill white -tag [list tile $tag]
                .c create text $xy -text $val -font numfont -tag $tag
                .c bind $tag <1> [list Click $val]
            }
        }
    }
 }
 ##+##########################################################################
 #
 # NewBoard -- creates a new board in B then draws it
 #
 proc NewBoard {{n 500}} {
    global B S
 
    set l [ScrambleBoard $n]
    for {set row 0} {$row < 4} {incr row} {
        for {set col 0} {$col < 4} {incr col} {
            set n [expr {int(rand() * [llength $l])}]
            set n 0
            set val [lindex $l $n]
            set B($row,$col) $val
            set B(r,$val) [list $row $col]
            set l [lreplace $l $n $n]
        }
    }
    DrawNewBoard
    set S(state) playing
    .solve config -state normal
 }
 ##+##########################################################################
 #
 # Creates a legal random board. To insure legality, it simulates
 # moving the tiles MAX times.
 #
 proc ScrambleBoard {{max 300}} {
    array set DIRS {up {-1 0} down {1 0} left {0 -1} right {0 1}}
    set b $::S(soln)
 
    for {set i 0} {$i < $max} {incr i} {
        set idx0 [lsearch $b 0]
        set r0 [expr {$idx0 / 4}]
        set c0 [expr {$idx0 - 4*$r0}]
 
        while {1} {
            set dir [lindex {up down left right} [expr {int(rand()*4)}]]
            lassign $DIRS($dir) dr dc
 
            set r1 [expr {$r0 + $dr}]
            set c1 [expr {$c0 + $dc}]
            if {$r1 >= 0 && $r1 <= 3 && $c1 >= 0 && $c1 <= 3} break
        }
        set idx1 [expr {$r1*4 + $c1}]
 
        # Swap idx0 and idx1 in the board
        set temp [lindex $b $idx0]
        lset b $idx0 [lindex $b $idx1]
        lset b $idx1 $temp
    }
    return $b
 }
 ##+##########################################################################
 #
 # Moves tiles in response to clicks on the board.
 #
 proc Click {val {force 0}} {
    global B
 
    if {! $force && $::S(state) ne "playing"} return
    lassign $B(r,$val) row col
    lassign $B(r,0) hrow hcol
    set dr [expr {$hrow-$row}]
    set dc [expr {$hcol-$col}]
 
    if {$dr != 0 && $dc != 0} return            ;# Diagonal move attempt
    if {$dr == 0 && $dc == 0} return            ;# NOP move attempt
 
    set adr [expr {$dr == 0 ? 0 : $dr/abs($dr)}];# Sign of dr
    set adc [expr {$dc == 0 ? 0 : $dc/abs($dc)}]
    set len [expr {abs($dr) + abs($dc)}]        ;# How many tiles too move
 
    for {set i 1} {$i <= $len} {incr i} {
        set r1 [expr {$hrow - $i * $adr}]
        set c1 [expr {$hcol - $i * $adc}]
        set val $B($r1,$c1)
        MoveTile $r1 $c1
        UpdateBoard $val 0
    }
    if {[IsSolved]} Victory
 }
 ##+##########################################################################
 #
 # MoveTile -- updates data structures for moving a tile
 #
 proc MoveTile {row col} {
    global B
 
    set val $B($row,$col)
 
    lassign $B(r,0) hrow hcol
    set B($hrow,$hcol) $B($row,$col)            ;# Hole get tile's value
    set B($row,$col) 0                          ;# Tile is now hole
    set B(r,$val) [list $hrow $hcol]            ;# Reverse indices
    set B(r,0) [list $row $col]
 }
 ##+##########################################################################
 #
 # UpdateBoard -- updates board to reflect moved tile
 #
 proc UpdateBoard {val0 val1} {
    global B
 
    ;# NB. the tiles are ALREADY swapped in B
    lassign [eval TileXY $B(r,$val0)] x0 y0
    lassign [eval TileXY $B(r,$val1)] x1 y1
 
    set dx [expr {$x1 - $x0}]
    set dy [expr {$y1 - $y0}]
    .c move tile$val1 $dx $dy
    .c move tile$val0 [expr {-$dx}] [expr {-$dy}]
 }
 ##+##########################################################################
 #
 # Returns TRUE if B is solved
 #
 proc IsSolved {} {
    global B
 
    set idx 0
    for {set row 0} {$row < 4} {incr row} {
        for {set col 0} {$col < 4} {incr col} {
            if {[incr idx] != $B($row,$col)} {  ;# Always fails for the hole
                return [expr {$idx == 16}]
            }
        }
    }
    return 0                                    ;# Should never get here
 }
 ##+##########################################################################
 #
 # Shows that you've won
 #
 proc Victory {} {
    .c itemconfig tile -fill cyan
    set ::S(state) solved
 }
 proc DumpBoard {b} {
    set idx -1
    for {set row 0} {$row < 4} {incr row} {
        for {set col 0} {$col < 4} {incr col} {
            set c "0x[string index $b [incr idx]]"
            set num [expr {$c eq "0x-" ? "" : $c}]
            puts -nonewline [format "%3s" $num]
        }
        puts ""
    }
 }
 ##+##########################################################################
 #
 # Returns x,y of the center of tile at row,col
 #
 proc TileXY {row col} {
    set x [expr {$col * $::S(sz) + $::S(sz)/2}]
    set y [expr {$row * $::S(sz) + $::S(sz)/2}]
    return [list $x $y]
 }
 ##+##########################################################################
 #
 # Returns rectangle of tile at row,col
 #
 proc TileRect {row col} {
    set x0 [expr {$col * $::S(sz)}]
    set y0 [expr {$row * $::S(sz)}]
    set x1 [expr {$x0 + $::S(sz)}]
    set y1 [expr {$y0 + $::S(sz)}]
    return [list $x0 $y0 $x1 $y1]
 }
 proc About {} {
    set msg "15 Puzzle\nby Keith Vetter, December 2005\n\n"
    append msg "Let's you create and try to solve the\n"
    append msg "classic 15 puzzle. If you have trouble,\n"
    append msg "just press the Solve button to see it done."
    tk_messageBox -title "About 15 Puzzle" -message $msg
 }
 ################################################################
 ################################################################
 #
 # Solution code below. Cribbed from http://www.javaonthebrain.com
 #
 
 proc Solve {} {
    global B MOVES HOLDER
 
    set ::S(state) solving
    .new config -state disabled
    .solve config -state disabled
 
    set MOVES {}
    unset -nocomplain HOLDER
    for {set i 0} {$i < 16} {incr i} {
        lassign $B(r,$i) row col
        set HOLDER([expr {$row*4 + $col}]) $i
    }
 
    AddMessage "Putting 1 into place"
    MoveTo 1 0                                  ;# 1 into place
    AddMessage "Putting 2 into place"
    MoveTo 2 1                                  ;# 2 into place
    Goal34                                      ;# 3,4 into place
    AddMessage "Putting 5 into place"
    MoveTo 5 4                                  ;# 5 into place
    AddMessage "Putting 6 into place"
    MoveTo 6 5                                  ;# 6 into place
    Goal78                                      ;# 7,8 into place
    Goal9,13                                    ;# 13,9 into place
    Goal10,14                                   ;# 14,10 into place
    Goal15
 
    DoMoves
    .new config -state normal
 }
 proc MakeArray {_var values} {
    upvar $_var var
    set idx -1
    foreach v $values {
        set var([incr idx]) $v
    }
 }
 MakeArray roundDisp {-4 -3 1 5 4 3 -1 -5 -4 -3 1 5 4 3 -1 -5 -4 -3 1 5 4 3 -1 -5 -4}
 MakeArray roundDx {0 1 1 1 0 -1 -1 -1 0 1 1 1 0 -1 -1 -1 0 1 1 1 0 -1 -1 -1 0}
 set detour1 {11 10 6 7 11 10 6 7 3 2 6 7 11}
 set detour2 {15 14 10 11 15 14 10 11 7 6 10 11 15}
 set detour3 {6 2 3 7}
 set detour4 {3 7}
 set detour5 {10 6 7 11}
 set detour6 {7 11}
 set detour7 {13 12 8 9}
 set detour8 {8 9}
 set detour9 {10 14 13 9 10 14 13 9 8 12 13 9 10}
 set detour10 {14 13 9 10}
 set detour11 {9 10}
 set detour12 {11 15 14 10 11 15 14 10 9 13 14 10 11}
 set roundAbout {11 10 14 15}
 
 proc Goal34 {} {
    global HOLDER
 
    if {$HOLDER(2) == 3 && $HOLDER(3) == 4} {   ;# Already in place
        set HOLDER(2) -1
        set HOLDER(3) -1
        return
    }
 
    AddMessage "Putting 3 & 4 into place"
    MoveTo 3 3
    set hpos [Locate 0]
 
    if {$hpos == 7 && $HOLDER(2) == 4} {        ;# Darn!
        AddMessage "Darn! 4 badly placed, need detour"
        MakeDetour $::detour3 7
        MakeDetour $::detour1 7
    } elseif {$hpos == 2 && $HOLDER(6) == 4} {  ;# Darn!
        AddMessage "Darn! 4 badly placed, need detour"
        MakeDetour $::detour4 2
        MakeDetour $::detour1 7
    } elseif {$HOLDER(2) == 4} {                ;# Darn!
        AddMessage "Darn! 4 badly placed, need detour"
        MoveTo 4 6
        MakeDetour $::detour4 2
        MakeDetour $::detour1 7
    } else {
        MoveTo 4 7
    }
 
    # Now walk 3,4 into position
    set HOLDER(3) 3                             ;# Unlock this piece
    set HOLDER(7) -1
    MoveTo 3 2
    set HOLDER(7) 4                             ;# Unlock this piece
    MoveTo 4 3
 }
 
 proc Goal78 {} {
    global HOLDER
 
    if {$HOLDER(6) == 7 && $HOLDER(7) == 8} {
        set HOLDER(6) -1
        set HOLDER(7) -1
        return
    }
 
    AddMessage "Putting 7 & 8 into place"
    MoveTo 7 7
    set hpos [Locate 0]
 
    if {$hpos == 11 && $HOLDER(6) == 8} {       ;# Darn!
        AddMessage "Darn! 8 badly placed, need detour"
        MakeDetour $::detour5 11
        MakeDetour $::detour2 11
    } elseif {$hpos == 6 && $HOLDER(10) == 8} { ;# Darn!
        AddMessage "Darn! 8 badly placed, need detour"
        MakeDetour $::detour6 6
        MakeDetour $::detour2 11
    } elseif {$HOLDER(6) == 8} {                ;# Darn!
        AddMessage "Darn! 8 badly placed, need detour"
        MoveTo 8 10
        MakeDetour $::detour6 6
        MakeDetour $::detour2 11
    } else {
        MoveTo 8 11
    }
    set HOLDER(7) 7                             ;# Unlock this piece
    set HOLDER(11) -1
    MoveTo 7 6
    set HOLDER(11) 8                            ;# Unlock this piece
    MoveTo 8 7
 }
 proc Goal9,13 {} {
    global HOLDER
 
    if {$HOLDER(8) == 9 && $HOLDER(12) == 13} {
        set HOLDER(8) -1
        set HOLDER(12) -1
        return
    }
 
    AddMessage "Putting 9 & 13 into place"
    MoveTo 13 8
    set hpos [Locate 0]
    if {$hpos == 9 && $HOLDER(12) == 9} {
        AddMessage "Darn! 9 badly placed, need detour"
        MakeDetour $::detour7 9
        MakeDetour $::detour9 9
    } elseif {$hpos == 12 && $HOLDER(13) == 9} {
        AddMessage "Darn! 9 badly placed, need detour"
        MakeDetour $::detour8 12
        MakeDetour $::detour9 9
    } elseif {$HOLDER(12) == 9} {
        AddMessage "Darn! 9 badly placed, need detour"
        MoveTo 9 13
        MakeDetour $::detour8 12
        MakeDetour $::detour9 9
    } else {
        MoveTo 9 9
    }
    set HOLDER(8) 13
    set HOLDER(9) -1
    MoveTo 13 12
    set HOLDER(9) 9
    MoveTo 9 8
 }
 proc Goal10,14 {} {                                     ;# 10,14
    global HOLDER
 
    if {$HOLDER(9) == 10 && $HOLDER(13) == 14} {
        set HOLDER(9) -1
        set HOLDER(13) -1
        return
    }
 
    AddMessage "Putting 10 & 14 into place"
    MoveTo 14 9
    set hpos [Locate 0]
    if {$hpos == 10 && $HOLDER(13) == 10} {
        AddMessage "Darn! 10 badly placed, need detour"
        MakeDetour $::detour10 10
        MakeDetour $::detour12 10
    } elseif {$hpos != 10 && $HOLDER(14) == 10} {
        AddMessage "Darn! 10 badly placed, need detour"
        MakeDetour $::detour11 13
        MakeDetour $::detour12 10
    } else {
        MoveTo 10 10
    }
    set HOLDER(9) 14
    set HOLDER(10) -1
    MoveTo 14 13
    set HOLDER(10) 10
    MoveTo 10 9
 }
 proc Goal15 {} {
    global HOLDER MOVES
 
    AddMessage "Last little bit"
    # Get hole into corner
    while {$HOLDER(15) != 0} {
        if {$HOLDER(10) == 0} {
            lappend MOVES 11
            set HOLDER(10) $HOLDER(11)
            set HOLDER(11) 0
        }
        if {$HOLDER(11) == 0} {
            lappend MOVES 15
            set HOLDER(11) $HOLDER(15)
            set HOLDER(15) 0
        }
        if {$HOLDER(14) == 0} {
            lappend MOVES 15
            set HOLDER(14) $HOLDER(15)
            set HOLDER(15) 0
        }
    }
 
    # Rotate until done
    while {$HOLDER(14) != 15} {
        MakeDetour $::roundAbout 15
    }
 }
 ##+##########################################################################
 #
 # AddMessage -- puts a message into move list to be displayed
 #
 proc AddMessage {msg} {
    lappend ::MOVES $msg
 }
 ##+##########################################################################
 #
 # MoveTo -- Moves "piece" to position "to"
 #
 proc MoveTo {piece to} {
    global HOLDER MOVES
 
    set ppath [GetPath $piece $to]
    set ppos [Locate $piece]
    set HOLDER($ppos) -1
    foreach tg $ppath {
        MoveHole $tg $ppos                      ;# Get the hole where we want it
        lappend MOVES $ppos                     ;# Move target into hole
 
        set HOLDER($ppos) 0                     ;# Update data structures
        set HOLDER($tg) -1
        set ppos $tg
    }
    return $MOVES
 }
 ##+##########################################################################
 #
 # GetPath -- gets path that "piece" will take to get to "to". How it completes
 # this path is somebody elses problem.
 #
 proc GetPath {piece to} {
    set ppath {}
    set hpos [Locate $piece]
 
    while {($hpos & 3) < ($to & 3)} {           ;# Go right if we need to
        lappend ppath [incr hpos]
    }
    while {($hpos & 3) > ($to & 3)} {           ;# Go left if we need to
        lappend ppath [incr hpos -1]
    }
 
    while {$hpos > $to} {                       ;# Get up if we need to
        lappend ppath [incr hpos -4]
    }
    while {$hpos < $to} {                       ;# Get up if we need to
        lappend ppath [incr hpos 4]
    }
    return $ppath
 }
 ##+##########################################################################
 #
 # MoveHole -- the guts of the solution. Figures out how to get the hole to
 # the target position next to ppos without disturbing already solved tiles.
 #
 proc MoveHole {tg ppos} {
    global HOLDER MOVES
    global roundDisp roundDx
 
    set hpos [Locate 0]                         ;# Find the hole
    lassign [list [expr {$hpos / 4}] [expr {$hpos & 3}]] hrow hcol
    lassign [list [expr {$ppos / 4}] [expr {$ppos & 3}]] prow pcol
    lassign [list [expr {$tg / 4}] [expr {$tg & 3}]] trow tcol
 
    # Get in neighborhood of target
    while {abs($hcol - $pcol) > 1 || abs($hrow - $prow) > 1} {
 
        if {$hcol < $tcol && $HOLDER([expr {$hpos+1}]) > 0} {
            set k [expr {$hpos + 1}]
            incr hcol
        } elseif {$hcol > $tcol && $HOLDER([expr {$hpos-1}]) > 0} {
            set k [expr {$hpos - 1}]
            incr hcol -1
        } elseif {$hrow < $trow && $HOLDER([expr {$hpos+4}]) > 0} {
            set k [expr {$hpos + 4}]
            incr hrow
        } else {
            set k [expr {$hpos - 4}]
            incr hrow -1
        }
 
        lappend MOVES $k
        set HOLDER($hpos) $HOLDER($k)
        set HOLDER($k) 0
        set hpos $k
    }
 
    # Now we're 1 away from target. Find shortest path to target
    if {$hpos == $tg} return
    set posCount 0
    set negCount 0
    set j 8
    while {$hpos != $ppos + $roundDisp($j)} {
        incr j
    }
    set k $j
    while {$ppos + $roundDisp($k) != $tg} {
        incr k
        set to [expr {$ppos + $roundDisp($k)}]
 
        if {$to >= 0 && $to < 16 && ($ppos&3)+$roundDx($k) < 4 &&
            ($ppos&3)+$roundDx($k) >= 0 && $HOLDER($to) > 0} {
            incr posCount
        } else {
            incr posCount 50
        }
    }
 
    set k $j
    while {$ppos+$roundDisp($k) != $tg} {
        incr k -1
        set to [expr {$ppos + $roundDisp($k)}]
 
        if {$to >= 0 && $to < 16 && ($ppos&3)+$roundDx($k) < 4 &&
            ($ppos&3)+$roundDx($k) >= 0 && $HOLDER($to) > 0} {
            incr negCount
        } else {
            incr negCount 50
        }
    }
    set l [expr {$posCount <= $negCount ? 1 : -1}]
    while {$hpos != $tg} {
        incr j $l
        set k [expr {$ppos + $roundDisp($j)}]
        lappend MOVES $k
        set HOLDER($hpos) $HOLDER($k)
        set HOLDER($k) 0
        set hpos $k
    }
 }
 ##+##########################################################################
 #
 # MakeDetour -- adds a canned set of moves to our move list
 #
 proc MakeDetour {mList hpos} {
    global HOLDER MOVES
 
    foreach to $mList {
        set HOLDER($hpos) $HOLDER($to)          ;# To goes into hole
        set HOLDER($to) 0                       ;# Mark new hole
        set hpos $to
        lappend MOVES $to
    }
    return $MOVES
 }
 ##+##########################################################################
 #
 # Locate -- returns cell in which a given piece is located
 #
 proc Locate {num} {
    for {set i 0} {$num != $::HOLDER($i)} {incr i} {}
    return $i
 }
 ##+##########################################################################
 #
 # DoMoves -- walks our move list and visually does each move
 #
 proc DoMoves {} {
    set cnt 0
    foreach move $::MOVES {
        if {! [string is integer $move]} {      ;# Not a move, a message
            set ::S(msg) $move
            continue
        }
        incr cnt
        lassign [list [expr {$move / 4}] [expr {$move & 3}]] row col
        Click $::B($row,$col) 1
        update
        after 200
    }
    set ::MOVES {}
    set ::S(msg) "Done in $cnt move[expr {$cnt > 1 ? "s" : ""}]"
 }
 
 ################################################################
 ################################################################
 
 DoDisplay
 NewBoard
 return