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
([1]). 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 ([2])RHS Nice. It works a lot like the Cubes [3] 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 edit
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 fphenix@hotmail.com (personal email; not read regularly)
Code edit
#!/bin/sh
# fphenix@hotmail.com \
exec wish "$0" {1+"$@"}
#/*************************************************/
#/* */
#/* Vertigo Game, 8 Septembre 2000 (C) */
#/* Vertigo Game, 2 January 2004 (TclTk 8.4) */
#/* (c)2000-2005 Frederic LIMOUZIN */
#/* fphenix@hotmail.com */
#/* 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 codeFred 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:
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
Frederic.Limouzin@gmail.com
Also check out TkVertigo at:
http://dire.straits.free.fr/vertigo
=====================================Then copy all this in a file Squorpion.tcl for instance:
#!/bin/sh
# Frederic.Limouzin@gmail.com \
# 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
