2048: Difference between revisions

</lang>

=={{header|Racket}}==

Play the RacketScript fork online here: http://rapture.twistedplane.com:8080/#example/2048-game

<lang Racket>

;; LICENSE: See License file LICENSE (MIT license)

;;

;; Repository: https://github.com/danprager/2048

;;

;; Copyright 2014: Daniel Prager

;; daniel.a.prager@gmail.com

;;

;; This is a largely clean-room, functional implementation in Racket

;; of the game 2048 by Gabriele Cirulli, based on 1024 by Veewo Studio,

;; and conceptually similar to Threes by Asher Vollmer.

;;

;;

;; HOW TO PLAY:

;; * Use your arrow keys to slide the tiles.

;; * When two tiles with the same number touch, they merge into one!

;; * Press <space> to rotate the board.

;;

#lang racket

(require rackunit

2htdp/image

(rename-in 2htdp/universe

[left left-arrow]

[right right-arrow]

[up up-arrow]

[down down-arrow]))

(define *side* 4) ; Side-length of the grid

(define *time-limit* #f) ; Use #f for no time limit, or number of seconds

(define *amber-alert* 60) ; Time indicator goes orange when less than this number of seconds remaining

(define *red-alert* 10) ; Time indicator goes red when less than this number of seconds remaining

(define *tile-that-wins* 2048) ; You win when you get a tile = this number

(define *magnification* 2) ; Scales the game board

(define (set-side! n)

(set! *side* n))

;;

;; Numbers can be displayed with substiture text. Just edit this table...

;;

(define *text*

'((0 "")

(2 "2")))

;; Color scheme

;;

;; From https://github.com/gabrielecirulli/2048/blob/master/style/main.css

;;

(define *grid-color* (color #xbb #xad #xa0))

(define *default-tile-bg-color* (color #x3c #x3a #x32))

(define *default-tile-fg-color* 'white)

(define *tile-bg-colors*

(map (lambda (x)

(match-define (list n r g b) x)

(list n (color r g b)))

'((0 #xcc #xc0 #xb3)

(2 #xee #xe4 #xda)

(4 #xed #xe0 #xc8)

(8 #xf2 #xb1 #x79)

(16 #xf5 #x95 #x63)

(32 #xf6 #x7c #x5f)

(64 #xf6 #x5e #x3b)

(128 #xed #xcf #x72)

(256 #xed #xcc #x61)

(512 #xed #xc8 #x50)

(1024 #xed #xc5 #x3f)

(2048 #xed #xc2 #x2e))))

(define *tile-fg-colors*

'((0 dimgray)

(2 dimgray)

(4 dimgray)

(8 white)

(16 white)

(32 white)

(64 white)

(128 white)

(256 white)

(512 white)

(1024 white)

(2048 white)))

;;--------------------------------------------------------------------

;; Rows may be represented as lists, with 0s representing empty spots.

;;

(define (nonzero? x) (not (zero? x)))

;; Append padding to lst to make it n items long

;;

(define (pad-right lst padding n)

(append lst (make-list (- n (length lst)) padding)))

;; Slide items towards the head of the list, doubling adjacent pairs

;; when no item is a 0.

;;

;; E.g. (combine '(2 2 2 4 4)) -> '(4 2 8)

;;

(define (combine lst)

(cond [(<= (length lst) 1) lst]

[(= (first lst) (second lst))

(cons (* 2 (first lst)) (combine (drop lst 2)))]

[else (cons (first lst) (combine (rest lst)))]))

;; Total of new elements introduced by combining.

;;

;; E.g. (combine-total '(2 2 2 4 4)) -> 4 + 8 = 12

;;

(define (combine-total lst)

(cond [(<= (length lst) 1) 0]

[(= (first lst) (second lst))

(+ (* 2 (first lst)) (combine-total (drop lst 2)))]

[else (combine-total (rest lst))]))

;; Slide towards the head of the list, doubling pairs, 0 are

;; allowed (and slid through), and length is preserved by

;; padding with 0s.

;;

;; E.g. (slide-left '(2 2 2 0 4 4)) -> '(4 2 8 0 0 0)

;;

(define (slide-left row)

(pad-right (combine (filter nonzero? row)) 0 (length row)))

;; Slide towards the tail of the list:

;;

;; E.g. (slide-right '(2 2 0 0 4 4)) -> '(0 0 0 0 0 4 8)

;;

(define (slide-right row) (reverse (slide-left (reverse row))))

;;--------------------------------------------------------------------

;; We use a sparse representation for transitions in a row.

;;

;; Moves take the form '(value initial-position final-position)

;;

(define (moves-row-left row [last #f] [i 0] [j -1])

(if (null? row)

null

(let ([head (first row)])

(cond [(zero? head) (moves-row-left (rest row) last (add1 i) j)]

[(equal? last head)

(cons (list head i j)

(moves-row-left (rest row) #f (add1 i) j))]

[else (cons (list head i (add1 j))

(moves-row-left (rest row) head (add1 i) (add1 j)))]))))

;; Convert a row into the sparse representaiton without any sliding.

;;

;; E.g. (moves-row-none '(0 2 0 4)) -> '((2 1 1) (4 3 3))

;;

(define (moves-row-none row)

(for/list ([value row]

[i (in-naturals)]

#:when (nonzero? value))

(list value i i)))

;; Reverse all moves so that:

;;

;; '(value initial final) -> '(value (- n initial 1) (- n final 1)

;;

(define (reverse-moves moves n)

(define (flip i) (- n i 1))

(map (λ (m)

(match-define (list a b c) m)

(list a (flip b) (flip c)))

moves))

(define (transpose-moves moves)

(for/list ([m moves])

(match-define (list v (list a b) (list c d)) m)

(list v (list b a) (list d c))))

(define (moves-row-right row [n *side*])

(reverse-moves (moves-row-left (reverse row)) n))

;;--------------------------------------------------------------------

;; Lift the sparse representation for transitions

;; up to two dimensions...

;;

;; '(value initial final) -> '(value (x initial) (x final))

;;

(define (add-row-coord i rows)

(for/list ([r rows])

(match-define (list a b c) r)

(list a (list i b) (list i c))))

(define (transpose lsts)

(apply map list lsts))

;; Slide the entire grid in the specified direction

;;

(define (left grid)

(map slide-left grid))

(define (right grid)

(map slide-right grid))

(define (up grid)

((compose transpose left transpose) grid))

(define (down grid)

((compose transpose right transpose) grid))

;; Calculate the change to score from sliding the grid left or right.

;;

(define (score-increment grid)

(apply + (map (λ (row)

(combine-total (filter nonzero? row)))

grid)))

;; Slide the grid in the specified direction and

;; determine the transitions of the tiles.

;;

;; We'll use these operations to animate the sliding of the tiles.

;;

(define (moves-grid-action grid action)

(let ([n (length (first grid))])

(apply append

(for/list ([row grid]

[i (in-range n)])

(add-row-coord i (action row))))))

(define (moves-grid-left grid)

(moves-grid-action grid moves-row-left))

(define (moves-grid-right grid)

(moves-grid-action grid moves-row-right))

(define (moves-grid-up grid)

((compose transpose-moves moves-grid-left transpose) grid))

(define (moves-grid-down grid)

((compose transpose-moves moves-grid-right transpose) grid))

;; Rotating the entire grid doesn't involve sliding.

;; It's a convenience to allow the player to view the grid from a different

;; orientation.

(define (moves-grid-rotate grid)

(let ([n (length (first grid))])

(for/list ([item (moves-grid-action grid moves-row-none)])

(match-define (list v (list i j) _) item)

(list v (list i j) (list j (- n i 1))))))

;; Chop a list into a list of sub-lists of length n. Used to move from

;; a flat representation of the grid into a list of rows.

;;

;;

(define (chop lst [n *side*])

(if (<= (length lst) n)

(list lst)

(cons (take lst n) (chop (drop lst n) n))))

;; The next few functions are used to determine where to place a new

;; number in the grid...

;;

;; How many zeros in the current state?

;;

(define (count-zeros state)

(length (filter zero? state)))

;; What is the absolute index of the nth zero in lst?

;;

;; E.g. (index-of-nth-zero '(0 2 0 4) 1 2)) 1) -> 2

;;

(define (index-of-nth-zero lst n)

(cond [(null? lst) #f]

[(zero? (first lst))

(if (zero? n)

0

(add1 (index-of-nth-zero (rest lst) (sub1 n))))]

[else (add1 (index-of-nth-zero (rest lst) n))]))

;; Place the nth zero in the lst with val.

;;

;; E.g. (replace-nth-zero '(0 2 0 4) 1 2)) -> '(0 2 2 4)

;;

(define (replace-nth-zero lst n val)

(let ([i (index-of-nth-zero lst n)])

(append (take lst i) (cons val (drop lst (add1 i))))))

;; There's a 90% chance that a new tile will be a two; 10% a four.

;;

(define (new-tile)

(if (> (random) 0.9) 4 2))

;; Create a random initial game-board with two non-zeros (2 or 4)

;; and the rest 0s.

;;

;; E.g. '(0 0 0 0

;; 0 2 0 0

;; 2 0 0 0

;; 0 0 0 0)

;;

(define (initial-state [side *side*])

(shuffle (append (list (new-tile) (new-tile))

(make-list (- (sqr side) 2) 0))))

;; The game finishes when no matter which way you slide, the board doesn't

;; change.

;;

(define (finished? state [n *side*])

(let ([grid (chop state n)])

(for/and ([op (list left right up down)])

(equal? grid (op grid)))))

;;--------------------------------------------------------------------

;; Graphics

;;

(define *text-size* 30)

(define *max-text-width* 40)

(define *tile-side* 50)

(define *grid-spacing* 5)

(define *grid-side* (+ (* *side* *tile-side*)

(* (add1 *side*) *grid-spacing*)))

;; Memoization - caching images takes the strain off the gc

;;

(define-syntax define-memoized

(syntax-rules ()

[(_ (f args ...) bodies ...)

(define f

(let ([results (make-hash)])

(lambda (args ...)

((λ vals

(when (not (hash-has-key? results vals))

(hash-set! results vals (begin bodies ...)))

(hash-ref results vals))

args ...))))]))

;; Look-up the (i,j)th element in the flat representation.

;;

(define (square/ij state i j)

(list-ref state (+ (* *side* i) j)))

;; Linear interpolation between a and b:

;;

;; (interpolate 0.0 a b) -> a

;; (interpolate 1.0 a b) -> b

;;

(define (interpolate k a b)

(+ (* (- 1 k) a)

(* k b)))

;; Key value lookup with default return - is there an out-of-the-box function

;; for this?

;;

(define (lookup key lst default)

(let ([value (assoc key lst)])

(if value (second value) default)))

;; Make a tile without a number on it in the appropriate color.

;;

(define (plain-tile n)

(square *tile-side*

'solid

(lookup n *tile-bg-colors* *default-tile-bg-color*)))

;; Make text for a tile

;;

(define (tile-text n)

(let* ([t (text (lookup n *text* (number->string n))

*text-size*

(lookup n *tile-fg-colors* *default-tile-fg-color*))]

[side (max (image-width t) (image-height t))])

(scale (if (> side *max-text-width*) (/ *max-text-width* side) 1) t)))

(define-memoized (make-tile n)

(overlay

(tile-text n)

(plain-tile n)))

;; Place a tile on an image of the grid at (i,j)

;;

(define (place-tile/ij tile i j grid-image)

(define (pos k)

(+ (* (add1 k) *grid-spacing*)

(* k *tile-side*)))

(underlay/xy grid-image (pos j) (pos i) tile))

;; Make an image of the grid from the flat representation

;;

(define *last-state* null) ; Cache the previous grid to avoid

(define *last-grid* null) ; senseless regeneration

(define (state->image state)

(unless (equal? state *last-state*)

(set! *last-grid*

(for*/fold ([im (square *grid-side* 'solid *grid-color*)])

([i (in-range *side*)]

[j (in-range *side*)])

(place-tile/ij (make-tile (square/ij state i j))

i j

im)))

(set! *last-state* state))

*last-grid*)

(define *empty-grid-image*

(state->image (make-list (sqr *side*) 0)))

;; Convert the sparse representation of moves into a single frame in an

;; animation at time k, where k is between 0.0 (start state) and 1.0

;; (final state).

;;

(define (moves->frame moves k)

(for*/fold ([grid *empty-grid-image*])

([m moves])

(match-define (list value (list i1 j1) (list i2 j2)) m)

(place-tile/ij (make-tile value)

(interpolate k i1 i2) (interpolate k j1 j2)

grid)))

;; Animation of simultaneously moving tiles.

;;

(define (animate-moving-tiles state op)

(let ([grid (chop state)])

(build-list 9 (λ (i)

(λ ()

(moves->frame (op grid)

(* 0.1 (add1 i))))))))

;; Animation of a tile appearing in a previously blank square.

;;

(define (animate-appearing-tile state value index)

(let ([start (state->image state)]

[tile (make-tile value)]

[i (quotient index *side*)]

[j (remainder index *side*)])

(build-list 4 (λ (m)

(λ ()

(place-tile/ij (overlay

(scale (* 0.2 (add1 m)) tile)

(plain-tile 0))

i j

start))))))

;;--------------------------------------------------------------

;;

;; The Game

;;

;; an image-procedure is a procedure of no arguments that produces an image

;; a world contains:

;; state is a ?

;; score is a number

;; winning-total is #f or a number, representing the final score <-- is this

;; necessary?

;; frames is a (list-of image-procedure)

;; start-time is a number, in seconds

(define-struct world (state score winning-total frames start-time) #:transparent)

;; The game is over when any animations have been finished and

;; no more moves are possible.

;;

;; note that winning the game does *not* end the game.

;;

(define (game-over? w)

(match-define (world state score wt frames start-time) w)

(and (null? frames) ; Finish animations to reach final state and show the banner

(or (finished? state)

(out-of-time? (world-start-time w)))))

;; Is the player out of time?

(define (out-of-time? start-time)

(and *time-limit* (< (+ start-time *time-limit*) (current-seconds))))

;; Given an arrow key return the operations to change the state and

;; produce the sliding animation.

;;

(define (key->ops a-key)

(cond

[(key=? a-key "left") (list left moves-grid-left)]

[(key=? a-key "right") (list right moves-grid-right)]

[(key=? a-key "up") (list up moves-grid-up)]

[(key=? a-key "down") (list down moves-grid-down)]

[else (list #f #f)]))

;; Respond to a key-press

;;

(define (change w a-key)

(match-let ([(list op moves-op) (key->ops a-key)]

[(world st score wt frames start-time) w])

(cond [(out-of-time? start-time) w] ; Stop accepting key-presses

[op

(let* ([grid (chop st)]

[slide-state (flatten (op grid))])

(if (equal? slide-state st)

w ; sliding had no effect

(let* ([replace (random (count-zeros slide-state))]

[index (index-of-nth-zero slide-state replace)]

[value (new-tile)]

[new-state (replace-nth-zero slide-state replace value)]

[horizontal? (member a-key (list "left" "right"))])

(make-world new-state

(+ score (score-increment

(if horizontal? grid (transpose grid))))

(cond [wt wt]

[(won-game? new-state)

(apply + (flatten new-state))]

[else #f])

(append frames

(animate-moving-tiles st moves-op)

(animate-appearing-tile slide-state value index))

start-time))))]

[(key=? a-key " ") ; rotate the board

(make-world ((compose flatten transpose reverse) (chop st))

score wt

(append frames

(animate-moving-tiles st moves-grid-rotate))

start-time)]

[else w]))) ; unrecognised key - no effect

;; Are we there yet?

;;

(define (won-game? state)

(= (apply max state) *tile-that-wins*))

;; Banner overlay text: e.g. You won! / Game Over, etc.

;;

(define (banner txt state [color 'black])

(let ([b-text (text txt 30 color)])

(overlay

b-text

(rectangle (* 1.2 (image-width b-text))

(* 1.4 (image-height b-text))

'solid 'white)

(state->image state))))

;; Convert number of seconds to "h:mm:ss" or "m:ss" format

;;

(define (number->time-string s)

(define hrs (quotient s 3600))

(define mins (quotient (remainder s 3600) 60))

(define secs (remainder s 60))

(define (xx n)

(cond [(<= n 0) "00"]

[(<= n 9) (format "0~a" n)]

[else (remainder n 60)]))

(if (>= s 3600)

(format "~a:~a:~a" hrs (xx mins) (xx secs))

(format "~a:~a" mins (xx secs))))

(define (time-remaining start)

(+ *time-limit* start (- (current-seconds))))

(define (time-elapsed start)

(- (current-seconds) start))

;; Display the grid with score below.

;;

;; If there are frames, show the next one. Otherwise show the steady state.

;;

(define (show-world w)

(match-define (world state score wt frames start-time) w)

(let* ([board (if (null? frames)

(cond [(finished? state) (banner "Game over" state)]

[(out-of-time? start-time) (banner "Out of Time" state 'red)]

;; Q: Why wt (i.e. winning-total) rather than won-game?

;; A: wt allows the keen player to continue playing...

[(equal? (apply + (flatten state)) wt) (banner "You won!" state)]

[else (state->image state)])

((first frames)))]

[score-text (text (format "Score: ~a" score) 16 'dimgray)]

[seconds ((if *time-limit* time-remaining time-elapsed) start-time)]

[time-text (text (format "Time: ~a"

(number->time-string seconds))

16

(cond [(or (> seconds *amber-alert*) (not *time-limit*)) 'gray]

[(> seconds *red-alert*) 'orange]

[else 'red]))])

(scale *magnification*

(above

board

(rectangle 0 5 'solid 'white)

(beside

score-text

(rectangle (- (image-width board)

(image-width score-text)

(image-width time-text)) 0 'solid 'white)

time-text)))))

;; Move to the next frame in the animation.

;;

(define (advance-frame w)

(match-define (world state score wt frames start-time) w)

(if (null? frames)

w

(make-world state score wt (rest frames) start-time)))

;; Use this state to preview the appearance of all the tiles

;;

(define (all-tiles-state)

(let ([all-tiles '(0 2 4 8 16 32 64 128 256 512 1024 2048 4096)])

(append all-tiles (make-list (- (sqr *side*) (length all-tiles)) 0))))

;; The event loop

;;

(define (start)

(big-bang (make-world (initial-state)

;(all-tiles-state)

0 #f null (current-seconds))

(to-draw show-world)

(on-key change)

(on-tick advance-frame 0.01)

(stop-when game-over? show-world)

(name "2048 - Racket edition")))

;;

;; TESTS

;;

(module+ test

(set-side! 4)

(check-equal? (slide-left '(0 0 0 0)) '(0 0 0 0))

(check-equal? (slide-left '(1 2 3 4)) '(1 2 3 4))

(check-equal? (slide-left '(2 0 4 0)) '(2 4 0 0))

(check-equal? (slide-left '(0 0 2 4)) '(2 4 0 0))

(check-equal? (slide-left '(2 0 2 0)) '(4 0 0 0))

(check-equal? (slide-left '(0 8 8 0)) '(16 0 0 0))

(check-equal? (slide-left '(4 4 8 8)) '(8 16 0 0))

(check-equal? (slide-right '(4 4 8 8)) '(0 0 8 16))

(check-equal? (slide-right '(4 4 4 0)) '(0 0 4 8))

(check-equal? (moves-row-left '(0 0 0 0)) '())

(check-equal? (moves-row-left '(1 2 3 4))

'((1 0 0)

(2 1 1)

(3 2 2)

(4 3 3)))

(check-equal? (moves-row-left '(2 0 4 0)) '((2 0 0)

(4 2 1)))

(check-equal? (moves-row-right '(2 0 4 0)) '((4 2 3)

(2 0 2)))

(check-equal? (moves-row-left '(0 0 2 4)) '((2 2 0)

(4 3 1)))

(check-equal? (moves-row-left '(2 0 2 0)) '((2 0 0)

(2 2 0)))

(check-equal? (moves-row-left '(2 2 2 0)) '((2 0 0)

(2 1 0)

(2 2 1)))

(check-equal? (moves-row-right '(2 2 2 0)) '((2 2 3)

(2 1 3)

(2 0 2)))

(check-equal? (moves-row-left '(2 2 4 4)) '((2 0 0)

(2 1 0)

(4 2 1)

(4 3 1)))

(check-equal? (moves-row-right '(2 2 4 4)) '((4 3 3)

(4 2 3)

(2 1 2)

(2 0 2)))

(check-equal? (add-row-coord 7 '((2 0 0)

(2 1 0)

(4 2 1)))

'((2 (7 0) (7 0))

(2 (7 1) (7 0))

(4 (7 2) (7 1))))

(check-equal? (left '(( 0 8 8 0)

(16 0 0 0)

( 2 2 4 4)

( 0 2 2 2)))

'((16 0 0 0)

(16 0 0 0)

( 4 8 0 0)

( 4 2 0 0)))

(check-equal? (right '(( 0 8 8 0)

(16 0 0 0)

( 2 2 4 4)

( 0 2 2 2)))

'((0 0 0 16)

(0 0 0 16)

(0 0 4 8)

(0 0 2 4)))

(check-equal? (up '((0 16 2 0)

(8 0 2 2)

(8 0 4 2)

(0 0 4 2)))

'((16 16 4 4)

(0 0 8 2)

(0 0 0 0)

(0 0 0 0)))

(check-equal? (down '((0 16 2 0)

(8 0 2 2)

(8 0 4 2)

(0 0 4 2)))

'((0 0 0 0)

(0 0 0 0)

(0 0 4 2)

(16 16 8 4)))

(check-equal? (left '(( 0 8 8 0)

(16 0 0 0)

( 2 2 4 4)

( 0 2 2 2)))

'((16 0 0 0)

(16 0 0 0)

( 4 8 0 0)

( 4 2 0 0)))

(check-equal? (moves-grid-left '(( 0 8 8 0)

(16 0 0 0)

( 2 2 4 4)

( 0 2 2 2)))

'((8 (0 1) (0 0))

(8 (0 2) (0 0))

(16 (1 0) (1 0))

(2 (2 0) (2 0))

(2 (2 1) (2 0))

(4 (2 2) (2 1))

(4 (2 3) (2 1))

(2 (3 1) (3 0))

(2 (3 2) (3 0))

(2 (3 3) (3 1))))

(check-equal? (moves-grid-right '(( 0 8 8 0)

(16 0 0 0)

( 2 2 4 4)

( 0 2 2 2)))

'((8 (0 2) (0 3))

(8 (0 1) (0 3))

(16 (1 0) (1 3))

(4 (2 3) (2 3))

(4 (2 2) (2 3))

(2 (2 1) (2 2))

(2 (2 0) (2 2))

(2 (3 3) (3 3))

(2 (3 2) (3 3))

(2 (3 1) (3 2))))

(check-equal? (moves-grid-up '(( 0 8 8 0)

(16 0 0 0)

( 2 2 4 4)

( 0 2 2 2)))

'((16 (1 0) (0 0))

(2 (2 0) (1 0))

(8 (0 1) (0 1))

(2 (2 1) (1 1))

(2 (3 1) (1 1))

(8 (0 2) (0 2))

(4 (2 2) (1 2))

(2 (3 2) (2 2))

(4 (2 3) (0 3))

(2 (3 3) (1 3))))

(check-equal? (moves-grid-down '(( 0 8 8 0)

(16 0 0 0)

( 2 2 4 4)

( 0 2 2 2)))

'((2 (2 0) (3 0))

(16 (1 0) (2 0))

(2 (3 1) (3 1))

(2 (2 1) (3 1))

(8 (0 1) (2 1))

(2 (3 2) (3 2))

(4 (2 2) (2 2))

(8 (0 2) (1 2))

(2 (3 3) (3 3))

(4 (2 3) (2 3))))

(check-equal? (chop '(1 2 3 4 5 6 7 8) 4)

'((1 2 3 4) (5 6 7 8)))

(check-equal? (length (initial-state 5)) 25)

(let* ([initial (initial-state)]

[initial-sum (apply + initial)]

[largest-3 (take (sort initial >) 3)])

(check-equal? (length initial) 16)

(check-true (or (= initial-sum 4)

(= initial-sum 6)

(= initial-sum 8)))

(check-true (or (equal? largest-3 '(2 2 0))

(equal? largest-3 '(4 2 0))

(equal? largest-3 '(4 4 0)))))

(check-equal? (count-zeros '(1 0 1 0 0 0 1)) 4)

(check-equal? (count-zeros '(1 1)) 0)

(check-equal? (replace-nth-zero '(0 0 0 1 2 0) 2 5)

'(0 0 5 1 2 0))

(check-true (finished? '(1 2 3 4) 2))

(check-false (finished? '(2 2 3 4) 2)))

(start)