Zen Loops
KBK 2011-01-01:
Ever since I saw Arend Hintze's Flash game, "Loops of Zen", I knew that sooner or later we had to replicate it in Tcl/Tk.
And I finally found a few hours to make it happen.
It would surely be possible to add functionality like timing how long it takes to solve levels, saving scores, and so on. But that would not be in the meditative spirit of this game. Just click and contemplate the balance of the universe.
etdxc 2011-01-03 I think this is really great 10/10.
DKF: Thanks! That's another few hours of my life gone… :-)
AK: What Donal said.
KPV : This seems to be a prettier version of Lights On.
JBR : I liked this game so much I packaged it as a starpack for OS X with a screenshot icon:
http://rkroll.com/tclwiki/zenloops.zip
Jeff Smith 2021-06-23 : Below is an online demo using CloudTk. This demo runs "Zen Loops" in an Alpine Linux Docker Container. It is a 27.4MB image which is made up of Alpine Linux + tclkit + Zen-Loops.kit + libx11 + libxft + fontconfig + ttf-linux-libertine. It is run under a user account in the Container. The Container is restrictive with permissions for "Other" removed for "execute" and "read" for certain directories.
package require Tcl 8.5
package require Tk 8.5
package require Ttk 8.5
namespace eval zenloops {
namespace path {::tcl::mathop}
variable density 0.75
variable fgcolour #000000
variable board
variable values
variable wrong
}
namespace path {::tcl::mathop}
#-----------------------------------------------------------------------------
#
# zenloops::choose --
#
# Chooses one from a variable-length set of choices
#
# Parameters:
# choices -- List of choices
#
# Results:
# Returns a random selection from the list.
#
#-----------------------------------------------------------------------------
proc zenloops::choose {choices} {
return [lindex $choices [expr {int([llength $choices] * rand())}]]
}
#-----------------------------------------------------------------------------
#
# zenloops::chooseMulti --
#
# Chooses r items from a variable-length set of choices
#
# Parameters:
# choices - List of choices
#
# Results:
# Returns a randome selection of r items from the list.
#
#-----------------------------------------------------------------------------
proc zenloops::chooseMulti {choices r} {
set n [llength $choices]
set retval {}
foreach item $choices {
if {$n * rand() <= $r} {
lappend retval $item
incr r -1
}
incr n -1
}
return $retval
}
#-----------------------------------------------------------------------------
#
# zenloops::drawsquare --
#
# Draws one square of the diagram on the canvas.
#
# Parameters:
#
# c -- Path name of the canvas
# x, y -- Co-ordinates of the center of the square
# s -- Edge length of the square
# r, d, l, u -- 1 if the square connects to the square to its right,
# the square to its right, the square below it, and
# the square to its left.
# tag -- Tag to apply. Two tags will be applied: just the tag, and
# [linsert $tag 0 $itemType]
#
#-----------------------------------------------------------------------------
proc zenloops::drawsquare {c x y s r d l u tag} {
variable fgcolour
$c delete -withtag $tag
# Three cases: (1) The square has a single connection.
# (2) The square has two connections that are opposite.
# (3) The square has two connections that are adjacent, or
# more than two connections, in which case each adjacent
# pair is linked.
switch -exact -- [expr {$r + $d + $l + $u}] {
1 {
$c create oval [- $x [/ $s 4]] [- $y [/ $s 4]] \
[+ $x [/ $s 4]] [+ $y [/ $s 4]] \
-width [/ $s 4] -outline $fgcolour -fill {} \
-tags [list $tag oval [linsert $tag 0 oval]]
if {$r} {
$c create line [+ $x [/ $s 4]] $y \
[+ $x [/ $s 2]] $y \
-width [/ $s 4] -fill $fgcolour -capstyle round \
-tags [list $tag line [linsert $tag 0 line]]
}
if {$d} {
$c create line $x [+ $y [/ $s 4]] \
$x [+ $y [/ $s 2]] \
-width [/ $s 4] -fill $fgcolour -capstyle round \
-tags [list $tag line [linsert $tag 0 line]]
}
if {$l} {
$c create line [- $x [/ $s 4]] $y \
[- $x [/ $s 2]] $y \
-width [/ $s 4] -fill $fgcolour -capstyle round \
-tags [list $tag line [linsert $tag 0 line]]
}
if {$u} {
$c create line $x [- $y [/ $s 4]] \
$x [- $y [/ $s 2]] \
-width [/ $s 4] -fill $fgcolour -capstyle round \
-tags [list $tag line [linsert $tag 0 line]]
}
return
}
2 {
if {$u && $d} {
$c create line $x [- $y [/ $s 2]] $x [+ $y [/ $s 2]] \
-width [/ $s 4] -fill $fgcolour -capstyle round \
-tags [list $tag line [linsert $tag 0 line]]
return
}
if {$l && $r} {
$c create line [- $x [/ $s 2]] $y [+ $x [/ $s 2]] $y \
-width [/ $s 4] -fill $fgcolour -capstyle round \
-tags [list $tag line [linsert $tag 0 line]]
return
}
}
}
if {$r} {
if {$d} {
$c create line [+ $x [/ $s 2]] $y \
[+ $x [* $s 0.3]] $y \
$x [+ $y [* $s 0.3]] \
$x [+ $y [/ $s 2]] \
-width [/ $s 4] \
-fill $fgcolour -capstyle round -smooth 1 \
-tags [list $tag line [linsert $tag 0 line]]
}
if {$u} {
$c create line [+ $x [/ $s 2]] $y \
[+ $x [* $s 0.3]] $y \
$x [- $y [* $s 0.3]] \
$x [- $y [/ $s 2]] \
-width [/ $s 4] \
-fill $fgcolour -capstyle round -smooth 1 \
-tags [list $tag line [linsert $tag 0 line]]
}
}
if {$l} {
if {$d} {
$c create line [- $x [/ $s 2]] $y \
[- $x [* $s 0.3]] $y \
$x [+ $y [* $s 0.3]] \
$x [+ $y [/ $s 2]] \
-width [/ $s 4] \
-fill $fgcolour -capstyle round -smooth 1 \
-tags [list $tag line [linsert $tag 0 line]]
}
if {$u} {
$c create line [- $x [/ $s 2]] $y \
[- $x [* $s 0.3]] $y \
$x [- $y [* $s 0.3]] \
$x [- $y [/ $s 2]] \
-width [/ $s 4] \
-fill $fgcolour -capstyle round -smooth 1 \
-tags [list $tag line [linsert $tag 0 line]]
}
}
return
}
#-----------------------------------------------------------------------------
#
# makeconnections --
#
# Determines the set of connections on the board to be solved.
#
# Parameters:
#
# size - Size of the board to make
#
# Return values:
# Returns a two-element list; the first element is the table of vertical
# connections ((size-1) x size), and the second is the table of
# horizontal connections (size x (size-1)).
#
#-----------------------------------------------------------------------------
proc zenloops::makeconnections {size} {
variable density
set vconn [lrepeat [- $size 1] [lrepeat $size 0]]
set hconn [lrepeat $size [lrepeat [- $size 1] 0]]
set did [lrepeat $size [lrepeat $size 0]]
# Connections will be made with probability $density
set n [expr {int(2 * $density * $size * $size-1)}]
# First, make sure that every cell is connected
for {set v 0} {$v < $size} {incr v} {
for {set h 0} {$h < $size} {incr h} {
if {[lindex $did $v $h]} continue
set choices {}
if {$v > 0} {
lappend choices [list [- $v 1] $h vconn [- $v 1] $h]
}
if {$v+1 < $size} {
lappend choices [list [+ $v 1] $h vconn $v $h]
}
if {$h > 0} {
lappend choices [list $v [- $h 1] hconn $v [- $h 1]]
}
if {$h+1 < $size} {
lappend choices [list $v [+ $h 1] hconn $v $h]
}
lassign [choose $choices] v0 h0 table v1 h1
lset did $v $h 1
incr n -1
if {![lindex $did $v0 $h0]} {
lset did $v0 $h0 1
incr n -1
}
lset $table $v1 $h1 1
}
}
# Fill in enough remaining cells to get the desired density
set choices {}
set v 0
foreach row $vconn {
set h 0
foreach cell $row {
if {!$cell} {
lappend choices [list vconn $v $h]
}
incr h
}
incr v
}
set v 0
foreach row $hconn {
set h 0
foreach cell $row {
if {!$cell} {
lappend choices [list hconn $v $h]
}
incr h
}
incr v
}
foreach item [chooseMulti $choices $n] {
lassign $item table v h
lset $table $v $h 1
}
return [list $vconn $hconn]
}
#-----------------------------------------------------------------------------
#
# makeboard --
#
# Makes a new board.
#
# Parameters:
#
# size - Size of the board.
#
# Results:
# Returns the new board as a (size x size) table of 4-element lists.
# Each list element represents whether the board element has a
# connection to the element to its right, below it, to its left, and
# above it.
#
#-----------------------------------------------------------------------------
proc zenloops::makeboard {size} {
variable board
lassign [makeconnections $size] vconn hconn
set initboard [lrepeat $size [lrepeat $size [lrepeat 4 0]]]
set v 0
foreach row $hconn {
set h 0
foreach cell $row {
if {$cell} {
lset initboard $v $h 0 1
lset initboard $v [+ $h 1] 2 1
}
incr h
}
incr v
}
set v 0
foreach row $vconn {
set h 0
foreach cell $row {
if {$cell} {
lset initboard $v $h 1 1
lset initboard [+ $v 1] $h 3 1
}
incr h
}
incr v
}
set board {}
foreach row $initboard {
set outrow {}
foreach cell $row {
set cut [expr {int(4*rand())}]
lappend outrow \
[list {*}[lrange $cell $cut end] \
{*}[lrange $cell 0 [- $cut 1]]]
}
lappend board $outrow
}
}
#-----------------------------------------------------------------------------
#
# evalcell --
#
# Evaluate whether a cell connects to its neighbours
#
# Parameters:
# v, h - Co-ordinates of the cell
#
# Reuslts:
# Returns 0 if the cell connects correctly, 1 if it has a problem.
#
#-----------------------------------------------------------------------------
proc zenloops::evalcell {v h} {
variable board
set n [llength $board]
set cell [lindex $board $v $h]
if {$h + 1 < $n} {
set shouldbe [lindex $board $v [+ $h 1] 2]
} else {
set shouldbe 0
}
if {[lindex $cell 0] != $shouldbe} {
return 1
}
if {$v + 1 < $n} {
set shouldbe [lindex $board [+ $v 1] $h 3]
} else {
set shouldbe 0
}
if {[lindex $cell 1] != $shouldbe} {
return 1
}
if {$h > 0} {
set shouldbe [lindex $board $v [- $h 1] 0]
} else {
set shouldbe 0
}
if {[lindex $cell 2] != $shouldbe} {
return 1
}
if {$v > 0} {
set shouldbe [lindex $board [- $v 1] $h 1]
} else {
set shouldbe 0
}
if {[lindex $cell 3] != $shouldbe} {
return 1
}
return 0
}
#-----------------------------------------------------------------------------
#
# adjustcell --
#
# Adjusts the valuation for a cell when the player spins a cell or
# one of its neighbours
#
# Parameters:
# v, h -- Co-ordinates of the cell being adjusted
#
# Results:
# None.
#
# Side effects:
# Updates values and wrong for the cell and its neighbours.
#
#-----------------------------------------------------------------------------
proc zenloops::adjustcell {v h} {
variable board
variable values
variable wrong
incr wrong [- [lindex $values $v $h]]
set val [evalcell $v $h]
lset values $v $h $val
incr wrong $val
}
#-----------------------------------------------------------------------------
#
# adjustvalues --
#
# Adjusts the valuation for a cell and its neighbours when the player
# spins a cell.
#
# Parameters:
# v, h -- Co-ordinates of the cell being spun#
# board -- State of the board
# weight -- -1 before the rotation, 1 afterward
# count of cells that are wrong.
#
# Results:
# None.
#
# Side effects:
# Updates values and wrong for the cell and its neighbours.
#
#-----------------------------------------------------------------------------
proc zenloops::adjustvalues {v h} {
variable values
variable wrong
variable board
set n [llength $board]
adjustcell $v $h
if {$v > 0} {
adjustcell [- $v 1] $h
}
if {$h > 0} {
adjustcell $v [- $h 1]
}
if {$v + 1 < $n} {
adjustcell [+ $v 1] $h
}
if {$h + 1 < $n} {
adjustcell $v [+ $h 1]
}
}
#-----------------------------------------------------------------------------
#
# evalboard --
#
# Make an initial evaluation of the board.
#
# Results:
# Returns a count of incorrect cells.
#
#-----------------------------------------------------------------------------
proc zenloops::evalboard {} {
variable board
variable values
variable wrong
set values {}
set wrong 0
set v 0
foreach row $board {
set outrow {}
set h 0
foreach cell $row {
set val [evalcell $v $h]
lappend outrow $val
incr wrong $val
incr h
}
lappend values $outrow
incr v
}
return $wrong
}
#-----------------------------------------------------------------------------
#
# geometry --
#
# Compute the geometry of the board from its size and the window
# dimensions.
#
# Parameters:
# w, h -- Width and height of the window
#
# Results:
# Returns a three-element list {step xorg yorg} where
# step is the spacing between squares
# (xorg, yorg) is the center of square (0,0)
#
#-----------------------------------------------------------------------------
proc zenloops::geometry {w h} {
variable board
if {$w > $h} {
set size $h
set xorg [expr {double($w - $h) / 2}]
set yorg 0
} else {
set size $w
set xorg 0
set yorg [expr {double($h - $w) / 2}]
}
set n [llength $board]
set step [expr {double($size) / ($n + 1)}]
set xorg [expr {$xorg + $step}]
set yorg [expr {$yorg + $step}]
return [list $step $xorg $yorg]
}
#-----------------------------------------------------------------------------
#
# drawboard --
#
# Draw the whole board from scratch
#
# Parameters:
# c -- Path name of the canvas
# w -- Width of the canvas
# h -- Height of the canvas
#
# Results:
# Draws the board.
#
#-----------------------------------------------------------------------------
proc zenloops::drawboard {c w h} {
variable board
lassign [geometry $w $h] step xorg yorg
$c delete all
set v 0
foreach row $board {
set h 0
foreach cell $row {
drawsquare $c [+ $xorg [* $step $h]] [+ $yorg [* $step $v]] $step \
{*}$cell [list $v $h]
incr h
}
incr v
}
return
}
#-----------------------------------------------------------------------------
#
# configlevel1 --
#
# Adjust the message for the level1 screen
#
# Parameters:
# c - Path name of the canvas
#
# Results:
# None.
#
#-----------------------------------------------------------------------------
proc configlevel1 {c} {
$c coords line [/ [winfo width $c] 2] [/ [winfo height $c] 2]
}
#-----------------------------------------------------------------------------
#
# startlevel1 --
#
# Start the first level by displaying instructions
#
# Parameters:
# c - Path name of the canvas
#
# Results:
# None.
#
#-----------------------------------------------------------------------------
proc zenloops::startlevel1 {c} {
variable board
set board [list [list [list 0 0 0 0]]]
$c create text [/ [winfo width $c] 2] [/ [winfo height $c] 2] \
-text [regsub -all -lineanchor {^[ \t]+} [string trim {
Zen Loops
Inspired by the game
"Loops of Zen"
originally written by
Dr. Arend Hintze
Restore harmony to the universe
by clicking the tiles until all
the loose ends are attached.
Ctrl-s to save the game.
Ctrl-l to load it.
Click to begin.
}] {}] \
-font {Courier -24} -anchor center -justify center -tags line
bind $c <1> [list [namespace which finishlevel] %W]
bind $c <Configure> [list [namespace which configlevel1] %W]
}
#-----------------------------------------------------------------------------
#
# startlevel --
#
# Start playing a new level. Level 1 is special - it displays
# instructions and invites the user to click to continue.
#
# Parameters:
# c - Path name of the canvas.
#
#-----------------------------------------------------------------------------
proc zenloops::startlevel {c} {
variable board
set n [+ 1 [llength $board]]
if {$n == 1} {
startlevel1 $c
} else {
while 1 {
zenloops::makeboard $n
set wrong [evalboard]
if {$wrong} break
}
bind $c <Configure> [list [namespace which drawboard] %W %w %h]
bind $c <Button-1> [list [namespace which spin] %W %x %y]
drawboard $c [winfo width $c] [winfo height $c]
fadein $c 100
}
}
#-----------------------------------------------------------------------------
#
# fadeout --
#
# Fade out a level when the player succeeds.
#
# Parameters:
# c -- Path name of the canvas.
# step -- Number of time steps that have been completed.
#
# Results:
# None.
#
# Side effects:
# Fades the board and schedules the next fadeout, or starts the next
# level.
#
#-----------------------------------------------------------------------------
proc zenloops::fadeout {c step} {
variable fgcolour
if {$step < 100} {
set intens [expr {255 * $step / 100}]
set fgcolour [format "#%02x%02x%02x" $intens $intens $intens]
$c itemconfigure oval -outline $fgcolour
$c itemconfigure line -fill $fgcolour
after 20 [list [namespace which fadeout] $c [+ 1 $step]]
} else {
$c delete all
startlevel $c
}
}
#-----------------------------------------------------------------------------
#
# fadein --
#
# Fade in a level when starting it.
#
# Parameters:
# c -- Path name of the canvas.
# step -- Number of time steps that have been completed.
#
# Results:
# None.
#
# Side effects:
# Fades the board and schedules the next fadein, or starts the next
# level.
#
#-----------------------------------------------------------------------------
proc zenloops::fadein {c step} {
variable fgcolour
if {$step > 0} {
set intens [expr {255 * $step / 100}]
set fgcolour [format "#%02x%02x%02x" $intens $intens $intens]
$c itemconfigure oval -outline $fgcolour
$c itemconfigure line -fill $fgcolour
after 20 [list [namespace which fadein] $c [- $step 1]]
}
return
}
#-----------------------------------------------------------------------------
#
# finishlevel --
#
# Finish playing a level
#
# Parameters:
# c - Path name of the canvas
#
# Results:
# None.
#
# Side effects:
# Starts a fade effect and advances to the next level when it finishes.
#
#-----------------------------------------------------------------------------
proc zenloops::finishlevel {c} {
bind $c <Button-1> {}
bind $c <Configure> {}
fadeout $c 0
}
#-----------------------------------------------------------------------------
#
# spin --
#
# Rotate the figure in a cell when the player mouses on the cell.
#
# Results:
# None.
#
# Side effects:
# Updates board valuation
#
#-----------------------------------------------------------------------------
proc zenloops::spin {c x y} {
variable board
variable values
variable wrong
set n [llength $board]
lassign [geometry [winfo width $c] [winfo height $c]] \
step xorg yorg
set v [expr {int(($y - $yorg + $step/2) / $step)}]
set h [expr {int(($x - $xorg + $step/2) / $step)}]
if {$v < 0 || $v >= $n || $h < 0 || $h >= $n} return
set cell [lassign [lindex $board $v $h] first]
lappend cell $first
lset board $v $h $cell
drawsquare $c [+ $xorg [* $step $h]] [+ $yorg [* $step $v]] $step \
{*}$cell [list $v $h]
adjustvalues $v $h
if {$wrong == 0} {
finishlevel $c
}
return
}
#-----------------------------------------------------------------------------
#
# load --
#
# Loads the current state.
#
# Parameters:
#
# f -- State file name
# c -- Path name of the canvas
#
# Results:
# None.
#
# Side effects:
# None.
#
#-----------------------------------------------------------------------------
proc zenloops::load {f c} {
uplevel 1 [list source $f]
bind $c <Configure> [list [namespace which drawboard] %W %w %h]
bind $c <Button-1> [list [namespace which spin] %W %x %y]
drawboard $c [winfo width $c] [winfo height $c]
}
#-----------------------------------------------------------------------------
#
# save --
#
# Saves the current state.
#
# Parameters:
#
# f -- State file name
#
# Results:
# None.
#
# Side effects:
# The state file is created or overwritten.
#
#-----------------------------------------------------------------------------
proc zenloops::save {f} {
variable board
variable values
variable wrong
if {[llength $board] > 1} {
set fh [open $f w]
puts $fh [list set zenloops::board $board]
puts $fh [list set zenloops::values $values]
puts $fh [list set zenloops::wrong $wrong]
close $fh
tk_messageBox -message "State saved to \"$f\"."
}
}
wm title . "Zen Loops"
wm iconname . "ZenLoops"
grid [canvas .c -width 512 -height 512 \
-background white -relief flat -borderwidth 0] \
-sticky nsew -columnspan 2 -row 0 -column 0
grid [ttk::frame .f] -row 1 -column 0
grid [ttk::sizegrip .grip] -row 1 -column 1 -sticky se
grid rowconfigure . 0 -weight 1
grid columnconfigure . 0 -weight 1
set zenloops::path [file dirname [info script]]
set zenloops::file [file join $zenloops::path zensave.tcl]
bind . <F2> [list console show]
bind . <Control-s> [list zenloops::save $zenloops::file]
bind . <Control-l> [list zenloops::load $zenloops::file .c]
# temp
set zenloops::board {}
zenloops::startlevel .cHJG: Without looking at the source, Save&Load are not obvious. Added to the welcome-message.
HE 2021-12-18: Loading a before saved level will directly finish an uncompleted level and go to the next level. Issue was zenloops::load doesn't set the bindings. Fixed.
HE 2021-12-18: Ctrl-s in welcome message lead to error message. Fixed.