uniquename 2013aug18For readers who do not have the time/facilities/whatever to setup and run the following code, here is an image to show the nice quality of the crossword grid that is produced. This image shows the American style layout. As the description above indicates, the British and Japanese layouts have more black squares than the American --- and fewer squares in the case of Japanese layouts.
##+##########################################################################
#
# Crossword Puzzle Builder
# by Keith Vetter, February 2006
#
package require Tk
catch {package require tile} ;# Use tile if available
catch {namespace import -force ::ttk::button}
array set S {title "Crossword Puzzle Builder" N 17 W 600 min 5 max 50}
array set U {undo {} redo {}}
proc DoDisplay {} {
wm title . $::S(title)
font create myFont -family Helvetica -size 7
canvas .c -bd 2 -relief ridge -width $::S(W) -height $::S(W)
bind .c <Configure> {ReCenter %W %h %w}
bind .c <Control-n> NewPuzzle
bind .c <Control-z> Undo
bind .c <Control-y> Redo
bind .c <Key-Delete> Clear
pack .c -side top -fill both -expand 1
DoMenus
DrawGrid
focus .c
}
proc DoMenus {} {
. configure -menu [menu .m -tearoff 0]
.m add cascade -menu [menu .m.file -tearoff 0] -label "File" -underline 0
.m add cascade -menu [menu .m.edit -tearoff 0] -label "Edit" -underline 0
.m add cascade -menu [menu .m.help -tearoff 0] -label "Help" -underline 0
.m.file add command -label "New" -under 0 -command NewPuzzle -accel "Ctrl+N"
.m.file add separator
.m.file add command -label "Save Puzzle" -under 0 -state disabled
.m.file add command -label "Print" -under 0 -state disabled
.m.file add separator
.m.file add command -label "Exit" -under 1 -command exit
.m.edit add command -label Undo -under 0 -command Undo \
-accel "Ctrl+Z" -state disabled
.m.edit add command -label Redo -under 0 -command Redo \
-accel "Ctrl+Y" -state disabled
.m.edit add command -label Clear -under 0 -command Clear -accel "Del"
.m.help add command -label "American Example" -under 0 -command American
.m.help add command -label "British Example" -under 0 -command British
.m.help add command -label "Japanese Example" -under 0 -command Japanese
.m.help add separator
.m.help add command -label About -under 0 -command About
}
proc ReCenter {W h w} { ;# Called by configure event
set h2 [expr {$h / 2}] ; set w2 [expr {$w / 2}]
$W config -scrollregion [list -$w2 -$h2 $w2 $h2]
Resize
}
proc Resize {} {
set w [winfo width .c]
set h [winfo height .c]
foreach {x0 y0 x1 y1} [.c bbox all] break
set sx [expr {($w-40)/2.0 / $x1}]
set sy [expr {($h-40)/2.0 / $y1}]
set sc [expr {$sx > $sy ? $sy : $sx}]
if {$sc < 0} return
.c scale all 0 0 $sc $sc
# Scale myFont here???
}
proc DrawGrid {} {
global S GRID
set sz 29
.c delete all
unset -nocomplain GRID
set x0 [expr {-$S(N) * $sz / 2}]
set y0 $x0
for {set row 0} {$row < $S(N)} {incr row} {
set GRID(-1,$row) 1 ;# Sentinels
set GRID($S(N),$row) 1
set GRID($row,-1) 1
set GRID($row,$S(N)) 1
set y1 [expr {$y0 + $row * $sz}]
set y2 [expr {$y1 + $sz}]
for {set col 0} {$col < $S(N)} {incr col} {
set x1 [expr {$x0 + $col * $sz}]
set x2 [expr {$x1 + $sz}]
.c create rect $x1 $y1 $x2 $y2 -tag b$row,$col -fill white -outline black
.c bind b$row,$col <1> [list BDown $row $col]
set GRID($row,$col) 0
}
}
Renumber
Resize
}
proc BDown {row col {noUndo 0}} {
set row2 [expr {$::S(N) - $row - 1}]
set col2 [expr {$::S(N) - $col - 1}]
set ::GRID($row,$col) [expr {! $::GRID($row,$col)}]
set ::GRID($row2,$col2) $::GRID($row,$col)
set fill [expr {$::GRID($row,$col) ? "black" : "white"}]
.c itemconfig b$row,$col -fill $fill
.c itemconfig b$row2,$col2 -fill $fill
Renumber
if {! $noUndo} {
lappend ::U(undo) [list $row $col]
set ::U(redo) {}
UndoDisplay
}
}
proc Renumber {} {
global S GRID
.c delete number
set n 1
for {set row 0} {$row < $S(N)} {incr row} {
set r0 [expr {$row-1}]
set r1 [expr {$row+1}]
for {set col 0} {$col < $S(N)} {incr col} {
if {$GRID($row,$col)} continue
set c0 [expr {$col-1}]
set c1 [expr {$col+1}]
if {($GRID($r0,$col) && ! $GRID($r1,$col)) ||
($GRID($row,$c0) && ! $GRID($row,$c1))} {
foreach {x y} [.c coords b$row,$col] break
set t [.c create text $x $y -text $n -font myFont -anchor nw \
-tag number]
.c bind $t <1> [list BDown $row $col]
incr n
}
}
}
.c move number 2 1
}
proc About {} {
set ABOUT {
This program lets you create grids suitable for both American and
British style crossword puzzles. Traditionally, these grids are square
with 180-degree rotational symmetry so that its pattern appears the
same if the paper is turned upside down. Most puzzle designs also
require that all the white cells are connected.
American crosswords typically have large chunks of white squares with
each answer at least three letters long. Black squares are limited to
about one-sixth of the design.
British crosswords are more latice-like with a higher percentage of
black squares with no two answers being next to each other. British
crosswords also differ in their clues which are traditionally very
cryptic.
Particularly curious is the Japanese language crossword; due to the
writing system, one syllable (typically katakana) is entered into
each white cell of the grid rather than one letter, resulting in the
typical solving grid seeming rather small in comparison to those of
other languages. There grids follow two additional rules: black cells
cannot share a side, and the corner cells must be white.
source: http://en.wikipedia.org/wiki/Crossword_puzzle}
regsub -all -line {^[ \t]+} $ABOUT "" ABOUT
set msg "$::S(title)\nby Keith Vetter, February 2007\n$ABOUT"
tk_messageBox -message $msg -title "About $::S(title)"
}
image create photo ::img::info -data {
R0lGODlhIAAgALMAAAAAAAAA/4SEhMbGxvf/Mf//////////////////////////////////////
/////yH5BAEAAAQALAAAAAAgACAAAAStkMhJibj41s0nHkUoDljXXaCoqqRgUkK6zqP7CvQQ7IGs
AiYcjcejFYAb4ZAYMB4rMaeO51sNkBKlc/uzRbng0NWlnTF3XAAZzExj2ET3BV7cqufctv2Tj0vv
Fn11RndkVSt6OYVZRmeDXRoTAGFOhTaSlDOWHACHW2MlHQCdYFebN6OkVqkZlzcXqTKWoS8wGJMh
s7WoIoC7v7i+v7uTwsO1o5HHu7TLtcodEQAAOw==}
proc NewPuzzle {{value ""}} {
if {$value eq ""} {
foreach {ok value} [NewDialog] break
if {! $ok} return
if {! [string is integer -strict $value]} return
if {$value < $::S(min) || $value > $::S(max)} return
}
set ::S(N) $value
DrawGrid
set ::U(undo) {}
set ::U(redo) {}
UndoDisplay
}
proc NewDialog {} {
set W .new
destroy $W
toplevel $W -padx 20
wm title $W "New Puzzle"
wm transient $W .
wm withdraw $W
label $W.icon -image ::img::info
label $W.title -text "New Puzzle" -font "Times 18 bold"
label $W.lvalue -text "Size ($::S(min)-$::S(max)): "
entry $W.value -width 5 -textvariable ::S(new,value)
set ::S(new,value) $::S(N)
frame $W.buttons
button $W.ok -text OK -command "set ::S(new,ok) 1; destroy $W"
button $W.cancel -text Cancel -command [list destroy $W]
set ::S(new,ok) 0
grid $W.icon $W.title - -
grid ^ $W.lvalue $W.value
grid $W.buttons - - - -sticky ew -pady {30 10}
grid $W.ok $W.cancel -in $W.buttons -padx 4 -sticky ew
grid columnconfigure $W.buttons {0 1} -uniform a
grid columnconfigure $W 3 -weight 1
grid configure $W.icon -padx {0 20}
grid configure $W.lvalue -sticky e
grid configure $W.value -sticky w
focus $W.value
$W.value icursor end
$W.value selection range 0 end
bind $W.value <Key-Return> [list $W.ok invoke]
CenterWindow $W .
wm deiconify $W
grab $W
tkwait window $W
return [list $::S(new,ok) $::S(new,value)]
}
proc CenterWindow {w {W .}} {
set x [expr {[winfo x $W] + \
([winfo width $W]-[winfo reqwidth $w])/2}]
set y [expr {[winfo y $W] + \
([winfo height $W]-[winfo reqheight $w])/2}]
wm geometry $w +$x+$y
}
proc Undo {} {
global U
if {$U(undo) eq {}} return
set move [lindex $U(undo) end]
set U(undo) [lrange $U(undo) 0 end-1]
lappend U(redo) $move
foreach {row col} $move {
BDown $row $col 1
}
UndoDisplay
}
proc UndoDisplay {} {
.m.edit entryconfig Undo -state [expr {$::U(undo) eq {} ? "disabled" : "normal"}]
.m.edit entryconfig Redo -state [expr {$::U(redo) eq {} ? "disabled" : "normal"}]
}
proc Redo {} {
global U
if {$U(redo) eq {}} return
set move [lindex $U(redo) end]
set U(redo) [lrange $U(redo) 0 end-1]
lappend U(undo) $move
foreach {row col} $move {
BDown $row $col 1
}
UndoDisplay
}
proc Clear {} {
global S GRID
set N2 [expr {$S(N)/2}]
set undo {}
for {set row 0} {$row <= $N2} {incr row} {
set row2 [expr {$S(N) - $row - 1}]
for {set col 0} {$col < $S(N)} {incr col} {
if {$GRID($row,$col)} {
set col2 [expr {$S(N) - $col - 1}]
set GRID($row,$col) 0
set GRID($row2,$col2) 0
.c itemconfig b$row,$col -fill white
.c itemconfig b$row2,$col2 -fill white
lappend undo $row $col
}
}
}
Renumber
if {$undo ne {}} {lappend ::U(undo) $undo}
UndoDisplay
}
proc American {} {
NewPuzzle 17
foreach {row col} {0 7 0 12 1 7 1 12 2 7 3 0 3 1 3 8 3 13 4 4 4 8
4 9 4 10 4 15 4 16 5 5 5 6 6 3 6 11 7 7 7 12 8 0 8 1 8 2} {
BDown $row $col
}
}
proc British {} {
NewPuzzle 15
foreach {row col} {1 0 3 0 5 0 7 0 7 1 7 2 9 1 9 2 11 1 13 1 1 2
1 4 0 4 1 6 1 7 1 9 1 11 3 2 5 2 3 4 5 4 7 4 3 6 3 7 5 6
6 6 7 6 3 11 3 9 4 9 5 8 5 10} {
BDown $row $col
}
}
proc Japanese {} {
NewPuzzle 9
foreach {row col} {0 4 1 3 2 2 3 1 7 0 6 1 5 2 6 3 4 4} {
BDown $row $col
}
}
DoDisplay
American
return