Keith Vetter 2008-07-28 : While reading Reddit yesterday, I came across a logic puzzle called Nonogram that I'd never seen before.
What is a nonogram anyway? Quoting Wikipedia[L1 ]:
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 8.5 ; # This uses ttk/tile
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