ulis, 27-01-2005. Un "grand jeu, haut en couleurs". Inspiré du jeu 7colors de Tatou (Infogrames).
02-02-2005 : v 0.9.4b
27-02-05: v 1.0. Ils scintillent !!!
Pourquoi
Pour le plaisir de programmer un jeu facile.
Comment
Une interface toute simple qui ne laisse actifs que les widgets nécessaires.
Le script
# ==================== # # CrystalsBattle # # v 1.0b # ulis (NOL) # ==================== # #################### # Documentation # #################### # compile: # use freewrap (http://sourceforge.net/projects/freewrap/) # install: # put the executable in your path # use: # run & play # #################### # -------------------- # parameters # -------------------- set size 15 set level 1 set time 0 set cdelay 2000 array set sizes {15 {25 20 "SMALL"} 30 {15 10 "BIG"}} array set cb {1 0 2 1} array set times {0 0 1 15000 2 30000 3 60000 4 120000} array set txTimes {0 "TIME" 1 "15 s" 2 "30 s" 3 "1 mn" 4 "2 mn"} array set txLevels {0 "NOVICE" 1 "NORMAL" 2 "EXPERT" 3 "KNIGHT"} set txTitle "La bataille des cristaux" set txName1 "me" set txName2 "computer" set txAuto "auto" set txStart "START" set txStop "STOP" set txQuit "QUIT" # -------------------- # colors & animation # -------------------- set glints 16 set period 250 array set colors0 \ { 01 #8888ff 11 #7373cf 21 #5d5daf 31 #5d5daf 02 #98e898 12 #73ba73 22 #5fa55f 32 #5f955f 03 #98e8e8 13 #73baba 23 #5fa5a5 33 #5f9595 04 #e89898 14 #ba7373 24 #a55f5f 34 #955f5f 05 #e898e8 15 #ba73ba 25 #a55fa5 35 #955f95 06 #e8e898 16 #baba73 26 #a5a55f 36 #95955f 07 #c8c8c8 17 #aaaaaa 27 #959595 37 #858585 } array set colors1 \ { 01 #3333df 11 #4848ff 21 #2d2dcf 31 #1d1daf 02 #13ba13 12 #18e818 22 #0fa50f 32 #0f950f 03 #13baba 13 #18e8e8 23 #0fa5a5 33 #0f9595 04 #ba1313 14 #e81818 24 #a50f0f 34 #950f0f 05 #ba13ba 15 #e818e8 25 #a50fa5 35 #950f95 06 #baba13 16 #e8e818 26 #a5a50f 36 #95950f 07 #cacaca 17 #f8f8f8 27 #b5b5b5 37 #a5a5a5 } # -------------------- # registered parameters # -------------------- catch { source CrystalsBattle.conf } # -------------------- # packages # -------------------- package require Tk # -------------------- # procs # -------------------- # -------------------- # createDisplay # -------------------- proc createDisplay {} \ { # frames # -------------------- catch \ { destroy .c destroy .f array unset ::set array unset ::crysiz array unset ::crycol array unset ::cryset array unset ::crytag } canvas .c -width $::width -height $::height \ -bd 0 -highlightt 0 frame .f # create header # -------------------- set font {Arial 16 bold} set xc $::header set yc [expr {round($::header * 0.25)}] .c create text [expr {$xc - 1}] [expr {$yc - 1}] \ -tags t1 -font $font -text $::count1 -fill white set xc [expr {$::width - $::header}] .c create text [expr {$xc - 1}] [expr {$yc - 1}] \ -tags t2 -font $font -text $::count2 -fill white entry .c.e1 -width 10 -textvariable ::txName1 \ -bd 1 -relief groove -justify center entry .c.e2 -width 10 -textvariable ::txName2 \ -bd 1 -relief groove -justify center set xc $::header set yc [expr {round($::header * 0.55)}] .c create window $xc $yc -window .c.e1 set xc [expr {$::width - $::header}] .c create window $xc $yc -window .c.e2 set xc $::header set yc [expr {round($::header * 0.9)}] .c create text [expr {$xc - 1}] [expr {$yc - 1}] \ -tags l1 -font $font -text 0% -fill white .c create text $xc $yc \ -tags {l1 lr1} -font $font -text 0% -fill gray25 set xc [expr {$::width - $::header}] .c create text [expr {$xc - 1}] [expr {$yc - 1}] \ -tags l2 -font $font -text 0% -fill white .c create text $xc $yc \ -tags {l2 lr2} -font $font -text 0% -fill gray25 set xc [expr {$::width / 2}] set yc [expr {round($::header * 0.33)}] set font {Times 28 italic} .c create text [expr {$xc - 1}] [expr {$yc - 1}] \ -font $font -text $::txTitle -fill white .c create text $xc $yc \ -font $font -text $::txTitle -fill gray25 button .c.b1 -width 15 -pady 3 -bd 1 -relief ridge \ -command setSize -text $::txSize set xc [expr {$::width / 3}] set yc [expr {round($::header * 0.85)}] .c create window $xc $yc -window .c.b1 button .c.b2 -width 15 -pady 3 -bd 1 -relief ridge \ -command setLevel set xc [expr {$::width / 2}] .c create window $xc $yc -window .c.b2 setLevel $::level button .c.b3 -width 15 -pady 3 -bd 1 -relief ridge \ -command setTime set xc [expr {$::width * 2 / 3}] .c create window $xc $yc -window .c.b3 setTime $::time # create crystals # -------------------- array set ::colors [array get ::colors0] set ::total 0 set xci0 [expr {$::size * 3 + $::padx * 2}] set xci1 [expr {$xci0 + $::size}] set yci [expr {$::size + $::pady + $::header}] set xc $xci0 set yc $yci for {set i 0} {$i < $::imax} {incr i} \ { for {set j 0} {$j < $::jmax} {incr j} \ { if {$j == $::jmax - 1 && $i % 2 == 1} { break } set c 0 while {$c == 0} \ { for {set k 0} {$k < 3} {incr k} \ { set c [expr {2 * $c + (rand() > 0.5 ? 1 : 0)}] } } createCrystal $xc $yc $::size $c incr ::total incr xc $::size2 } incr yc $::size set xc [expr {$i % 2 == 0 ? $xci1 : $xci0}] } set ::half [expr {$::total / 2}] # create selection # -------------------- array set ::colors [array get ::colors1] set xc [expr {$::size + $::padx}] set yc [expr {$::height - $::pady}] checkbutton .c.cb1 -variable ::cb(1) -text $::txAuto .c create window $xc $yc -window .c.cb1 set yc [expr {$::height - $::size2 - $::pady}] .c create rectangle \ [expr {$xc - $::size}] [expr {$yc + $::size}] \ [expr {$xc + $::size}] [expr {$yc + $::size - $::size2 * 7}] \ -tags r1 -outline "" -fill "" for {set i 1} {$i < 8} {incr i} \ { createCrystal $xc $yc $::size $i .c bind t$yc:$xc <Button-1> [list selectColor 1 $i] .c bind t$yc:$xc <Enter> [list enterColor 1 $i] .c bind t$yc:$xc <Leave> [list leaveColor 1 $i] set yc [expr {$yc - $::size2}] } set xc [expr {$::width - $::size - $::padx}] set yc [expr {$::pady + $::header}] checkbutton .c.cb2 -variable ::cb(2) -text $::txAuto .c create window $xc $yc -window .c.cb2 set yc [expr {$::size2 + $::pady + $::header}] .c create rectangle \ [expr {$xc - $::size}] [expr {$yc - $::size}] \ [expr {$xc + $::size}] [expr {$yc - $::size + $::size2 * 7}] \ -tags r2 -outline "" -fill "" for {set i 1} {$i < 8} {incr i} \ { createCrystal $xc $yc $::size $i .c bind t$yc:$xc <Button-1> [list selectColor 2 $i] .c bind t$yc:$xc <Enter> [list enterColor 2 $i] .c bind t$yc:$xc <Leave> [list leaveColor 2 $i] set yc [expr {$yc + $::size * 2}] } # create buttons # -------------------- button .f.b1 -width 30 -pady 3 -bd 1 -relief ridge \ -text $::txStart -command start button .f.b2 -width 30 -pady 3 -bd 1 -relief ridge \ -text $::txQuit -command quit grid .f.b1 .f.b2 -padx 20 -pady 10 # display # -------------------- pack .c pack .f focus .c.e1 .c.e1 selection range 0 end .c.e1 icursor end # colors # -------------------- set ::abg [.c.e1 cget -bg] set ::dbg [.c.e1 cget -disabledback] } # -------------------- # setSize # -------------------- proc setSize {{size ""}} \ { if {$size == ""} \ { set sizes [array names ::sizes] set n [lsearch -exact $sizes $::size] set n [expr {$n == 0 ? 1 : 0}] set size [lindex $sizes $n] } set ::size $size foreach {::imax ::jmax ::txSize} $::sizes($size) break set ::size2 [expr {$::size * 2}] set ::height [expr {$::imax * $::size + $::size + $::pady * 2 + $::header}] set ::width [expr {($::jmax + 2) * $::size2 + $::padx * 4}] set ::start 1 createDisplay } # -------------------- # setLevel # -------------------- proc setLevel {{level ""}} \ { if {$level == ""} \ { set level [incr ::level] if {$level > 3} { set level [set ::level 0] } } .c.b2 config -text $::txLevels($level) } # -------------------- # setTime # -------------------- proc setTime {{time ""}} \ { if {$time == ""} \ { set time [incr ::time] if {$time > 4} { set time [set ::time 0] } } .c.b3 config -text $::txTimes($time) } # -------------------- # createTriangle # -------------------- proc createTriangle {xc yc num size color} \ { if {$size == $::size} \ { set tags [list t$yc:$xc t$yc:$xc:$num] } \ else \ { set tags [list t:$::turn t$yc:$xc:$num] } set size1 $size set size2 $size if {$num % 2 == 0} { set size1 -$size1 } if {$num < 2} { set size2 -$size2 } .c create polygon \ $xc [expr {$yc + $size1}] \ [expr {$xc + $size2}] $yc \ $xc $yc -fill $color -tags $tags } # -------------------- # changeTriangle # -------------------- proc changeTriangle {tag num color} \ { .c itemconfig $tag:$num -fill $color } # -------------------- # createCrystal # -------------------- proc createCrystal {xc yc size c {player 0}} \ { for {set i 0} {$i < 4} {incr i} \ { set id [createTriangle $xc $yc $i $size $::colors($i$c)] } set tag t$yc:$xc set ::crysiz($tag) $size set ::crycol($tag) $c set ::cryset($tag) $player set ::crytag($tag) $tag } # -------------------- # changeCrystal # -------------------- proc changeCrystal {tag c} \ { for {set i 0} {$i < 4} {incr i} \ { changeTriangle $tag $i $::colors($i$c) } set ::crycol($tag) $c } # -------------------- # selectColor # -------------------- proc selectColor {player color} \ { if {$player != $::turn || $::cb($player) == 1} { return } if {$color == $::set(c1) || $color == $::set(c2)} { return } .c config -cursor "" displayResult [llength [computeNewSet $player $color]] } # -------------------- # twinkle # -------------------- proc twinkle {args} \ { if {[llength $args] == 1} \ { # restore set tag [lindex $args 0] if {[info exists ::crycol($tag)] && $::crycol($tag) > 0} \ { set c $::crycol($tag) set s $::cryset($tag) if {$s > 0} { set s 1 } foreach i {0 1 2 3} \ { .c itemconf $tag:$i -fill [set ::colors${s}($i$c)] } } set delay [expr {$::period + int(rand() * $::period)}] after $delay twinkle } \ else \ { # exchange while 1 \ { set xci0 [expr {$::size * 3 + $::padx * 2}] set xci1 [expr {$xci0 + $::size}] set xc $xci0 set yci [expr {$::size + $::pady + $::header}] set yc $yci set imax [expr {$::imax - 1}] set jmax [expr {$::jmax - 1}] set i [expr {round(rand() * $imax)}] if {$i % 2 == 1} { set xc $xci1; incr jmax -1 } set j [expr {round(rand() * $jmax)}] incr xc [expr {$j * $::size2}] incr yc [expr {$i * $::size}] set tag t$yc:$xc if {[info exists ::crytag($tag)]} \ { while {$::crytag($tag) != $tag} { set tag $::crytag($tag) } break } } set c $::crycol($tag) set i [expr {int(rand() * 4 - 0.001)}] set s $::cryset($tag) if {$s > 0} { set s 1 } .c itemconf $tag:$i -fill [set ::colors${s}(0$c)] after 1 twinkle $tag } } # -------------------- # computeNewSet # -------------------- proc computeNewSet {player color {do 1}} \ { # extend limits if {$do} { set ::set(c$player) $color } set sz $::size set newset $::set($player) for {set ndx 0} {$ndx < [llength $newset]} {incr ndx} \ { set stag [lindex $newset $ndx] if {$do} { changeCrystal $stag $color } foreach {yc xc} [split [string range $stag 1 end] :] break set size $::crysiz($stag) set n [expr {$size / $sz}] set xc1 [expr {$xc - $size - $sz}] set xc2 [expr {$xc + $size + $sz}] set yc1 $yc set yc2 $yc for {set i 0} {$i < $n + 2} {incr i} \ { foreach xc [list $xc1 $xc1 $xc2 $xc2] yc [list $yc1 $yc2 $yc1 $yc2] \ { set tag t$yc:$xc if {![info exists ::cryset($tag)]} { continue } if {$::cryset($tag) != 0} { continue } if {$::crycol($tag) == $color} \ { if {[lsearch -exact $newset $tag] == -1} \ { lappend newset $tag if {$do} \ { lappend ::set($player) $tag set ::cryset($tag) $player } } } } incr xc1 $sz incr xc2 -$sz incr yc1 $sz incr yc2 -$sz } } # return newset if {$do} \ { set ::current($player) [llength $newset] grow $player $color } return $newset } # -------------------- # grow # -------------------- proc grow {player color} \ { set sz $::size # restore set .c delete t:$player set newset [lsort -decr $::set($player)] foreach t $newset \ { set ::crycol($t) $color; set ::crysiz($t) $sz } # grow crystals foreach stag $newset \ { if {$::crycol($stag) != $color} { continue } foreach {yc xc} [split [string range $stag 1 end] :] break set size $sz while 1 \ { set n [expr {$size / $sz}] set s [list] set xc1 [expr {$xc - $size}] set xc2 [expr {$xc + $size}] set yc0 [expr {$yc - $sz}] for {set nn 0} {$nn < $n} {incr nn} \ { set t t$yc0:$xc1 if { ![info exists ::cryset($t)] || $::crycol($t) != $color || $::crysiz($t) != $sz } \ { break } lappend s $t set t t$yc0:$xc2 if { ![info exists ::cryset($t)] || $::crycol($t) != $color || $::crysiz($t) != $sz } \ { break } lappend s $t incr xc1 $sz incr xc2 -$sz incr yc0 -$sz } set t t$yc0:$xc if { [llength $s] == 2 * $n && [info exists ::cryset($t)] && $::crycol($t) == $color && $::crysiz($t) == $sz } \ { lappend s $t $stag set yc [expr {$yc - $sz}] set size [expr {$size + $sz}] set stag t$yc:$xc createCrystal $xc $yc $size $color $player foreach t $s \ { set ::crycol($t) 0 set ::crytag($t) $stag } } \ else \ { break } } } } # -------------------- # displayResult # -------------------- proc displayResult {count} \ { set player $::turn set ratio [expr {$count / double($::total) * 100}] .c itemconfig l$player -text [format %2d [expr {round($ratio)}]]% update if {$ratio == 50 && [llength $::set(c1)] == $::half && [llength $::set(c2)] == $::half} \ { .c itemconfig l1 -text 50% .c itemconfig l2 -text 50% stop } \ elseif {$ratio >= 50} \ { .c itemconfig t$player -text [incr ::count$player] stop displayWinner } \ else \ { changeTurn } } # -------------------- # displayWinner # -------------------- proc displayWinner {} \ { if {$::start} { return } set color [.c.e$::turn cget -fg] set color [expr {$color == "red" ? "black" : "red"}] .c.e$::turn config -fg $color .c itemconfig lr$::turn -fill $color after 500 displayWinner } # -------------------- # changeTurn # -------------------- set ::turnID "" proc changeTurn {} \ { catch [list after cancel $::turnID] if {!$::start} { return } set player $::turn .c.e$player config -disabledback $::dbg .c itemconfig r$player -fill $::dbg set player [expr {$player == 1 ? 2 : 1}] set ::turn $player .c.e$player config -disabledback $::abg .c itemconfig r$player -fill $::abg # computer? if {$::cb($player)} { after $::cdelay play } \ elseif {$::time > 0} \ { set ::turnID [after $::times($::time) changeTurn] } } # -------------------- # enterColor # -------------------- proc enterColor {player color} \ { if {$player != $::turn || $::cb($player) == 1} { return } if {$color == $::set(c1) || $color == $::set(c2)} { return } .c config -cursor target } # -------------------- # leaveColor # -------------------- proc leaveColor {player color} \ { if {$player != $::turn || $::cb($player) == 1} { return } if {$color == $::set(c1) || $color == $::set(c2)} { return } .c config -cursor "" } # -------------------- # play # -------------------- proc play {} \ { set player $::turn set level $::level if {$level == 2} \ { set other [expr {$player == 1 ? 2 : 1}] if {$::current($player) < $::current($other)} \ { set level 1 } } switch -exact $level \ { 0 \ { # novice set c 0 while {$c == 0} \ { for {set k 0} {$k < 3} {incr k} \ { set c [expr {2 * $c + (rand() > 0.5 ? 1 : 0)}] } if {$c == $::set(c1) || $c == $::set(c2)} { set c 0 } } } 1 \ { # normal set mc 0 set n 0 foreach c {1 2 3 4 5 6 7} \ { if {$c == $::set(c1) || $c == $::set(c2)} { continue } set t [llength [computeNewSet $player $c [set do 0]]] if {$t > $n} { set n $t; set mc $c } } set c $mc } 2 \ { # expert set mc 0 set n 0 foreach c {1 2 3 4 5 6 7} \ { if {$c == $::set(c1) || $c == $::set(c2)} { continue } set t [llength [computeNewSet $player $c [set do 0]]] if {$t > ($::total / 2.0 + 0.001)} { set mc $c; break } incr t $t incr t [llength [computeNewSet $other $c [set do 0]]] if {$t > $n} { set n $t; set mc $c } } set c $mc } 3 \ { # knight set mc1 0 set mc2 0 set n 0 set dx 0 set dy 0 set s 0 foreach {xi yi} $::first($player) break foreach t $::set($player) \ { foreach {y x} [split [string range $t 1 end] :] break set ss [expr {abs($xi - $x) + abs($yi - $y)}] if {$ss > $s} { set s $ss } } set s0 $s foreach c {1 2 3 4 5 6 7} \ { if {$c == $::set(c1) || $c == $::set(c2)} { continue } set tt [computeNewSet $player $c [set do 0]] set t [llength $tt] if {$t > $n} { set n $t; set mc1 $c } set ss 0 foreach t $tt \ { foreach {y x} [split [string range $t 1 end] :] break incr ss [expr {abs($xi - $x) + abs($yi - $y)}] } if {$ss > $s} { set s $ss; set mc2 $c } } set c [expr {$s > $s0 ? $mc2 : $mc1}] } } displayResult [llength [computeNewSet $player $c]] } # -------------------- # quit # -------------------- proc quit {} \ { set fn CrystalsBattle.conf catch \ { set fp [open $fn w] puts $fp \ " set ::size $::size; set ::level $::level; set ::time $::time; set ::cdelay $::cdelay; array set ::sizes {[array get ::sizes]}; array set ::cb {[array get ::cb]}; array set ::times {[array get ::times]}; array set ::txTimes {[array get ::txTimes]}; array set ::txLevels {[array get ::txLevels]}; set ::txTitle \"$::txTitle\"; set ::txName1 \"$::txName1\"; set ::txName2 \"$::txName2\"; set ::txAuto \"$::txAuto\"; set ::txStart \"$::txStart\"; set ::txStop \"$::txStop\"; set ::txQuit \"$::txQuit\"; set ::glints $::glints; set ::period $::period; array set ::colors0 [array get ::colors0]; array set ::colors1 [array get ::colors1]; " close $fp } msg if {$msg != ""} { puts stderr $msg } exit } # -------------------- # start # -------------------- set restart 0 set start 0 proc start {} \ { set ::start 1 if {$::restart} { createDisplay } .f.b1 config -text $::txStop -command stop .c.b1 config -state disabled .c.b2 config -state disabled .c.b3 config -state disabled .c.e1 config -state disabled -fg black -bg $::abg .c.e2 config -state disabled -fg black -bg $::abg .c.cb1 config -state disabled .c.cb2 config -state disabled .c itemconfig l1 -state "" .c itemconfig l2 -state "" .c itemconfig lr1 -fill gray25 .c itemconfig lr2 -fill gray25 array unset ::set set xc [expr {$::size * ($::jmax * 2 + 1) + $::padx * 2}] set yc [expr {$::size + $::pady + $::header}] set tag t$yc:$xc set ::set(2) [list $tag] set ::set(c2) $::crycol($tag) set ::first(2) [list $xc $yc] set ::cryset($tag) 2 set xc [expr {$::size * 3 + $::padx * 2}] set yc [expr {$::size * $::imax + $::pady + $::header}] set tag t$yc:$xc set ::set(1) [list $tag] set ::set(c1) $::crycol($tag) set ::first(1) [list $xc $yc] set ::cryset($tag) 1 set ::turn [expr {rand() > 0.5 ? 1 : 2}] array set ::current {1 0 2 0} changeTurn } # -------------------- # stop # -------------------- proc stop {} \ { catch [list after cancel $::turnID] set ::start 0 set ::restart 1 .f.b1 config -text $::txStart -command start .c.b1 config -state normal .c.b2 config -state normal .c.b3 config -state normal .c.e1 config -state normal .c.e2 config -state normal .c.cb1 config -state normal -fg black .c.cb2 config -state normal -fg black .c itemconfig r1 -fill $::dbg .c itemconfig r2 -fill $::dbg } # -------------------- # bgerror # -------------------- proc bgerror {args} { tk_messageBox -message "bgerror:\n$args" } # -------------------- # computed values # -------------------- set padx 10 set pady 10 set header 80 set turn 0 set count1 0 set count2 0 setSize $::size # -------------------- # animate # -------------------- set delay 0 for {set i 0} {$i < $glints} {incr i} \ { after $delay twinkle; incr delay $period } # -------------------- # global events # -------------------- wm protocol . WM_DELETE_WINDOW quit bind . <Escape> quit # -------------------- # go # -------------------- wm title . "Crystals Battle" focus -force . raise .
Voir aussi
Discussion
ulis, 05-02-2005: Pour obtenir un exécutable, utiliser freewrap (http://sourceforge.net/projects/freewrap/, choisir son OS suivant son goût).
VWa, 25-02-2005 : Jeu superbe ! bravo ulis.
Catégorie Exemple | Catégorie Jeu | Applications ludiques