[Keith Vetter] 2007-02-08 : 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

------

[uniquename] 2013aug18

For 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.

[vetter_CrosswordPuzzleBuilder_wiki17662_screenshot_611x549.jpg]

------

======
 ##+##########################################################################
 #
 # 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
======

<<categories>> Toys