[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.

[Zen Loops screenshot]

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.

----
======
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.

            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
}

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
# temp
set zenloops::board {}
zenloops::startlevel .c

======

<<categories>>Games