HJG 2014-03-25 - Work in progress / Playable, but no "Game over" processing 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, and like tetris, the goal is to merge those numbers.
Rules:
There are several variants, some of them only for iOS or Android:
There is also a portable version at http://portableapps.com/news/2014-03-20--2048-portable-1.0-released .
With a download-size of nearly 18 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.
# 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: * event generate