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

[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:'''
   * [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