penguzzle

著名的15谜游戏（15-puzzle ）的Tcl/Tk版本

#!/usr/bin/wishx

source ~/puzz/lib/init


keylset config pcew 50
keylset config pceh 50
keylset config nrow 4
keylset config ncol 4

set EMPR [keylget config nrow]
set EMPC [keylget config ncol]


image create photo imgfull -file $IMGPATH/img0.gif


proc deletePuzzle {}\
{
	global config
	for {set r 1} {$r <= [keylget config nrow]} {incr r} \
	{
		for {set c 1} {$c <= [keylget config ncol]} {incr c} \
		{
			catch {destroy .m.f.b$r$c}
		}
	}
}

proc createPieces {}\
{
	global config piece pospce
	set piece {}
	set pospce {}
	for {set r 1} {$r <= [keylget config nrow]} {incr r} \
	{
		for {set c 1} {$c <= [keylget config ncol]} {incr c} \
		{
			image create photo img$r$c
			img$r$c copy imgfull \
				-from [expr 200/[keylget config ncol]*($c-1)] \
				[expr 200/[keylget config nrow]*($r-1)] \
				[expr 200/[keylget config ncol]*$c] \
				[expr 200/[keylget config nrow]*$r]
			keylset piece $r.$c.row $r
			keylset piece $r.$c.col $c
			keylset pospce $r.$c.row $r
			keylset pospce $r.$c.col $c
		}
	}
}

proc drawPuzzle {}\
{
	global config but_option
	for {set r 1} {$r <= [keylget config nrow]} {incr r} \
	{
		for {set c 1} {$c <= [keylget config ncol]} {incr c} \
		{
			eval button .m.f.b$r$c -image img$r$c\
				-width [keylget config pcew] \
				-height [keylget config pceh] \
				$but_option
			grid configure .m.f.b$r$c -row $r -column $c
			bind .m.f.b$r$c <1> "movePiece $r $c"
		}
	}
	destroy .m.f.b[keylget config nrow][keylget config ncol]
}

proc movePiece {r c}\
{
	global EMPR EMPC pospce	piece
	set newR [keylget piece $r.$c.row]
	set newC [keylget piece $r.$c.col]
	if {$EMPR == [keylget piece $r.$c.row]}\
	{
		if {[keylget piece $r.$c.col] < $EMPC}\
		{
			set col [expr $EMPC - 1]
			while {$col >= [keylget piece $r.$c.col]}\
			{
				set curbutr [keylget pospce $EMPR.$col.row]
				set curbutc [keylget pospce $EMPR.$col.col]
				grid configure .m.f.b$curbutr$curbutc \
					-row $EMPR -column [expr $col + 1]
				keylset piece $curbutr.$curbutc.col \
					[expr $col + 1]
				keylset pospce $EMPR.[expr $col+1].row $curbutr
				keylset pospce $EMPR.[expr $col+1].col $curbutc
				incr col -1
			}
			set EMPR $newR
			set EMPC $newC
		}\
		else\
		{
			set col [expr $EMPC + 1]
			while {$col <= [keylget piece $r.$c.col]}\
			{
				set curbutr [keylget pospce $EMPR.$col.row]
				set curbutc [keylget pospce $EMPR.$col.col]
				grid configure .m.f.b$curbutr$curbutc \
					-row $EMPR -column [expr $col - 1]
				keylset piece $curbutr.$curbutc.col \
					[expr $col - 1]
				keylset pospce $EMPR.[expr $col-1].row $curbutr
				keylset pospce $EMPR.[expr $col-1].col $curbutc
				incr col
			}
			set EMPR $newR
			set EMPC $newC
		}
	}\
	elseif {$EMPC == [keylget piece $r.$c.col]}\
	{
		if {[keylget piece $r.$c.row] < $EMPR}\
		{
			set row [expr $EMPR - 1]
			while {$row >= [keylget piece $r.$c.row]}\
			{
				set curbutr [keylget pospce $row.$EMPC.row]
				set curbutc [keylget pospce $row.$EMPC.col]
				grid configure .m.f.b$curbutr$curbutc \
					-row [expr $row + 1] -column $EMPC
				keylset piece $curbutr.$curbutc.row \
					[expr $row + 1]
				keylset pospce [expr $row+1].$EMPC.row $curbutr
				keylset pospce [expr $row+1].$EMPC.col $curbutc
				incr row -1
			}
			set EMPR $newR
			set EMPC $newC
		}\
		else\
		{
			set row [expr $EMPR + 1]
			while {$row <= [keylget piece $r.$c.row]}\
			{
				set curbutr [keylget pospce $row.$EMPC.row]
				set curbutc [keylget pospce $row.$EMPC.col]
				grid configure .m.f.b$curbutr$curbutc \
					-row [expr $row - 1] -column $EMPC
				keylset piece $curbutr.$curbutc.row \
					[expr $row - 1]
				keylset pospce [expr $row-1].$EMPC.row $curbutr
				keylset pospce [expr $row-1].$EMPC.col $curbutc
				incr row
			}
			set EMPR $newR
			set EMPC $newC
		}
	}
	if {[checkWin]}\
	{
		win;
	}\
	else\
	{
		lost;
	}
}

proc win {}\
{
	.t.win configure -text "You win !!!   "
}

proc lost {}\
{
	.t.win configure -text ""
}

proc shuffle {}\
{
	global config
	set nrow [keylget config nrow]
	set ncol [keylget config ncol]
	random seed [clock seconds]
	loop i 1 400\
	{
		catch {
			movePiece [expr [random $nrow] + 1] \
			[expr [random $ncol] + 1]
			update
		}
	}
}

proc checkWin {}\
{
	global piece config
	for {set r 1} {$r <= [keylget config nrow]} {incr r}\
	{
		for {set c 1} {$c <= [keylget config ncol]} {incr c}\
		{
			if {[keylget piece $r.$c.row] != $r}\
			{
				return 0
			}
			if {[keylget piece $r.$c.col] != $c}\
			{
				return 0
			}
		}
	}
	return 1
}

wm title . "Penguzzle 1.0"
wm geometry . 440x260+100+100
wm resizable . 0 0

frame .t
pack .t -side top -fill both
	eval button .t.quit -text Quit -command {{destroy .}} $but_option
	pack .t.quit -side right
	label .t.win -font $fontlabel -foreground #990000
	pack .t.win -side right
	eval button .t.shu -text Shuffle -command {shuffle} $but_option
	pack .t.shu -side left
	eval radiobutton .t.r1 -text 4x4 -variable radiosize -value 1 \
		$check_option \
		-command {{
			deletePuzzle
			keylset config nrow 4
			keylset config ncol 4	
			keylset config pcew 50
			keylset config pceh 50
			set EMPR [keylget config nrow]
			set EMPC [keylget config ncol]
			createPieces
			drawPuzzle
		}}
	pack .t.r1 -side left
	.t.r1 select
	eval radiobutton .t.r2 -text 5x5 -variable radiosize -value 2 \
		$check_option \
		-command {{
			deletePuzzle
			keylset config nrow 5
			keylset config ncol 5	
			keylset config pcew 40
			keylset config pceh 40
			set EMPR [keylget config nrow]
			set EMPC [keylget config ncol]
			createPieces
			drawPuzzle
		}}
	pack .t.r2 -side left
	eval radiobutton .t.r3 -text 6x6 -variable radiosize -value 3 \
		$check_option \
		-command {{
			deletePuzzle
			keylset config nrow 6
			keylset config ncol 6	
			keylset config pcew 33
			keylset config pceh 33
			set EMPR [keylget config nrow]
			set EMPC [keylget config ncol]
			createPieces
			drawPuzzle
		}}
	pack .t.r3 -side left

frame .m
pack .m -side top -fill both
	frame .m.f -background black
	pack .m.f -side left -fill both -padx 5
	frame .m.r -background #CCCCAA
	pack .m.r -side right -fill both
		label .m.r.lb -image imgfull -relief sunken
		pack .m.r.lb 

createPieces
drawPuzzle