#!/bin/sh
#
# Word Square Puzzle
# (c) Q Solutions 1999
#
# \
exec wish $0 $* &
# \
exit
	set Square(Width) 4
	set Square(Height) 6

	set Tile(1)  { {P} {R} {E} {I} { } { } {N} { } {C} }
	set Tile(2)  { {Y} { } {I} { } { } {N} {E} {V} {E} }
	set Tile(3)  { { } {A} { } {E} {N} {U} { } {E} { } }
	set Tile(4)  { { } {X} { } {A} {C} {R} { } {E} { } }
	set Tile(5)  { {C} { } {U} {L} { } {L} {E} {E} {L} }
	set Tile(6)  { {E} { } {D} {A} { } {E} {N} { } {R} }
	set Tile(7)  { {A} {N} {D} {R} { } { } {R} {O} {D} }
	set Tile(8)  { {E} { } {R} {H} { } { } {I} {G} {N} }
	set Tile(9)  { {B} {E} {T} {E} { } {O} {A} { } {W} }
	set Tile(10) { {A} {G} {E} {G} { } {V} {O} {R} {E} }
	set Tile(11) { {M} {I} {X} {T} { } {O} {H} { } {N} }
	set Tile(12) { {T} {E} {A} { } { } {B} {V} {I} {E} }
	set Tile(13) { { } {B} { } {L} {E} {A} { } {R} { } }
	set Tile(14) { { } {I} { } {A} {P} {S} { } {E} { } }
	set Tile(15) { { } {T} { } {T} {H} {E} { } {I} { } }
	set Tile(16) { {D} { } {F} {E} { } {O} {M} {A} {D} }
	set Tile(17) { {F} {R} {E} { } {P} { } {S} {T} {U} }
	set Tile(18) { {I} {T} {E} { } {E} { } {W} {R} {Y} }
	set Tile(19) { {E} {C} {O} { } {A} { } {E} {L} {I} }
	set Tile(20) { {R} {V} {E} { } { } {R} {M} { } {E} }
	set Tile(21) { {S} {W} {E} {E} { } {R} {T} {E} {A} }
	set Tile(22) { {V} {I} {E} { } {C} { } {H} {E} {E} }
	set Tile(23) { {W} { } {K} {A} { } {L} {R} { } {A} }
	set Tile(24) { { } {M} { } {M} {I} {T} { } {T} { } }

	set Square(Start) [list 1 1]

proc SquareInit {} {
	global Solve Tile Square

	set Square(Moves) 0
	set Square(Used) [list]
	set Square(Vacant) ""
	set Square(Clicked) [list]
	set Square(DropTile) [list]
	set Square(SelectColour) Blue
	set Square(CorrectColour) Green
	set Square(IncorrectColour) Red
	set Square(Message) {Word Square Puzzle}

	for  {set i 0} {$i <= $Square(Width) * $Square(Height) } {incr i } {
		set Square($i,Used) 0
		set Tile($i,Used) 0
		foreach j {0 1 2 3 4 5 6 7 8 9 } {
			set Square($i,$j) ""
		}
	}
}

proc Clear {} {
	global Square

	set i [expr $Square(Width) * $Square(Height)]
	while { $i } {
		UnUseTile $i
		incr i -1
	}
}

proc MakeGameWin { } {
	global Square Tile

	set win $Square(Win)
	MakeWin $win Square 0
	set win $Tile(Win)
	MakeWin	$win Tile 10
}

proc MakeWin {win array gap } {
	global Square Tile

	for {set r 1} {$r <= $Square(Height) } {incr r} {
		#grid rowconfigure $win $r -minsize 80
		#grid columnconfigure $win $r -minsize 80
		for {set c 1} {$c <= $Square(Width) } {incr c} {
			set n [expr ($r - 1) * $Square(Width) + $c]
			set fr $win.sq$n
			grid [frame $fr -bd 1 -relief solid] -row $r -column $c -sticky news -padx $gap -pady $gap
			MakeSquare $fr $array $n
			foreach w "$fr [grid slaves $fr]" {
				bind $w <1> "SquareClick $array $n"
			}
			if { $array == "Square" } {
				foreach w "$fr [grid slaves $fr]" {
					bind $w <3> "SquareClear $n"
				}
			}
		}
	}
}

proc MakeSquare { win array n } {

	upvar #0 $array Square
	global $array

	set Square($n,Used) 0

	for {set r 1} {$r <= 3 } {incr r} {
		grid rowconfigure $win $r -minsize 10
		grid columnconfigure $win $r -minsize 10
		for {set c 1} {$c <= 3 } {incr c} {
			set v [expr ($r - 1) * 3 + $c]
			set lb $win.lb$v
			grid [label $lb -width 2 -bd 1 -relief solid -textvariable $array\($n,$v) ] -row $r -column $c -sticky news
			set $Square($n,$v) *
		}
	}
}

proc FillSquare { array n list} {

	upvar #0 $array Square

	set win $Square(Win).sq$n

	set sq 9
	while { $sq }  {
		set Square($n,$sq) [lindex $list [expr $sq -1]]
		incr sq -1
	}
	set mode Draw
	if { $array == "Square" && ! $Square($n,Used)} { set mode Erase }
	if { $array == "Tile" &&  $Square($n,Used)} { set mode Erase }
	ColourSquare $array $n $mode
}

proc ColourSquare {array n mode } {

	upvar #0 $array Square

	set win $Square(Win).sq$n
	switch $mode {
		Select {
			set bg Blue 
			set erase Blue}
		Draw {
			set erase Black
			set bg White
		}
		Erase {
			if {$array == "Tile" } {
				set bg Black 
				set erase Black
			}
			if {$array == "Square" } {
				set bg #d9d9d9 
				set erase #d9d9d9
			}
		}
	}
	foreach w "$win [grid slaves $win]" {
		$w config -bg $bg
	}
	set i 9
	while { $i } {
		set lb $win.lb$i
		set txt [$lb cget -text]
		if { $txt == " " } {
			$lb config -bg $erase
		}
		if { $txt == "" } {
			$lb config -bg #d9d9d9
		}
		incr i -1
	}
}

proc SquareClear { n } {
	global Square Tile

	if { $n == [lindex $Square(Start) 1]} {
		bell
		set Square(Message) "Tile is fixed and cannot be cleared"
		return
	}
	set t $Square($n,Used)
	if { $t > 0 } {
		set Tile($t,Used) 0
		UnUseTile $t
		set Square($n,Used) 0
		FillSquare Square $n $Square(Vacant)
	}
}

proc AddTile { t n {flag 1}} {

	global Square Tile

	if { $flag && ($n == [lindex $Square(Start) 1] ||  $t == [lindex $Square(Start) 0]) } {
		bell
		set Square(Message) "add: Tile is fixed and cannot be moved"
		return
	}
	set Square(Clicked) ""
	set Square(Message) ""
	UseTile $t $n
	incr Square(Moves)
}

proc UnUseTile { t } {
	global Square Tile
	
	if { $t == 0 } { return }
	if { $t == [lindex $Square(Start) 0] } {
		return
	}
	set n $Tile($t,Used)
	set Tile($t,Used) 0
	if { $n > 0 } {
		SquareClear $n
	}
	ColourSquare Tile $t Draw
}

proc UseTile { t n} {
	global Square Tile
	
	if { $t == 0 } { return }
	set p $Tile($t,Used)
	SquareClear $p
	set p $Square($n,Used)
	UnUseTile $p
	set Tile($t,Used) $n
	set Square($n,Used) $t
	FillSquare Square $n $Tile($t)
	ColourSquare Tile $t Erase
}

proc SquareClick {array n } {
	global Square Tile

	if { $Square(Clicked) != "" && [lindex $Square(Clicked) 0] == $array && [lindex $Square(Clicked) 1] == $n } {
			ColourSquare [lindex $Square(Clicked) 0] $n Draw
			set Square(Clicked) ""
			set Square(Message) ""
			return			
	}
	if { $n == [lindex $Square(Start) 1] ||  $n == [lindex $Square(Start) 0] } {
		bell
		set Square(Message) "Tile is fixed and cannot be moved"
		return
	}
	if { $array == "Tile" } {
		if { $Tile($n,Used) } {
			set Square(Message) "Tile has already been placed."
			bell
			return
		}
		if { $Square(Clicked) != "" && [lindex $Square(Clicked) 1] == $n } {
			ColourSquare [lindex $Square(Clicked) 0] $n Draw
			set Square(Clicked) ""
			set Square(Message) ""
			return
		}
		if { $Square(Clicked) != "" } {
			ColourSquare [lindex $Square(Clicked) 0] [lindex $Square(Clicked) 1] Draw
		}
		ColourSquare Tile $n Select
		set Square(Clicked) [list Tile $n]
		set Square(Message) "Click puzzle square to place tile"
		return
	}
	if {$Square(Clicked) == "" || ( [lindex $Square(Clicked) 0] == "Square" && $Square($n,Used)) } {
		if { $Square(Clicked) != "" } {
			ColourSquare [lindex $Square(Clicked) 0] [lindex $Square(Clicked) 1] Draw
		}
		set Square(Clicked) [list $array $n]
		ColourSquare $array $n Select
		set Square(Message) "Click puzzle square to move tile"
		return
	} 
	if { $Square(Clicked) != ""  } {
		set click [lindex $Square(Clicked) 1]
		if { [lindex $Square(Clicked) 0]  == "Square" } { set click $Square($click,Used) }
		AddTile $click $n
		return
	} 
	set Square(Message) "Puzzle square is empty"
	bell
}

proc RefreshSquare {} {
	global Square Tile

	set n [expr $Square(Width) * $Square(Height)]
	while { $n } {
		set mode Draw
		if { ! $Square($n,Used)} { set mode Erase }
		ColourSquare Square $n $mode
		set mode Draw
		if { $Tile($n,Used)} { set mode Erase }
		ColourSquare Tile $n $mode
		incr n -1
	}

}

proc Load {} {
	global Solve Square Tile

	set x [tk_getOpenFile -defaultextension .ws -parent .  -filetypes {{Game .ws} {All .*} }]
	if { $x == "" } {return}
	set f [open $x r]
	gets $f
	gets $f
	array set Tile [gets $f]
	array set Square [gets $f]
	close $f
	RefreshSquare
	eval AddTile $Square(Start) 0
	set Square(Message) ""
}

proc Save {} {
	global Solve Square Tile

	set x [tk_getSaveFile -defaultextension .ws -parent . -filetypes {{Game .ws} {All .*} }]
	if { $x == "" } {return}

	set f [open $x w]
	puts $f "# Word Square Save File"
	puts $f "#"
	puts $f "[array get Tile]"
	puts $f "[array get Square]"
	close $f
	set Square(Message) "Puzzle Saved"
}

proc MakeUI {} {
	global Solve Square Tile 
	set w ""
	pack [frame $w.cmd -bd 2 -relief solid] -side left -anc nw -ipadx 5 -ipady 5 -fill y
	pack [frame $w.top -bd 0 -relief solid] -side top  -anc nw -pady 10 -ipadx 5
	pack [frame $w.game -bd 0 -relief raised] -side top -padx 5 -anc c -fill y -expand 1
	pack [frame $w.mess] -side bottom -pady 10 -anc n 
	pack [label $w.mess.label -textvariable Square(Message)] -anc n

	pack [label $w.cmd.l3 -text "Game" -relief sunken -bd 1] -anc n -fill x -ipady 5
	pack [button $w.cmd.b6 -text "Load" -command "Load"] -fill x
	pack [button $w.cmd.b7 -text "Save" -command "Save"] -fill x
	pack [button $w.cmd.b8 -text "Reset" -command "Clear"] -fill x
	pack [button $w.cmd.b2 -text "Edit" -command editTiles] -fill x
	pack [label $w.cmd.l4 -text "Help" -relief sunken -bd 1] -anc n -fill x -ipady 10
	pack [button $w.cmd.b10 -text "Info" -command "Help"] -fill x
	pack [label $w.cmd.l21 -text "Moves" -relief sunken -bd 1] -anc n -fill x -ipady 10
	pack [label $w.cmd.e22 -textvariable Square(Moves) -bd 5 -relief sunken] -fill x -ipady 10
	set Square(TilesLeft,Win) $w.top
	set Square(Game,Win) $w.game
	set Square(Win) $w.game.board
	set Tile(Win) $w.game.tile
	pack [frame $w.game.tile -bd 3 -relief sunken] -side left -anc nw -padx 20
	pack [frame $w.game.board -bd 3 -relief raised] -side left -anc nw

	bind $w.cmd.l3 <Control-Alt-2> Cheat
}

SquareInit
MakeUI
MakeGameWin
#pack forget $Square(Win)
#pack forget $Tile(Win)

set t [expr $Square(Width) * $Square(Height)]
while {$t} {
	FillSquare Tile $t $Tile($t)
	incr t -1
}
eval AddTile $Square(Start) 0

proc Rand {} { return [expr int(rand() * 9 + 1)] }



proc Help {} {

	set w .help
	if { [winfo exists $w] } { wm deiconify $w ; raise $w ; focus $w ; return }

	toplevel $w
	pack [button $w.b -text Ok -command "wm withdraw $w"] -side bottom -anc se
	pack [text $w.text -yscrollcommand "$w.sc set" -wrap word] -side left -anc nw -padx 5
	pack [scrollbar $w.sc -command "$w.text yview"] -side left -fill y -anc ne
	$w.text insert end \
"Word Square Puzzle

OBJECTIVE

Place the tiles to make the crossword puzzle in the correct order.

LAYOUT

The unplaced tiles are in a row above the NxN game board.
To select a tile click with the left button.
To place the selected tile, click in the game square with the left button.

To remove a piece, click on the tile with the right button.

One tile is placed as a start for the puzzle. This tile cannot be moved or
removed.

EDIT

The edit button allows you to change the puzzle tiles and thus create a new word puzzle game.
The puzzles can be made harder by specifing a starting position of 0,0

--
Philip Quaife


"
	$w.text see 1.0
	$w.text config -state disabled
}



proc editTiles {} {

	global Square Tile


	set cnt 24

	UnUseTile [lindex $Square(Start) 0]

	set win .edit
	if { [winfo exists $win] } {
		wm deiconify $win
		raise $win
		return
	}
	toplevel $win

	pack [frame $win.btn  -takefocus 0] -side left -anc nw
	pack [frame $win.square -bd 1 -relief raised] -side left -fill both -anc c 

	set w $win.btn
	pack [button $w.b1 -text "\\Next" -command {editNext 1} -takefocus 0] -anc nw
	pack [button $w.b2 -text "\\Prev" -command {editNext -1} -takefocus 0] -anc nw
	pack [button $w.b3 -text "Clear" -command "editClear $w.e" -takefocus 0] -anc nw
	pack [button $w.b4 -text "Close" -command "wm withdraw $win" -takefocus 0] -anc nw
	pack [entry $w.e -width 9 -takefocus 0] -anc nw -pady 5 -padx 1
	pack [label $w.lst -text "Start"] -anc nw
	pack [entry $w.st -textvariable Square(Start) -width 9 -takefocus 0] -anc nw -pady 5 -padx 1

	global edit

	set edit(Win) $win.square
	set edit(1,Used) 1

	pack [frame $win.square.sq1] -anc c -padx 20 -pady 20
	MakeSquare $win.square.sq1 edit	1 
	ColourSquare edit 1 Draw
	set l "after idle [list editPost $w.e]"
	bind $w.e <Key> $l
	bind $w.e <Key-Return> "editPut $w.e;break"
	focus $w.e
	raise $win
	set edit(edit,Num) 0
	editNext 1

}

proc editPost {w } {

	set l [$w get]
	FillSquare edit 1 "[split $l {}]"

}
proc editClear {w } {

	FillSquare edit 1 ""
	$w delete 0 end
}


proc editPut {w} {
	global edit Tile Square

	set list [$w get]
	FillSquare edit 1 {}
	set i $edit(edit,Num)
	set Tile($i) "[split $list {}]"
	FillSquare Tile $i "[split $list {}]"
	$w delete 0 end
	editNext 1
}


proc editNext {dir} {
	global edit Tile Square

	set i [incr edit(edit,Num) $dir]
	if { $i < 1 } { set i 24}
	if { $i > 24 } { set i 1}
	set edit(edit,Num) $i
	FillSquare edit 1 $Tile($i)	
}


