HJG 2014-04-04 - Work in progress / Playable, but highscore is not saved yet. Also, no options 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 :)
There is also a portable version at http://portableapps.com/news/2014-04-17--2048-portable-2.1-released
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-p11.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.
TODO:
* Random new tiles
* Score, Highscore-file
* 2048-movement
* Select play-variant
* cheat / tutorial - mode
}
package require Tk
global Prg
set Prg(Title) "1K-Puzzle"
set Prg(Version) "v0.11"
set Prg(Date) "2014-03-25"
set Prg(Author) "Hans-Joachim Gurt"
set Prg(Contact) [string map -nocase {: @ ! .} gurt:gmx!de]
set Prg(About) "Combine equal numbers, to reach 1024"
set Prg(Msg) "Press up/down/left/right\nto move the numbers."
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) 1
set Prg(UserMoves) 0
set Prg(TileMoves) 0
set Prg(TilesFree) 0
set Prg(TileMerges) 0
set Prg(Score) 0
set Prg(HiScore) 457
array set colors {
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 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
}
}
}
proc Fill_1 {} {
## TODO: random start
if 1 {
SetCell 1 1 1
SetCell 1 2 1
incr ::Prg(Score) 2
}
if 0 {
SetCell 1 1 1
SetCell 1 2 1
SetCell 1 3 1
SetCell 1 4 1
SetCell 2 1 2
SetCell 2 2 2
SetCell 2 4 1
SetCell 3 1 1
SetCell 3 3 1
SetCell 3 4 1
SetCell 4 2 1
SetCell 4 4 1
incr ::Prg(Score) 12
}
if 0 {
SetCell 1 4 1
SetCell 2 2 1
SetCell 2 3 1
SetCell 3 2 1
SetCell 3 4 1
SetCell 4 1 1
SetCell 4 2 1
SetCell 4 3 1
SetCell 4 4 1
incr ::Prg(Score) 9
}
}
proc Fill_2 {} {
global Prg
set i $Prg(OptStart)
incr i 1
puts "Fill_2 : $i"
switch $i {
1 {
SetCell 1 1 1
SetCell 1 2 1
set ::Prg(Score) 2
}
2 {
SetCell 2 3 1
SetCell 3 2 1
set ::Prg(Score) 2
}
3 {
SetCell 3 3 1
SetCell 4 1 1
set ::Prg(Score) 2
}
default {
SetCell 2 3 1
SetCell 4 2 2
set ::Prg(Score) 3
set i 0
}
}
set Prg(OptStart) $i
# puts "Fill_2 = $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} {
SetCell $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 }
SetCell $r $c $v
}
#---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+
proc SetCell { r c v } {
set color black
set val " "
if { $v > 0 } { set val $v }
#puts "SetCell $r $c $v "
set color $::colors($v)
puts "SetCell $r $c $v : $color"
.b$r$c configure -text $val -bg $color
}
proc Mv { r1 c1 r2 c2 } {
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
SetCell $r2 $c2 [expr $v1+$v2]
SetCell $r1 $c1 0
incr Prg(TileMerges) 1
}
if {$v2 == " "} { ;# destination is free: move tile #1
SetCell $r2 $c2 $v1
SetCell $r1 $c1 0
incr Prg(TileMoves) 1
}
}
}
proc Move { dir } {
global Prg
set Prg(Dbg) "Button pressed: $dir"
puts $Prg(Dbg)
## TODO: "original" 2048 movement
## TODO: better move-algorithm
set Prg(TileMoves) 0
set Prg(TileMerges) 0
# "single-step" movement :
if 0 {
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
}
}
###
# "greedy" movement :
if 1 {
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
}
}
set Prg(Dbg) "Moves: $Prg(TileMoves) \nMerges: $Prg(TileMerges) "
puts $::Prg(Dbg)
set a $Prg(TileMoves)
incr a $Prg(TileMerges)
if {$a == 0 } {
set Prg(Dbg) "No Move"
puts $::Prg(Dbg)
} else {
incr ::Prg(UserMoves) 1 ;# Move was successful
# Find free tile(s), check for game over, create new tile:
set freeTiles 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
}
}
}
set Prg(TilesFree) $freeTiles
set Prg(Dbg) "Free: $freeTiles"
puts $::Prg(Dbg)
## TODO: select (random) new number and position
if {$freeTiles < 1} {
set Prg(Msg) "GAME OVER !\n Score $Prg(Score)"
puts $::Prg(Msg)
} else {
after 150 SetCell $r0 $c0 1
incr ::Prg(Score) 1
}
}
}
#---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+
proc Start { i } {
set ::Prg(UserMoves) 0
set ::Prg(Score) 0
.fB configure -bg gray80 ;# cyan
.fJ configure -bg cyan
.bt_start configure -fg red
.bt_quit configure -fg red
# Fill_Test
# after 1000 { Fill_Zero }
Fill_Zero
if {$i == 0} {
Fill_1
} else {
Fill_2
}
}
proc ButtonInvoke { w } {
event generate $w <1>
event generate $w <ButtonRelease-1>
# after 100 {event generate $w <ButtonRelease-1>}
}
proc InitGUI {} {
global Prg
wm title . "$Prg(Title) $Prg(Version)"
puts "$Prg(Title) $Prg(Version)"
frame .f0 -background grey ;# Outer frame
pack .f0 -padx 10 -pady 10
frame .fS -background LightYellow1 ;# Score-Display
label .lb_1 -text $Prg(Title) -width 10 -bg DeepPink1 -pady 8
label .lb_2 -textvar Prg(Msg) -width 30 -bg grey -pady 8 -height 2
# label .lb_F -textvar Prg(TilesFree) -width 8 -bg cyan -padx 6 -pady 2
label .lb_S -textvar Prg(Score) -width 8 -bg pink -padx 6 -pady 4
label .lb_H -textvar Prg(HiScore) -width 8 -bg cyan -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 -background grey80 -pady 8 -padx 8 ;# Joystick-Buttons
frame .fB -background cyan -pady 2 ;# 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
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_start -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_start .bt_quit -in .fB -side left -padx 18 -pady 2
bind all <Return> { Start 1 }
## bind all <Return> { Fill_Test } ;# 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>> }
}
InitGUI
Start 0
# bind all <Key-F2> {console show}
# catch {console show}
# catch {wm withdraw .}
#.See also: