ZHUOWARE BACKYARD - NOTE INDEX|ZHUOWARE BACKYARD TOP|ZHUOWARE表ページ

Pentomino Solver in tcl/tk //　ペントミノ求解スクリプト

July 14-17, 2009 by Zhuo

I have written a Pentomino Solver in tcl/tk.

Download:

Pentomino Solver 00.zip

Usage:

Install Tcl/Tk, with Img extension package, on your PC. I recommend ActiveTcl 8.4.x. The free community version is fine.
Please have a careful look into the script using your text editor to make sure no suspicious actions are embedded.
Simply double-click "PentominoSolver_00.tcl" to start.
All the trials are displayed on the board. PLEASE KEEP THIS BOARD WINDOW AT THE TOP, AND NEVER HIDE IT BY ANY OTHER WINDOWS. Such other windows are shot when the board image is saved into the file.

The piece-layout data is written to "sollog.txt", and the board screen shot for each solution is taken and saved in "solNNNNN.gif" (N...number) .
The format of the line in the sollog.txt is as follows:

   0 {0 0 0,n,0} {0 1 1,n,2} {0 2 2,n,3} {1 3 5,n,0} ... {10 1 3,i,1}

   0:   the index of this solution.
   {0 0 0,n,0}:    x=0, y=0, piece 0, normal side, rotate 90x0 degrees.
   {0 1 1,n,2}:    x=0, y=1, piece 1, normal side, rotate 90x2 degrees.
   :
   {10 1 3,i,1}:   x=10,y=1, piece 3, inverse side, rotate 90x1 degrees.

If by any chance you want to terminate, type to the console: "exit" and all the windows will be closed.

Comments:

This is a very primitive implementation without any efficient branch-cut logics: A straight-forward recursion is adopted. Anyway, have fun :-)

#
# piece puzzle solver
#
# by zhuo
#
# Rev. 0.0. July 14, 2009 - July 17, 2009  first version.
#
#
######################################################################
# board. width 12, height 5
# pieces
#
#[0]
#  ooooo  (no inversion)
#[1]
#  oo
#   ooo
#[2]
#  o o
#  ooo    (no inversion)
#[3]
#  oooo
#  o
#[4]
#    o
#  oooo
#[5]
#  ooo
#   oo
#[6]
#  o
#  ooo  (no inversion)
#  o
#[7]
#  o
#  ooo
#   o

#[8]
#   o
#  ooo   (no rotation, no inversion)
#   o
#[9]
#  oo
#   oo
#    o
#[10]
#  o
#  ooo
#    o
#[11]
#    o  
#    o
#  ooo   (no inversion)
#
#
# rotation ok
# inversion( upside-down) ok
#
#####################################################################





######################################################################
# packages
######################################################################
package require Img 1.3
source "Colors.tcl"
console show



######################################################################
# params
######################################################################
set ::boardWidth 12
set ::boardHeight 5

set ::nPieces 12

set ::pieceOrigPatterns {
    { { 0 0 0 0 0 } }
    { { 1 1 -1 -1 } { -1 1 1 1 } }
    { { 2 -1 2 } { 2 2 2 } }
    { { 3 3 3 3 } { 3 -1 -1 -1 } }
    { { -1 -1 4 -1 } { 4 4 4 4 } }
    { { 5 5 5 } { -1 5 5 } }
    { { 6 -1 -1 } { 6 6 6 } { 6 -1 -1 } }
    { { 7 -1 -1 } { 7 7 7 } { -1 7 -1 } }
    { { -1 8 -1 } { 8 8 8 } { -1 8 -1 } }
    { { 9 9 -1 } { -1 9 9 } { -1 -1 9 } }
    { { 10 -1 -1 } { 10 10 10 } { -1 -1 10 } }
    { { -1 -1 11 } { -1 -1 11 } { 11 11 11 } } 
}
set ::pieceRotations { 2 4 4 4 4 4 4 4 1 4 2 4 }
set ::pieceHasInversions { 0 1 0 1 1 1 0 1 0 0 1 0 }


proc patInvert { srcpat } {
    set newpat {} 
    for { set i [expr [llength $srcpat]-1]} { $i >= 0 } { incr i -1} {
	lappend newpat [lindex $srcpat $i]
    }
    return $newpat
}


# get a rotated version of the srcPattern
#
#   [        ]        [  ] 
#   [        ]     <- [  ]
#                     [  ]
#                     [  ]
proc patRotate { src } {
    set oheight [llength $src]
    set owidth [llength [lindex $src 0]]
    set nheight $owidth
    set nwidth $oheight
    set npat {}
    for { set nh [expr $nheight -1] } { $nh >= 0} {incr nh -1} {
	set nline {}
	for { set nw 0 } { $nw < $nwidth } {incr nw} {
	    lappend nline [lindex $src $nw $nh]
	}
	lappend npat $nline
    }
    return $npat
}

# test of the proc above; looks fine.
# puts [patRotate [lindex $::pieceOrigPatterns 7]]





######################################################################
# generate all patterns at the beginning 
######################################################################

array set ::piecePatterns { } 

for { set ip 0 } { $ip < $::nPieces } { incr ip } {
    # prepare color codes as well!
    set col [Colors_rgbToColorCode [Colors_hsvToRgb [expr {350.0 * $ip /$::nPieces}] 0.7 0.9]]

    set pat [lindex $::pieceOrigPatterns $ip]
    for { set rot 0 } { $rot < [lindex $::pieceRotations $ip] } { incr rot } {
	set pieceKey [format "%d,n,%d" $ip $rot]
	set ::piecePatterns($pieceKey) $pat
	set pat [patRotate $pat]
	set ::pieceColor($pieceKey) $col
    }
    if { [lindex $::pieceHasInversions $ip] } {
	set pat [patInvert [lindex $::pieceOrigPatterns $ip]]
	for { set rot 0 } { $rot < [lindex $::pieceRotations $ip] } { incr rot } {
	    set pieceKey [format "%d,i,%d" $ip $rot]
	    set ::piecePatterns($pieceKey) $pat
	    set pat [patRotate $pat]
	    set ::pieceColor($pieceKey) $col
	}
    }
}


## test dump:
#foreach n [lsort [array names ::piecePatterns]] {
#    puts "$n: $::piecePatterns($n)"
#}



######################################################################
# set up display
######################################################################



set ::boardSize 40
canvas .c -width [expr $::boardSize * $::boardWidth] -height [expr $::boardSize * $::boardHeight]
pack .c -side top

#prepare grids
for { set y 0 } { $y < $::boardHeight } { incr y } {
    for { set x 0 } { $x < $::boardWidth } { incr x } {
	.c create rectangle 1 1 $::boardSize $::boardSize -fill white -outline gray -tags "$x,$y"
	.c move "$x,$y" [expr $x * $::boardSize] [expr $y * $::boardSize]
    }
}



# show piece at grid x,y
proc showPieceAt { pieceKey gx gy } {
    set y $gy
    foreach row $::piecePatterns($pieceKey) {
	set x $gx
	foreach p $row {
	    if { $p >= 0 } {
		.c itemconfigure "$x,$y" -fill $::pieceColor($pieceKey)
	    }
	    incr x
	}
	incr y
    }
}
proc hidePieceAt { pieceKey gx gy } {
    set y $gy
    foreach row $::piecePatterns($pieceKey) {
	set x $gx
	foreach p $row {
	    if { $p >= 0 } {
		.c itemconfigure "$x,$y" -fill white
	    }
	    incr x
	}
	incr y
    }
}




proc setPieceAt { pieceKey gx gy boardImageArray} {
    upvar $boardImageArray boardImage
    set y $gy
    foreach row $::piecePatterns($pieceKey) {
	set x $gx
	foreach p $row {
	    if { $p >= 0 } {
		set boardImage($x,$y) $p
	    }
	    incr x
	}
	incr y
    }
}


proc clearPieceAt { pieceKey gx gy boardImageArray } {
    upvar $boardImageArray boardImage
    set y $gy
    foreach row $::piecePatterns($pieceKey) {
	set x $gx
	foreach p $row {
	    if { $p >= 0 } {
		set boardImage($x,$y) -1
	    }
	    incr x
	}
	incr y
    }
}



proc saveBoardFile { gifname } {
    image create photo boardsnap -data .c
    boardsnap write $gifname -format gif
    image delete boardsnap
}
    





######################################################################
# solver
######################################################################




# pieceUsage: { if0used if1used  ... if11used }
# piecePos { {x0 y0 pieceKey0} {x1 y1 pieceKey1} ... }
# choices: { { x y pieceKey } { x y pieceKey } ... }

proc resetBoardImage { boardImageArray } {
    upvar $boardImageArray boardImage

    for { set y 0 } { $y < $::boardHeight } { incr y } {
	for { set x 0 } { $x < $::boardWidth } { incr x } {
	    set boardImage($x,$y) -1
	}
    }
}


set ::solutionCnt 0
set ::logfname "sollog.txt"

proc solve {} {
    set ::fd [open $::logfname "w"]
    set pieceUsage { 0 0 0 0 0 0 0 0 0 0 0 0 }
    set piecePos {}
    resetBoardImage boardImage 

    solveOneStep $pieceUsage $piecePos boardImage
    puts "end"
    puts $::fd "end"
    close $::fd
}



proc solveOneStep { pieceUsage piecePos boardImageArray } {
    upvar $boardImageArray boardImage

    update

    set xy [getNextTarget boardImage]

    # if the board is completely full, return with !, doing nothing.
    if { $xy == "" } {
	puts "$::solutionCnt $piecePos"
	puts $::fd "$::solutionCnt $piecePos"
	flush $::fd
	saveBoardFile [format "sol%05d.gif" $::solutionCnt]
	incr ::solutionCnt
	return 2
    }


    # list up all the choices at (x,y).  give if none found.
    set choices [generateChoices $xy $pieceUsage boardImage]
    if { [llength $choices] == 0 } {
	return 1
    }

    # try each of them
    foreach c $choices {
	set x [lindex $c 0]
	set y [lindex $c 1]
	set pk [lindex $c 2]
	scan $pk "%d,%s,%d" pidx inv rot
	

	setPieceAt $pk $x $y boardImage
	showPieceAt $pk $x $y

	solveOneStep [lreplace $pieceUsage $pidx $pidx 1] [linsert $piecePos end $c] boardImage

	hidePieceAt $pk $x $y
	clearPieceAt $pk $x $y boardImage
    }	
    return 0
}



proc getNextTarget { boardImageArray } {
    upvar $boardImageArray boardImage

    for { set x 0 } { $x < $::boardWidth } { incr x } {
	if { $x % 2 == 0 } {
	    for { set y 0 } { $y < $::boardHeight } { incr y } {
		if { $boardImage($x,$y) == -1 } {
		    return "$x,$y"
		}
	    }
	} else {
	    for { set y [expr {$::boardHeight-1}]} { $y >= 0 } { incr y -1 } {
		if { $boardImage($x,$y) == -1 } {
		    return "$x,$y"
		}
	    }
	}
    }
    return ""
}





proc generateChoices { xy pieceUsage boardImageArray } {
    upvar $boardImageArray boardImage
    set choices {}

    set pieceIdx 0
    foreach used $pieceUsage {
	if { $used == 0 } {
	    foreach pieceKey [array names ::piecePatterns -regexp "^$pieceIdx,"] {
		foreach newChoices [generateChoicesForPieceKey $xy $pieceKey boardImage] {
		    lappend choices $newChoices
		}
	    }
	}
	incr pieceIdx
    }
    return $choices
}



proc generateChoicesForPieceKey { xy pieceKey boardImageArray } {
    upvar $boardImageArray boardImage
    scan $xy "%d,%d" x y
    set pat $::piecePatterns($pieceKey)
    set ph [llength $pat]
    set pw [llength [lindex $pat 0]]

    set beg_ty [expr {$y - $ph + 1}]
    if { $beg_ty < 0 } { set beg_ty 0 }
    set end_ty [expr {$::boardHeight - $ph}]
    if { $end_ty > $y } { set end_ty $y }

    set beg_tx [expr {$x - $pw + 1}]
    if { $beg_tx < 0 } { set beg_tx 0 }
    set end_tx [expr {$::boardWidth - $pw}]
    if { $end_tx > $x } { set end_tx $x }


    set newChoices {}
    for { set ty $beg_ty } { $ty <= $end_ty } { incr ty } {
	for { set tx $beg_tx } { $tx <= $end_tx } { incr tx } {
	    # speed up: skip if pattern does not cover (x,y)
	    if { [lindex $pat [expr {$y-$ty}] [expr {$x-$tx}]] < 0 } { continue }
	    if { [isPiecePlaceable $tx $ty $pat boardImage] } {
		lappend newChoices [list $tx $ty $pieceKey]
	    }
	}
    }
    return $newChoices 
}


proc isPiecePlaceable { x y pat boardImageArray } {
    upvar $boardImageArray boardImage
    set ty $y
    foreach row $pat {
	set tx $x
	foreach p $row {
	    if { $p >= 0 && $boardImage($tx,$ty) >= 0 } {
		return 0
	    }
	    incr tx
	}
	incr ty
    }
    return 1
}



######################################################################
solve

Pentomino Solver in tcl/tk // ペントミノ求解スクリプト

Pentomino Solver in tcl/tk //　ペントミノ求解スクリプト