aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Initial data commit

Browse source
This commit is contained in:
Ingy döt Net 2023-07-01 11:58:00 -04:00
parent 72d218235f
commit f23f22d71c
199087 changed files with 3378941 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

320
Task/2048/Factor/2048.factor Normal file
View file

@ -0,0 +1,320 @@
USE: accessors
FROM: arrays => <array> array ;
FROM: assocs => assoc-filter keys zip ;
FROM: combinators => case cleave cond ;
FROM: combinators.short-circuit => 1|| 1&& 2&& ;
FROM: continuations => cleanup ;
FROM: formatting => printf sprintf ;
FROM: fry => '[ _ ;
FROM: grouping => all-equal? clump group ;
FROM: io => bl flush nl readln write ;
FROM: kernel => = 2bi 2dup 2drop and bi bi* bi@ boa boolean clone equal? dip drop dup if if* keep loop nip not over swap throw tri unless when with xor ;
FROM: math => integer times * + > >= ;
FROM: math.functions => ^ ;
FROM: math.parser => hex> ;
FROM: math.order => +lt+ +gt+ +eq+ ;
FROM: random => random sample ;
FROM: sequences => <iota> <repetition> any? all? append concat each first flip head if-empty interleave length map pop push reduce reverse second set-nth tail ;
FROM: sorting => sort ;
FROM: vectors => <vector> ;
IN: 2048-game
ERROR: invalid-board ;
SYMBOL: left
SYMBOL: right
SYMBOL: up
SYMBOL: down
TUPLE: tile
{ level integer }
;
TUPLE: board
{ width integer }
{ height integer }
{ tiles array }
;
M: tile equal?
{
[ and ] ! test for f
[ [ level>> ] bi@ = ]
}
2&&
;
: valid-board? ( w h -- ? )
* 0 > ! board with 0 tiles does not have a meaningful representation
;
: <board> ( w h -- board )
[ valid-board? [ invalid-board throw ] unless ]
[ 2dup * f <array> board boa ] 2bi
;
: <tile> ( n -- tile )
tile boa
;
! 1 in 10 tile starts as 4
: new-tile ( -- tile )
10 random 0 = [ 2 ] [ 1 ] if
<tile>
;
<PRIVATE
: space-left? ( board -- ? )
tiles>> [ f = ] any?
;
: rows>> ( board -- seq )
dup tiles>>
[ drop { } ] [ swap width>> group ] if-empty
;
: rows<< ( seq board -- )
[ concat ] dip tiles<<
;
: columns>> ( board -- seq )
rows>> flip
;
: columns<< ( seq board -- )
[ flip concat ] dip tiles<<
;
: change-rows ( board quote -- board )
over [ rows>> swap call( seq -- seq ) ] [ rows<< ] bi
; inline
: change-columns ( board quote -- board )
over [ columns>> swap call( seq -- seq ) ] [ columns<< ] bi
; inline
: can-move-left? ( seq -- ? )
{
! one element seq cannot move
[ length 1 = not ]
! empty seq cannot move
[ [ f = ] all? not ]
[ 2 clump
[
{
! test for identical adjescent tiles
[ [ first ] [ second ] bi [ and ] [ = ] 2bi and ]
! test for empty space on the left and tile on the right
[ [ first ] [ second ] bi [ xor ] [ drop f = ] 2bi and ]
} 1||
] any?
]
} 1&&
;
: can-move-direction? ( board direction -- ? )
{
{ left [ rows>> [ can-move-left? ] any? ] }
{ right [ rows>> [ reverse can-move-left? ] any? ] }
{ up [ columns>> [ can-move-left? ] any? ] }
{ down [ columns>> [ reverse can-move-left? ] any? ] }
} case
;
: can-move-any? ( board -- ? )
{ left right up down } [ can-move-direction? ] with any?
;
: empty-indices ( seq -- seq )
[ length <iota> ] keep zip
[ nip f = ] assoc-filter keys
;
: pick-random ( seq -- elem )
1 sample first
;
! create a new tile on an empty space
: add-tile ( board -- )
[ new-tile swap [ empty-indices pick-random ] keep [ set-nth ] keep ] change-tiles drop
;
! combines equal tiles justified right or does nothing
: combine-tiles ( tile1 tile2 -- tile3 tile4 )
2dup { [ and ] [ = ] } 2&&
[ drop [ 1 + ] change-level f swap ] when
;
: justify-left ( seq -- seq )
[
{
{ [ dup f = ] [ 2drop +lt+ ] }
{ [ over f = ] [ 2drop +gt+ ] }
[ 2drop +eq+ ]
} cond
] sort
;
: collapse ( seq -- seq )
justify-left
! combine adjescent
dup length <vector>
[ over
[ swap [ push ] keep ]
[
{
[ pop combine-tiles ]
[ push ]
[ push ]
} cleave
] if-empty
] reduce
! fill in the gaps after combination
justify-left
;
! draws an object
GENERIC: draw ( obj -- )
PRIVATE>
! a single tile is higher than 2048 (level 10)
: won? ( board -- ? )
tiles>> [ dup [ level>> 11 >= ] when ] any?
;
! if there is no space left and no neightboring tiles are the same, end the board
: lost? ( board -- ? )
{
[ space-left? ]
[ won? ]
[ can-move-any? ]
} 1|| not
;
: serialize ( board -- str )
[ width>> ]
[ height>> ]
[ tiles>>
[ dup f = [ drop 0 ] [ level>> ] if "%02x" sprintf ] map concat
] tri
"%02x%02x%s" sprintf
;
: deserialize ( str -- board )
[ 2 head hex> ] [ 2 tail ] bi
[ 2 head hex> ] [ 2 tail ] bi
2 group [ hex> dup 0 = [ drop f ] [ tile boa ] if ] map
board boa
;
: move ( board direction -- )
{
{ left [ [ [ collapse ] map ] change-rows ] }
{ right [ [ [ reverse collapse reverse ] map ] change-rows ] }
{ up [ [ [ collapse ] map ] change-columns ] }
{ down [ [ [ reverse collapse reverse ] map ] change-columns ] }
} case drop
;
: get-input ( -- line )
readln
;
: parse-input ( line -- direction/f )
{
{ "a" [ left ] }
{ "d" [ right ] }
{ "w" [ up ] }
{ "s" [ down ] }
{ "q" [ f ] }
[ "Wrong input: %s\n" printf flush
get-input parse-input ]
} case
;
<PRIVATE
: init ( board -- )
'[ _ add-tile ] 2 swap times
;
M: tile draw ( tile -- )
level>> 2 swap ^ "% 4d" printf
;
M: boolean draw ( _ -- )
drop 4 [ bl ] times
;
: horizontal-line ( board -- )
width>>
" " write
"+------" <repetition> concat
write "+ " write nl
;
: separator ( -- )
" | " write
;
M: board draw ( board -- )
[ horizontal-line ] keep
[ rows>> ]
[
'[ _ horizontal-line ]
[ separator
[ separator ] [ draw ] interleave
separator nl
] interleave
]
[ horizontal-line ]
tri
flush
;
: update ( board -- f )
{
[
get-input parse-input [
{
[ can-move-direction? ]
[ over [ move ] [ add-tile ] bi* t ]
} 2&& drop t
] [ drop f ] if*
]
[ can-move-any? ]
} 1&&
;
: exit ( board -- )
{
{ [ dup lost? ] [ "You lost! Better luck next time." write nl ] }
{ [ dup won? ] [ "You won! Congratulations!" write nl ] }
[ "Bye!" write nl ]
} cond drop
;
PRIVATE>
: start-2048 ( -- )
4 4 <board>
[
! Initialization
[ init ]
[ draw ]
! Event loop
[ [ dup [ update ] [ draw ] bi ] loop ] tri
]
! Cleanup
[ exit ]
[ ]
cleanup
;
MAIN: start-2048