[HJG] 2014-04-22 - The game is playable now, but only "greedy movement", and no options/variants yet. This is a nice little game with numbers, also suitable for small displays, e.g. mobile-phones. Like 15-puzzle and sudoku, only numbers are used. Like tetris, new items keep coming in, and the player has to get rid of them (i.e. merge those numbers to make room for more). Rules: * The playfield has tiles with numbers. * With the arrow-keys all tiles move. * Tiles with the same number merge. * The goal is to reach a high number, e.g. 1024 or 2048. * After every move, a new low number appears on a free tile. * The game is over when there is no free tile to create a new number. There are several variants, some of them only for iOS or Android: * The web-based "official version" of [http://gabrielecirulli.github.io/2048%|%2048 by Gabriele Cirulli%|%], with code at https://github.com/gabrielecirulli/2048 * [https://itunes.apple.com/us/app/1024!/id823499224%|%1024%|%] by [http://www.veewo.com%|%Veewo Studio%|%] * [https://play.google.com/store/apps/details?id=com.veewo.a1024%|%1024%|%] * [http://asherv.com/threes/%|%Threes by Asher Vollmer%|%] * [http://saming.fr/p/2048%|%Saming's 2048 %|%] [AMG]: Discussion of clones of this game: [http://techcrunch.com/2014/03/24/clones-clones-everywhere-1024-2048-and-other-copies-of-popular-paid-game-threes-fill-the-app-stores/]. Apparently Threes came first. [HJG]: Actually, the first place I heard about this game was at http://xkcd.com/1344 (, which made no sense to me, so I had to go to http://www.explainxkcd.com/wiki/index.php/1344 :) Now there is a new portable version at http://portableapps.com/news/2014-04-17--2048-portable-2.1-released, which offers a number of play-variants. But with a download-size of 20 MB (as it contains the node-webkit browser engine), this strikes me as quite a bit of bloat. So, I decided to try a more frugal version in tcl. When finished, it would be nice to make this into a selfcontained tclkit / starkit. I noticed there are several ways to interpret the rules for moving and joining, so I'm going to put in a menu for user-options... ====== # http://wiki.tcl.tk/39566 # 1k-p27.tcl if 0 { A small game of moving and combining numbers, like 1024 by Veewo Studio, 2048 by Gabriele Cirulli, or Threes by Asher Vollmer. Currently only "greedy movement", i.e. 1 1 1 1 --> _ _ _ 4 TODO: * Options / Menu for selection of play-variant ** First fit / Last fit / Random new tiles ** singlestep / greedy / 2048-movement * more flashy messages / text-effects * loadable color-table * cheat / tutorial - mode * tweak layout for small screen / pocket-pc * Joystick-buttons on/off * separate highscores for each play-variant * a few more records, e.g. lowscore / fastfill } package require Tk global Prg Colors set Prg(Title) "1K-Puzzle" set Prg(Version) "v0.27" set Prg(Date) "2014-04-13" set Prg(Author) "Hans-Joachim Gurt" ##set Prg(Contact) "gurt@gmx.de" ##set Prg(Contact) "[format %s@%s.%s gurt gmx de]" set Prg(Contact) [string map -nocase {: @ ! .} gurt:gmx!de] set Prg(About) "A small game, moving around and combining numbers." set Prg(Msg) "$Prg(Title) $Prg(Version)\nby $Prg(Author)" set Prg(Help1) "Press up/down/left/right\nto move the numbers." set Prg(Help2) "Combine equal numbers,\nto reach value 1024." set Prg(Dbg) "Test" set Prg(OptDebug) 0 set Prg(OptSkin) 1 set Prg(OptMove) 1 set Prg(OptNew1) 1 set Prg(OptNew2) 1 set Prg(OptGoal) 1024 set Prg(OptStart) 2 set Prg(State) 0 ;# 0=Init 1,2=Start 6=play 9=GameOver set Prg(UserMoves) 0 set Prg(NewTiles) 0 set Prg(TileMoves) 0 set Prg(TileMerges) 0 set Prg(TilesFree) 16 set Prg(TileSum) 0 set Prg(MaxTile) 0 set Prg(HiTile) 0 ;# 512 set Prg(Score) 0 set Prg(HiScore) 0 ;# 7550 set Prg(LastMoves) {} set UserDir $::env(HOME) set UserDir "D:/Home/HaJo/Games" ;## set filepath [file join $UserDir 1K_score.dat] set Prg(HiScoreFN) $filepath array set Colors { BgO grey HdrBg DeepPink1 HdrFg black Msg0bg grey60 Msg0fg black Msg1bg SlateBlue1 Msg1fg black Msg2bg SlateBlue2 Msg2fg black Msg9bg red Msg9fg white Sc0 LightYellow1 Sc1 pink Sc2 cyan BgJ_x grey80 BgJ_a cyan BgB_x grey80 BgB_a cyan BTx0 black BTx1 blue BTx9 red Empty white 0 white 1 PeachPuff1 2 Goldenrod1 4 Orange2 8 Salmon1 16 IndianRed1 32 FireBrick1 64 PaleGreen1 128 MediumSpringGreen 256 Green1 512 SteelBlue1 1024 RoyalBlue1 2048 DeepPink1 4096 SlateBlue1 8192 Gold1 16384 SpringGreen1 } # ... # MistyRose1 Azure1 SlateBlue1 RoyalBlue1 DodgerBlue1 SteelBlue1 # DeepSkyBlue1 SkyBlue1 LightSkyBlue1 SlateGray1 LightBlue1 # LightCyan1 PaleTurquoise1 CadetBlue1 Turquoise1 Cyan1 # DarkSlateGray1 # AquaMarine1 DarkSeaGreen1 SeaGreen1 PaleGreen1 SpringGreen1 # Green1 Chartreuse1 OliveDrab1 DarkOliveGreen1 # Khaki LightGoldenrod1 LightYellow1 Yellow1 Gold1 # Goldenrod1 DarkGoldenrod1 # RosyBrown1 IndianRed1 Sienna1 BurlyWood1 Wheat1 Tan1 # Chocolate1 FireBrick1 Brown1 Salmon1 LightSalmon1 # Orange1 DarkOrange1 Coral1 Tomato1 OrangeRed1 Red1 # DeepPink1 HotPink1 Pink1 LightPink1 # PaleVioletRed1 Maroon1 VioletRed1 Magenta1 Orchid1 Plum1 # MediumOrchid1 DarkOrchid1 Purple1 MediumPurple1 Thistle1 # ... proc int x { expr int($x) } proc maxi { curr hi } { if { $curr > $hi } { return $curr } else { return $hi } } proc Beep {} { # puts "\a" bell } proc sleep { ms } { after $ms } ### proc Fill_Zero {} { for {set r 1} {$r<=4} {incr r} { for {set c 1} {$c<=4} {incr c} { # .b$r$c configure -text " " -bg white ;# -bg SystemButtonFace ;# -bg grey83 .b$r$c configure -text " " -bg $::Colors(Empty) } } } proc Fill_1 {} { # no random start : cycle thru unique starting positions global Prg set i $Prg(OptStart) puts "Fill_1 : $i" switch $i { 1 { ;# 1-2 SetTile 1 1 1 SetTile 1 2 1 set ::Prg(NewTiles) 2 } 2 { ;# 2-3 SetTile 2 3 1 SetTile 3 2 1 set ::Prg(NewTiles) 2 } 3 { ;# 3-4 SetTile 1 3 1 SetTile 4 4 1 set ::Prg(NewTiles) 2 } 4 { ;# 1-3 SetTile 3 3 1 SetTile 4 1 1 set ::Prg(NewTiles) 2 } 5 { ;# 1-4 SetTile 1 1 1 SetTile 2 2 1 SetTile 3 4 1 SetTile 4 3 1 set ::Prg(NewTiles) 4 } 6 { ;# 2+3 SetTile 2 3 1 SetTile 4 2 2 set ::Prg(NewTiles) 2 } 9 { ;# 4+2 SetTile 1 1 2 SetTile 2 1 1 SetTile 3 1 1 SetTile 4 1 2 set ::Prg(NewTiles) 4 } default { ;# 3+4 SetTile 3 3 2 SetTile 1 4 1 set ::Prg(NewTiles) 2 set i 0 } } incr i 1 set Prg(OptStart) $i # puts "Fill_1 = $Prg(OptStart)" } ### Test: proc Fill_Test {} { set cNr 0 for {set r 1} {$r<=4} {incr r} { for {set c 1} {$c<=4} {incr c} { SetTile $r $c $cNr if { $cNr==0 } { set cNr 1 } else { set cNr [expr $cNr+$cNr] } } } } proc Ping1 { r c } { # set v 99 set v [.b$r$c cget -text] set ::Prg(Dbg) "Ping: $r $c = $v" } proc Ping { r c } { set v [.b$r$c cget -text] set ::Prg(Dbg) "Ping: $r $c = $v" if { $v == " " } { set v 1 } else { set v [expr $v+$v] } if { $v == "16384" } { set v 0 } SetTile $r $c $v } proc Status { } { global Prg set Prg(Dbg) "Last moves: $Prg(LastMoves) ." set Prg(LastMoves) {} puts $Prg(Dbg) set m [CheckPossibleMoves] set ::Prg(Dbg) "Status: UserMoves $Prg(UserMoves) NewTiles $Prg(NewTiles) TileMoves $Prg(TileMoves) TileMerges $Prg(TileMerges) MaxTile $Prg(MaxTile) TileSum $Prg(TileSum) Free $Prg(TilesFree) Score $Prg(Score) " puts $::Prg(Dbg) puts "CheckPossibleMoves: $m" # puts "CheckPossibleMoves: [CheckPossibleMoves]" } #---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+ proc SetTile { r c v } { # set tile at row, col to value global Prg Colors set color black set val " " if { $v > 0 } { set val $v incr $Prg(NewTiles) 1 } #puts "SetTile $r $c $v " set color $Colors($v) puts "SetTile $r $c : $v = $color" .b$r$c configure -text $val -bg $color incr Prg(TilesFree) -1 incr Prg(TileSum) $v set Prg(Dbg) "$Prg(NewTiles) Free= $Prg(TilesFree) \nTileSum= $Prg(TileSum)" puts $::Prg(Dbg) } proc Mv { r1 c1 r2 c2 } { #: Move a single tile (and, if possible, merge it with others) global Prg set v1 [.b$r1$c1 cget -text] set v2 [.b$r2$c2 cget -text] set Prg(Dbg) "Mv: $r1 $c1 - $r2 $c2 = $v1,$v2" # puts $::Prg(Dbg) if {$v1 ne " "} { if {$v2 == $v1 } { ;# matching tiles: merge tile #1 + #2 set sum [expr $v1+$v2] # SetTile $r2 $c2 [expr $v1+$v2] SetTile $r2 $c2 $sum SetTile $r1 $c1 0 incr Prg(TileMerges) 1 # SCORE: sum of merged tiles incr ::Prg(Score) $sum if {$sum > $::Prg(MaxTile)} { set ::Prg(MaxTile) $sum } } if {$v2 == " "} { ;# destination is free: move tile #1 SetTile $r2 $c2 $v1 SetTile $r1 $c1 0 incr Prg(TileMoves) 1 } } } proc Move { dir } { #: Process move-commands from player, # then check results, generate new tile, or game-over. global Prg Colors puts "State: $Prg(State)" set Prg(State) [maxi $Prg(State) 6] .lb_2 configure -bg $Colors(Msg0bg) -fg $Colors(Msg0fg) puts "State: $Prg(State)" set Prg(Dbg) "Button pressed: $dir" puts $Prg(Dbg) # Debug/Logging; append Prg(LastMoves) $dir if { $dir == "_" } { append Prg(LastMoves) " \n" return } if { $dir == "." } { append Prg(LastMoves) " = $Prg(Score) \n" return } ## TODO: better move-algorithm set Prg(TileMoves) 0 set Prg(TileMerges) 0 if 0 { # "single-step" movement : if { $dir == 1 } { Mv 2 1 1 1; Mv 3 1 2 1; Mv 4 1 3 1 Mv 2 2 1 2; Mv 3 2 2 2; Mv 4 2 3 2 Mv 2 3 1 3; Mv 3 3 2 3; Mv 4 3 3 3 Mv 2 4 1 4; Mv 3 4 2 4; Mv 4 4 3 4 } if { $dir == 2 } { Mv 3 1 4 1; Mv 2 1 3 1; Mv 1 1 2 1 Mv 3 2 4 2; Mv 2 2 3 2; Mv 1 2 2 2 Mv 3 3 4 3; Mv 2 3 3 3; Mv 1 3 2 3 Mv 3 4 4 4; Mv 2 4 3 4; Mv 1 4 2 4 } if { $dir == 3 } { Mv 1 2 1 1; Mv 1 3 1 2; Mv 1 4 1 3 Mv 2 2 2 1; Mv 2 3 2 2; Mv 2 4 2 3 Mv 3 2 3 1; Mv 3 3 3 2; Mv 3 4 3 3 Mv 4 2 4 1; Mv 4 3 4 2; Mv 4 4 4 3 } if { $dir == 4 } { Mv 1 3 1 4; Mv 1 2 1 3; Mv 1 1 1 2 Mv 2 3 2 4; Mv 2 2 2 3; Mv 2 1 2 2 Mv 3 3 3 4; Mv 3 2 3 3; Mv 3 1 3 2 Mv 4 3 4 4; Mv 4 2 4 3; Mv 4 1 4 2 } } ### if 1 { # "greedy" movement : if { $dir == 1 } { Mv 2 1 1 1; Mv 3 1 2 1; Mv 4 1 3 1 Mv 2 1 1 1; Mv 3 1 2 1; Mv 2 1 1 1; Mv 2 2 1 2; Mv 3 2 2 2; Mv 4 2 3 2 Mv 2 2 1 2; Mv 3 2 2 2; Mv 2 2 1 2; Mv 2 3 1 3; Mv 3 3 2 3; Mv 4 3 3 3 Mv 2 3 1 3; Mv 3 3 2 3; Mv 2 3 1 3; Mv 2 4 1 4; Mv 3 4 2 4; Mv 4 4 3 4 Mv 2 4 1 4; Mv 3 4 2 4; Mv 2 4 1 4; } if { $dir == 2 } { Mv 3 1 4 1; Mv 2 1 3 1; Mv 1 1 2 1 Mv 3 1 4 1; Mv 2 1 3 1; Mv 3 1 4 1; Mv 3 2 4 2; Mv 2 2 3 2; Mv 1 2 2 2 Mv 3 2 4 2; Mv 2 2 3 2; Mv 3 2 4 2; Mv 3 3 4 3; Mv 2 3 3 3; Mv 1 3 2 3 Mv 3 3 4 3; Mv 2 3 3 3; Mv 3 3 4 3; Mv 3 4 4 4; Mv 2 4 3 4; Mv 1 4 2 4 Mv 3 4 4 4; Mv 2 4 3 4; Mv 3 4 4 4; } if { $dir == 3 } { Mv 1 2 1 1; Mv 1 3 1 2; Mv 1 4 1 3 Mv 1 2 1 1; Mv 1 3 1 2 Mv 1 2 1 1 Mv 2 2 2 1; Mv 2 3 2 2; Mv 2 4 2 3 Mv 2 2 2 1; Mv 2 3 2 2 Mv 2 2 2 1 Mv 3 2 3 1; Mv 3 3 3 2; Mv 3 4 3 3 Mv 3 2 3 1; Mv 3 3 3 2 Mv 3 2 3 1 Mv 4 2 4 1; Mv 4 3 4 2; Mv 4 4 4 3 Mv 4 2 4 1; Mv 4 3 4 2 Mv 4 2 4 1 } if { $dir == 4 } { Mv 1 3 1 4; Mv 1 2 1 3; Mv 1 1 1 2 Mv 1 3 1 4; Mv 1 2 1 3 Mv 1 3 1 4 Mv 2 3 2 4; Mv 2 2 2 3; Mv 2 1 2 2 Mv 2 3 2 4; Mv 2 2 2 3 Mv 2 3 2 4 Mv 3 3 3 4; Mv 3 2 3 3; Mv 3 1 3 2 Mv 3 3 3 4; Mv 3 2 3 3 Mv 3 3 3 4 Mv 4 3 4 4; Mv 4 2 4 3; Mv 4 1 4 2 Mv 4 3 4 4; Mv 4 2 4 3 Mv 4 3 4 4 } } ### if 0 { # "original" 2048 movement : # TODO ... } ### set Prg(Dbg) "Moves : $Prg(TileMoves) \nMerges: $Prg(TileMerges) " puts $::Prg(Dbg) set a $Prg(TileMoves) incr a $Prg(TileMerges) if {$a == 0 } { set m [CheckPossibleMoves] set Prg(Dbg) "Move not possible / $m" puts $::Prg(Dbg) set Prg(Msg) "invalid move" Beep } else { incr ::Prg(UserMoves) 1 ;# Move was successful # Find free tile(s), check for game over, create new tile: set freeTiles 0 set Prg(TileSum) 0 set r0 0 set c0 0 for {set r 1} {$r<=4} {incr r} { for {set c 1} {$c<=4} {incr c} { set v [.b$r$c cget -text] if {$v == " "} { incr freeTiles 1 set r0 $r set c0 $c } else { incr Prg(TileSum) [int $v] } } } set Prg(TilesFree) $freeTiles set Prg(Dbg) "Free: $freeTiles" puts $::Prg(Dbg) ## TODO: select (random) new number and position set m [CheckPossibleMoves] puts "CPM=$m" ##set Prg(Msg) "GAME: $Prg(UserMoves) $Prg(TilesFree) : $m" # set Prg(Msg) "Moves: $Prg(UserMoves) \n Sum : $Prg(TileSum)" set Prg(Msg) "Moves: $Prg(UserMoves)" puts $::Prg(Msg) } if {$m < 1} { set Prg(State) 9 set Prg(Msg) "GAME OVER !\n " # set Prg(Msg) "GAME OVER !\n Score $Prg(Score)" # set Prg(Msg) "GAME OVER !\n after $Prg(UserMoves) moves" if {$Prg(Score) > $Prg(HiScore)} { set Prg(HiScore) $Prg(Score) append Prg(Msg) "New Highscore !" HiScoreFile_Write } else { append Prg(Msg) "after $Prg(UserMoves) moves." } .lb_2 configure -bg $Colors(Msg9bg) -fg $Colors(Msg9fg) .fJ configure -bg $Colors(BgJ_x) .fB configure -bg $Colors(BgJ_a) puts $::Prg(Msg) } else { if { $a > 0 } { after 150 SetTile $r0 $c0 1; # after 151 set Prg(Msg) {"Moves: $Prg(UserMoves) \n Sum : $Prg(TileSum)"} after 152 set Prg(Msg) {"Moves: $Prg(UserMoves)"} } } } proc CheckPossibleMoves {} { # More moves are possible when an empty tile is found, # or tiles with the same value at neighboring positions. # Returns 0 if no more moves are possible. # Shortcut: exits when the first possible move is found. set res 0 # check along rows: for {set r 1} {$r<=4} {incr r} { set prev " " for {set c 1} {$c<=4} {incr c} { set v [.b$r$c cget -text] if {$v == " "} { return 1 ;# free tile found } else { if { $v==$prev } { incr res 1; return $v } ## puts "CPM: $r $c : '$prev'$v' = $res" } set prev $v } } # check along cols: for {set c 1} {$c<=4} {incr c} { set prev " " for {set r 1} {$r<=4} {incr r} { set v [.b$r$c cget -text] if {$v ne " "} { if { $v==$prev } { incr res 1; return $v } ## puts "CPM: $r $c : '$prev'$v' = $res" } set prev $v } } return $res } #---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+ ### Test: Autoplay if 0 { proc P1 { } { # after 100 .b1 invoke; #set d 200 #Move 3; sleep $d; update idletasks #Move 1; sleep $d; update set d 100 foreach k { 3 3 3 1 } { incr d 250 after $d Move $k } } proc P2 { } { set d 100 foreach k { 3 1 3 1 3 1 3 1 3 1 3 1 3 1 3 1 3 1 3 1 3 1 3 1 3 1 3 1 3 1 3 1 4 1 3 1 } { incr d 250 after $d Move $k } } proc P5 { } { ;# from default startposition 2-3, this sequence ;# fills up the playfield in 223 moves to score 1020: # see P8 set d 100 foreach k { 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 } { incr d 250 after $d Move $k } } proc P6 { } { ;# 1016 .. 2080 .. 3106 .. 4700 .. 5010 .. 5578 .. 6116 .. 7042 set d 100 foreach k { 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 _ 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 _ 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 _ 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 _ 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 . 4 1 3 4 1 3 _ 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 4 1 4 1 3 . 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 _ 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 _ 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 _ 4 1 4 1 4 1 . 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 _ 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 _ 1 3 _ 4 1 4 1 4 1 4 3 1 1 4 1 4 3 4 1 4 1 4 1 3 1 4 1 3 . 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 _ 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 _ 1 3 3 1 1 3 3 1 1 3 3 1 1 4 1 3 . 1 3 1 1 3 1 1 1 1 1 1 1 1 _ 3 1 1 1 1 1 1 1 1 4 1 3 1 1 1 1 _ 4 3 1 1 4 1 3 1 4 1 3 4 1 3 . 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 _ 1 4 1 3 1 1 1 1 1 4 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 _ 1 3 4 1 3 1 1 1 1 1 1 4 1 . 3 1 1 1 1 1 1 3 _ 1 3 3 3 3 3 1 3 3 3 1 3 4 1 3 1 3 3 3 3 3 3 _ 4 1 3 3 4 3 4 1 4 3 1 4 4 1 3 1 4 3 1 4 1 3 1 1 1 1 1 1 _ 4 1 3 1 3 4 1 3 1 1 1 1 4 1 1 3 4 1 4 1 3 . 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 1 3 3 1 _ } { incr d 200 after $d Move $k } } proc P7 { } { # Repeat / Key set d 100 foreach {r k} { 15 1 14 3 14 1 6 3 1 4 1 2 } { for {set i 1} {$i<=$r} {incr i} { incr d 250 after $d Move $k } } } proc P8 { } { ;# from default startposition 2-3, this sequence ;# fills up the playfield in 223 moves to score 1020: set d 100 for {set i 1} {$i<=55} {incr i} { foreach k { 1 3 3 1 } { incr d 250 after $d Move $k } } foreach k { 1 3 3 . } { incr d 250 after $d Move $k } } proc _P3 { } { # Fast testgame (~24s) : 87 moves, score 304 ## 1241324 1212124 1212123 121434 121212121212 1421211143 ## 121212312 341341111 1431342 12434323 12332 133333 . set d 100 foreach k { 1 2 4 1 3 2 4 1 2 1 2 1 2 4 1 2 1 2 1 2 3 1 2 1 4 3 4 1 2 1 2 1 2 1 2 1 2 1 2 1 4 2 1 2 1 1 1 4 3 1 2 1 2 1 2 3 1 2 3 4 1 3 4 1 1 1 1 1 4 3 1 3 4 2 1 2 4 3 4 3 2 3 1 2 3 3 2 1 3 3 3 3 3 } { incr d 250 after $d Move $k } } } proc P3 { } { # Fast testgame (~24s) : 87 moves, score 304 set d 100 puts "P3:" foreach s { 1241324 1212124 1212123 121434 121212121212 1421211143 121212312 341341111 1431342 12434323 12332 133333 } { # puts $s for {set i 0} {$i<=[string length $s] } {incr i} { set k [string index $s $i] # puts $k if { [string first $k "_1234."] >= 0 } { incr d 250 after $d Move $k } } } } proc P4 { } { # Simple repeat: Up, Left --> gets to score 1020 in 223 moves set d 100 for {set i 1} {$i<=112} {incr i} { foreach k { 1 3 } { incr d 250 after $d Move $k } } } proc P9 { } { # Roundabout/Repeat: set d 100 for {set i 1} {$i<=101} {incr i} { foreach k { 1 4 2 3 } { incr d 250 after $d Move $k } } } proc Play { } { #: AutoPlay for testing P4; } #---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+ proc Tick { state } { #: Attractmode global Prg Colors puts "Tick: $Prg(State) $state" if { $Prg(State) > 2 } { return } set Prg(State) $state if { $state == 1 } { set Prg(Msg) $Prg(Help1) .lb_2 configure -bg $Colors(Msg1bg) -fg $Colors(Msg1fg) .fJ configure -bg $Colors(BgJ_a) after 3000 { Tick 2 } } if { $Prg(State) == 2 } { set Prg(Msg) $Prg(Help2) .lb_2 configure -bg $Colors(Msg2bg) -fg $Colors(Msg2fg) after 5000 { Tick 1 } } } proc Start { arg } { global Prg Colors puts "Start ..." set Prg(State) 1 set Prg(UserMoves) 0 set Prg(Score) 0 set Prg(MaxTile) 0 set Prg(LastMoves) {} # set Prg(Msg) $Prg(Help1) .bt_quit configure -fg $Colors(BTx9) .bt_new configure -fg $Colors(BTx1) .lb_2 configure -bg $Colors(Msg0bg) -fg $Colors(Msg0fg) if { $arg==0 } { #; called from main .fJ configure -bg $Colors(BgJ_x) .fB configure -bg $Colors(BgB_a) .bt_new configure -fg $Colors(BTx1) } else { #; called from button .fJ configure -bg $Colors(BgJ_a) .fB configure -bg $Colors(BgB_x) set Prg(Msg) "New game selected" } # Fill_Test # after 1000 { Fill_Zero } Fill_Zero Fill_1 foreach id [after info] {after cancel $id} after 7000 { Tick 1 } } proc HiScoreFile_Read {} { set filepath $::Prg(HiScoreFN) puts "Read file $filepath ..." if {![file exists $filepath] || [catch { set fh [open $filepath r] } ] } { puts "Error: open $filepath" return 1 } set i 0 while {![chan eof $fh]} { gets $fh line incr i 1 puts "$i:$line." if {$line ne ""} { set ::Prg(HiScore) $line } } close $fh } proc HiScoreFile_Write {} { set filepath $::Prg(HiScoreFN) puts "Write file $filepath ..." set fh [open $filepath w] ;# w / w+ puts $fh $::Prg(HiScore) close $fh } proc _ButtonInvoke { w } { event generate $w <1> event generate $w # after 100 {event generate $w } } #---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+ proc InitGUI {} { global Prg Colors wm title . "$Prg(Title) $Prg(Version)" puts "$Prg(Title) $Prg(Version)" frame .f0 -background $Colors(BgO) ;# Outer frame pack .f0 -padx 10 -pady 10 frame .fS -background $Colors(Sc0) ;# Score-Display label .lb_1 -text $Prg(Title) -width 10 \ -bg $Colors(HdrBg) -fg $Colors(HdrFg) -pady 8 label .lb_2 -textvar Prg(Msg) -width 30 \ -bg $Colors(Msg0bg) -fg $Colors(Msg0fg) -pady 8 -height 2 label .lb_S -textvar Prg(Score) -width 8 -bg $Colors(Sc1) -padx 6 -pady 4 label .lb_H -textvar Prg(HiScore) -width 8 -bg $Colors(Sc2) -padx 6 -pady 4 # rows of playfield: frame .f1 -background red frame .f2 -background yellow frame .f3 -background green frame .f4 -background blue # buttons: frame .fJ -bg $Colors(BgJ_x) \ -pady 8 -padx 8 ;# Joystick-Buttons frame .fB -bg $Colors(BgB_a) \ -pady 4 ;# Start/Quit-Buttons pack .lb_1 -in .f0 -pady 5 pack .fS -in .f0 -pady 5 pack .lb_S .lb_H -in .fS -side left -padx 2 -pady 2 pack .f1 .f2 .f3 .f4 -in .f0 pack .lb_2 -in .f0 -pady 5 pack .fJ -pady 4 pack .fB option add *Button.width 4 option add *Button.height 2 for {set r 1} {$r<=4} {incr r} { for {set c 1} {$c<=4} {incr c} { # button .b$r$c -text " " -command " Ping $r $c " button .b$r$c -text " " } } option add *Button.width 1 option add *Button.height 1 button .b1 -text "^" -command { Move 1 } button .b2 -text "v" -command { Move 2 } button .b3 -text "<" -command { Move 3 } button .b4 -text ">" -command { Move 4 } label ._ -text "+" option add *Button.width 6 option add *Button.height 1 button .bt_new -text "New " -command { Start 1 } button .bt_quit -text "Quit" -command { exit } pack .b11 .b12 .b13 .b14 -in .f1 -side left -padx 0 pack .b21 .b22 .b23 .b24 -in .f2 -side left -padx 0 pack .b31 .b32 .b33 .b34 -in .f3 -side left -padx 0 pack .b41 .b42 .b43 .b44 -in .f4 -side left -padx 0 pack .b1 -in .fJ -side top pack .b2 -in .fJ -side bottom pack .b3 -in .fJ -side left pack ._ -in .fJ -side left pack .b4 -in .fJ -side right pack .bt_new .bt_quit -in .fB -side left -padx 18 -pady 2 # bind all { Start 1 } ## bind all { Fill_Test } ;# Test ## bind all { Play } ;# Test bind all { Play } ;# Test bind all { P3 } ;# Test bind all { Status } ;# Test bind all { Move . } ;# Test bind all { exit } ;# button-animation : bind all <> { event generate %W <1> after 50 {event generate %W } } # Cursorkeys: bind all { .b1 invoke; event generate .b1 <> } bind all { .b2 invoke; event generate .b2 <> } bind all { .b3 invoke; event generate .b3 <> } bind all { .b4 invoke; event generate .b4 <> } # Keypad-Cursorkeys: bind all { .b1 invoke; event generate .b1 <> } bind all { .b2 invoke; event generate .b2 <> } bind all { .b3 invoke; event generate .b3 <> } bind all { .b4 invoke; event generate .b4 <> } focus -f .bt_new } InitGUI HiScoreFile_Read Start 0 # Test: bind all { catch {console show} } # catch {console show} # catch {wm withdraw .} return #. ====== '''See also:''' * [event generate] - http://wiki.tcl.tk/10002 * Colors with Names * event generate - animated button-click * Techniques for reading and writing application configuration files * Loading and Saving Application Configuration Files * gridDemo-Pack <> Games