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 [email protected] (personal email; not read regularly)
Code edit
#!/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:
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
