2048 game for the 8th programming language

I doubt that I can convert anyone to use the 8th programming language but here is a 2048 game example anyway. Works on desktop and mobile platforms.

\
\ 2048 game for the 8th programming language
\
needs[ nk/gui nk/buttons nk/keyboard stack/rstack ]

0 hw:displaysize? nip 36 n:/ 1.5 n:* constant MIN-ROW-HEIGHT

: font! \ n s
  >r font:system font:new
  r> font:atlas! drop ;

: setup-fonts
  0 hw:displaysize? nip
  50 n:/ dup "font1" font!
  1.8 n:* dup "font2" font!
  1.8 n:* "font3" font! ;

\ Game states
0 constant PLAY
1 constant WON
2 constant GAMEOVER

[ @scan:LEFT, @scan:RIGHT, @scan:UP, @scan:DOWN ] constant CURSOR-KEYS

with: nk
: key-state-changed?  \  s a -- a
  scancode?
  ( if 1 else 0 then ) a:map over get over ?:
  rot third set
  ' n:cmp a:2map ;

: cursor-key?  \ -- n | null
  null "keystates" CURSOR-KEYS key-state-changed?
  (
    swap a:pop -1 n:= if
      rot drop break
    else
      nip
    then
  ) 0 third a:len nip n:1- loop- drop ;

4 constant GRID-SIZE
GRID-SIZE n:sqr constant GRID-SIZE-SQUARED

[[204,192,179,255],[238,228,218,255],[237,224,200,255],[242,177,121,255],
 [245,149,99,255],[246,124,95,255],[246,94,59,255],[237,207,114,255],
 [237,204,97,255],[237,200,80,255],[237,197,63,255],[237,194,46,255]] constant bg-colors

[[249,246,242,255],[119,110,101,255]] constant fg-colors

var empty-cells
nullvar tile-items
nullvar block-list

: update-empty-cells
  a:new
  ( tile-items @ over a:_@ null? if
      drop a:push
    else
      2drop
    then
  ) 0 GRID-SIZE-SQUARED n:1- loop
  empty-cells ! ;

: random-tile
  [1,1,1,1,1,1,1,1,1,2] a:len rand-pcg swap n:mod a:_@ ;

: create-new-tile
  empty-cells @
  a:len rand-pcg swap n:mod dup>r a:@ tile-items @ swap random-tile a:! drop r> a:- drop ;

: get-row-at  \ n -- a
  a:new
  ( >r tile-items @
    third GRID-SIZE n:* r@ n:+ a:_@ null? if
      drop 0 a:push
    else
      a:push
    then rdrop
  ) 0 GRID-SIZE n:1- loop nip ;

: get-column-at  \ n -- a
  a:new
  ( >r tile-items @
    r@ GRID-SIZE n:* fourth n:+ a:_@ null? if
      drop 0 a:push
    else
      a:push
    then rdrop
  ) 0 GRID-SIZE n:1- loop nip ;

: merge  \ source-row -- indices merged-row
  a:new  \ source-row non-empty-tiles
  a:new  \ source-row non-empty-tiles indices

  ( dup>r third a:len nip a:!
    third r@ a:_@ dup 0 n:> if
      third swap a:push drop
    else
      drop
    then
    rdrop
  ) 0 4 pick a:len nip n:1- loop
 
  a:new
  \ source-row non-empty-tiles indices merged-row

  ( dup>r fourth a:len nip n:1- n:= if
      third r@ a:_@ a:push
    else
      third r@ dup n:1+ 2 a:close a:_@ a:open n:= if
        ( >r over r@ a:_@ over a:len nip n:> if
            over r@ a:@ n:1- r@ swap a:! drop
          then
          rdrop
        ) 0 5 pick a:len nip n:1- loop
        third r@ a:_@ n:1+ a:push
        2 step
      else
        third r@ a:_@ a:push
      then
    then
    rdrop
  ) 0 4 pick a:len nip n:1- loop

  ( 0 a:! ) over a:len nip 5 pick a:len nip n:1- loop 2swap 2drop ;

\ block format: [index,value,target,merged,LERP]
: build-block-list
  a:new
  tile-items @
  ( null? !if
      2dup 0 5 a:close a:push
    else
      2drop
    then
  ) a:each drop
  block-list ! ;

"moved?" constant MOVED?
"blocks" constant BLOCKS
"merged-row" constant MERGED-ROW
"source-row" constant SOURCE-ROW
"indices" constant INDICES

: pre-move
  false MOVED? w:!
  a:new BLOCKS w:! ;

: post-move
  MOVED? w:@ if 
    update-empty-cells create-new-tile
  then
  BLOCKS w:@ block-list ! ;

: row-col-source-merged? \ n rev? row? -- T \\ n
  rot dup>r swap if get-row-at else get-column-at then
  swap  if
    a:rev 
  then
  dup SOURCE-ROW w:!
  merge MERGED-ROW w:! INDICES w:!
  SOURCE-ROW w:@ MERGED-ROW w:@ 
  ' n:= a:= 2nip ;
  
locals:
: move-left
  pre-move
  ( false true row-col-source-merged? !if
      true MOVED? w:!
      ( >r SOURCE-ROW w:@ r@ a:_@ 0 n:> INDICES w:@ r@ a:_@ r@ n:= not and if
          \ checks if a merge has happened and at what position
          MERGED-ROW w:@ INDICES w:@ r@ a:_@  a:_@
          SOURCE-ROW w:@ r@ a:_@ n:>
          tile-items @ GRID-SIZE 1 rpick n:* INDICES w:@ r@ a:_@ n:+ a:_@ null? if
            drop false
          else
            drop true
          then
          and if
            \ move and merge
            BLOCKS w:@
            GRID-SIZE 1 rpick n:* r@ n:+
            tile-items @ over a:_@
            GRID-SIZE 1 rpick n:* INDICES w:@ r@ a:_@ n:+
            over n:1+
            1
            5 a:close a:push drop

            tile-items @ GRID-SIZE 1 rpick n:* r@ n:+ a:@ n:1+
            GRID-SIZE 1 rpick n:* INDICES w:@ r@ a:_@ n:+ swap a:! drop
          else
            \ move
              BLOCKS w:@
              GRID-SIZE 1 rpick n:* r@ n:+
              tile-items @ over a:_@
              GRID-SIZE 1 rpick n:* INDICES w:@ r@ a:_@ n:+
              over
              1
              5 a:close a:push drop

              tile-items @ GRID-SIZE 1 rpick n:* r@ n:+ a:@
              GRID-SIZE 1 rpick n:* INDICES w:@ r@ a:_@ n:+ swap a:! drop           
          then
          tile-items @ GRID-SIZE 1 rpick n:* r@ n:+ null a:! drop
        else
          tile-items @ GRID-SIZE 1 rpick n:* r@ n:+ a:_@ null? !if           
            drop
            BLOCKS w:@
            GRID-SIZE 1 rpick n:* r@ n:+
            tile-items @ over a:_@
            2dup
            0
            5 a:close a:push drop
          else
            drop
          then
        then
        rdrop
      ) 0 SOURCE-ROW w:@ a:len nip n:1- loop
    else
      ( >r
        tile-items @ GRID-SIZE 1 rpick n:* r@ n:+ a:_@ null? !if           
          drop
          BLOCKS w:@
          GRID-SIZE 1 rpick n:* r@ n:+
          tile-items @ over a:_@
          2dup
          0
          5 a:close a:push drop
        else
          drop
        then
        rdrop
      ) 0 SOURCE-ROW w:@ a:len nip n:1- loop
    then
    rdrop
  ) 0 GRID-SIZE n:1- loop
 
  post-move ;

locals:
: move-right
  pre-move
  ( true true row-col-source-merged? !if
      true MOVED? w:!
      SOURCE-ROW w:@ a:rev SOURCE-ROW w:!
      MERGED-ROW w:@ a:rev MERGED-ROW w:!
      INDICES w:@ a:rev INDICES w:!
     
      \ recalculate the indices from the end to the start
      ( INDICES w:@ swap GRID-SIZE n:1- third third a:_@ n:- a:! drop
      ) 0 GRID-SIZE n:1- loop

      ( SOURCE-ROW w:@ a:len nip n:1- swap n:- >r
        SOURCE-ROW w:@ r@ a:_@ 0 n:> INDICES w:@ r@ a:_@ r@ n:= not and if
        \ checks if a merge has happened and at what position
        MERGED-ROW w:@ INDICES w:@ r@ a:_@  a:_@
        SOURCE-ROW w:@ r@ a:_@ n:>
        tile-items @ GRID-SIZE 1 rpick n:* INDICES w:@ r@ a:_@ n:+ a:_@ null? if
          drop false
        else
          drop true
        then
        and if
          \ move and merge
            BLOCKS w:@
            GRID-SIZE 1 rpick n:* r@ n:+
            tile-items @ over a:_@
            GRID-SIZE 1 rpick n:* INDICES w:@ r@ a:_@ n:+
            over n:1+
            1
            5 a:close a:push drop

            tile-items @ GRID-SIZE 1 rpick n:* r@ n:+ a:@ n:1+
            GRID-SIZE 1 rpick n:* INDICES w:@ r@ a:_@ n:+ swap a:! drop
          else
            \ move
              BLOCKS w:@
              GRID-SIZE 1 rpick n:* r@ n:+
              tile-items @ over a:_@
              GRID-SIZE 1 rpick n:* INDICES w:@ r@ a:_@ n:+
              over
              1
              5 a:close a:push drop

              tile-items @ GRID-SIZE 1 rpick n:* r@ n:+ a:@
              GRID-SIZE 1 rpick n:* INDICES w:@ r@ a:_@ n:+ swap a:! drop           
          then
          tile-items @ GRID-SIZE 1 rpick n:* r@ n:+ null a:! drop
        else
          tile-items @ GRID-SIZE 1 rpick n:* r@ n:+ a:_@ null? !if           
            drop
            BLOCKS w:@
            GRID-SIZE 1 rpick n:* r@ n:+
            tile-items @ over a:_@
            2dup
            0
            5 a:close a:push drop
          else
            drop
          then
        then
        rdrop
      ) 0 SOURCE-ROW w:@ a:len nip n:1- loop
    else
      ( SOURCE-ROW w:@ a:len nip n:1- swap n:- >r
        tile-items @ GRID-SIZE 1 rpick n:* r@ n:+ a:_@ null? !if           
          drop
          BLOCKS w:@
          GRID-SIZE 1 rpick n:* r@ n:+
          tile-items @ over a:_@
          2dup
          0
          5 a:close a:push drop
        else
          drop
        then
        rdrop
      ) 0 SOURCE-ROW w:@ a:len nip n:1- loop
    then
    rdrop
  ) 0 GRID-SIZE n:1- loop
 
  post-move ;

locals:
: move-up
  pre-move
  ( false false row-col-source-merged? !if
      true MOVED? w:!
      ( >r SOURCE-ROW w:@ r@ a:_@ 0 n:> INDICES w:@ r@ a:_@ r@ n:= not and if
          \ checks if a merge has happened and at what position
          MERGED-ROW w:@ INDICES w:@ r@ a:_@  a:_@
          SOURCE-ROW w:@ r@ a:_@ n:>
          tile-items @ GRID-SIZE INDICES w:@ r@ a:_@ n:* 1 rpick n:+ a:_@ null? if
            drop false
          else
            drop true
          then
          and if
            \ move and merge
            BLOCKS w:@
            GRID-SIZE r@ n:* 1 rpick n:+
            tile-items @ over a:_@
            GRID-SIZE INDICES w:@ r@ a:_@ n:* 1 rpick n:+
            over n:1+
            1
            5 a:close a:push drop

            tile-items @ GRID-SIZE r@ n:* 1 rpick n:+ a:@ n:1+
            GRID-SIZE INDICES w:@ r@ a:_@ n:* 1 rpick n:+ swap a:! drop
          else
            \ move
              BLOCKS w:@
              GRID-SIZE r@ n:* 1 rpick n:+
              tile-items @ over a:_@
              GRID-SIZE INDICES w:@ r@ a:_@ n:* 1 rpick n:+
              over
              1
              5 a:close a:push drop

              tile-items @ GRID-SIZE r@ n:* 1 rpick n:+ a:@
              GRID-SIZE INDICES w:@ r@ a:_@ n:* 1 rpick n:+ swap a:! drop           
          then
          tile-items @ GRID-SIZE r@ n:* 1 rpick n:+ null a:! drop
        else
          tile-items @ GRID-SIZE r@ n:* 1 rpick n:+ a:_@ null? !if           
            drop
            BLOCKS w:@
            GRID-SIZE r@ n:* 1 rpick n:+
            tile-items @ over a:_@
            2dup
            0
            5 a:close a:push drop
          else
            drop
          then
        then
        rdrop
      ) 0 SOURCE-ROW w:@ a:len nip n:1- loop
    else
      ( >r
        tile-items @ GRID-SIZE r@ n:* 1 rpick n:+ a:_@ null? !if           
          drop
          BLOCKS w:@
          GRID-SIZE r@ n:* 1 rpick n:+
          tile-items @ over a:_@
          2dup
          0
          5 a:close a:push drop
        else
          drop
        then
        rdrop
      ) 0 SOURCE-ROW w:@ a:len nip n:1- loop
    then
    rdrop
  ) 0 GRID-SIZE n:1- loop
 
  post-move ;

locals:
: move-down
  pre-move
  ( true false row-col-source-merged? !if
      true MOVED? w:!
      SOURCE-ROW w:@ a:rev SOURCE-ROW w:!
      MERGED-ROW w:@ a:rev MERGED-ROW w:!
      INDICES w:@ a:rev INDICES w:!
     
      \ recalculate the indices from the end to the start
      ( INDICES w:@ swap GRID-SIZE n:1- third third a:_@ n:- a:! drop
      ) 0 GRID-SIZE n:1- loop

      ( SOURCE-ROW w:@ a:len nip n:1- swap n:- >r
        SOURCE-ROW w:@ r@ a:_@ 0 n:> INDICES w:@ r@ a:_@ r@ n:= not and if
        \ checks if a merge has happened and at what position
        MERGED-ROW w:@ INDICES w:@ r@ a:_@  a:_@
        SOURCE-ROW w:@ r@ a:_@ n:>
        tile-items @ GRID-SIZE INDICES w:@ r@ a:_@ n:* 1 rpick n:+ a:_@ null? if
          drop false
        else
          drop true
        then
        and if
            \ move and merge
            BLOCKS w:@
            GRID-SIZE r@ n:* 1 rpick n:+
            tile-items @ over a:_@
            GRID-SIZE INDICES w:@ r@ a:_@ n:* 1 rpick n:+
            over n:1+
            1
            5 a:close a:push drop

            tile-items @ GRID-SIZE r@ n:* 1 rpick n:+ a:@ n:1+
            GRID-SIZE INDICES w:@ r@ a:_@ n:* 1 rpick n:+ swap a:! drop
          else
            \ move
              BLOCKS w:@
              GRID-SIZE r@ n:* 1 rpick n:+
              tile-items @ over a:_@
              GRID-SIZE INDICES w:@ r@ a:_@ n:* 1 rpick n:+
              over
              1
              5 a:close a:push drop

              tile-items @ GRID-SIZE r@ n:* 1 rpick n:+ a:@
              GRID-SIZE INDICES w:@ r@ a:_@ n:* 1 rpick n:+ swap a:! drop           
          then
          tile-items @ GRID-SIZE r@ n:* 1 rpick n:+ null a:! drop
        else
          tile-items @ GRID-SIZE r@ n:* 1 rpick n:+ a:_@ null? !if           
            drop
            BLOCKS w:@
            GRID-SIZE r@ n:* 1 rpick n:+
            tile-items @ over a:_@
            2dup
            0
            5 a:close a:push drop
          else
            drop
          then
        then
        rdrop
      ) 0 SOURCE-ROW w:@ a:len nip n:1- loop
    else
      ( >r
        tile-items @ GRID-SIZE r@ n:* 1 rpick n:+ a:_@ null? !if           
          drop
          BLOCKS w:@
          GRID-SIZE r@ n:* 1 rpick n:+
          tile-items @ over a:_@
          2dup
          0
          5 a:close a:push drop
        else
          drop
        then
        rdrop
      ) 0 SOURCE-ROW w:@ a:len nip n:1- loop
    then
    rdrop
  ) 0 GRID-SIZE n:1- loop

  post-move ; 

locals:
: test-left
  false MOVED? w:!
  ( dup>r get-row-at dup SOURCE-ROW w:!
    merge MERGED-ROW w:! INDICES w:!
    SOURCE-ROW w:@ MERGED-ROW w:@ ' n:= a:= 2nip !if
      true MOVED? w:!
      break
    then
    rdrop
  ) 0 GRID-SIZE n:1- loop
 
  MOVED? w:@ ;

locals:
: test-right
  false MOVED? w:!
  ( dup>r get-row-at a:rev dup SOURCE-ROW w:!
    merge MERGED-ROW w:! INDICES w:!
    SOURCE-ROW w:@ MERGED-ROW w:@ ' n:= a:= 2nip !if
      true MOVED? w:!
      break
    then
    rdrop
  ) 0 GRID-SIZE n:1- loop
 
  MOVED? w:@ ;

locals:
: test-up
  false MOVED? w:!
  ( dup>r get-column-at dup SOURCE-ROW w:!
    merge MERGED-ROW w:! INDICES w:!
    SOURCE-ROW w:@ MERGED-ROW w:@ ' n:= a:= 2nip !if
      true MOVED? w:!
      break
    then
    rdrop
  ) 0 GRID-SIZE n:1- loop
 
  MOVED? w:@ ;

locals:
: test-down
  false MOVED? w:!
  ( dup>r get-column-at a:rev dup SOURCE-ROW w:!
    merge MERGED-ROW w:! INDICES w:!
    SOURCE-ROW w:@ MERGED-ROW w:@ ' n:= a:= 2nip !if
      true MOVED? w:!
      break
    then
    rdrop
  ) 0 GRID-SIZE n:1- loop
 
  MOVED? w:@ ;

: can-move?
  test-left test-right or
  test-up or test-down or ;

: won?
  0
  tile-items @
  ( null? !if
      11 n:= if
        1 n:bor
      then
    else
      drop
    then
  ) a:each! drop ;

: new-win
  {
    name: "main",
    wide: 360,
    high: 400,
    minw: 360,
    minh: 400,
    resizable: true,
    bg: "white",
    title: "2048"
  } win ;

: setup
  a:new tile-items !
  ( update-empty-cells
      create-new-tile ) 2 times

  build-block-list ;

\ draws text centered inside rectangle
: centered-text  \ rect s font bg-color fg-color --
  5 a:close
  [1,2] a:@ a:open measure-font pt>rect >r
  0 a:@ r> center-rect 0 swap a:!
  a:open draw-text ;

: index>rect  \ n -- rect
  dup GRID-SIZE n:/ n:int swap
  GRID-SIZE n:mod
  1 tuck grid ;

: draw-blocks
  block-list @
  ( -1 a:@ >r
    2 a:@ index>rect rect>pos x>pt
    over 0 a:_@ index>rect tuck rect>pos x>pt
    ( r@ n:lerp ) a:2map rdrop
    third [1,3,4] a:_@ a:open 0 n:= if
      nip
    else
      drop
    then
    >r swap rect>size pt>rect swap rect-ofs dup 4 bg-colors r@ a:_@ fill-rect
    2 r@ n:^ >s "font2" bg-colors r@ a:_@ fg-colors r> 3 n:< >n a:_@ centered-text
    drop
  ) a:each! drop ;

: 101grid
  1 0 1 grid ;

: 111grid
  1 1 1 grid ;

: >grid 
  101grid rect>local grid-push ;

: declare 
  "font3" [238,228,218,128] fg-colors 1 a:_@ centered-text ;

: game-over
  0 101grid "Game Over" declare ;

: won
  0 101grid "You Won!" declare ;

: do-dir \ n --
  [ ' move-left , ' move-right , ' move-up , ' move-down ] 
  case ;
 
: test-won won? if
    build-block-list
    "game-state" WON set
  else
    can-move? !if
      build-block-list
      "game-state" GAMEOVER set
    then
  then null do ;

: 2048-grid
  widget if
    1 1 layout-grid-begin
      0 101grid 4 [119,110,101,255] fill-rect
      0 101grid { rows: 4, cols: 4, rgap: 8, cgap: 8, margin: 8 } layout-grid-begin   
        ( >r
          ( 1 r@ 1 grid
            4 bg-colors 0 a:_@ fill-rect
          ) 0 3 loop rdrop
        ) 0 3 loop

        "game-state" get !if
          0  \ blocks moving? flag
          block-list @
          ( -1 a:@ dup if
              0.1 n:- 0 1 n:clamp -1 swap a:! drop
              1 n:bor
            else
              2drop
            then
          ) a:each! drop
          !if
            build-block-list
            cursor-key? null? !if
              do-dir test-won
            else
              drop
            then
          else
            null do   
          then
        then
        draw-blocks         
      layout-grid-end
      [ ' noop , ' won  , ' game-over ]
      "game-state" get case
    layout-grid-end
  else
    drop
  then ;

: top
  widget if
    1 1 layout-grid-begin
      0 101grid dup
        4 [119,110,101,255] fill-rect
      { rows: 1, cols: [0.75, -1], cgap: 8, margin: 8 } layout-grid-begin   
        0 101grid rect>local grid-push 
          "Restart" ( setup "game-state" PLAY set ) button-label
        0 111grid rect>local grid-push 
          "Quit" ' bye button-label
      layout-grid-end
    layout-grid-end
  else
    drop
  then ;

: maintain-aspect-ratio  \ rect -- rect
  dup 2 rect@ swap 3 rect@ rot n:min tuck 2 swap rect! 3 rot rect! center-rect ;

: main-render
  {
    bg: "gray",
    flags: [ @WINDOW_NO_SCROLLBAR ],
    game-state: @PLAY
  }
  begin
    null { rows: [ @MIN-ROW-HEIGHT, -1], cols: 1, rgap: 4, margin: 0 } layout-grid-begin
      0 >grid top
      1 101grid maintain-aspect-ratio rect>local grid-push 2048-grid
    layout-grid-end
  end ;

(
  \ swipe event "d" is dir: 0=indeterminate, 1=left, 2=right, 3=up, 4=down
  "d" m:_@ 0;
  n:1- do-dir test-won
) w:is nk:swipe

: app:main
  setup-fonts setup
  new-win ' main-render -1 render-loop ;

what is “8th”?
some of that code looks like “Forth” on steriods

8th is like a Forth with steroids…