[Keith Vetter] 2008-07-28 : While reading Reddit yesterday,
I came across a logic puzzle called '''Nonogram''' that I'd
never seen before.

So, what is a nonogram anyway? Quoting Wikipedia[http://en.wikipedia.org/wiki/Nonogram]:

    Nonograms are picture logic puzzles in which cells
    in a grid have to be colored or left blank
    according to numbers given at the side of the grid
    to reveal a hidden picture. In this puzzle type,
    the numbers measure how many unbroken lines of
    filled-in squares there are in any given row or
    column. For example, a clue of "4 8 3" would mean
    there are sets of four, eight, and three filled
    squares, in that order, with at least one blank
    square between successive groups.

Here's a little program I wrote to help me learn how to
solve these puzzles. Right now it doesn't have many features
but I'll be adding to it (if these puzzle capture my interest).
Others are more than welcome to extend it.

It has 12 canned puzzles to choose from, ranging from trivial
to easy.

----
======
##+##########################################################################
#
# Nonogram -- plays several different stored nonogram puzzles
# by Keith Vetter, July 2008
#
# http://www.puzzle-nonograms.com/
# http://activityworkshop.net/puzzlesgames/nonograms/puzzle1.html
# http://www.nonogrid.com/download.php
# http://twan.home.fmf.nl/blog/haskell/Nonograms.details
#
package require Tk

array set S {title "Tk Nonogram"
    sz .25i
    sz2 .2i
    state go
}
array set COLORS {-1 red 0 white 1 green}

set idx 0
set P([incr idx]) {w 5 h 5 rows {3 4 1 3 2} columns {2 2 {2 2} 4 1}}
set P([incr idx]) {w 5 h 5 rows {{1 3} 3 3 1 2} columns {1 2 {3 1} 3 3}}
set P([incr idx]) {w 5 h 5 rows {3 {1 1 1} 3 {1 1} {1 1}}
    columns {{1 1} {1 2} 3 {1 2} {1 1}}}
set P([incr idx]) {w 10 h 10
    rows {{2 4} {7 2} {3 1} {3 1 1} {1 1 1} {3} {1 1 3} {7} {2 2} {3 1}}
    columns {{5 2} {4 1 2} {3 1} {1 2} {1 1} {1 1 1} {2 1} {1 5} {2 4} {3 6}}
}
set P([incr idx]) {w 10 h 10
    rows {{1 6} {1 4} {1 3} 2 1 2 {6 1} {4 4} {3 5} {1 5}}
    columns {1 2 {3 3} {1 5} {2 3} {3 1 1 2} {4 4} {4 4} 3 4}
}
set P([incr idx]) {w 10 h 10
    rows {5 {1 5} {2 2} {4 1 3} {4 1} 5 4 3 {3 2 1} {3 1}}
    columns {{1 1 5} 7 7 4 {2 2} {4 2} {3 1} {2 1} 4 {3 1}}
}
set P([incr idx]) {w 10 h 10
    rows {5 4 2 2 {7 2} {7 1} 9 6 {3 1} 1}
    columns {{2 2} {4 1} {1 4 1} {2 4} {2 4} {3 4} {3 4} 2 {1 3} 3}
}
set P([incr idx]) {w 10 h 10
    rows {{3 1} {3 1} {3 2 2} {3 2 2} {3 6} {1 1 4} {3 4} {2 1} 2 1}
    columns {5 {3 1} 5 {2 2} 9 8 3 4 3 5}
}
set P([incr idx]) {w 10 h 10
    rows {5 {5 1} {1 2} 3 {1 2} {1 2 1} {4 1} {5 3} {6 2} {4 1}}
    columns {1 2 {1 6} {2 4} {2 4} {2 4} {2 1} {2 1 4} {3 2} {5 1 1}}
}
set P([incr idx]) {w 15 h 15
    rows {{1 3} {1 4} {3 3} {1 9} {2 6 3} {2 7 1} {11 1} {9 1} {11 1} {8 1 2}
        {6 3} {3 1 2} 1 2 {3 1}}
    columns {{2 4 1 2} {3 3 2} {6 1} 6 {2 7} {2 7 1 1} {12} 9 8 {6 1}
        9 {2 1} 3 {2 1 1} {7 1}}
}
set P([incr idx]) {
    w 20
    h 10
    rows {{3 3 2} {5 3 2} {2 2 2 2} {2 2 2 2} {3 2 2 1 2} {7 3 3 3} {7 10} {3 3 9} {2 2 3 3} {2 3 2 1}}
    columns {{3} {6} {7} {7} {2 2} {3 2} {7} {1 7} {2 3} {6 1} {7} {5} {4} {4} {4} {4} {4} {4} {8} {7}}
}
set P([incr idx]) {
    w 15
    h 15
    rows {{2 1} {2 2} {4} {3} {5} {7 2} {2 8 1} {4 3 1} {3 2 1} {3 1} {3 1} {4} {3 1} {3 3} {2 4}}
    columns {{2} {3} {3} {5} {2 3} {2 3} {1 2 3} {1 10} {1 5 2}
        {7} {5} {4 1} {3 2 2} {1 3} {3 2}}
}

##+##########################################################################
#
# DoDisplay -- Makes our display
#
proc DoDisplay {} {
    global S

    wm title . $S(title)
    frame .buttons -bd 2 -relief ridge
    label .title -font {Helvetica 24 bold} -justify c -textvariable ::S(puzzle)
    pack .title -side top -fill x
    pack .buttons -side bottom -fill x

    ::ttk::button .buttons.restart -text Restart -command Restart
    ::ttk::button .buttons.undo -text "Undo" -command Undo

    set values {}
    foreach v [lsort -dictionary [array names ::P]] {
        lappend values "Puzzle $v"
    }
    ::ttk::combobox .buttons.cb -values $values -textvariable ::S(puzzle) \
        -state readonly -exportselection 0 -width 12 -justify center -height 12
    eval pack [winfo child .buttons] -side left -expand 1 -pady .1i

    foreach tr [trace vinfo ::S(puzzle)] {
        eval trace vdelete ::S(puzzle) $tr
    }
    trace variable ::S(puzzle) w PickPuzzle
    set ::S(puzzle) [lindex $values [expr {int(rand()*[llength $values])}]]
}
##+##########################################################################
#
# PickPuzzle -- Changes current puzzle
#
proc PickPuzzle {var1 var2 op} {
    set n [scan $::S(puzzle) "Puzzle %d" who]
    if {$n == 1} {
        CreateBoard $who
    }
}
##+##########################################################################
#
# CreateBoard -- Creates the actual game board
#
proc CreateBoard {{n ""}} {
    global S B

    if {$n ne ""} { ReadBoard $n }
    destroy .b
    frame .b -bd 2 -relief solid -pady .125i -padx .125i
    pack .b -side top -expand 1 -pady {0 .2i} -padx .2i

    set colSpan [expr {$B(w) + 1 + $B(w)/5}]
    set rowSpan [expr {$B(h) + 1 + $B(h)/5}]

    set gCol 0
    for {set col 0} {$col < $B(w)} {incr col} {
        incr gCol
        if {$col > 0 && ($col % 5) == 0} {
            frame .b.xx$gCol -bd 2 -relief solid -bg black
            grid .b.xx$gCol -row 0 -column $gCol -rowspan $rowSpan -sticky ns
            incr gCol
        }

        set w .b.h_,$col
        set txt [lindex $B(columns) $col]
        set txt [join [split $txt] \n]
        label $w -text $txt -anchor s -relief solid -bd 1 -padx 3 -bg white
        grid $w -row 0 -column $gCol -sticky news
        grid columnconfigure .b $gCol -minsize $S(sz)
    }
    set gRow 0
    for {set row 0} {$row < $B(h)} {incr row} {
        incr gRow
        if {$row > 0 && ($row % 5) == 0} {
            frame .b.rr$gRow -bd 2 -relief solid -bg black
            grid .b.rr$gRow -row $gRow -columnspan $colSpan -sticky ew
            incr gRow
        }
        set w .b.h$row,_
        set txt [lindex $B(rows) $row]
        label $w -text $txt -anchor e -bd 1 -relief solid -bg white
        grid $w -row $gRow -column 0 -sticky news
        grid rowconfigure .b $gRow -minsize $S(sz)
    }
    grid columnconfigure .b 0 -minsize $S(sz2)

    set gRow 0
    for {set row 0} {$row < $B(h)} {incr row} {
        incr gRow
        if {$row > 0 && ($row % 5) == 0} {
            incr gRow
        }
        set gCol 0
        for {set col 0} {$col < $B(w)} {incr col} {
            incr gCol
            if {$col > 0 && ($col % 5) == 0} {
                incr gCol
            }
            set w .b.c$gRow,$gCol
            canvas $w -bd 1 -relief solid -highlightthickness 0 \
                -width 0 -height 0 -bg white
            bind $w <Button-1> [list LeftClick $row $col]
            bind $w <Button-2> [list MiddleClick $row $col]
            bind $w <Button-3> [list RightClick $row $col]
            grid $w -row $gRow -column $gCol -sticky news
            set B(b,$row,$col) 0
            set B(w,$row,$col) $w
        }
    }

    set S(state) go
    set B(undo) {}
    bind all <Control-Key-z> Undo
}
##+##########################################################################
#
# LeftClick -- Handles mouse left click
#
proc LeftClick {row col} {
    global B
    if {$::S(state) ne "go"} return

    lappend B(undo) [list $row $col $B(b,$row,$col)]
    set B(b,$row,$col) [expr {$B(b,$row,$col) > 0 ? 0 : 1}]
    DrawCell $row $col
    IsSolved
}
##+##########################################################################
#
# RightClick -- Handles mouse right click
#
proc RightClick {row col} {
    global B
    if {$::S(state) ne "go"} return

    lappend B(undo) [list $row $col $B(b,$row,$col)]
    set B(b,$row,$col) [expr {$B(b,$row,$col) < 0 ? 0 : -1}]
    DrawCell $row $col
    IsSolved
}
##+##########################################################################
#
# MiddleClick -- Handles mouse middle click -- clear entry
#
proc MiddleClick {row col} {
    global B
    if {$::S(state) ne "go"} return

    if {$B(b,$row,$col) != 0} {
        lappend B(undo) [list $row $col $B(b,$row,$col)]
    }

    set B(b,$row,$col) 0
    DrawCell $row $col
    IsSolved
}
##+##########################################################################
#
# Undo -- Undo last moves
#
proc Undo {} {
    global B

    if {$B(undo) eq ""} return
    if {$::S(state) ne "go"} return

    set move [lindex $B(undo) end]
    set B(undo) [lrange $B(undo) 0 end-1]

    foreach {row col val} $move break
    set B(b,$row,$col) $val

    DrawCell $row $col
    IsSolved
}
##+##########################################################################
#
# DrawCell -- Draws one cell on/off/empty
#
proc DrawCell {row col} {
    global B

    set w $B(w,$row,$col)
    set cw [winfo width $w]
    set ch [winfo height $w]
    set x0 3
    set y0 3
    set x1 [expr {$cw - $x0 - 1}]
    set y1 [expr {$ch - $y0 - 1}]

    $w delete all
    if {$B(b,$row,$col) > 0} {
        set x0 3
        set y0 3
        set x1 [expr {$cw - $x0 - 1}]
        set y1 [expr {$ch - $y0 - 1}]
        $w create rect $x0 $y0 $x1 $y1 -fill black
    } elseif {$B(b,$row,$col) < 0} {
        set x0 8
        set y0 8
        set x1 [expr {$cw - $x0 - 1}]
        set y1 [expr {$ch - $y0 - 1}]
        $w create line $x0 $y0 $x1 $y1 -width 2 -fill red
        $w create line $x0 $y1 $x1 $y0 -width 2 -fill red
    }
}
##+##########################################################################
#
# IsSolved -- Checks if puzzle is solved. Also highlights
# solved rows
#
proc IsSolved {} {
    global B S

    set solved 1
    for {set row 0} {$row < $B(h)} {incr row} {
        set n [Validate row $row]
        if {$n != 1} { set solved 0 }
    }
    for {set col 0} {$col < $B(w)} {incr col} {
        set n [Validate column $col]
        if {$n != 1} { set solved 0 }
    }
    if {$solved} {
        set S(state) solved
        foreach w [info commands .b.c*] {
            $w config -bg yellow
        }
    }
}
##+##########################################################################
#
# Validate -- Checks && highlights if a given row/column is done
#
proc Validate {what who} {
    set valid [IsValid $what $who]

    if {$what eq "row"} {
        set w .b.h$who,_
    } else {
        set w .b.h_,$who
    }
    $w config -bg $::COLORS($valid)
    return $valid
}
##+##########################################################################
#
# IsValid -- Checks if a row/column is done
#  1 if done; -1 if bad; 0 otherwise
#
proc IsValid {what who} {
    global B

    set a {}
    if {$what eq "row"} {
        for {set col 0} {$col < $B(w)} {incr col} {
            lappend a [expr {$B(b,$who,$col) > 0}]
        }
        set toMatch [lindex $B(rows) $who]
    } else {
        for {set row 0} {$row < $B(h)} {incr row} {
            lappend a [expr {$B(b,$row,$who) > 0}]
        }
        set toMatch [lindex $B(columns) $who]
    }
    set cnt1 [expr [join $a +]]
    set cnt2 [expr [join $toMatch +]]
    if {$cnt1 < $cnt2} { return 0 }
    if {$cnt1 > $cnt2} { return -1 }

    set b {}
    set last 0
    set cnt 0
    foreach item $a {
        if {$item == 1} {
            incr cnt
        } elseif {$last == 1} {
            lappend b $cnt
            set cnt 0
        }
        set last $item
    }
    if {$cnt > 0} {
        lappend b $cnt
    }
    if {$b eq $toMatch} { return 1}
    return 0
}
##+##########################################################################
#
# Restart -- Can you guess?
#
proc Restart {} {
    global B
    for {set row 0} {$row < $B(h)} {incr row} {
        for {set col 0} {$col < $B(w)} {incr col} {
            set B(b,$row,$col) 0
            DrawCell $row $col
            $B(w,$row,$col) config -bg white
        }
    }
    set ::S(state) go
    IsSolved
}
##+##########################################################################
#
# ReadBoard -- Stub for now, later we can read a file
#
proc ReadBoard {n} {
    global B P
    array unset B
    array set B $P($n)
}
################################################################
DoDisplay

return

======
----
!!!!!!
%| [Category Games] | [Category Application] 
!!!!!!