Kirjoittelin 2048 pelin 8th ohjelmointikielellä.
\
\ 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 ;Päivitin koodin tukemaan myös mobiililaitteita, eli pitäisi toimia myös Android ja iOS alustoilla. Siirrot voi tehdä kursori näppäimillä tai swaippaamalla.
\
\ 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 ;Aihe on jo aika vanha, joten et voi enää vastata siihen.