2048 game in 80 lines of Racket

2048.rkt

#lang slideshow
(require slideshow/code)
; WASD to take a move
(define SIDE 50)
(define color-table (list "gray" (list 238 228 218) (list 238 224 198) (list 243 177 116)
                          (list 243 177 116) (list 248 149 90) (list 249 94 50) (list 239 207 108)
                          (list 239 207 99) (list 239 203 82) (list 239 199 57) (list 239 195 41)
                          (list 255 60 57)))
(define label-table (list "" "1" "2" "4" "8" "16" "32" "64" "128" "256" "512" "1024" "2048"))

(define (square s) (filled-rectangle s s))
(define (block t) (cc-superimpose (colorize (square SIDE) (list-ref color-table t)) (text (list-ref label-table t))))

(define (board->columns board)
  (map (lambda (i) (map (lambda (y) (list-ref board y)) (map (lambda (x) (+ x i)) (range 0 13 4)))) (range 4)))
(define (board->rows board)
  (map (lambda (i) (map (lambda (y) (list-ref board y)) (range (* 4 i) (* 4 (+ i 1))))) (range 4)))

(define (rows->board rows) (flatten rows))
(define (columns->board cols) (rows->board (board->columns (rows->board cols))))

(define vertical-border (colorize (filled-rectangle 5 SIDE) (list 128 128 128)))
(define horizontal-border (colorize (filled-rectangle (+ 5 (* 4 (+ SIDE 5))) 5) (list 128 128 128)))

(define (render-row r)
  (if (null? r) vertical-border
      (hc-append vertical-border (block (car r)) (render-row (cdr r)))))

(define (render-board b)
  (define (render-board-recur b)
    (if (null? b) horizontal-border
        (vc-append horizontal-border (render-row (car b)) (render-board-recur (cdr b)))))
  (println (render-board-recur (board->rows b))))

(define (merge-blocks l)
  (define (merge-blocks-recur l)
    (cond [(null? l) null]
          [(null? (cdr l)) l]
          [(zero? (car l)) (merge-blocks-recur (cdr l))]
          [(and (equal? (car l) (cadr l)) (positive? (car l))) (cons (+ 1 (car l)) (merge-blocks-recur (cddr l)))]
          [else (cons (car l) (merge-blocks-recur (cdr l)))]))
  (let ([merged (merge-blocks-recur (filter (lambda (x) (positive? x)) l))])
    (append merged (build-list (- 4 (length merged)) (lambda (x) 0)))))

(define (merge-board board dir)
  (let ([rc (map (if (even? dir) reverse identity) ((if (> dir 2) board->columns board->rows) board))])
    ((if (> dir 2) columns->board rows->board) (map (if (even? dir) reverse identity) (map merge-blocks rc)))))

(define (random-pos b)
  (let ([x (random 4)]
        [y (random 4)])
    (if (zero? (list-ref b (+ y (* 4 x)))) (+ y (* 4 x)) (random-pos b))))
(define (spawn-block b)
  (let ([ind (random-pos b)])
    (define (set-block-recur b i)
      (cond [(null? b) null]
            [(equal? i ind) (cons (+ 1 (random 2)) (set-block-recur (cdr b) (+ 1 i)))]
            [else (cons (car b) (set-block-recur (cdr b) (+ 1 i)))]))
    (set-block-recur b 0)))

(define (get-input)
  (define valid-moves (list 'a 'd 'w 's))
  (displayln "Next move: ")
  (let ([move (read)])
    (if (member move valid-moves) (- 5 (length (member move valid-moves))) (get-input))))

(define (lost? board)
  (and (andmap (lambda (x) (positive? x)) board) (andmap (lambda (b) (equal? b board)) (map (lambda (i) (merge-board board i)) (range 1 5)))))

(define (next-move board)
  (define (lost-game board) (render-board board) "You lost!")
  (render-board board)
  (if (ormap (lambda (x) (= x 12)) board) "You win!"
      (let* ([move (get-input)]
             [merged (merge-board board move)])
        (if (lost? merged) (lost-game merged)
            (let ([spawned (spawn-block  merged)])
              (if (lost? spawned) (lost-game spawned) (next-move spawned)))))))

(next-move (spawn-block (spawn-block (build-list 16 (lambda (x) 0)))))