[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...

I left some debugging code in, e.g. console-output and autoplay,
which can be used to record and replay a game. <<br>>
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.<<br>>
You can think of this tclkit as a runtime for Tcl/TK 
(like JRE for Java, .NET for C#, VBASIC etc.), just much smaller.

   * Download a Tclkit: e.g. http://tclkit.googlecode.com/files/tclkit-8.5.8-win32.upx.exe  (1.3 MB)
   * download the above script into a textfile "1k.tcl", i.e. the part between "package require Tk" and "#." (30 KB)
   * put both files into the same directory  (the desktop should be fine, but I recommand a fresh directory, e.g. in the user's home)
   * Drop the script 1k.tcl onto the runtime tclkit*.exe --> program should run now

----
[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]).

======
package require Tcl 8.5
package require struct::matrix
package require struct::list

# Enable single-keypress moves on Windows using TWAPI and on *nix using
# TTY raw mode.
set inputMethod compatible
catch {
    package require term::ansi::ctrl::unix
    ::term::ansi::ctrl::unix::raw
    set inputMethod raw
}
catch {
    package require twapi
    twapi::modify_console_input_mode stdin -lineinput false -echoinput false
    set inputMethod twapi
}

# Board size.
set size 4

# 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]
        uplevel $script
        cell-set "$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 {} {
    global 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} {
    global 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.
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 "$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} {
                    # -level 2 is to return from both forcells and move-all.
                    return -level 2 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} {
            puts "You win!"
            quit-game
        }
    }
}

# Check lose condition. The player loses when the win condition isn't met and
# there are no possible moves.
proc check-lose {possibleMoves} {
    set values [dict values $possibleMoves]
    if {!(true in $values || 1 in $values)} {
        puts "You lose."
        quit-game
    }
}

# 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} {
            puts ""
        }
        puts -nonewline [
            if {$cell != 0} {
                if {[::struct::list equal "$i $j" $highlight]} {
                    format "\[%4s\]" $cell*
                } else {
                    format "\[%4s\]" $cell
                }

            } else {
                lindex "......"
            }
        ]
    }
    puts "\n"
}

proc quit-game {} {
    global inputMethod
    switch $inputMethod {
        twapi {
            twapi::modify_console_input_mode stdin -lineinput true \
                                                   -echoinput true
        }
        raw {
            ::term::ansi::ctrl::unix::cooked
        }
   }
   exit 0
}

proc get-player-input {} {
    global inputMethod
    set input [
        switch $inputMethod {
            twapi { read stdin 1 }
            raw { read stdin 1 }
            default { gets stdin }
        }
    ]
    if {$input eq "q"} {
        quit-game
    }
    return $input
}

proc main {} {

    global size

    struct::matrix board

    chan configure stdin -buffering none

    # 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
    }

    set controls {
        h {0 -1}
        j {1 0}
        k {-1 0}
        l {0 1}
    }

    # Game loop.
    while true {
        set playerMove 0
        set possibleMoves {}

        # Add new tile to the board and print the board highlighting this tile.
        print-board [spawn-new]

        check-win

        # Find possible moves.
        foreach {button vector} $controls {
            dict set possibleMoves $button [can-move? $vector]
        }
        check-lose $possibleMoves

        # Get valid input from the player.
        while {$playerMove == 0} {
            # Print prompt.
            puts -nonewline "Move ("
            foreach {button vector} $controls {
                if {[dict get $possibleMoves $button]} {
                    puts -nonewline $button
                }
            }
            puts ")?"

            set playerInput [get-player-input]

            # Validate input.
            if {[dict exists $possibleMoves $playerInput] &&
                [dict get $possibleMoves $playerInput]} {
                set playerMove [dict get $controls $playerInput]
            }
        }

        # Apply current move until no changes occur on the board.
        while true {
            if {[move-all $playerMove] == 0} break
        }
    }
}

main
======

"Screenshot":

======
[   8][   2][   2]......
........................
............[  2*]......
........................

Move (hjkl)?
======

The star indicates a new tile.

----

'''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]


<<categories>> Games