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:
There are several variants, some of them only for iOS or Android:
AMG: Discussion of clones of this game: [L1 ]. 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...
I left some debugging code in, e.g. console-output and autoplay, which can be used to record and replay a game.
I'm fairly sure the curious can figure it out, so have fun !
# http://wiki.tcl.tk/39566
# 1k-p32.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.32"
set Prg(Date) "2014-04-21"
set Prg(Author) "Hans-Joachim Gurt"
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(GameVar) "GL1" ;# Move=Greedy NewTile=Last New=1
set UserDir $::env(HOME)
#set UserDir "D:/Home/HaJo/Games" ;##
set filepath [file join $UserDir 1K_score.dat]
set Prg(HiScoreFN) $filepath
set Prg(DateTime) "Now"
set Prg(FinalMoves) 0
set Prg(LowMoves) 999 ;# 79
set Prg(MaxTile) 0
set Prg(HiTile) 0 ;# 512
set Prg(Score) 0
set Prg(HiScore) 0 ;# 7550
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(LastMoves) {}
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 Now {} {
set td [clock format [clock seconds] -format "%Y-%m-%d %H:%M:%S" ]
return $td
}
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)
.fJ configure -bg $Colors(BgJ_a)
.fB configure -bg $Colors(BgJ_x)
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"
append Prg(LastMoves) "< "
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
proc P3 { } {
# Fast testgame (~22s) : 79 moves, score 234
set d 100
# puts "P234:"
foreach s { 111111111111111_33333333333333_11111111111111_333333_
42 13131313 4_13131313 3333 43 13131 .
} {
for {set i 0} {$i<=[string length $s] } {incr i} {
set k [string index $s $i]
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
set Prg(DateTime) [Now]
puts "Start: $Prg(DateTime)"
set Prg(State) 1
set Prg(UserMoves) 0
set Prg(Score) 0
set Prg(MaxTile) 0
set Prg(LastMoves) {}
.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} ;# cancel all 'after'-commands
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 <ButtonRelease-1>
# after 100 {event generate $w <ButtonRelease-1>}
}
#---+----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
font create fontH -family fixed -weight bold
label .lb_1 -text $Prg(Title) -width 10 -font fontH \
-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 6 -padx 6 ;# Joystick-Buttons
frame .fB -bg $Colors(BgB_a) \
-pady 4 ;# Start/Quit-Buttons
pack .lb_1 -in .f0 -pady 4
pack .fS -in .f0 -pady 4
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 <Return> { Start 1 }
## bind all <Return> { Fill_Test } ;# Test
## bind all <space> { Play } ;# Test
bind all <Key-F5> { Play } ;# Test
bind all <Key-F9> { P3 } ;# Test
bind all <Return> { Status } ;# Test
bind all <BackSpace> { Move . } ;# Test
bind all <Escape> { exit }
;# button-animation :
bind all <<Click>> {
event generate %W <1>
after 50 {event generate %W <ButtonRelease-1>}
}
# Cursorkeys:
bind all <KeyPress-Up> { .b1 invoke; event generate .b1 <<Click>> }
bind all <KeyPress-Down> { .b2 invoke; event generate .b2 <<Click>> }
bind all <KeyPress-Left> { .b3 invoke; event generate .b3 <<Click>> }
bind all <KeyPress-Right> { .b4 invoke; event generate .b4 <<Click>> }
# Keypad-Cursorkeys:
bind all <Key-KP_8> { .b1 invoke; event generate .b1 <<Click>> }
bind all <Key-KP_2> { .b2 invoke; event generate .b2 <<Click>> }
bind all <Key-KP_4> { .b3 invoke; event generate .b3 <<Click>> }
bind all <Key-KP_6> { .b4 invoke; event generate .b4 <<Click>> }
focus -f .bt_new
}
InitGUI
HiScoreFile_Read
Start 0
# Test:
bind all <Key-F2> { catch {console show} }
# catch {console show}
# catch {wm withdraw .}
return
#.Until I can do a proper starkit, here is a quick description of how to run this tcl-program standalone (i.e. without installing a full Tcl/Tk-suite), using a tclkit.
You can think of this tclkit as a runtime for Tcl/TK (like JRE for Java, .NET for C#, VBASIC etc.), just much smaller.
dbohdan 2014-06-12: Here's a text-only version with non-greedy movement. The implementation has a slight list processing bent.
Update: Fixed just moving a 2 tile onto a new 2* tile not being recognized as a valid move. Refactored TWAPI input support contributed by pooryorick and added similar for *nix (see: Reading a single character from the keyboard using Tcl).
PYK 2014-06-15: I thought it would be fun to have a random play mode, which led to other ideas, including making it more game-like by clearing the screen between plays. That in turn led to a need to aggregate puts commands for speedier rendering over a high-latency connection. Also switched to event-driven input to allow user to pause random-play mode or toggle back to normal play. Added prompt to select board size, as well as a report of turns taken at end of game. Did more work on terminal control. Made the code more library-like so that a GUI skin might be feasible in the future. dbohdan, if you'd rather keep your own version here without my modifications, just revert the changes and I'll fork my changes to a different page.
dbohdan 2014-06-15: Thanks for asking! I don't mind your changes at at all; it's great you made the code more modular. That said, I don't think a wiki page is quite the right way for people to collaborate on a piece of code already this long and growing, especially since it may benefit from being split into multiple files later.
Since I already had all my revisions in a Git repo I put it on GitHub under the MIT license: https://github.com/dbohdan/2048-tcl . Your latest change is pretty major, so I didn't commit it myself. If you have an account fork it and issue a pull request so that you get proper credit for your contribution. If you don't use GitHub an alternative like Bitbucket or Chisel is also an option (although I have very limited experience with Fossil).
#! /bin/env tclsh
# A minimal implementation of the game 2048 in Tcl.
# http://wiki.tcl.tk/39566
package require Tcl 8.5
package require struct::matrix
package require struct::list
# utilities
proc vars args {
foreach varname $args {
uplevel [list variable $varname]
}
}
# Iterate over all cells of the game board and run script for each.
#
# The game board is a 2D matrix of a fixed size that consists of elements
# called "cells" that each can contain a game tile (corresponds to numerical
# values of 2, 4, 8, ..., 2048) or nothing (zero).
#
# - cellList is a list of cell indexes (coordinates), which are
# themselves lists of two numbers each. They each represent the location
# of a given cell on the board.
# - varName1 are varName2 are names of the variables the will be assigned
# the index values.
# - cellVarName is the name of the variable that at each step of iteration
# will contain the numerical value of the present cell. Assigning to it will
# change the cell's value.
# - script is the script to run.
proc forcells {cellList varName1 varName2 cellVarName script} {
upvar $varName1 i
upvar $varName2 j
upvar $cellVarName c
foreach cell $cellList {
set i [lindex $cell 0]
set j [lindex $cell 1]
set c [cell-get $cell]
set status [catch [list uplevel $script] cres copts]
switch $status {
2 {
return -options [dict replace $copts -level 2] $cres
}
default {
return -options $copts $cres
}
}
cell-set [list $i $j] $c
}
}
# Generate a list of cell indexes for all cells on the board, i.e.,
# {{0 0} {0 1} ... {0 size-1} {1 0} {1 1} ... {size-1 size-1}}.
proc cell-indexes {} {
variable size
set list {}
foreach i [::struct::list iota $size] {
foreach j [::struct::list iota $size] {
lappend list [list $i $j]
}
}
return $list
}
# Check if a number is a valid cell index (is 0 to size-1).
proc valid-index i {
variable size
expr {0 <= $i && $i < $size}
}
# Return 1 if the predicate pred is true when applied to all items on the list
# or 0 otherwise.
proc map-and {list pred} {
set res 1
foreach item $list {
set res [expr {$res && [$pred $item]}]
if {! $res} break
}
return $res
}
# Check if list represents valid cell coordinates.
proc valid-cell? cell {
map-and $cell valid-index
}
# Get the value of a game board cell.
proc cell-get cell {
board get cell {*}$cell
}
# Set the value of a game board cell.
proc cell-set {cell value} {
board set cell {*}$cell $value
}
# Filter a list of board cell indexes cellList to only have those indexes
# that correspond to empty board cells.
proc empty cellList {
::struct::list filterfor x $cellList {[cell-get $x] == 0}
}
# Pick a random item from the given list.
proc pick list {
lindex $list [expr {int(rand() * [llength $list])}]
}
# Put a "2*" into an empty cell on the board. The star is to indicate it's new
# for the player's convenience.
proc spawn-new {} {
set emptyCell [pick [empty [cell-indexes]]]
if {[llength $emptyCell] > 0} {
forcells [list $emptyCell] i j cell {
set cell 2
}
}
return $emptyCell
}
# Return vector sum of lists v1 and v2.
proc vector-add {v1 v2} {
set result {}
foreach a $v1 b $v2 {
lappend result [expr {$a + $b}]
}
return $result
}
# If checkOnly is false try to shift all cells one step in the direction of
# directionVect. If checkOnly is true just say if that move is possible.
proc move-all {directionVect {checkOnly 0}} {
set changedCells 0
forcells [cell-indexes] i j cell {
set newIndex [vector-add [list $i $j] $directionVect]
set removedStar 0
# For every nonempty source cell and valid destination cell...
if {$cell != 0 && [valid-cell? $newIndex]} {
if {[cell-get $newIndex] == 0} {
# Destination is empty.
if {$checkOnly} {
return true
} else {
# Move tile to empty cell.
cell-set $newIndex $cell
set cell 0
incr changedCells
}
} elseif {([cell-get $newIndex] eq $cell) &&
[string first + $cell] == -1} {
# Destination is the same number as source.
if {$checkOnly} {
return -level 2 true
} else {
# When merging two tiles into one mark the new tile with
# the marker of "+" to ensure it doesn't get combined
# again this turn.
cell-set $newIndex [expr {2 * $cell}]+
set cell 0
incr changedCells
}
}
}
}
if {$checkOnly} {
return false
}
# Remove "changed this turn" markers at the end of the turn.
if {$changedCells == 0} {
forcells [cell-indexes] i j cell {
set cell [string trim $cell +]
}
}
return $changedCells
}
# Is it possible to move any tiles in the direction of directionVect?
proc can-move? directionVect {
move-all $directionVect 1
}
# Check win condition. The player wins when there's a 2048 tile.
proc check-win {} {
forcells [cell-indexes] i j cell {
if {$cell == 2048} {
variable output "You win!\n"
quit-game 0
}
}
}
# Check lose condition. The player loses when the win condition isn't met and
# there are no possible moves.
proc check-lose possibleMoves {
if {![llength $possibleMoves]} {
variable output "You lose.\n"
quit-game 0
}
}
# Pretty-print the board. Specify an index in highlight to highlight a cell.
proc print-board {{highlight {-1 -1}}} {
forcells [cell-indexes] i j cell {
if {$j == 0} {
append res \n
}
append res [
if {$cell != 0} {
if {[struct::list equal [list $i $j] $highlight]} {
format {[%4s*]} $cell
} else {
format {[%4s]} $cell
}
} else {
lindex ......
}
]
}
append res \n
}
proc quit-game status {
vars done inputMethod inputmode_save output playing stty_save turns
#after cancel $playing
#chan event stdin readable {}
puts $output[set output {}]
puts [list turns $turns]
set turns 0
switch $inputMethod {
twapi {
twapi::modify_console_input_mode stdin {*}$inputmode_save
}
raw {
if {$inputmode_save ne {}} {
exec stty $inputmode_save 2>@stderr
}
}
}
set done $status
return -level 2
}
proc input {} {
vars inputMethod output playing
variable playerInput [read stdin 1]
if {[set charcode [scan $playerInput %c]] in [list 10 {}]} {
if {$charcode eq 10 && $inputMethod ne {}} {
#this only happens in raw/twapi mode. add a newline to stdout
append output \n
}
set playerInput {}
}
after cancel $playing
play_user
}
proc play_user {} {
vars controls inputMethod output playerInput playerMove \
playtype possibleMoves preferences size
if {!$size} {
set size $playerInput
if {![string is digit $size]} {
set size 0
return
}
if {$size eq {}} {
set size 4
}
# Generate an empty board of a given size.
board add columns $size
board add rows $size
forcells [cell-indexes] i j cell {
set cell 0
}
after idle startturn
return
}
switch [scan $playerInput %c] {
3 {
if {$playtype eq random} {
set playtype user
} else {
quit-game 0
}
}
}
if {[dict exists $preferences $playerInput]} {
switch $playerInput {
q {
quit-game 0
}
r {
set playtype random
after idle [namespace code play_random]
return
}
? {
append output $controls\n
append output $preferences\n
}
}
} elseif {$playerInput in $possibleMoves} {
set playerMove [dict get $controls $playerInput]
}
turn
}
proc play_random {} {
vars controls playing playerInput possibleMoves
variable delay 1000
set playerInput [lindex $possibleMoves [
expr {entier(rand() * [llength $possibleMoves])}]]
play_user
set playing [after $delay [namespace code play_random]]
}
proc turn {} {
vars playerMove turns
if {$playerMove eq {}} {
flush stdout
} else {
incr turns
# Apply current move until no changes occur on the board.
while true {
if {[move-all $playerMove] == 0} break
}
}
startturn
}
proc startturn {} {
vars controls inputMethod output ingame
variable playerMove {}
variable possibleMoves {}
#buffer output to speed up rending on slower terminals
if {!$ingame} {
puts {type "?" for help at any time after entering board size}
puts {select board size (4)}
set ingame 1
return
}
switch $inputMethod {
twapi {
twapi::clear_console stdout
}
raw {
::term::ansi::send::clear
}
}
# Add new tile to the board and print the board highlighting this tile.
append output \n[print-board [spawn-new]]
check-win
# Find possible moves.
foreach {button vector} $controls {
if {[can-move? $vector]} {
lappend possibleMoves $button
}
}
check-lose $possibleMoves
append output "\nMove ("
foreach {button vector} $controls {
if {$button in $possibleMoves} {
append output $button
}
}
append output {)? }
puts -nonewline $output[set output {}]
flush stdout
}
proc init {} {
# Board size.
variable size 0
variable playmode play_user
variable cell
variable delay 0
variable ingame 0
variable playing {}
variable playtype user
variable turns 0
struct::matrix board
variable inputmode_save {}
variable inputMethod {}
chan configure stdin -blocking 0
if {![catch {package require twapi}]} {
set inputmode_save [twapi::get_console_input_mode stdin]
twapi::modify_console_input_mode stdin -lineinput false \
-echoinput false
set inputMethod twapi
} else {
catch {
if {[auto_execok stty] ne {}} {
if {[catch {set inputmode_save [
exec stty -g 2>@stderr]} eres eopts]} {
return
#todo: find other ways to save terminal state
}
package require term::ansi::ctrl::unix
package require term::ansi::send
term::ansi::ctrl::unix::raw
set inputMethod raw
}
}
}
variable controls {
h {0 -1}
j {1 0}
k {-1 0}
l {0 1}
}
variable preferences {
q quit
r {random play
You can speed through random play by pressing "r" in quick
succession
press any other valid input key to interrupt random play
}
? {help
}
}
startturn
chan event stdin readable [namespace code input]
}
proc main {} {
variable done
interp bgerror {} [namespace code bgerror]
after idle init
vwait [namespace current]::done
exit $done
}
proc bgerror args {
puts stderr $::errorInfo
quit-game 1
}
#from http://wiki.tcl.tk/40097
proc mainScript {} {
global argv0
if {[info exists argv0]
&& [file exists [info script]] && [file exists $argv0]} {
file stat $argv0 argv0Info
file stat [info script] scriptInfo
expr {$argv0Info(dev) == $scriptInfo(dev)
&& $argv0Info(ino) == $scriptInfo(ino)}
} else {
return 0
}
}
if {[mainScript]} {
main
}
"Screenshot":
[ 8][ 2][ 2]...... ........................ ............[ 2*]...... ........................ Move (hjkl)?
The star indicates a new tile.
See also: