[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[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. ---- [KPV] 2008-08-02 : Here's an update of the nonogram program. I included over 30 more built in puzzles, a way to load arbitrary puzzles and a solver. I had a lot of fun solving 10x10 puzzles, but for larger puzzles I got stuck. I don't know how humans can figure out that 7 3 3 3 on a 20 wide board has some fixed positions. So I wrote a routine that will solve any row or column. The algorithm it uses is to enumerate all legal moves for a set of pips and a given strip, then loop through all cells looking for ones which are either on or off in every legal move. Those cells must therefore be on or off. It turns out [AK] had similar ideas and he sent me his version of the solver. The GUI lets you invoke this solve algorithm in three ways: clicking on an arrow next to a row or column will try to solve it. ''One Pass'' on the hint menu runs the algorithm once on each row and column. ''Solve'' runs the One Pass routine repeatedly until the puzzle is solved or no progress is made. Note, some puzzles are not solvable by this technique--they require what they call ''advanced reasoning'' or ''searching for contradictions''; more charitably you could call it ''backtracking''; I call it ''guessing''. The ''soccer'' puzzle in this program requires such techniques. ---- [KPV] 2008-08-05 : Third iteration of this program and I finally got it to where I like playing it--in fact I've found I've wasted a too much time playing it. For me, 10x10 is the most fun size to play: 5x5 is trivial and 15x15 is just too hard. I've added code to create new puzzles of various size. It simple fills in a board with random positions at about 60% density. A few of these random puzzles are not solvable, but most are. ---- ====== ##+########################################################################## # # Nonogram -- plays several different stored nonogram puzzles # by Keith Vetter, July 2008 # # http://www.comp.lancs.ac.uk/~ss/nonogram/ # 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 # # Todo: # turn into full solver # read from file # titles for puzzle # package require Tk package require tile array set S {title "Tk Nonogram" sz .25i sz2 .2i state go delay 100 delay2 200 } array set COLORS {-1 red 0 white 1 green} catch {font delete lblFont} font create lblFont -family "Times Roman" -size 8 -weight bold ##+########################################################################## # # DoDisplay -- Makes our display # proc DoDisplay {} { global S wm title . $S(title) DoMenus label .title -font {Helvetica 24 bold} -justify c -textvariable ::B(title) frame .buttons -bd 2 -relief ridge frame .buttons2 -bd 0 label .msg -textvariable ::S(msg) pack .title -side top -fill x pack .buttons -side bottom -fill x pack .buttons2 -side bottom -fill x -padx .2i -pady {0 .2i} pack .msg -in .buttons2 -side bottom ::ttk::button .buttons.new -text "New" -command NewGame ::ttk::button .buttons.restart -text Restart -command Restart set values [GetTitles] ::ttk::combobox .buttons.cb -values $values -textvariable ::S(puzzle) \ -state readonly -exportselection 0 -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]-10))}]] update bind all Undo bind all ReadFile bind all OneHint bind all OnePass bind all SolveIt bind all FillSpaces bind all NewGame bind all {console show} } ##+########################################################################## # # DoMenus -- isn't installing menus really verbose and clunky? # proc DoMenus {} { option add *Menu.tearOff 0 . config -menu [menu .menu] menu .menu.game .menu add cascade -label "Game" -underline 0 -menu .menu.game .menu.game add command -label "Restart" -command Restart -underline 0 .menu.game add command -label "Undo" -command Undo -underline 0 \ -accelerator "Ctrl+Z" .menu.game add separator .menu.game add command -label "Open..." -command ReadFile -underline 0 \ -accelerator "Ctrl+O" .menu.game add separator .menu.game add command -label "Exit" -underline 1 -command exit menu .menu.cheat .menu add cascade -label "Hint" -underline 0 -menu .menu.cheat .menu.cheat add command -label "Hint" -command OneHint -underline 0 \ -accelerator "Ctrl+H" .menu.cheat add command -label "One Pass" -command OnePass -underline 0 \ -accelerator "Ctrl+A" .menu.cheat add command -label "Solve" -command SolveIt -underline 0 \ -accelerator "Ctrl+S" menu .menu.help .menu add cascade -label "Help" -underline 0 -menu .menu.help .menu.help add command -label "About" -underline 0 -command About } ##+########################################################################## # # PickPuzzle -- Changes current puzzle # proc PickPuzzle {var1 var2 op} { set n [scan $::S(puzzle) "Random %dx%d" width height] if {$n == 2} { Random $width $height return } set n [lsearch $::S(titles) $::S(puzzle)] if {$n != -1} { CreateBoard [expr {$n - 5}] } } ##+########################################################################## # # NewGame -- Starts a new game. If we're doing a random puzzle, # pick another random puzzle, otherwise pick a random stored # puzzle. # proc NewGame {} { global S set n [scan $::S(puzzle) "Random %dx%d" width height] if {$n == 2} { Random $width $height return } set names [array names P] set who [lindex $names [expr {int(rand()*[llength $names])}]] 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 -padx .2i set colSpan [expr {$B(width) + 1 + $B(width)/5}] set rowSpan [expr {$B(height) + 1 + $B(height)/5}] # Draw the top 2 header rows set gCol 1 for {set col 0} {$col < $B(width)} {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 1 -column $gCol -rowspan $rowSpan -sticky ns incr gCol } set w .b.a_,$col button $w -image ::bmp::darrow -bd 0 -command [list SolveCol $col] grid $w -row 0 -column $gCol -sticky ew 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 \ -font lblFont bind $w <3> [list SolveCol $col] grid $w -row 1 -column $gCol -sticky news grid columnconfigure .b $gCol -minsize $S(sz) } grid columnconfigure .b 1 -minsize $S(sz) # Draw the left 2 header columns set gRow 1 for {set row 0} {$row < $B(height)} {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 -column 1 -columnspan $colSpan -sticky ew incr gRow } set w .b.a$row,_ button $w -image ::bmp::rarrow -bd 0 -command [list SolveRow $row] grid $w -row $gRow -column 0 -sticky ns set w .b.h$row,_ set txt [lindex $B(rows) $row] label $w -text " $txt" -anchor e -bd 1 -relief solid -bg white \ -font lblFont bind $w <3> [list SolveRow $row] grid $w -row $gRow -column 1 -sticky news grid rowconfigure .b $gRow -minsize $S(sz) } grid columnconfigure .b 0 -minsize $S(sz2) # Draw the actual cells set gRow 1 for {set row 0} {$row < $B(height)} {incr row} { incr gRow if {$row > 0 && ($row % 5) == 0} { incr gRow } set gCol 1 for {set col 0} {$col < $B(width)} {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 [list LeftClick $row $col] bind $w [list MiddleClick $row $col] bind $w [list RightClick $row $col] bind $w [list DoTooltip $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) {} } ##+########################################################################## # # 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 DoTooltip $row $col } ##+########################################################################## # # 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 DoTooltip $row $col } ##+########################################################################## # # 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 DoTooltip $row $col } ##+########################################################################## # # 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 {{autoFill 0}} { global B S set solved 1 for {set row 0} {$row < $B(height)} {incr row} { set n [Validate row $row] if {$n != 1} { set solved 0 } if {$n == 1 && $autoFill} { AutoFill row $row } } for {set col 0} {$col < $B(width)} {incr col} { set n [Validate column $col] if {$n != 1} { set solved 0 } if {$n == 1 && $autoFill} { AutoFill col $col } } 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(width)} {incr col} { lappend a [expr {$B(b,$who,$col) > 0}] } set toMatch [lindex $B(rows) $who] } else { for {set row 0} {$row < $B(height)} {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 || $b eq {}} { 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(height)} {incr row} { for {set col 0} {$col < $B(width)} {incr col} { set B(b,$row,$col) 0 DrawCell $row $col $B(w,$row,$col) config -bg white } } set ::S(state) go IsSolved } ##+########################################################################## # #FillSpaces -- Puts in all empty spaces on valid lines # proc FillSpaces {} { global B for {set row 0} {$row < $B(height)} {incr row} { if {[IsValid row $row] == 1} { for {set col 0} {$col < $B(width)} {incr col} { if {$B(b,$row,$col) == 0} { RightClick $row $col } } } } for {set col 0} {$col < $B(width)} {incr col} { if {[IsValid col $col] == 1} { for {set row 0} {$row < $B(height)} {incr row} { if {$B(b,$row,$col) == 0} { RightClick $row $col } } } } } ##+########################################################################## # # ReadBoard -- Stub for now, later we can read a file # proc ReadBoard {n} { unset -nocomplain ::B array set ::B $::P($n) } ##+########################################################################## # # ReadFile -- Read and load a nonogram file # proc ReadFile {{fname ""}} { if {$fname eq ""} { set types {{{Nonogram Files} {.non}} {{All Files} *}} set fname [tk_getOpenFile -defaultextension [lindex $types 0 1] \ -title "Nonogram Open File" -filetypes $types] if {$fname eq ""} return } set arr [_ReadFile $fname] unset -nocomplain ::B array set ::B $arr set ::S(puzzle) "" CreateBoard } ##+########################################################################## # # _ReadFile -- Reads and parses a nonogram file # format: http://www.comp.lancs.ac.uk/~ss/nonogram/fmt2 # proc _ReadFile {fname} { set fin [open $fname r] set lines [split [read $fin] \n]; list close $fin unset -nocomplain BB set BB(width) -1 set BB(height) -1 set BB(rows) {} set BB(columns) {} set BB(title) [file rootname [file tail $fname]] set state normal foreach line $lines { set line [string trim $line] if {$line eq ""} { set state normal continue } if {$state eq "normal"} { if {$line eq "rows"} { set state rows } elseif {$line eq "columns"} { set state columns } else { regexp {^(.*?)\s+(.*?)\s*$} "$line " => name value set BB($name) [string trim $value {""}] } } else { lappend BB($state) [split $line ","] } } if {[llength $BB(rows)] != $BB(height)} { error "row data is wrong: got [llength $BB(rows)], wanted $BB(height)" } if {[llength $BB(columns)] != $BB(width)} { error "column data is wrong: got [llength $BB(columns)], wanted $BB(width)" } return [array get BB] } ##+########################################################################## # # UnRead -- Turns board into our internal dictionary format. Used so # that we can open a nonogram file, call this routine and embed the # puzzle into the program. # proc UnRead {} { global B set result "set P(\[incr idx]) \{ " append result "width $B(width) height $B(height)\n" if {[info exists B(title)] && $B(title) ne ""} { append result " title $B(title)\n" } append result " rows \{" $B(rows) "\}\n" append result " columns \{" $B(columns) "\}\n" append result "\}\n" clipboard clear clipboard append $result return $result } ##+########################################################################## # # AutoFill -- Fills in blanks w/ X's on complete rows # proc AutoFill {what who} { global B if {$what eq "row"} { set row $who for {set col 0} {$col < $B(width)} {incr col} { if {$B(b,$row,$col) == 0} { set B(b,$row,$col) -1 DrawCell $row $col } } } else { set col $who for {set row 0} {$row < $B(height)} {incr row} { if {$B(b,$row,$col) == 0} { set B(b,$row,$col) -1 DrawCell $row $col } } } } ##+########################################################################## # # Solve -- Brute force try all possible solutions for this # combination of pips and this strip of the board. Returns # new strip w/ forced on and forced off locations set. # proc Solve {pips board} { set all [AllLegal $pips $board] if {$all eq ""} { return "" } set cnt [llength $all] array unset CNTS ;# For each position, count how many moves have pip there foreach sln $all { foreach pip $pips pos $sln { for {set i 0} {$i < $pip} {incr i} { set n [expr {$pos + $i}] incr CNTS($n) } } } # Find all positions w/ 0 or $cnt on set result {} set progress {} for {set i 0} {$i < [llength $board]} {incr i} { set there [lindex $board $i] if {! [info exists CNTS($i)]} { set now -1 } elseif {$CNTS($i) == $cnt} { set now 1 } else { set now 0 } lappend result $now if {$there != $now} { lappend progress $i } } return [list $result $progress] } ##+########################################################################## # # AllLegal -- Returns list of all legal moves for this combination # of pips on this board strip. Works by placing first pip and recursively # calling itself for the remainder. Not very optimized right now. # proc AllLegal {pips board} { # Optimization: # start at first on cell - pip # end at boardLen - pip OR room for $rest # if we hit a X we could skip forward more than 1 set rest [lassign $pips pip] set boardLen [llength $board] set where {} for {set pos 0} {$pos + $pip <= $boardLen} {incr pos} { if {[WillFit $pos $pip $board]} { set start [expr {$pos+$pip+1}] set b [lrange $board $start end] if {$rest eq {}} { if {[lsearch $b 1] == -1} { lappend where $pos } } else { set subs [AllLegal $rest $b] foreach sub $subs { set sln $pos foreach item $sub { lappend sln [expr {$item + $start}] } lappend where $sln } } } if {[lindex $board $pos] == 1} break ;# Can't leave pip to our left } return $where } ##+########################################################################## # # WillFit -- Returns true if there is room to put $pip pips at $pos # proc WillFit {pos pip board} { if {[lindex $board $pos] == -1} { return 0} ;# Quick check on starting pos if {[lindex $board $pos-1] == 1} { return 0};# One before if {[lindex $board $pos+$pip] == 1} { return 0} ;# One after set b [lrange $board $pos [expr {$pos + $pip - 1}]] set n [lsearch $b -1] if {$n != -1} { return 0} return 1 } proc OneHint {} { global B S if {$S(state) ne "go"} return unset -nocomplain all for {set row 0} {$row < $B(height)} {incr row} { set valid [IsValid row $row] if {$valid == 1} continue ;# Solved already if {$valid < 0} { set ::S(msg) "Bad Board"; return } set all([expr {rand()}]) [list row $row] } for {set col 0} {$col < $B(width)} {incr col} { set valid [IsValid col $col] if {$valid == 1} continue ;# Solved already if {$valid < 0} { set ::S(msg) "Bad Board"; return } set all([expr {rand()}]) [list col $col] } # Go through random list and try until ok foreach idx [array names all] { foreach {what who} $all($idx) break if {$what eq "row"} { set w .b.a${who},_ set cmd SolveRow } else { set w .b.a_,${who} set cmd SolveCol } set clr [$w cget -bg] $w config -bg cyan set progress [$cmd $who] if {$progress eq "bad"} { set ::S(msg) "Bad board" $w config -bg $clr return } if {$progress ne {}} { $w config -bg $clr return } update after $::S(delay2) { set ::tick . } vwait ::tick $w config -bg $clr } set ::S(msg) "No progress" } ##+########################################################################## # # OnePass -- Does one pass over every row/column trying to # solve each one. Not very smart about skipping ones which # are already solved or haven't changed from last time. # proc OnePass {} { if {$::S(state) ne "go"} {return 0} set changed 0 for {set row [expr {$::B(height)-1}]} { $row >= 0} {incr row -1} { set valid [IsValid row $row] if {$valid == 1} continue if {$valid == -1} { set ::S(msg) "Bad board" return 0 } set w .b.a${row},_ set clr [$w cget -bg] $w config -bg cyan set progress [SolveRow $row] if {$progress eq "bad"} { set ::S(msg) "Bad board" $w config -bg $clr return 0 } update after $::S(delay) { set ::tick . } vwait ::tick if {$progress ne {}} { incr changed } #if {$progress ne {}} {puts "progress at row $row => '$progress'"} $w config -bg $clr } for {set col 0} {$col < $::B(width)} {incr col} { set valid [IsValid col $col] if {$valid == 1} continue if {$valid == -1} { set ::S(msg) "Bad board" return 0 } set w .b.a_,${col} set clr [$w cget -bg] $w config -bg cyan set progress [SolveCol $col] if {$progress eq "bad"} { set ::S(msg) "Bad board" $w config -bg $clr return 0 } update after $::S(delay) { set ::tick . } vwait ::tick if {$progress ne {}} { incr changed } #if {$progress ne {}} {puts "progress at column $col => '$progress'"} $w config -bg $clr } if {! $changed} { set ::S(msg) "No progress" } return $changed } proc SolveIt {} { if {$::S(state) ne "go"} return while {1} { set n [OnePass] if {! $n} break if {$::S(state) ne "go"} return } puts "done w/ SolveIt" } ##+########################################################################## # # SolveRow -- Gets solution to this row and puts in the new info # proc SolveRow {row} { foreach {sln progress} [_SolveRow $row] break if {! [info exists sln] || $sln eq {}} { ;# BAD set w .b.h$row,_ $w config -bg $::COLORS(-1) return bad } foreach col $progress { set want [lindex $sln $col] if {$want == 1} { LeftClick $row $col } if {$want == -1} { RightClick $row $col } } IsSolved 1 return $progress } ##+########################################################################## # # _SolveRow -- Returns solution for this row # proc _SolveRow {row} { global B set pips [lindex $B(rows) $row] set board {} for {set col 0} {$col < $B(width)} {incr col} { lappend board $B(b,$row,$col) } return [Solve $pips $board] } ##+########################################################################## # # SolveCol -- Gets solution for this column and puts in the new info # proc SolveCol {col} { foreach {sln progress} [_SolveCol $col] break if {! [info exists sln] || $sln eq {}} { ;# BAD set w .b.h_,$col $w config -bg $::COLORS(-1) return bad } foreach row $progress { set want [lindex $sln $row] if {$want == 1} { LeftClick $row $col } if {$want == -1} { RightClick $row $col } } IsSolved 1 return $progress } ##+########################################################################## # # _SolveCol -- Returns solution for this column # proc _SolveCol {col} { global B set pips [lindex $B(columns) $col] set board {} for {set row 0} {$row < $B(height)} {incr row} { lappend board $B(b,$row,$col) } return [Solve $pips $board] } ##+########################################################################## # # DoTooltip -- Displays row and column of on blocks # proc DoTooltip {row col} { global S B set rowLen [set colLen 0] if {$B(b,$row,$col) == 1} { set rowLen 1 for {set col2 [expr {$col+1}]} {$col2 < $B(width)} {incr col2} { if {$B(b,$row,$col2) != 1} break incr rowLen } for {set col2 [expr {$col-1}]} {$col2 >= 0} {incr col2 -1} { if {$B(b,$row,$col2) != 1} break incr rowLen } set colLen 1 for {set row2 [expr {$row+1}]} {$row2 < $B(height)} {incr row2} { if {$B(b,$row2,$col) != 1} break incr colLen } for {set row2 [expr {$row-1}]} {$row2 >= 0} {incr row2 -1} { if {$B(b,$row2,$col) != 1} break incr colLen } } set ::S(msg) "($rowLen,$colLen)" } ##+########################################################################## # # GetTitles -- Returns list of puzzle titles for our combobox # proc GetTitles {} { set values {"Random 5x5" "Random 10x10" "Random 15x15" "Random 20x20" "Random 25x25"} foreach v [lsort -dictionary [array names ::P]] { array set tmp $::P($v) if {! [info exists tmp(title)]} { set tmp(title) "Puzzle $v ($tmp(width)x$tmp(height))" lappend ::P($v) title $tmp(title) } lappend values $tmp(title) array unset tmp } set ::S(titles) $values return $values } ##+########################################################################## # # ReverseBoard -- Takes current board state and turns it into # our internal puzzle form, thereby letting you create your own # puzzles. No user interface nor any way of setting size. # proc ReverseBoard {} { global B unset -nocomplain PP set rows [set cols {}] for {set row 0} {$row < $B(height)} {incr row} { lappend rows [Board2Pips row $row] } for {set col 0} {$col < $B(width)} {incr col} { lappend columns [Board2Pips col $col] } set result "set P(\[incr idx]) \{ " append result "width $B(width) height $B(height)\n" append result " rows \{" $rows "\}\n" append result " columns \{" $columns "\}\n" append result "\}\n" clipboard clear clipboard append $result return $result } ##+########################################################################## # # Board2Pips -- Turns row or column into a pip count # proc Board2Pips {what who} { set strip {} if {$what eq "row"} { for {set col 0} {$col < $::B(width)} {incr col} { lappend strip [expr {$::B(b,$who,$col) > 0}] } } else { for {set row 0} {$row < $::B(height)} {incr row} { lappend strip [expr {$::B(b,$row,$who) > 0}] } } set pips {} set last 0 set cnt 0 foreach item $strip { if {$item == 1} { incr cnt } elseif {$last == 1} { lappend pips $cnt set cnt 0 } set last $item } if {$cnt > 0} {lappend pips $cnt} if {$pips eq {}} {set pips 0} return $pips } proc About {} { set txt "Nonograms\nby Keith Vetter, July 2008\n\n" append txt "Nonograms are picture logic puzzles in which cells\n" append txt "in a grid have to be colored or left blank\n" append txt "according to numbers given at the side of the grid\n" append txt "to reveal a hidden picture.\n\n" append txt "In this puzzle type, the numbers measure how many\n" append txt "unbroken lines of filled-in squares there are in\n" append txt "any given row or column. For example, a clue of '4\n" append txt "8 3' would mean there are sets of four, eight, and\n" append txt "three filled squares, in that order, with at least\n" append txt "one blank square between successive groups.\n" append txt "(from wikipedia)" tk_messageBox -message $txt -title "About $::S(title)" } proc Random {w h {density .6}} { global B unset -nocomplain B set B(width) $w set B(height) $h for {set row 0} {$row < $h} {incr row} { for {set col 0} {$col < $w} {incr col} { set B(b,$row,$col) [expr {rand() < $density}] } } set B(title) "Random" set B(rows) [set B(cols) {}] for {set row 0} {$row < $B(height)} {incr row} { lappend B(rows) [Board2Pips row $row] } for {set col 0} {$col < $B(width)} {incr col} { lappend B(columns) [Board2Pips col $col] } CreateBoard } ################################################################# # # Static global data # image create bitmap ::bmp::rarrow -data { #define right_width 11 #define right_height 11 static char right_bits = { 0x00, 0x00, 0x20, 0x00, 0x60, 0x00, 0xe0, 0x00, 0xfc, 0x01, 0xfc, 0x03, 0xfc, 0x01, 0xe0, 0x00, 0x60, 0x00, 0x20, 0x00, 0x00, 0x00 } } image create bitmap ::bmp::darrow -data { #define down_width 11 #define down_height 11 static char down_bits = { 0x00, 0x00, 0x00, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0xfe, 0x03, 0xfc, 0x01, 0xf8, 0x00, 0x70, 0x00, 0x20, 0x00, 0x00, 0x00 } } image create bitmap ::bmp::blank -data { #define blank_width 11 #define blank_height 11 static char right_bits = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 } } set idx -1 #_set P([incr idx]) {width 5 height 5 title Easy rows {3 4 1 3 2} columns {2 2 {2 2} 4 1}} #_set P([incr idx]) {width 5 height 5 rows {{1 3} 3 3 1 2} columns {1 2 {3 1} 3 3}} #_set P([incr idx]) {width 5 height 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]) {width 5 height 5 rows {3 {3 1} 3 1 {1 1}} columns {{2 1} 2 {3 1} 1 3}} #_set P([incr idx]) {width 5 height 5 rows {3 {3 1} 3 1 {1 1}} columns {{2 1} 2 {3 1} 1 3}} #_set P([incr idx]) {width 5 height 5 rows {{1 2} 2 {1 1} {1 2} 3} columns {1 4 1 {1 3} {1 2}}} #_set P([incr idx]) {width 5 height 5 rows {{2 2} {3 1} {1 2} 1 1} columns {4 {2 1} 1 {1 1} 3}} #_set P([incr idx]) {width 10 height 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]) {width 10 height 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]) {width 10 height 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]) {width 10 height 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]) {width 10 height 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]) {width 10 height 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]) { width 10 height 10 #_ rows {7 3 {1 2} 1 3 {4 2} {4 2} {5 4} {4 3} {2 1 2}} #_ columns {{1 6} {1 6} {1 5} {1 1 5} {2 1} 3 {4 1} 2 5 5} #_} #_set P([incr idx]) { width 10 height 10 #_ rows {4 5 2 3 {1 1} {3 6} {2 4} {3 4} {1 4} {3 4}} #_ columns {{1 5} {1 1 3} {4 1 1 1} {4 1} {2 1 1} {1 1} 5 6 5 5} #_} #_set P([incr idx]) { width 10 height 10 #_ rows {{1 3} {1 3} {1 4} {1 6} 3 3 {1 1 3} {3 3} {5 2} 6} #_ columns {{4 1} 2 2 4 {1 3} {1 4} 2 8 9 9} #_} #_set P([incr idx]) { width 10 height 10 #_ rows {{3 3} 3 5 {2 2} {1 5} 4 {6 1} 5 {4 1} {2 3}} #_ columns {{5 4} {4 4} {3 3} {1 1 3} 6 4 {1 2} {1 3 1} {1 1} 2} #_} #_set P([incr idx]) { width 10 height 10 #_ rows {{2 3} {1 5} 5 {4 2} 2 {3 4} {2 4} {2 4} {1 4} {1 1}} #_ columns {{2 6} {1 4} 1 {1 1} 3 4 {4 5} {3 4} {2 4} {1 4}} #_} #_set P([incr idx]) { width 10 height 10 #_ rows {{2 1 2} {2 1 1 2} {2 4} 2 {1 3} 8 {2 3} {3 2} {3 2} 4} #_ columns {3 {3 1} {2 2} {2 5} 5 {1 1 1 1} {2 1} {3 3} {3 5} {1 5}} #_} #_set P([incr idx]) { width 10 height 10 #_ rows {5 5 4 7 {1 4} 3 {3 2} {2 2} {2 3} {4 3}} #_ columns {{2 1} {3 1 1} {3 4} {4 3} {5 1} 1 2 {3 2} 7 7} #_} #_set P([incr idx]) { width 10 height 10 #_ rows {{3 2} {1 3 2} {3 1} 2 {3 3} {2 5} {2 6} {1 5} {1 3} {1 1}} #_ columns {{4 4} 5 {3 2} 2 {2 3} 5 6 5 {2 3} {3 1}} #_} #_set P([incr idx]) { width 10 height 10 #_ rows {{1 2} {1 2} {1 4} {1 3} {5 3} {5 1} {6 1} 5 {3 1} {4 1}} #_ columns {{2 2 1} {3 1} 8 6 {1 1 5} {3 2} {3 2} 3 {2 2} 3} #_} #_set P([incr idx]) { width 10 height 10 #_ rows {4 {1 1} 1 {1 3} {3 4} 8 8 {1 4} {3 3} {3 2}} #_ columns {{4 2} {3 2} 6 2 6 {1 4} {2 5} {1 5} {1 3} 3} #_} #_set P([incr idx]) { width 10 height 10 #_ rows {{5 2} {5 2} {2 2} {2 2} {1 3} {1 5} 5 {2 1 1 1} 4 4} #_ columns {{2 3} {2 3} {4 2} {6 3} 2 3 2 4 7 7} #_} #_set P([incr idx]) { width 10 height 10 #_ rows {{5 2} {4 1} 2 {3 2} {4 2} 9 {2 1 3} 3 {1 3} {1 2}} #_ columns {{2 2} {2 1} {2 4} {2 4} {1 3} 3 {1 1} {1 4} 9 8} #_} #_set P([incr idx]) { width 10 height 10 #_ rows {4 4 {4 1} {1 1 4} {1 4 1} {2 1} {1 2 2} {1 2} {1 1 4} 8} #_ columns {4 {3 3} {5 1} {3 1} {3 2} {4 1} {3 1 2} {2 2} 4 6} #_} #_set P([incr idx]) { width 10 height 10 #_ rows {1 {2 1} {1 2} {2 2 1} {2 2} {5 2} {7 1} {1 6} {6 1} {2 2 1}} #_ columns {{4 3} {1 1 1 2} 4 4 8 9 3 3 2 {4 1}} #_} #_set P([incr idx]) { width 10 height 10 #_ rows {{1 1} 1 {1 2 1} 6 7 7 6 {1 4} 5 7} #_ columns {{1 1 1} 1 2 {2 2} 7 {5 2} 8 5 5 8} #_} #_set P([incr idx]) { width 10 height 10 #_ rows {4 4 {2 1} {3 3} {1 2} {4 2} 4 5 7 8} #_ columns {5 5 7 {4 5} {4 3} {2 2} {2 2} {1 1} 4 3} #_} #_set P([incr idx]) { width 15 height 15 #_ rows {{1 1 2} {2 3 2} {3 1 1 3 2} {11 1} {4 4} {4 2} 4 {4 3} {4 3} {1 2 5} {1 7} {6 1} {5 1 3 1} {6 1 1} {6 1}} #_ columns {{6 3} {7 3} {10 3} {8 1 3} {1 3} {2 2} {3 2} {4 4} {2 3} {5 4} {3 4} {2 7} 4 {3 3} {4 1 1 2}} #_} #_set P([incr idx]) {width 15 height 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]) {width 15 height 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}} #_} #_set P([incr idx]) { width 15 height 15 #_ rows {{4 3} {4 5} {3 7} {6 3} {5 3} {6 2} {3 5} {1 2 5} {3 1} {2 4 1} {2 5} {1 4} {1 8} {2 2 1} {4 4 1}} #_ columns {{3 1 6} {6 2 2} {8 1} {2 4 1} 5 {3 1 1 1 1} {3 1 1 1} {3 5} {6 5} {6 4} {3 9} {1 5 1} {4 1} 2 4} #_} #_set P([incr idx]) {width 20 height 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]) {width 25 height 25 #_ rows { {1 1 7 4} {2 3 6 2} {2 12 2} {5 12} {1 8} {2 1 7} {2 1 1 1 4} {1 1 2 5} {7 5} {1 5 4} {5 6 5} {4 14} {13 2} {12 1} {12} {4 4 3} {1 1 2} {5 1 1} {5 3 6} {4 4 3 5} {4 3 3 3} {2 1 9} {2 10} {2 8 6} {3 4 3 2 4}} #_ columns { {4 6 8} {3 3 6 8} {1 2 11 1} {1 2 6 4} {2 1 1 3 2} {1 1 4 1} {2 5 1} {1 1 1 5 2} {4 9 6} {3 10 1 3} {2 8 1 4} {1 2 7 7} {5 4 1 6} {6 2 6} {6 1 1 4} {6 2 2 4} {6 3 1 3} {6 2 7} {10 4 2} {10 2 2} {5 2 1} {1 5 2 2} {1 2 2} {3 1} {3 1}} #_} set P([incr idx]) { width 9 height 10 title "Apple" rows {2 2 {2 1 2} {4 4} {1 7} {1 7} {1 7} {2 6} 7 {2 2}} columns {5 {2 2} {5 2} 7 {2 5} {2 7} {1 8} 7 5} } set P([incr idx]) { width 13 height 13 title Seahorse rows {3 {1 2 2} 9 {1 5} 5 {5 1} {5 1} {3 6} {1 1 5} {1 1 1 3} {1 2 2} {1 2} 5} columns {3 {1 1} {3 1 1 1} {1 1 1 1} {1 3 1} {1 1} {3 4 2} 12 {1 9} 10 8 {1 1} 2} } set P([incr idx]) { width 15 height 10 title "Sun" rows {{1 5 2} {2 5 2} {2 3 2 2} {2 3 2 3} {1 1 4} {2 3 3} {5 1} {1 7 5} 7 {2 5 6}} columns {{3 1 1 1} {3 1 1} {2 2} {2 4} {4 5} {4 5} {4 5} {2 4} {2 2} {3 1 1} {3 2 1 1} {1 2 1 1} {2 1 1} {3 1 1} {2 2 1}} } set P([incr idx]) { width 25 height 10 title "Chopper" rows {{1 1} {1 19} {5 1} {2 5} {13 1} {12 1} {5 1} 6 {3 1} 10} columns {1 1 5 4 {1 2} 2 {1 2} {1 2} {1 2} {1 2} {1 2 1} {1 3 1} {1 3 1} {1 5 1} {1 7} {4 4} {1 1 3} {1 1 1 1} {1 1 1 1} {1 2 1} {1 1} 1 1 1 1} } set P([incr idx]) { width 22 height 29 title "Cockroach" rows {{4 4} {2 2 2 2} {1 1 1 1} {1 4 1} {1 1 1 1} {1 1 6 1 1} {1 1 8 1 1} {3 8 3} {1 12 1} {2 1 6 1 2} {1 2 2 1} {1 6 5 1} {9 8} {2 7 5 2} {2 7 4 2} {2 7 4 2} {1 1 7 4 1 1} {1 8 3 1 1} {10 5} {11 6} {2 7 2 2} {2 7 2 2} {2 7 2 2} {2 6 1 2} {1 6 1 1} {2 5 2} {1 1 3 1 1} {1 1 1 1} {1 1}} columns {{2 1} {2 3 3} {1 8 7} {9 1 6} {2 1 2 2} {1 1 9} {1 15} {2 3 15 2} {2 6 15} {1 5 16} {1 5 16} {1 5 13} {1 5 3 9} {2 6 6} {2 3 15 2} {1 15} {1 1 9} {2 1 1 2} {9 1 6} {1 9 7} {2 3 3} {2 1}} } set P([incr idx]) { width 20 height 20 title "Martini" rows {{2 1 4} {1 1 1 4} {2 1 6} {3 4 1 6} {5 1 2 1 1} {3 1 6} {3 1 1 4} {3 3 2} {2 1 3} {1 3 2 1} {2 1 1 1} {1 2 1 2} {3 2 1 2} {5 3 1 1} {6 5 1 1} {13 1 1} {3 3 7 1} {3 6 3 1} {3 3 2 3 1} {2 8 4}} columns {{4 5} {1 3 7} {1 3 7} {1 1 4 5 1} {1 6 1 8} {1 3 5 7} {4 6} {4 1 1 1 1 1} {3 1 1 2 6} {2 1 1 1 7} {3 3 6 1} {2 7} 6 4 {3 8 1} {1 2 2 1} {1 4 7} {1 4 2} {1 2 3} 3} } set P([incr idx]) { width 25 height 25 title "Snow Flake" rows {{10 10} {9 3 9} {3 2 2 3} {2 4 2 2 4 2} {2 2 3 1 3 2 2} {2 1 1 2 3 2 1 1 2} {2 1 2 1 1 1 2 1 2} {2 2 6 6 2 2} {2 2 2 3 2 2 2} {1 5 2 2 5 1} {2 1 1 1 1 1 1 2} {2 1 11 1 2} {1 3 1 1 1 1 3 1} {2 1 11 1 2} {2 1 1 1 1 1 1 2} {1 5 2 2 5 1} {2 2 2 3 2 2 2} {2 2 6 6 2 2} {2 1 2 1 1 1 2 1 2} {2 1 1 2 3 2 1 1 2} {2 2 3 1 3 2 2} {2 4 2 2 4 2} {3 2 2 3} {9 3 9} {10 10}} columns {{10 10} {9 3 9} {3 2 2 3} {2 4 2 2 4 2} {2 2 3 1 3 2 2} {2 1 1 2 3 2 1 1 2} {2 1 2 1 1 1 2 1 2} {2 2 6 6 2 2} {2 2 2 3 2 2 2} {1 5 2 2 5 1} {2 1 1 1 1 1 1 2} {2 1 11 1 2} {1 3 1 1 1 1 3 1} {2 1 11 1 2} {2 1 1 1 1 1 1 2} {1 5 2 2 5 1} {2 2 2 3 2 2 2} {2 2 6 6 2 2} {2 1 2 1 1 1 2 1 2} {2 1 1 2 3 2 1 1 2} {2 2 3 1 3 2 2} {2 4 2 2 4 2} {3 2 2 3} {9 3 9} {10 10}} } set P([incr idx]) { width 30 height 34 title "Brontosaurus" rows {{3 7} {1 3 7 2} {5 10 1} {4 13 1} {3 14 1} {3 15 1} {2 16 1} {20 1} {7 10 1} {6 11 1} {6 12 1} {6 12 1} {1 3 4 7 1} {1 2 4 6 1} {2 5 6 2} {2 5 7 1} {3 4 6 1} {4 5 6 2} {4 4 7 1} {4 7 1} {5 7 2} {5 7 2} {6 2} {4 2} {3 2} {3 2} {4 3} {6 5} {3 12} 20 20 8 4 2} columns {2 {1 2} 8 12 {5 6} {6 1 2} {9 2 3} {16 3} {17 3} {8 3 3} {7 6 3} {8 9 2 3} {22 4} {22 4} {12 8 3} {13 5 1 2} {1 14 1 2} {1 18 4} {1 18 4} {1 19 4} {1 17 4} {2 16 1 3} {2 8 1 3} {8 6 1 3} {4 7 3} {3 5 4} {1 4 4} {2 4} 9 6} } set P([incr idx]) { width 20 height 20 title "Soccer Player" url http://en.wikipedia.org/wiki/Image:Paint_by_numbers_Animation.gif rows {3 5 {3 1} {2 1} {3 3 4} {2 2 7} {6 1 1} {4 2 2} {1 1} {3 1} 6 {2 7} {6 3 1} {1 2 2 1 1} {4 1 1 3} {4 2 2} {3 3 1} {3 3} 3 {2 1}} columns {2 {1 2} {2 3} {2 3} {3 1 1} {2 1 1} {1 1 1 2 2} {1 1 3 1 3} {2 6 4} {3 3 9 1} {5 3 2} {3 1 2 2} {2 1 7} {3 3 2} {2 4} {2 1 2} {2 2 1} {2 2} 1 1} } set P([incr idx]) { width 21 height 10 title Me rows {{4 4 4 4} {2 2 2 2} {2 2 2 2} {2 2 2 2} {4 1 2} {4 2 2} {5 2 2} {2 2 2 2} {2 2 2 2} {4 4 3}} columns {{1 1} 10 10 {1 3 1} 4 {1 2 2 1} {3 3} {2 2} {1 1} 0 1 4 7 {1 4} 3 1 3 {1 5} 7 4 1} } set P([incr idx]) { width 15 height 15 title House rows {{3 2} {5 2} {2 4} {2 3} {2 2} {2 3 3 2} {3 3 3 3} {3 3 3 3} {2 2} {2 2} {2 5 2} {2 5 2} {2 2 2 2} {2 2 2 2} {2 2 2 2}} columns {2 10 11 2 {2 3} {2 3 5} {2 3 5} {2 2} {2 3 5} {2 3 5} {2 3} 5 15 10 2} } ################################################################ DoDisplay set S(puzzle) "Random 10x10" return ====== <> Games | Application