Author Topic: 2048 Challenge  (Read 7434 times)

Offline John

  • Forum Support / SB Dev
  • Posts: 3510
    • ScriptBasic Open Source Project
2048 Challenge
« on: June 23, 2016, 10:55:00 PM »
2048 is a popular terminal game and here is a C version of it. It might be fun to have a few BASIC variations of it.

Source Code

Online Version
« Last Edit: June 23, 2016, 10:57:07 PM by John »

Offline jalih

  • Advocate
  • Posts: 109
Re: 2048 Challenge
« Reply #1 on: July 10, 2023, 07:44:23 AM »
I just started writing a version of 2048 using the 8th programming language. I got it figured out how to make blocks slide nicely when moving. I still need to add movement for up and down but that should be simple addition. Also texts should be centered inside block rectangles and visual look still needs some work.

2048 game for 8th

Offline John

  • Forum Support / SB Dev
  • Posts: 3510
    • ScriptBasic Open Source Project
Re: 2048 Challenge
« Reply #2 on: July 10, 2023, 10:00:23 AM »
Hi Jalih,

Glad you are still with us.

I'm thinking on submitting an entry using a VB6 OCX and ScriptBasic. This would show how to use VB as a UI component.
« Last Edit: July 11, 2023, 09:45:37 AM by John »

Offline John

  • Forum Support / SB Dev
  • Posts: 3510
    • ScriptBasic Open Source Project
Re: 2048 Challenge
« Reply #3 on: July 11, 2023, 07:34:37 PM »
This is a VB6 version I found. I had to replace the StatusBar with a Label to get it to compile. StatusBar doesn't seem to be a valid common control in later updates of the library.

2048 Repository


Offline jalih

  • Advocate
  • Posts: 109
Re: 2048 Challenge
« Reply #4 on: July 12, 2023, 09:46:05 AM »
This is a VB6 version I found. I had to replace the StatusBar with a Label to get it to compile. StatusBar doesn't seem to be a valid common control in later updates of the library.

Does it animate sliding blocks?

I was able to complete my 8th version.

Offline John

  • Forum Support / SB Dev
  • Posts: 3510
    • ScriptBasic Open Source Project
Re: 2048 Challenge
« Reply #5 on: July 12, 2023, 01:42:00 PM »
Quote
Does it animate sliding blocks?

Yes, but not as smooth as yours.

I attached the compiled 2048.exe file.
« Last Edit: July 12, 2023, 02:10:13 PM by John »

Offline jalih

  • Advocate
  • Posts: 109
Re: 2048 Challenge
« Reply #6 on: July 14, 2023, 07:14:20 AM »
Here is the full 8th source code for my game:

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

22 font:system font:new "font1" font:atlas! drop
42 font:system font:new "font2" font:atlas! drop
84 font:system font:new "font3" font:atlas! drop

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

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

: key-state-changed?   \  s a -- a
  nk:scancode?
  ( if 1 else 0 then ) a:map over nk:get over ?:
  rot 2 pick nk: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 2 pick 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 @
    2 pick 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:* 3 pick 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 2 pick a:len nip a:!
    2 pick r@ a:_@ dup 0 n:> if
      2 pick 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 3 pick a:len nip n:1- n:= if
      2 pick r@ a:_@ a:push
    else
      2 pick 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
        2 pick r@ a:_@ n:1+ a:push
        2 step
      else
        2 pick 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 ! ;

locals:
: move-left
  false "moved?" w:!
  a:new "blocks" 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:!
      ( >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
 
  "moved?" w:@ if
    update-empty-cells
    create-new-tile
  then

  "blocks" w:@ block-list ! ;

locals:
: move-right
  false "moved?" w:!
  a:new "blocks" 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:!
      "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- 2 pick 2 pick 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
 
  "moved?" w:@ if
    update-empty-cells
    create-new-tile
  then

  "blocks" w:@ block-list ! ;

locals:
: move-up
  false "moved?" w:!
  a:new "blocks" 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:!
      ( >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
 
  "moved?" w:@ if
    update-empty-cells
    create-new-tile
  then

  "blocks" w:@ block-list ! ;

locals:
: move-down
  false "moved?" w:!
  a:new "blocks" 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:!
      "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- 2 pick 2 pick 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
 
  "moved?" w:@ if
    update-empty-cells
    create-new-tile
  then

  "blocks" w:@ block-list ! ;

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: 512,
    high: 512,
    resizable: false,
    bg: "white",
    title: "2048"
  } nk:win ;

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

  build-block-list ;

\ t should be between 0 to 1 range
: lerp \ a b t -- n
  0 1 n:clamp >r over n:- r> n:* n:+ ;

\ draws text centered inside rectangle
: centered-text  \ rect s font bg-color fg-color -- 
  3 pick 3 pick nk:measure-font nk:pt>rect 5 roll swap nk:center-rect -4 roll nk:draw-text ;

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

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

: game-over
  0 1 0 1 nk:grid "Game Over" "font3" [238,228,218,128] fg-colors 1 a:_@ centered-text ;

: won
  0 1 0 1 nk:grid "You Won!" "font3" [238,228,218,128] fg-colors 1 a:_@ centered-text ;
 
: 2048
  nk:widget if
    1 1 nk:layout-grid-begin
      0 1 0 1 nk:grid
        4 [119,110,101,255] nk:fill-rect
      0 1 0 1 nk:grid { rows: 4, cols: 4, rgap: 8, cgap: 8, margin: 8 } nk:layout-grid-begin   
        ( >r
          ( 1 r@ 1 nk:grid
            4 bg-colors 0 a:_@ nk:fill-rect
          ) 0 3 loop rdrop
        ) 0 3 loop

        "game-state" nk: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
              [ ' move-left , ' move-right , ' move-up , ' move-down ] case
              won? if
                build-block-list
                "game-state" WON nk:set
              else
                can-move? !if
                  build-block-list
                  "game-state" GAMEOVER nk:set
                then
              then
              null nk:do
            else
              drop
            then
          else
            null nk:do     
          then
        then

        draw-blocks
         
      nk:layout-grid-end
      [ ' noop , ' won , ' game-over ]
      "game-state" nk:get case
    nk:layout-grid-end
  else
    drop
  then ;

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

: main-render
  {
    bg: "white",
    flags: [ @nk:WINDOW_NO_SCROLLBAR ],
    game-state: @PLAY
  }
  nk:begin
    null { rows: [0.1,0.9], cols: 1, rgap: 4, margin: 0 } nk:layout-grid-begin
      0 1 0 1 nk:grid nk:rect>local nk:grid-push
        top
      1 1 0 1 nk:grid nk:rect>local nk:grid-push
        2048
    nk:layout-grid-end
  nk:end ;

: app:main
  init 
  new-win ' main-render -1 nk:render-loop ;

Offline jalih

  • Advocate
  • Posts: 109
Re: 2048 Challenge
« Reply #7 on: August 13, 2023, 01:39:10 AM »
I modified my 2048 game to support mobile platforms, so it now should also work with Android and iOS platforms.

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

: init-window-size
  mobile? if
    hw:displaysize?
  else
    400 460
  then ;

init-window-size constant HEIGHT constant WIDTH

: setup-fonts
  HEIGHT 0.05 n:* dup>r dup font:system "font1" 3 a:close ["size","font","name"] swap m:zip font:new drop
  r> 1.6 n:* dup>r dup font:system "font2" 3 a:close ["size","font","name"] const swap m:zip font:new drop
  r> 1.8 n:* dup font:system "font3" 3 a:close ["size","font","name"] const swap m:zip font:new drop ;

\ 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: @WIDTH,
    high: @HEIGHT,
    resizable: false,
    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: [ 0.12, -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 ;
« Last Edit: August 13, 2023, 05:45:42 AM by jalih »