#!/bin/sh
#
# Maths Square Puzzle
# (c) Q Solutions 1999
#
# \
exec wish $0 $* &
# \
exit
	set Tile(1) {2 3 9 4}
	set Tile(2) {1 7 4 5}
	set Tile(3) {1 6 6 5}
	set Tile(4) {1 5 7 3}
	set Tile(5) {2 9 5 7}
	set Tile(6) {7 8 8 9}
	set Tile(7) {1 4 5 8}
	set Tile(8) {2 5 8 3}
	set Tile(9) {2 2 8 5}
#	set Solve(Def,Path) {- 1 2 4 5 3 6 7 8 9}
#	set Solve(Def,Path) {- 5 2 4 6 8 9 7 1 3}
	set Solve(Def,Path) {- 5 1 2 4 3 6 9 8 7}
	set Solve(Def,Tiles) { 1 2 3 4 5 6 7 8 9}

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) {Math Square Puzzle}

	set Solve(Square) 1
	set Solve(Active) 0
	set Solve(Iterations) 0
	foreach i {1 2 3 4 5 6 7 8 9 } {
		set Square($i,Used) 0
		set Square($i,Tile) 0
		set Square($i,Rotate) 0
		set Tile($i,Used) 0
		set Square($i,Tiles) $Square(Vacant)
		foreach j {1 2 3 4 } {
			set Square($i,$j) " "
		}
	}
}

proc Clear {} {

	SquareInit
	RefreshSquare
}

proc MakeGameWin { } {
	global Square Tile

	set win $Square(Game,Win).square
	pack [frame $win -bd 5 -relief raised] -expand 1
	set win $Square(Game,Win).square.sq
	set Square(Square,Win) $win
	pack [frame $win -bd 1 -relief solid] -expand 1
	foreach r {1 2 3 } {
	grid rowconfigure $win $r -minsize 80
	grid columnconfigure $win $r -minsize 80
	foreach c { 1 2 3} {
		set n [expr ($r - 1) * 3 + $c]
		set fr $win.sq$n
		grid [frame $fr -bd 1 -relief solid] -row $r -column $c -sticky news
		pack [label $fr.top -textvariable Square($n,1)] -side top -anc n 
		pack [label $fr.bot -textvariable Square($n,3)] -side bottom -anc s
		pack [label $fr.left -textvariable Square($n,4)] -side left -anc w -padx 10
		pack [label $fr.right -textvariable Square($n,2)] -side right -anc e -padx 10
		foreach w "$fr [pack slaves $fr]" {
			bind $w <1> "SquareClick $fr $n RotateSquareClick"
			bind $w <3> "SquareClearCheck $n"
		}
	}
 }
}

proc ColourSquare { n c } {
	global Square Tile

	if { $n < 1 || $n > 9 } { return }
	set win $Square(Square,Win).sq$n
	foreach w "$win [pack slaves $win]" {
		$w config -bg $c
	}
}

proc DrawTilesLeft {  } {
	global Square Tile

	set win $Square(TilesLeft,Win)
	foreach i {1 2 3 4 5 6 7 8 9} {
		if { [lsearch -exact $i $Square(Used)] == -1 } {
			set fr $win.fr$i
			if { ! [winfo exists $fr] } {
				pack [frame $fr -bd 1 ] -side left -padx 5
			}		
			MakeTile $fr $i 55
		}
	}
}

proc MakeTile { win t w} {
	global Square Tile
	
	set Tiles $Tile($t)
	if { $Tile($t,Used) } { set Tiles "{ } { } { } { }" }

	set fr $win.tile
	if { ! [winfo exists $fr] } {
		pack [frame $fr -bd 1 -relief solid -width $w -height $w] 
		pack propagate $fr 0
		pack [label $fr.top] -side top -anc n 
		pack [label $fr.bot] -side bottom -anc s
		pack [label $fr.left] -side left -anc w
		pack [label $fr.right] -side right -anc e
	}
	if { ! $Tile($t,Used) } {
		set c "TileSelect $fr $t"
	} else {
		set c {bell}
	}
	foreach w "$fr [pack slaves $fr]" {
		bind $w <1> $c
	}
	$fr.top configure  -text [lindex $Tiles 0]
	$fr.right configure  -text [lindex $Tiles 1]
	$fr.bot configure  -text [lindex $Tiles 2]
	$fr.left configure  -text [lindex $Tiles 3]
}

proc AddTileCheck {t n} {
	global Square Tile

	incr Square(Moves)
	set Square(Message) {}
	AddTile $t $n
	DrawTilesLeft
	foreach t { 1 2 3 4 } {
		set r [CheckSquare $n]
		if { $r } { CheckDone ; return }
		RotateSquare ClockWise $n
	}
	set Square(Message) {Tile Can't go here}
	
}

proc CheckDone { } {
	global Square Tile

	set Done 1
	foreach t {1 2 3 4 5 6 7 8 9} {
		if { ! $Tile($t,Used) } { return }
	}
	foreach s {1 2 3 4 5 6 7 8 9} {
		if { ! [CheckSquare $s] } { return }
	}
	set Square(Message) "Solved after $Square(Moves) moves"
	bell
}

proc AddTile { t n } {

	global Square Tile

	UnUseTile $Square($n,Used)
	UseTile $t $n
	set Square($n,Tile) $t
	set Square($n,Tiles) $Tile($t)
	set Square($n,Used) $t
	DrawSquare $n

}

proc SquareClearCheck { n } {
	global Square Tile

	set Square(Message) {}
	SquareClear $n
	RefreshSquare
}

proc SquareClear { n } {
	global Square Tile

	if { $n < 1 || $n > 9 } {
		puts "Clear called with $n"
		return
	}
	set t $Square($n,Used)
	set Square($n,Used) 0
	set Square($n,Tile)  0
	set Square($n,Tiles) $Square(Vacant)
	DrawSquare $n
	ColourSquare $n #d9d9d9
	if { $t > 0 } {
		set Tile($t,Used) 0
		DrawTilesLeft
	}
}

proc UnUseTile { t } {
	global Square Tile
	
	if { $t == 0 } { return }
	if { $t < 1 || $t > 9 } {
		puts "unuse called with $t"
		return
	}
	set n $Tile($t,Used)
	set Tile($t,Used) 0
	if { $n > 0 } {
		SquareClear $n
	}
}

proc UseTile { t n} {
	global Square Tile
	
	if { $t == 0 } { return }
	if { $t < 1 || $t > 9 } {
		puts "use called with $t $n"
		return
	}
	if { $n < 1 || $n > 9 } {
		puts "Clear called with $t $n"
		return
	}
	set p $Tile($t,Used)
	if { $p > 0 } { UnUseTile $t }
	set Tile($t,Used) $n
	set Square($n,Used) $t
}

proc CheckSquare { n } {
	global Square Tile

	set Ok 1	
	set c [expr ($n-1) % 3 + 1]
	set r [expr ($n-1) / 3 + 1]
	if { $n < 1 || $n > 9 } {
		puts "checksq called with $n"
		return
	}
	foreach {r1 c1 s1 s2} { 0 1 1 3  0 -1 3 1  1 0 2 0  -1 0 0 2} {
		set rn [expr $r + $r1]
		set cn [expr $c + $c1]
		if { $rn < 1 || $rn > 3 || $cn < 1 || $cn > 3 } {continue}
		set n2 [expr ($rn - 1) * 3 + $cn ]
		if { ! $Square($n2,Used) } { continue }
		set o [CheckTile $n $n2 $s1 $s2]
		if { ! $o } {
			set Ok 0
			ColourSquare $n2 $Square(IncorrectColour)
		} else {
			ColourSquare $n2 $Square(CorrectColour)
		}
	}
	if { ! $Ok } {
		ColourSquare $n $Square(IncorrectColour)
	} else {
		ColourSquare $n $Square(CorrectColour)
	}
	return $Ok
}

proc CheckTile { n n2 s1 s2} {
	global Square Tile

	if { $n2 < 1 || $n2 > 9 } { return 1}
	if { $n < 1 || $n > 9 } { return 1}
	if { !$Square($n2,Used) } { return 1}
	set p1 [lindex $Square($n,Tiles) $s1]
	set p2 [lindex $Square($n2,Tiles) $s2]
	if { $p1 == " " || $p2 == " " } {
		puts "err: $n:$n2 $s1 , $s2"
		set p1 0
		set p2 0
	}
    return [expr ($p1 + $p2) == 10]
}


proc SquareClick {w n Proc} {
	global Square Tile

	if { $Square(Clicked) != "" } {
		Colour [lindex $Square(Clicked) 0] #d9d9d9
		AddTileCheck [lindex $Square(Clicked) 1] $n
		set Square(Clicked) [list]	
	} else {
		if { $Square($n,Used) } {
			RotateSquareClick Clockwise $n
		} else {
			bell
		}
	}
}

proc TileSelect { w t } {
	global Square Tile

	set s $Square(Clicked)
	if { $s != "" } {
		Colour [lindex $s 0] #d9d9d9
	}
	Colour $w $Square(SelectColour)
	set Square(Clicked) [list $w $t]
	set Square(Message) "Click Game Square to place Tile"
}

proc Colour { w c} {
	foreach i "$w [pack slaves $w]" {
		$i config -bg $c
	}
}

proc RotateSquareClick {dir n} {
	global Square Tile

	incr Square(Moves)
	RotateSquare $dir $n
}

proc RotateSquare {dir n} {
	global Square Tile
	
	if { $Square($n,Tile) == 0 } {
		bell
		return
	}
	set Tiles $Square($n,Tiles)
	if { $dir == "Clock" } {
		set Tiles "[lindex $Tiles 3] [lrange $Tiles 0 2]"
	} else {
		set Tiles "[lrange $Tiles 1 3] [lindex $Tiles 0]"
	}
	set Square($n,Tiles) $Tiles
	DrawSquare $n
	CheckDone
	CheckSquare $n
}

proc DrawSquare { n } {
	global Square Tile
	
	set Tiles "0 $Square($n,Tiles)"

	foreach i { 1 2 3 4 } {
		set Square($n,$i) [lindex $Tiles $i]
	}
}

proc ShiftTiles { d } {
	global Square Tile

	switch $d {
		L { set ts {1 4 7} ; set swap {2 1 3 2 5 4 6 5 8 7 9 8} ;set cs {3 6 9} }
		R { set ts {3 6 9} ; set swap {2 3 1 2 5 6 4 5 8 9 7 8} ;set cs {1 4 7} }
		U { set ts {1 2 3} ; set swap {4 1 7 4 5 2 8 5 6 3 9 6} ;set cs {7 8 9} }
		D { set ts {7 8 9} ; set swap {4 7 1 4 5 8 2 5 6 9 3 6} ;set cs {1 2 3} }
	}
	foreach s $ts { 
		set t $Square($s,Used)
		if { $t > 0 } {
			UnUseTile $t
		}
	}
	foreach {i j} $swap {
		set Square($j,Used)  $Square($i,Used)
		set Square($j,Tiles) $Square($i,Tiles)
		set Square($j,Tile)  $Square($i,Tile)
		set Tile($Square($j,Tile),Used) $j
		DrawSquare $i
		DrawSquare $j
	}
	foreach s $cs { 
		set t $Square($s,Used)
			set Square($s,Used) 0
			set Square($s,Tile) 0
			set Square($s,Tiles) $Square(Vacant)
	}
	RefreshSquare
}

proc RefreshSquare {} {
	global Square Tile

	DrawTilesLeft
	foreach n {1 2 3 4 5 6 7 8 9} {
		DrawSquare $n
		if { $Square($n,Used) }  {
		 CheckSquare $n
		} else {
			ColourSquare $n #d9d9d9
		}
	}
}


proc Solve {} {
	global Solve

	if { $Solve(Active) } {
		set Solve(Active) 0
		RefreshSquare
	} else {
		set Solve(Active) 1
		if { $Solve(Square) == 0 } { set Solve(Square) 1 }
		SolveInit
		Iterate
	}
}

proc SolveInit {} {
	global Solve Square Tile

	set Path [list]
	foreach s [lrange $Solve(Def,Path) 1 end] {
		if { ! $Square($s,Used) } {
			lappend Path $s
		}
	}
	if { $Path == "" } { set Solve(Active) 0 ; return }
	set l [llength $Path]
	set Solve(Path) [concat - $Path]
	set Solve(Max) $l
	set Solve(Optimize) 1
	if { $l != 9 } { set Solve(Optimize) 0 }
	set Solve(Square) 1
	set Solve(Iterations) 0
	if { [info exists Solve(Mark)] } {set Solve(Mark,Old) $Solve(Mark)}
	Mark 1
	set Square(Message) "Auto Solve Running ...."
}

proc Iterate {} {
	global Solve Square Tile

	if { ! $Solve(Active) } { return }
	incr Solve(Iterations)
	set S $Solve(Square)
	if { $S > $Solve(Max) } {
		set Square(Message) "Solved after $Solve(Iterations) iterations"
		bell
		set Solve(Active) 0
		return
	}
	set s [lindex $Solve(Path) $S]
	set t $Square($s,Tile)
	if { $t == 0 } {
		set t [NextTile 0]
		AddTile $t $s
		set Square($s,Rotate) 1
		if { $Solve(Optimize) && ($s == 5) } {
			#puts "Optimize"
			set Square($s,Rotate) 4
		}
#		IterateNext
		#puts "$S: $s , new tile $t"
	}

	while { 1 } {
		if { [CheckSquare $s] && $Square($s,Rotate) < 5} {
			#if { $s == 5 } { puts "5 ok $Square($s,Rotate)" }
			incr Solve(Square)
			IterateNext
			return
		}
		incr Square($s,Rotate)
		if { $Square($s,Rotate) > 4 } { break }
		RotateSquare AntiClockwise $s
	}
	#puts "$S: $s  ! Check"

	set t [NextTile $t]
	if { $S == 1 } {
		set Square(Message) "Level $t: $Solve(Iterations)"
	}
	if { $t == 0 } {
		#puts "backtrack -> $S"
		incr S -1
		set Solve(Square) $S
		if { $S == 0 } {
			Mark 0
			bell
			set Square(Message) "No Solution Found"
			set Solve(Active) 0
			if { [info exists Solve(Mark,Old)]} {
				set Solve(Mark) $Solve(Mark,Old)
				unset Solve(Mark,Old)
			}
			return
		}
		SquareClear $s
		update
		set s [lindex $Solve(Path) $S]
		set t $Square($s,Tile)
		incr Square($s,Rotate)
		RotateSquare AntiClockwise $s
		IterateNext
		return
	}

	#puts "$S: $s  next tile $t"

	AddTile $t $s
	set Square($s,Rotate) 1
	IterateNext
}

proc IterateNext {} {
	global Solve Square Tile
	if { $Solve(Active) } { after idle Iterate }
	DrawTilesLeft
}

proc NextTile { s } {
	global Tile

	for {set i [expr $s+1]} {$i < 10} {incr i} {
		if { ! $Tile($i,Used) } { return $i }
	}
	return 0
}


proc Load {} {
	global Solve Square Tile

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

	set f [open $x r]
	gets $f
	gets $f
	array set Solve [gets $f]
	array set Tile [gets $f]
	array set Square [gets $f]
	close $f
	RefreshSquare
}

proc Save {} {
	global Solve Square Tile

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

	set f [open $x w]
	puts $f "# MSquare Save File"
	puts $f "#"
	puts $f "[array get Solve]"
	puts $f "[array get Tile]"
	puts $f "[array get Square]"
	close $f
}

proc Mark { force } {
	global Solve Square Tile

	if { $force || ! [info exists Solve(Mark)] } {
		foreach t { 1 2 3 4 5 6 7 8 9 } {
			set s $Tile($t,Used)
			set r {0 0 0 0}
			if { $s } { set r $Square($s,Tiles) }
			lappend Solve(Mark) [list $t $s $r]
		}
		set Square(Message) {Board Marked, press button again to restore}
		return
	}
	Clear
	foreach p $Solve(Mark) {
		if { ! [lindex $p 1]  } { continue }
		set s [lindex $p 1]
		AddTile [lindex $p 0] $s
		set Square($s,Tiles) [lindex $p 2]
	}
	unset Solve(Mark)		
	RefreshSquare
}

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 "Clear" -command "Clear"] -fill x
	pack [button $w.cmd.b12 -text "Un/Mark" -command "Mark 0"] -fill x
	pack [button $w.cmd.b11 -text "Generate" -command "Generate"] -fill x
	
	pack [label $w.cmd.l1 -text "Shift\nTiles" -relief sunken -bd 1] -anc n -fill x -ipady 10
	pack [button $w.cmd.b1 -text "Left" -command "ShiftTiles L"] -fill x
	pack [button $w.cmd.b2 -text "Right" -command "ShiftTiles R"] -fill x
	pack [button $w.cmd.b3 -text "Up" -command "ShiftTiles U"] -fill x
	pack [button $w.cmd.b4 -text "Down" -command "ShiftTiles D"] -fill x
	pack [label $w.cmd.l2 -text "Solve\nPuzzle" -relief sunken -bd 1] -anc n -fill x -ipady 10
	pack [button $w.cmd.b5 -text "Start/Stop" -command "Solve"] -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
	set Square(TilesLeft,Win) $w.top
	set Square(Game,Win) $w.game
	bind $w.cmd.l3 <Control-Alt-2> Cheat
}

SquareInit
MakeUI
MakeGameWin
DrawTilesLeft


proc Cheat {} {
	global Solve Square Tile

	if { ! [info exists Solve(Solution)] } { return }
	set tiles [lindex $Solve(Solution) 4]
	foreach t {1 2 3 4 5 6 7 8 9} {
		set tl $Tile($t)
		foreach r {1 2 3 4} {
			if { $tiles == $tl } { 
				AddTileCheck $t 5
				set Square(Message) {Dumb Human, can't figure it out huh!}
				 return 
			}
			set tl [concat [lindex $tl 3] [lrange $tl 0 2]]
		}
	}
	set Square(Message) {Poor human, cant cheat}
	bell

}

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

proc Generate {} {

	global Solve Square Tile 

	Clear
	foreach n {1 2 3 4 5 6 7 8 9} {
		set Tile($n) {0 0 0 0}
		AddTile $n $n
	}
	
	foreach n {1 2 3 4 5 6 7 8 9} {
		set c [expr ($n-1) % 3 + 1]
		set r [expr ($n-1) / 3 + 1]
		set Tiles [list]
		foreach {r1 c1 s1 s2} { -1 0 0 2   0 1 1 3  1 0 2 0   0 -1 3 1  } {
			set rn [expr $r + $r1]
			set cn [expr $c + $c1]
			if { $rn < 1 || $rn > 3 || $cn < 1 || $cn > 3 } {
				lappend Tiles [Rand]

			} else {
				set n2 [expr ($rn - 1) * 3 + $cn ]
				set p1 [lindex $Tile($n) $s1]
				set p2 [lindex $Tile($n2) $s2]
				set s [expr 10 - $p2]
				if { $p2 == 0 } { set s [Rand] }
				lappend Tiles $s
			}
		}
		set Tile($n) $Tiles
		AddTile $n $n
	}
	foreach n {1 2 3 4 5 6 7 8 9} {
		lappend Solution $Tile($n)
	}
	set Solve(Solution) $Solution
	foreach n {1 2 3 4 5 6 7 8 9} {
		set i [Rand] 
		set l $Tile($n)
		while { $i } {
			set l "[lindex $l 3] [lrange $l 0 2]"
			incr i -1
		}
		set Tile($n) $l
	}
	set i [expr [Rand] * 3 + 1]
	while { $i } {
		set s [Rand] 
		set d [Rand]
		set t $Tile($d)
		set Tile($d) $Tile($s)
		set Tile($s) $t
		incr i -1
	}
	Clear
	RefreshSquare
}

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 \
"Math Square Puzzle

OBJECTIVE

The aim of the puzzle is to place all 9 tiles so that each pair of numbers on
adjacent edges adds up to 10.

LAYOUT

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

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

Tiles are auto-rotated when placed to the first correct orientation with adjacent pieces, if there is more than one correct orientation, click on the tile with the left button to rotate the tile 90 degrees anti-clockwise.

MOVING

The placed tiles can be moved as a group left,right,up,down within the 3x3 grid. Those tiles
that move outside the grid are returned to the unplaced tile row. Moving tiles
is usefull for seeing if there is a solution on the other side of a group of
four tiles.

MARK

The Un/Mark button will mark the current grid and restore it with a second press of the button.
The Solve button will create its own mark from the current position and restore the grid if no solution can be found.

GENERATE

The generate button will create a new puzzle with at least one solution.
The Solution is saved in any save file so you can cheat if required.


SOLVING

The solve button will attempt to find a solution to the puzzle from the current puzzle layout. 

If no tiles have been placed, the program does an exhaustive search starting at the first tile and stops at the first solution found. While this is a large number of iterations, it is somewhat less then the 1.73E22 possible combinations.
Emperically this has been around 1.2E4 iterations.

HINT

A certain combination of modifiers plus buttons on the right place will cause the program to reveal the tile for the center square.
This will reduce the number of combinations to about 500.


--
Philip Quaife


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










