Vertigo - a little Tk game

Fred Limouzin - 7 Feb 2005:

Here's a little game I coded about a year ago from my version in C. It's called Vertigo - a little Tk game and has been inspired by an old game from After-Dark (can't remember the platform). This is my first wiki page so bear with me if I'm making a mess out if it!

First of all, here's a screenshot:

http://dire.straits.free.fr/vertigo/TkVertigo.gif

More information on rules and how to play can be found below in the help file.

You'll find the code and help file ready for download at this location: http://dire.straits.free.fr/vertigo ([L1 ]). Else copy and paste the help text below and save in a file called VertigoTkRegles.txt (b-t-w: regles = rules in French!). Then copy & paste the code into a file called (for instance) TkVertigo.tk.

It's by no mean state-of-the-art, but as usual with Tcl, had the advantage of being coded in just a few hours, whilst I had spent ages on the C version!

Any feedback, comments, etc. much appreciated. Have fun!

--Fred ([L2 ])

RHS Nice. It works a lot like the Cubes [L3 ] game I wrote, only Cubes doesn't have people, just cubes :) - RS: see also Collapse - currently my favorite game on the iPaq :^)

Brian Theado - 05March2005 - Added package require Tk and made it so the help file is accessible even if executed from a different directory (i.e. in a starkit).

This is the help file. Copy everything in a text file named VertigoTkRegles.txt (must use this name as it is expected by the code thereafter).

help file 

Tk-Vertigo, by Frederic Limouzin
Copyrights (c)2004-2005 Fred Limouzin
(inspired by an old game from AFTER-DARK).
Download it at http://dire.straits.free.fr/vertigo



Goal: Set the people free!
Secondary goal: Destroy all bricks.



People:
=======
There are as many people as columns.
Each person (grey square at the top at the beginning), has a 'quality'
randomly assigned at the beginning of a new game.
Dark Grey = Quality of 0; light grey (nearly white) = 6.
This corresponds to the maximum number of bricks directly below him
from which he'll start his descend from his column;

For instance, Renaud, second-to-none-alpinist, has a quality of 6. 
He'll be able to free himself if he stands on a column up to 6
bricks tall. Taller, he'll remain prisoner.

On the other hand, Fred, desperately lacking exercise after all those
hours spent on the front of a computer, has a quality of 0. He'll be
set free only if all bricks below him are destroyed.


Bricks and Blocks:
==================
When a game starts, the game table is filled in randomly by picking
a color for each brick.
A block is a contiguous ensemble of at least 2 bricks of same color..

For instance, in the following game table:
  R B P V P
  V R R R P
  V R P P P
  B R P B P
  P R R R V
  V B B B B

You find 4 blocks:

  . . . . P            . . . . .
  . . . . P            . R R R .
  . . P P P            . R . . .
  . . P . P            . R . . .
  . . . . .            . R R R .
  . . . . .            . . . . .

  . . . . .            . . . . .
  V . . . .            . . . . .
  V . . . .            . . . . .
  . . . . .    and     . . . . .
  . . . . .            . . . . .
  . . . . .            . B B B B


The goal is therefore to destroy all blocks by clicking on one of the
bricks constituting the block we want to blast, and by doing so the
columns will collapse and decrease their size, having the prisoners
ever so slightly closer from freedom.

Thanks to Gravity, not only apples, but bricks fall if the supporting
bricks below them vanish.

From the preceding example, if we click on a Red brick from the red
'C'-shaped-block, that block disapears.

  R B P V P
  V - - - P
  V - P P P
  B - P B P
  P - - - V
  V B B B B

But due to Gravity, this is in fact what happens:

  R - - - P
  V - - - P
  V - P V P
  B - P P P
  P B P B V
  V B B B B

Note that by blasting the Red C-shaped block, we have increased the
size of the Blue and Purple blocks.

When a full column is destroyed, the game is squeezed to the left.

For instance if we now select a brick in the Blue block, the second
column from the left will be empty. But after the squeezing force
the result is in fact as follows:

  R - - - -
  V - - P -
  V - - P -
  B P - P -
  P P V P -
  V P P V -


Scores:
=======
Each freed prisoner gives a lame lonely point.

If - and only if - all dudes have escaped from Shawshank, then each
empty column adds another point

If all bricks have been destroyed, a Bonus of 50 points is Oh So
generously given to you time wasters.

Finally, and also only in the case of an empty game table, the 'timed'
Bonus left at the end of the game is added. When you start a game the
timed-Bonus is 100. But hurry!, every second robes you of a precious
point.

'Tries' is the number of games played in one session.
'Best' is the best score you got in one session of x games.


Interface:
==========
Although the C version gives very little configurability, the Tk
Version gives plenty! Just browse the menu, and select the level
of difficulty, which depends on many parameters.

The game knows if it is over and you are stuck with no more 'moves'
or if you won. A message in red is displayed under the game table
in both cases.

Very often you'll be unable to destroy all bricks. Do not despair,
hit the 'New Game' button and try again.

Warning: I find this game very addictive. I will not be held
responsible of O.D'ing, time wasted, sleep or job loss.... :-)

Enjoy, Have Fun!

--Fred
[email protected] (personal email; not read regularly)

Code 

#!/bin/sh
# [email protected] \
exec wish "$0" {1+"$@"}

#/*************************************************/
#/*                                               */
#/* Vertigo Game, 8 Septembre 2000  (C)           */
#/* Vertigo Game, 2 January   2004  (TclTk 8.4)   */
#/* (c)2000-2005 Frederic LIMOUZIN                */
#/* [email protected]                           */
#/* download it from dire.straits.free.fr/vertigo */
#/*                                               */
#/*************************************************/

package require Tk
set DEBUG false
if {($tcl_platform(platform) eq {windows}) && ($DEBUG eq {true})} {
    console show
}

#--------------------------------------------------------------------

set fname(scores) VertigoScores.log ;# not used yet; tbd
set fname(rules)  [file join [file dirname [info script]] VertigoTkRegles.txt]

# ----=================================================----

# Sorry half of my comments are in French!
# (i.e. those that came straight from my version in C from which
#  I based the Tk Version)

#// Table de Jeu Max(X)*Max(Y). x E [0;Max(X)-1]; y E [0;Max(Y)-1]
#//rem: au debut, les personnage se trouvent en fait a y=Max(Y).
set Options(XMax)       16
set Options(YMax)       10
set Options(BoxSize)    20 ;#pixels
set Options(BoxBorder)   2 ;#pixels
set Options(Offset)     10
#//Chaque brique a une qualite (example: couleur), choisi parmi les
#//qualite disponibles dans l'espace defini par la constante ci-dessous:
#// Qualite Brique E [0;Max(QBriq)-1]
#//max: 6; conseille: 5 (3:facile; 6:difficile)
set Options(ColorList)   {red blue green yellow orange darkblue purple cyan}
set Options(NbColors)    4
#//Les personnages ont une 'Qualite'; il s'agit du nombre de briques
#//a partir et au dessous duquel ils entament leur dessente, et se
#//liberent.
#//Un personnage de qualite 3 pourra se liberer si la pile en dessous
#//de lui est au maximum de 3 briques (il se libere donc s'il a 0,1,2 ou 3
#//briques sous lui, mais reset prisonier s'il y a 4 ou plus briques).
#// Qualite Personne E [0;Max(QPers)-1]
#//max: 6; conseille: 6 (0:difficile, 6:facile)
set Options(QualMax)     6
set Options(QualMin)     0
#//Bonus
set Options(AllFreedBonus)   50
set Options(TimeBonus)      101

# ----=================================================----

set Scores(points) 0
set Scores(essais) 0
set Scores(best)   0
set Scores(bonus) $Options(TimeBonus)
set Scores(decbonus) off
set Scores(game) off

# ----=================================================----

wm title     . "TkVertigo"
wm iconname  . "TkVertigo"
wm resizable . 0 0     ;# not resizable in either x or y

# ----=================================================----

set Menu(Root) .menubar
set Menu(File) $Menu(Root).filemenu
set Menu(Pref) $Menu(Root).prefmenu
set Menu(Help) $Menu(Root).help
menu $Menu(Root)
. configure -menu $Menu(Root)
$Menu(Root) add cascade -label "File" -menu $Menu(File) -underline 0
$Menu(Root) add cascade -label "Pref" -menu $Menu(Pref) -underline 0
$Menu(Root) add cascade -label "Help" -menu $Menu(Help) -underline 0

menu $Menu(File) -tearoff 0
$Menu(File) add command -label "Load" -command {Load}
$Menu(File) add command -label "Save" -command {Save}
$Menu(File) add separator
$Menu(File) add command -label "Exit" -command {Quit} -underline 1 -accelerator "Ctrl-X"

proc Load {} {tk_messageBox -message "Not Done yet..." -type ok}
proc Save {} {tk_messageBox -message "Not Done yet..." -type ok}
proc About {} {tk_messageBox -message "TkVertigo (for Tcl/Tk8.4+)\nCopyrights(c)2004-2005 Frederic Limouzin" -title TkVertigo -type ok}
proc Quit {} {
    catch {after cancel $::afterId} res
    exit
}
#------------------
menu $Menu(Pref) -tearoff 1 -title "Preferences"
menu $Menu(Pref).cols -tearoff 0
menu $Menu(Pref).rows -tearoff 0
menu $Menu(Pref).nbcolors -tearoff 0
menu $Menu(Pref).qmax -tearoff 0
menu $Menu(Pref).qmin -tearoff 0
menu $Menu(Pref).blocsz -tearoff 0
for {set i 5} {$i <= 20} {incr i} {
   $Menu(Pref).cols add radiobutton -label $i -value $i -variable Options(XMax) -command {InitBoard}
   $Menu(Pref).rows add radiobutton -label $i -value $i -variable Options(YMax) -command {InitBoard}
}
for {set i 3} {$i <= 8} {incr i} {
   $Menu(Pref).nbcolors add radiobutton -label $i -value $i -variable Options(NbColors) -command {InitBoard}
}
for {set i 0} {$i <= 6} {incr i} {
   $Menu(Pref).qmax add radiobutton -label $i -value $i -variable Options(QualMax) -command {InitBoard}
   $Menu(Pref).qmin add radiobutton -label $i -value $i -variable Options(QualMin) -command {InitBoard}
}
foreach i {15 20 30 40 60} {
   $Menu(Pref).blocsz add radiobutton -label $i -value $i -variable Options(BoxSize) -command {InitBoard}
}
$Menu(Pref) add cascade -label "Nb Cols" -menu $Menu(Pref).cols
$Menu(Pref) add cascade -label "Nb Rows" -menu $Menu(Pref).rows
$Menu(Pref) add separator
$Menu(Pref) add cascade -label "Nb Colors" -menu $Menu(Pref).nbcolors
$Menu(Pref) add separator
$Menu(Pref) add cascade -label "Qual Max" -menu $Menu(Pref).qmax
$Menu(Pref) add cascade -label "Qual Min" -menu $Menu(Pref).qmin
$Menu(Pref) add separator
$Menu(Pref) add cascade -label "Bloc Size" -menu $Menu(Pref).blocsz
$Menu(Pref) add checkbutton -label "Bloc Border" -onvalue 2 -offvalue 0 -variable Options(BoxBorder) -command {InitBoard}

#------------------

menu $Menu(Help) -tearoff 1 -title "Help Menu"
$Menu(Help) add command -label "Help"  -command {Help}
$Menu(Help) add command -label "About" -command {About}

# ----=================================================----

label .titre -text {~~---===[ Vertigo by Fred ]===---~~} -font {Courier}
pack .titre -side top
label .cprght -text {Copyrights (c)2000-2005 Fred-Phenix, Fred Limouzin} -justify right
pack .cprght -side bottom -fill x -anchor e
button .xit -text Exit -command {exit}
pack .xit -side bottom -fill x
set remtxt {}
label .rembox -textvariable remtxt -foreground red
pack .rembox -side bottom
canvas .board -background black -relief sunken -borderwidth $Options(BoxBorder)
pack .board -side left
frame .score
label .score.lbbon -text {Bonus:}
label .score.bon -textvariable Scores(bonus)
label .score.lbpts -text {Points:}
label .score.pts -textvariable Scores(points)
label .score.lbtry -text {Tries:}
label .score.try  -textvariable Scores(essais)
label .score.lbbest -text {Best:}
label .score.best -textvariable Scores(best)
button .score.new -text {New Game} -command {NewGame}
grid .score.lbbon  -row 1 -column 1
grid .score.bon    -row 1 -column 2
grid .score.lbpts  -row 2 -column 1
grid .score.pts    -row 2 -column 2
grid .score.lbtry  -row 3 -column 1
grid .score.try    -row 3 -column 2
grid .score.lbbest -row 4 -column 1
grid .score.best   -row 4 -column 2
grid .score.new    -row 5 -column 1 -columnspan 2
pack .score -side right

# ----=================================================----

proc RectangleCoords {px py} {
    global Options
    set t [expr {(($Options(YMax) + 1) * $Options(BoxSize)) + (2 * $Options(Offset))}]
    set x1 [expr {($px * $Options(BoxSize)) + $Options(Offset)}]
    set y1 [expr {($py * $Options(BoxSize)) + $Options(Offset)}]
    set x2 [expr {$x1 + $Options(BoxSize)}]
    set y2 [expr {$y1 + $Options(BoxSize)}]
    return [list $x1 [expr {$t - $y1}] $x2 [expr {$t - $y2}]]
}

# ----=================================================----

proc ClickOnBox {px py} {
    global Board
    if {$::DEBUG eq {true}} {
        puts "$px,$py,$Board($px,$py,type),$Board($px,$py,color),$Board($px,$py,qual)"
    }
    DestroyBloc $px $py
    Freedom
    SkeezeEmptyCol
    TestEndGame
}

# ----=================================================----

proc TestEndGame {} {
    global Scores
    global Options
    global remtxt
    #games was over and still is!
    if {!$Scores(game)} {
        return off
    #game not over
    } elseif {[RemainingBloc]} {
        set remtxt {}
    #game over
    } else {
        set Scores(decbonus) off
        set Scores(game)     off
        set rc [RemainingColumn]
        #All columns destroyed (hence all people freed) => Bonus
        if {$rc == 0} {
            set Scores(points) $Options(AllFreedBonus)
            incr Scores(points) $Scores(bonus)
            set remtxt "You Win!"
        #not all columns destroyed
        } else {
            #add nb of col destroyed ONLY when all people freed
            if {$Scores(points) == $Options(XMax)} {
                set remtxt "No more Remaining bloc left! Not all columns destroyed!"
                incr Scores(points) [expr {$Options(XMax) - $rc}]
            } else {
                set remtxt "No more Remaining bloc left! Not everyone free!"
            }
        }
        set Scores(bonus) 0
    }
}


# ----=================================================----

proc NewGame {} {
    global Scores
    global remtxt
    global Options
    set remtxt {}
    incr Scores(essais)
    if {$Scores(points) > $Scores(best)} {
        set Scores(best) $Scores(points)
    }
    set Scores(points)   0
    set Scores(bonus)    $Options(TimeBonus)
    set Scores(decbonus) off

    InitBoard
    set Scores(decbonus) on
    set Scores(game) on
    DecBonus
}

# ----=================================================----

proc InitBoard {} {
    global Options
    global Board
    if {$Options(QualMax) < $Options(QualMin)} {
        foreach {Options(QualMin) Options(QualMax)} [list $Options(QualMax) $Options(QualMin)] {break;} ;#Quick Swap
    }
    eval .board delete [.board find all]

    .board configure -width  [expr {($Options(XMax) + 1) * $Options(BoxSize)}]
    .board configure -height [expr {($Options(YMax) + 2) * $Options(BoxSize)}]
    array unset -nocomplain Board
    for {set i 0} {$i < $Options(XMax)} {incr i} {
        for {set j 0} {$j <= $Options(YMax)} {incr j} {
            if {$j == $Options(YMax)} {
                set q [expr {int(rand()*(1 + $Options(QualMax) - $Options(QualMin))) + $Options(QualMin)}]
                set Board($i,$Options(YMax),color) [format {#%06X} [expr {0x222222 * (1 + $q)}]]
                set Board($i,$Options(YMax),type) Person
                set Board($i,$Options(YMax),qual) $q
            } else {
                set Board($i,$j,color) [lindex $Options(ColorList) [expr {int(rand()*$Options(NbColors))}]]
                set Board($i,$j,type) Bric
                set Board($i,$j,qual) {}
            }
            .board create rectangle [RectangleCoords $i $j] \
                 -fill $Board($i,$j,color) -outline black -width $Options(BoxBorder) \
                 -tags tagcoord($i,$j)
            .board bind tagcoord($i,$j) <Button-1> [list ClickOnBox $i $j]
        }
    }
}

# ----=================================================----

proc Gravity {} {
    global Options
    global Board
    for {set i 0} {$i < $Options(XMax)} {incr i} {
        for {set j 0} {$j < $Options(YMax)} {incr j} {
            if {$Board($i,$j,type) eq "Empty"} {
                for {set jj [expr {$j+1}]} {$jj <= $Options(YMax)} {incr jj} {
                    if {$Board($i,$jj,type) ne "Empty"} {
                        foreach f {type color qual} e {Empty black {}} {
                            set Board($i,$j,$f) $Board($i,$jj,$f)
                           set Board($i,$jj,$f) $e
                        }
                        .board itemconfigure tagcoord($i,$j)  -fill $Board($i,$j,color)
                        .board itemconfigure tagcoord($i,$jj) -fill $Board($i,$jj,color)
                        break;
                    }
                }
            }
        }
    }
}

# ----=================================================----

proc Freedom {} {
    global Options
    global Board
    global Scores
    for {set i 0} {$i < $Options(XMax)} {incr i} {
        for {set j 0} {$j < $Options(QualMax)} {incr j} {
            if {($Board($i,$j,type) eq "Person") && ($Board($i,$j,qual) >= $j)} {
                set Board($i,$j,type) Empty
                foreach f {type color qual} e {Empty black {}} {
                    set Board($i,$j,$f) $e
                }
                .board itemconfigure tagcoord($i,$j) -fill $Board($i,$j,color)
                incr Scores(points)
            }
        }
    }
}

# ----=================================================----

proc SkeezeEmptyCol {} {
    global Options
    global Board
    global Scores
    for {set i 0} {$i < [expr {$Options(XMax) - 1}]} {incr i} {
        if {$Board($i,0,type) eq "Empty"} {
            for {set ii [expr {$i+1}]} {$ii < $Options(XMax)} {incr ii} {
                if {$Board($ii,0,type) ne "Empty"} {
                    for {set jj 0} {$jj < [expr {$Options(YMax)+1}]} {incr jj} {
                        foreach f {type color qual} e {Empty black {}} {
                            set Board($i,$jj,$f) $Board($ii,$jj,$f)
                            set Board($ii,$jj,$f) $e
                        }
                       .board itemconfigure tagcoord($i,$jj)  -fill $Board($i,$jj,color)
                       .board itemconfigure tagcoord($ii,$jj) -fill $Board($ii,$jj,color)
                    }
                    break;
                }
            }
        }
    }
}

# ----=================================================----

proc Recurs_BlocOutline {x y c} {
    global Options
    global Board
    global MatrixDestruction
    global nbBricsInBloc
    if {($Board($x,$y,type) eq "Bric")&&($Board($x,$y,color) eq $c)&&($MatrixDestruction($x,$y) == 0)} {
        set MatrixDestruction($x,$y) 1
        incr nbBricsInBloc
        if {$x > 0} {
            Recurs_BlocOutline [expr {$x-1}] $y $c
        }
        if {$x < $Options(XMax)-1} {
            Recurs_BlocOutline [expr {$x+1}] $y $c
        }
        if {$y > 0} {
            Recurs_BlocOutline $x [expr {$y-1}] $c
        }
        if {$y < $Options(YMax)-1} {
            Recurs_BlocOutline $x [expr {$y+1}] $c
        }
    }
}

# ----=================================================----

proc BlocOutline {x y} {
    global Options
    global Board
    global MatrixDestruction
    global nbBricsInBloc
    set nbBricsInBloc 0
    for {set i 0} {$i < $Options(XMax)} {incr i} {
        for {set j 0} {$j < $Options(YMax)} {incr j} {
            set MatrixDestruction($i,$j) 0
        }
    }
    set currcolor $Board($x,$y,color)
    Recurs_BlocOutline $x $y $currcolor

    #if bloc (2 brics of same color side-by-side or more) then return 1
    if {$nbBricsInBloc > 1} {
        return 1
    #else (isolated bric) return 0
    } else {
        return 0
    }
}

# ----=================================================----

proc DestroyBloc {x y} {
    global Options
    global Board
    global MatrixDestruction
    if {[BlocOutline $x $y] == 1} {
        for {set i 0} {$i < $Options(XMax)} {incr i} {
            for {set j 0} {$j < $Options(YMax)} {incr j} {
                if {$MatrixDestruction($i,$j) == 1} {
                    foreach f {type color qual} e {Empty black {}} {
                        set Board($i,$j,$f)  $e
                    }
                   .board itemconfigure tagcoord($i,$j) -fill $Board($i,$j,color)
                }
            }
        }
    }
    Gravity
}

# ----=================================================----

proc RemainingBloc {} {
    global Options
    set br 0
    for {set i 0} {$i < $Options(XMax)} {incr i} {
        for {set j 0} {$j < $Options(YMax)} {incr j} {
            if {[BlocOutline $i $j] > 0} {
                set br 1
                break;
            }
        }
        if {$br} {
            break;
        }
    }
    return $br
}

# ----=================================================----

proc RemainingColumn {} {
    global Options
    global Board
    set colleft 0
    while {($colleft < $Options(XMax)) && ($Board($colleft,0,type) ne "Empty")} {
        incr colleft
    }
    return $colleft
}

# ----=================================================----

proc DecBonus {} {
    global Scores
    if {$Scores(bonus) > 0} {
        #decr bonus every second
        set ::afterId [after 1000 {uplevel #0 {DecBonus}}]
        if {$Scores(decbonus)} {
            incr Scores(bonus) -1
        }
    } else {
        set Scores(decbonus) off
    }
}

# ----=================================================----

proc Help {} {
    global fname
    toplevel .help
    wm title .help "Vertigo Help"
    text .help.txt -relief sunken -bd 2 -font {Courier} \
                 -yscrollcommand {.help.scroll set} \
                 -setgrid 1 -height 30
    scrollbar .help.scroll -command {.help.txt yview}
    button .help.exit -text "Exit" -command {destroy .help} -anchor center
    pack .help.exit -side bottom -fill x
    pack .help.txt -side left -fill y
    pack .help.scroll -side right -fill y
    set Rf [open $fname(rules) r]
    .help.txt insert end [read $Rf [file size $fname(rules)]]
    close $Rf
}

# ----=================================================----

.score.new invoke

#end of code

Fred Limouzin - 9 May 2005:

Squorpion: Another little game I coded this week-end. Unfortunately for me ;-), I've just done a quick check of the TkGamePack.kit, and there seems to be a similar game already (i.e. Dots). The only difference may possibly be the number of players (I haven't yet run 'Dots'). Anyway I won't bother creating a new page, I just add it in here as bonus game for Vertigo - a little Tk game.

Screenshot:

http://dire.straits.free.fr/vertigo/TkSquorpion.jpg

Copy all this in a file called Squorpion.txt (must use this name):

 ===================================
 =    Squorpion by Fred Limouzin   =
 ===================================

 Copyrights (c)2005 - all rights reserved.
 Tested on WinXp/TclTk8.4.9; Cygwin/TclTk8.4.1; SunSolaris/TclTk8.4.4


 This is a game I used to play at recess with my friends when I was a kid.
 All that was needed was a few colored pens and a sheet of paper. Of course
 nowdays one would require a computer to play this game... :-)

 I couldn't remember its actual name, so I decided to call it 'Squorpion'.
 (i.e the contraction of 'Square' and of 'Morpion' (which is the french name
 for the Tic-Tac-Toe game)).

 The goal of the game is to complete more squares than the opponents.

 Rules are easy:
 Each player can draw a line on the grid (i.e. click on the grid on the
 edge/side of a square). If the drawn line completes a square, the player
 scores a point, keeps the turn, and can draw the next line as well.
 Although there is no specific chack for if as of now, one has to take any
 available opportunity.

 Once the full grid has been completed, the winner is the player with the
 most squares claimed.

 The menu lets you tweak many parameters:
 - number of players: '1' means you against the computer (so in fact 2!),
                      '2' to '6' means 2 to 6 human players.
 - size of the grid/game-table (number of rows and columns);
 - colored lines or black lines;
 - pixunit.
 In Human vs. Computer mode you can also choose:
 - Computer starts or not;
 - Smart computer or not. In non-smart mode (very easy mode) the computer
   selects its next line randomly. In smart mode (rather non-so-stupid mode)
   the computer can spot squares to be taken, and tries avoiding creating
   opportunities to the opponent. Note: The current algorithm isn't very
   evolved so the computer cannot spot the best move or 'think' ahead.

 The score frame indicates the current player, the current game score (number
 of squares) and the number of overall games won.

 Don't let Squorpion sting you!

 Enjoy. Have Fun!

 It still amazes me what Tcl/Tk allows you do!

 --Fred
 [email protected]

 Also check out TkVertigo at:
 http://dire.straits.free.fr/vertigo

 =====================================

Then copy all this in a file Squorpion.tcl for instance:

 #!/bin/sh
 # [email protected] \
 # v1.0 - May 2005 - Copyrights (c)2005 Fred Limouzin \
 # Download it from http://dire.straits.free.fr/vertigo \
 exec tclsh "$0" ${1+"$@"}

 package require Tk

 #================ INIT =======================================

 set ::OPPONENT        {} ;# leave empty
 set ::PLAYEREXTREMMAX  6 ;# must be 6
 set ::OFFSET(X)       10 ;# in pixels
 set ::OFFSET(Y)       10 ;# in pixels
 set ::PIXUNIT          3 ;# in pixels
 set ::BOXLNGTH        16 ;# in pixels (must be even)
 set ::LNWIDTH [expr {2 * $::PIXUNIT}] ;# in pixels

 array set pref {
     NBPLAYERSEL 1
     LNCOLORED true
     COMPSTART true
     COMPSMART true
     NBCOLS 6
     NBROWS 5
     nbwirecols -1
     nbwirerows -1
 }
 set ::MAXSCORE -1

 # x players + grid color
 set clrLst   {red   blue    green purple yellow orange   gray  }
 set symbLst  {cross diamond plus  square circle triangle grille}

 #================= PROCS ======================================

 #--------------------------------
 # re-adjust the nbwire* values when NB* have been modified.
 proc UpdateTableSize {} {
     global pref
     set pref(nbwirecols) [expr {$pref(NBCOLS) + 1}]
     set pref(nbwirerows) [expr {$pref(NBROWS) + 1}]
     set ::MAXSCORE [expr {$pref(NBCOLS) * $pref(NBROWS)}]
     return 0
 } ;# end of UpdateTableSize

 #--------------------------------
 proc calcCoord {dir cr {offset 0}} {
     return [expr {((($::BOXLNGTH * $cr) + $offset) * $::PIXUNIT) + \
                      $::OFFSET([string toupper $dir])}]
 } ;# end of calcCoord

 #--------------------------------
 proc AutoPlayEasy {} {
     global pref
     global ObjLocLst
     while {true} {
         set llen [llength $ObjLocLst]
         if {$llen == 0} {
             break
         }
         set rnd [expr {int(rand() * $llen)}]
         foreach {dir x y} [lindex $ObjLocLst $rnd] {break;} ;#assign
         if {[CheckWire $dir $x $y] == 0} {
             ClickOnWire $dir $x $y on
             break
         }
         set Lst [lreplace $ObjLocLst $rnd $rnd]
     }
     return 0
 }

 #--------------------------------
 proc AutoPlaySmart {} {
     global pref
     global ObjLocLst
     set done false
     for {set pass 0} {$pass < 2} {incr pass} {
         set Lst $ObjLocLst
         while {true} {
             set llen [llength $Lst]
             if {$llen == 0} {
                 break
             }
             set rnd [expr {int(rand() * $llen)}]
             foreach {dir x y} [lindex $Lst $rnd] {break;} ;#assign
             if {[CheckWire $dir $x $y] == 0} {
                 if {( (([lindex [CheckSquares $dir $x $y true] $pass] > 0) \
                           &&($pass == 0)) \
                     ||(([lindex [CheckSquares $dir $x $y true] $pass] <= 2) \
                           && ($pass > 0)) )} then {
                     ClickOnWire $dir $x $y on
                     set done true
                     break
                 }
             }
             set Lst [lreplace $Lst $rnd $rnd]
         }
         if {$done} {
             break
         }
     }
     if {!$done} {
         AutoPlayEasy
     }
     return 0
 }

 #--------------------------------
 proc AutoPlay {} {
     global pref
     if {$pref(COMPSMART)} {
         AutoPlaySmart
     } else {
         AutoPlayEasy
     }
     return 0
 }

 #--------------------------------
 proc UpdateCurrPlayer {} {
     global currPlayer
     global Player
     global clrLst
     global symbLst
     global w
     if {($Player == 1) && ($::OPPONENT ne {human})} {
         set t {C}
     } else {
         set t {H}
     }
     set currPlayer "Current player = [string totitle [lindex $clrLst $Player]]"
     append currPlayer " [string totitle [lindex $symbLst $Player]];"
     append currPlayer " Select a line."
     for {set p 0} {$p < $::NBPLAYER} {incr p} {
         $w(score).lbl(curr,$p)  configure -text {}
     }
     $w(score).lbl(curr,$Player) configure -text "<*$t*>"
     if {$t eq {C}} {
         AutoPlay
     }
     return 0
 } ;# end of UpdateCurrPlayer

 #--------------------------------
 proc TestEndGame {} {
     global Score
     global currPlayer
     global clrLst
     global symbLst
     set tot 0 ; set lst [list]
     set end false
     for {set p 0} {$p < $::NBPLAYER} {incr p} {
         incr tot $Score($p)
         lappend lst [list $p $Score($p)]
     }
     if {$tot == $::MAXSCORE} {
         set lst [lsort -integer -decreasing -index 1 $lst]
         set winscore [lindex [lindex $lst 0] 1]
         set currPlayer "****** WINNER:"
         foreach {currwin currwinscore} [join $lst] {
             if {$currwinscore < $winscore} {
                 break;
             }
             append currPlayer " [string totitle [lindex $clrLst $currwin]]"
             append currPlayer " [string totitle [lindex $symbLst $currwin]]" ";"
             incr Score(tot,$currwin)
         }
         append currPlayer " !! ******"
         set end true
     }
     return $end
 } ;# end of TestEndGame

 #--------------------------------
 proc DrawMark {col row} {
     global Player
     global symbLst
     global clrLst
     global Score
     global w
     set gridClr [lindex $clrLst  end]
     set clr     [lindex $clrLst  $Player]
     set symb    [lindex $symbLst $Player]
     set colp1   [expr {$col + 1}]
     set rowp1   [expr {$row + 1}]
     set halfbox [expr {$::BOXLNGTH / 2}]

     incr Score($Player)

     switch $symb {
         triangle {  set xm [calcCoord x $col   $halfbox]
                     set x1 [calcCoord x $col    3]
                     set x2 [calcCoord x $colp1 -3]
                     set y1 [calcCoord y $row    3]
                     set y2 [calcCoord y $rowp1 -3]
                     $w(gameTable) create polygon $xm $y1 $x2 $y2 $x1 $y2 $xm $y1 \
                             -outline $clr -fill $gridClr -width $::LNWIDTH
                  }
         circle   {  set x1 [calcCoord x $col    3]
                     set x2 [calcCoord x $colp1 -3]
                     set y1 [calcCoord y $row    3]
                     set y2 [calcCoord y $rowp1 -3]
                     $w(gameTable) create oval $x1 $y1 $x2 $y2 \
                             -outline $clr -width $::LNWIDTH
                  }
         diamond  {  set xm [calcCoord x $col   $halfbox]
                     set x1 [calcCoord x $col    2]
                     set x2 [calcCoord x $colp1 -2]
                     set ym [calcCoord y $row   $halfbox]
                     set y1 [calcCoord y $row    2]
                     set y2 [calcCoord y $rowp1 -2]
                     $w(gameTable) create polygon $xm $y1 $x2 $ym $xm $y2 $x1 $ym $xm $y1 \
                             -outline $clr -fill $gridClr -width $::LNWIDTH
                  }
         plus     {  set xm [calcCoord x $col   $halfbox]
                     set x1 [calcCoord x $col    2]
                     set x2 [calcCoord x $colp1 -2]
                     set ym [calcCoord y $row   $halfbox]
                     set y1 [calcCoord y $row    2]
                     set y2 [calcCoord y $rowp1 -2]
                     $w(gameTable) create line $xm $y1 $xm $y2 -fill $clr -width $::LNWIDTH
                     $w(gameTable) create line $x1 $ym $x2 $ym -fill $clr -width $::LNWIDTH
                  }
         square   {  set x1 [calcCoord x $col    3]
                     set x2 [calcCoord x $colp1 -3]
                     set y1 [calcCoord y $row    3]
                     set y2 [calcCoord y $rowp1 -3]
                     $w(gameTable) create polygon $x1 $y1 $x2 $y1 $x2 $y2 $x1 $y2 $x1 $y1 \
                             -outline $clr -fill $gridClr -width $::LNWIDTH
                  }
         cross -
         default  {
                     set x1 [calcCoord x $col    2]
                     set x2 [calcCoord x $colp1 -2]
                     set y1 [calcCoord y $row    2]
                     set y2 [calcCoord y $rowp1 -2]
                     $w(gameTable) create line $x1 $y1 $x2 $y2 -fill $clr -width $::LNWIDTH
                     $w(gameTable) create line $x2 $y1 $x1 $y2 -fill $clr -width $::LNWIDTH
                  }
     }
     return [expr {[TestEndGame] ? 1 : 0}]
 } ;# end of DrawMark

 #--------------------------------
 proc CheckWire {dir x y} {
     global clrLst
     global w
     set gridClr [lindex $clrLst end]
     set currState [$w(gameTable) itemcget tagCoord($dir,$x,$y) -fill]
     if {$currState eq $gridClr} {
         return 0
     } else {
         return 1
     }
 } ;# end of CheckWire

 #--------------------------------
 proc CheckSquares {dir x y {justtest false}} {
     global pref
     set keepsameplayer false
     set end 0
     set nbsquares 0
     set sidemax 0
     if {$dir eq {v}} {
         set yp1 [expr {$y + 1}]
         if {$x > 0} {
             set xm1 [expr {$x - 1}]
             set sq 1
             incr sq [CheckWire v $xm1 $y]
             incr sq [CheckWire h $xm1 $y]
             incr sq [CheckWire h $xm1 $yp1]
             set sidemax [expr {($sq > $sidemax) ? $sq : $sidemax}]
             if {$sq == 4} {
                 incr nbsquares
                 if {!$justtest} {
                     incr end [DrawMark $xm1 $y]
                     set keepsameplayer true
                 }
             }
         }
         if {$x < $pref(NBCOLS)} {
             set xp1 [expr {$x + 1}]
             set sq 1
             incr sq [CheckWire h $x $y]
             incr sq [CheckWire v $xp1 $y]
             incr sq [CheckWire h $x $yp1]
             set sidemax [expr {($sq > $sidemax) ? $sq : $sidemax}]
             if {$sq == 4} {
                 incr nbsquares
                 if {!$justtest} {
                     incr end [DrawMark $x $y]
                     set keepsameplayer true
                 }
             }
         }
     } else {
         set xp1 [expr {$x + 1}]
         if {$y > 0} {
             set ym1 [expr {$y - 1}]
             set sq 1
             incr sq [CheckWire h $x $ym1]
             incr sq [CheckWire v $x $ym1]
             incr sq [CheckWire v $xp1 $ym1]
             set sidemax [expr {($sq > $sidemax) ? $sq : $sidemax}]
             if {$sq == 4} {
                 incr nbsquares
                 if {!$justtest} {
                     incr end [DrawMark $x $ym1]
                     set keepsameplayer true
                 }
             }
         }
         if {$y < $pref(NBROWS)} {
             set yp1 [expr {$y + 1}]
             set sq 1
             incr sq [CheckWire v $x $y]
             incr sq [CheckWire h $x $yp1]
             incr sq [CheckWire v $xp1 $y]
             set sidemax [expr {($sq > $sidemax) ? $sq : $sidemax}]
             if {$sq == 4} {
                 incr nbsquares
                 if {!$justtest} {
                     incr end [DrawMark $x $y]
                     set keepsameplayer true
                 }
             }
         }
     }
     if {!$justtest} {
         if {!$keepsameplayer} {
             NextPlayer
         } elseif {$end == 0} {
             UpdateCurrPlayer
         }
     }
     return [list $nbsquares $sidemax]
 } ;# end of CheckSquares

 #--------------------------------
 proc ClickOnWire {dir x y {flash off}} {
     global Player
     global clrLst
     global pref
     global w
     $w(gameTable) configure -state disabled
     if {$flash} {
         set flashcnt 3 ; set delay 400 ;# ms
     } else {
         set flashcnt 1 ; set delay 10 ;# ms
     }
     set flashcnt [expr {$flashcnt | 0x00000001}] ;# force odd number
     set currState [CheckWire $dir $x $y]
     if {!$currState} { ;# if off then turn it on with black or color
         for {set i 0} {$i < $flashcnt} {incr i} {
             if {($i % 2) == 1} {
                 set newClr [lindex $clrLst end]
             } elseif {!$pref(LNCOLORED)} {
                 set newClr black
             } else {
                 set newClr [lindex $clrLst $Player]
             }
             after $delay "$w(gameTable) itemconfigure tagCoord($dir,$x,$y) -fill $newClr ; set ::DONE true"
             vwait ::DONE ;# update idletasks
         }
         CheckSquares $dir $x $y
     }
     $w(gameTable) configure -state normal
     return 0
 } ;# end of ClickOnWire

 #--------------------------------
 # switch to next player
 proc NextPlayer {} {
     global Player
     set Player [expr {($Player + 1) % $::NBPLAYER}]
     UpdateCurrPlayer
     return 0
 } ;# end of NextPlayer

 #--------------------------------
 #draw grid and initialize game
 proc Init {} {
     global pref
     global Player
     global w
     global Score
     global Menu
     global ObjLocLst

     set ::NBPLAYER $pref(NBPLAYERSEL)
     if {$::NBPLAYER == 1} {
         incr ::NBPLAYER
         set ::OPPONENT computer
         $Menu(Pref) entryconfigure $Menu(Pref,start,idx) -state normal
         $Menu(Pref) entryconfigure [expr {$Menu(Pref,start,idx) + 1}] -state normal
     } else {
         set ::OPPONENT human
         $Menu(Pref) entryconfigure $Menu(Pref,start,idx) -state disabled
         $Menu(Pref) entryconfigure [expr {$Menu(Pref,start,idx) + 1}] -state disabled
     }

     set Player 0
     if {$pref(COMPSTART) && ($::OPPONENT eq {computer})} {
         incr Player
     }

     UpdateTableSize ;# initialize the nbwire* values

     set width  [expr {($::OFFSET(X) * 2) + ($::PIXUNIT * $::BOXLNGTH * $pref(NBCOLS))}]
     set height [expr {($::OFFSET(Y) * 2) + ($::PIXUNIT * $::BOXLNGTH * $pref(NBROWS))}]
     $w(gameTable) configure -width $width -height $height

     for {set p 0} {$p < $::PLAYEREXTREMMAX} {incr p} {
         set Score($p) 0
         foreach elmt {curr name score totscore} {
             if {$p < $::NBPLAYER} {
                 set clr black
             } else {
                 set clr lightgray
             }
             $w(score).lbl($elmt,$p) configure -foreground $clr
         }
     }

     set ObjLocLst [list]
     foreach d {v h} {
         for {set i 0} {$i < $pref(nbwirecols)} {incr i} {
             for {set j 0} {$j < $pref(nbwirerows)} {incr j} {
                 lappend ObjLocLst [list $d $i $j]
             }
         }
     }

     DrawGrid
     UpdateCurrPlayer
     return 0
 } ;# end of Init

 #--------------------------------
 #draw grid and initialize game
 proc DrawGrid {} {
     global pref
     global clrLst
     global w

     eval $w(gameTable) delete [$w(gameTable) find all]

     set gridClr [lindex $clrLst end]

     for {set wv 0} {$wv < $pref(nbwirerows)} {incr wv} {
         for {set col 0} {$col < $pref(NBCOLS)} {incr col} {
             set x1 [calcCoord x $col]
             set x2 [calcCoord x [expr {$col + 1}]]
             set y  [calcCoord y $wv]
             $w(gameTable) create line $x1 $y $x2 $y -fill $gridClr -width $::LNWIDTH \
                      -tags tagCoord(h,$col,$wv)
             $w(gameTable) bind tagCoord(h,$col,$wv) <Button-1> [list ClickOnWire h $col $wv]
         }
     }
     for {set wh 0} {$wh < $pref(nbwirecols)} {incr wh} {
         for {set row 0} {$row < $pref(NBROWS)} {incr row} {
             set x  [calcCoord x $wh]
             set y1 [calcCoord y $row]
             set y2 [calcCoord y [expr {$row + 1}]]
             $w(gameTable) create line $x $y1 $x $y2 -fill $gridClr -width $::LNWIDTH \
                      -tags tagCoord(v,$wh,$row)
             $w(gameTable) bind tagCoord(v,$wh,$row) <Button-1> [list ClickOnWire v $wh $row]
         }
     }
     return 0
 } ;# end of DrawGrid

 #--------------------------------
 proc Quit {} {exit}

 #--------------------------------
 proc About {} {
     tk_messageBox -message "TkSquorpion (for Tcl/Tk8.4+)\nCopyrights(c)2005 \
             Frederic Limouzin" -title TkSquorpion -type ok
 }
 proc Help {} {
     set fname(rules) [file join [file dirname [info script]] Squorpion.txt]
     toplevel .help
     wm title .help {Squorpion Help}
     text .help.txt -relief sunken -bd 2 -font {Courier} \
                  -yscrollcommand {.help.scroll set} -setgrid 1 -height 30
     scrollbar .help.scroll -command {.help.txt yview}
     button .help.exit -text "Exit" -command {destroy .help} -anchor center
     pack .help.exit -side bottom -fill x
     pack .help.txt -side left -fill y
     pack .help.scroll -side right -fill y
     set Rf [open $fname(rules) r]
     .help.txt insert end [read $Rf [file size $fname(rules)]]
     close $Rf
 } ;# end of Help

 #================= MENU ======================================

 set Menu(Root) .menubar
 set Menu(File) $Menu(Root).filemenu
 set Menu(Pref) $Menu(Root).prefmenu
 set Menu(Help) $Menu(Root).help

 menu $Menu(Root)
 . configure -menu $Menu(Root)
 $Menu(Root) add cascade -label "File" -menu $Menu(File) -underline 0
 $Menu(Root) add cascade -label "Pref" -menu $Menu(Pref) -underline 0
 $Menu(Root) add cascade -label "Help" -menu $Menu(Help) -underline 0

 menu $Menu(File) -tearoff 0
 $Menu(File) add command -label "New Game" -command {Init}
 $Menu(File) add separator
 $Menu(File) add command -label "Exit" -command {Quit}

 menu $Menu(Pref) -tearoff 1 -title "Preferences"
 menu $Menu(Pref).cols -tearoff 0
 menu $Menu(Pref).rows -tearoff 0
 menu $Menu(Pref).nbcolors -tearoff 0
 menu $Menu(Pref).clrln -tearoff 0
 menu $Menu(Pref).blocsz -tearoff 0
 for {set i 3} {$i <= 17} {incr i 2} {
     $Menu(Pref).cols add radiobutton -label $i -value $i -variable pref(NBCOLS) -command {Init}
     $Menu(Pref).rows add radiobutton -label $i -value $i -variable pref(NBROWS) -command {Init}
 }
 set ::NBPLAYER $pref(NBPLAYERSEL)
 for {set i 1} {$i <= $::PLAYEREXTREMMAX} {incr i} {
     $Menu(Pref).nbcolors add radiobutton -label $i -value $i -variable pref(NBPLAYERSEL) -command {Init}
 }
 for {set i 2} {$i <= 4} {incr i} {
     $Menu(Pref).blocsz add radiobutton -label $i -value $i -variable ::PIXUNIT -command {Init}
 }
 $Menu(Pref) add cascade -label "Nb Cols" -menu $Menu(Pref).cols
 $Menu(Pref) add cascade -label "Nb Rows" -menu $Menu(Pref).rows
 $Menu(Pref) add separator
 $Menu(Pref) add cascade -label "Nb Players" -menu $Menu(Pref).nbcolors
 set Menu(Pref,start,idx) 5 ;# tear=0,nbcol=1,nbrow=2,sepa=3,nbplayer=4,compstart=5,smart=6,etc.
 $Menu(Pref) add checkbutton -label "Let computer start" -onvalue true -offvalue false \
         -variable pref(COMPSTART) -state disabled -command {Init}
 $Menu(Pref) add checkbutton -label "Smart computer" -onvalue true -offvalue false \
         -variable pref(COMPSMART) -state disabled -command {Init}
 $Menu(Pref) add separator
 $Menu(Pref) add checkbutton -label "Colored lines" -onvalue true -offvalue false \
         -variable pref(LNCOLORED) -command {Init}
 $Menu(Pref) add separator
 $Menu(Pref) add cascade -label "Bloc Size" -menu $Menu(Pref).blocsz

 menu $Menu(Help) -tearoff 1 -title "Help Menu"
 $Menu(Help) add command -label "Help"  -command {Help}
 $Menu(Help) add command -label "About" -command {About}

 #================= GUI ========================================

 wm title     . "TkSquorpion" ; wm iconname  . "TkSquorpion"
 wm resizable . 0 0     ;# not resizable in either x or y

 set w(currPlayer) .lbl(currPlayer)
 set w(gameTable)  .cnv(gameTable)
 set w(score)      .frm(score)
 set w(xit)        .xit
 set w(cpright)    .cpyright
 label $w(cpright) -text {Copyrights (c)2005 Fred-Phenix, Fred Limouzin} -justify right -anchor e
 canvas $w(gameTable) -width 800 -height 800 -background #CCCCCC
 labelframe $w(score) -text "Score: "
 for {set p 0} {$p < [expr {[llength $clrLst] - 1}]} {incr p} {
     set txt "[string totitle [lindex $clrLst $p]] [string totitle [lindex $symbLst $p]]"
     label $w(score).lbl(name,$p) -text $txt
     label $w(score).lbl(score,$p) -textvariable Score($p) -width 3
     label $w(score).lbl(curr,$p) -text {} -width 5
     set Score(tot,$p) 0
     label $w(score).lbl(totscore,$p) -textvariable Score(tot,$p) -width 3
     set pp1 [expr {$p + 1}] ; set gp 1
     foreach elmt {curr name score totscore} {
         grid $w(score).lbl($elmt,$p) -row $pp1 -column $gp -rowspan 1 -columnspan 1 -sticky ew
         incr gp
     }
 }
 incr pp1
 button $w(score).new -text "New Game" -command {Init}
 grid $w(score).new -row $pp1 -column 1 -rowspan 1 -columnspan 4 -sticky we
 label $w(currPlayer) -textvariable currPlayer
 button $w(xit) -text {Exit} -command {Quit}

 pack $w(cpright)    -side bottom -fill x
 pack $w(xit)        -side bottom -fill x
 pack $w(currPlayer) -side bottom -fill x
 pack $w(gameTable)  -side left   -fill both
 pack $w(score)      -side right  -fill both

 Init

 # end of code
Category GamesTcl/Tk gamesCategory Application
Updated 2012-11-22 03:24:43