Minimalistic 2048

[cameyo]

Code Select Expand

;---------------------------------
; Minimalistic 2048 (4x4)
; Use "W" "A" "S" "D" key to move
; (load "g2048.lsp")
;---------------------------------
(define (print-grid)
  (for (i 0 3)
    (for (j 0 3)
      (print (format "%4d " (grid i j))))
    (println)) '>)
;
(define (find-zeros)
  (let (pts '())
    (for (i 0 3)
      (for (j 0 3)
        (if (zero? (grid i j)) (push (list i j) pts -1)))) pts))
;
(define (new-game)
  (setq grid (array-list (array 4 4 '(0))))
  (setq zeros (randomize (find-zeros)))
  (setf (grid (zeros 0)) 2)
  (setf (grid (zeros 1)) 2)
  (input))
;
(define (input)
  (print-grid)
  (case (setq key (read-key))
    (87 (up))    (119 (up))
    (65 (left))  (97  (left))
    (85 (down))  (115 (down))
    (68 (right)) (100 (right))
    (48 (exit)) ; "0" --> quit the game
    (true (begin (println "Wrong key.") (setq key-error true)))
  )
  (cond ((ref 2048 grid) (println "Bravo! You win.") (print-grid))
        ((= key-error true) (setq key-error nil) (input))
        (true
          (setq zeros (randomize (find-zeros)))
          (when zeros ; put 2 or 4 in a free cell
            (if (zero? (rand 2))
                (setf (grid (zeros 0)) 2)
                (setf (grid (zeros 0)) 4)))
          (input))))
;
(define (shift-right row)
  (let ((non-zero (filter (fn (x) (!= x 0)) row))
        (zeroes (filter (fn (x) (= x 0)) row)))
    (extend zeroes non-zero)))
;
(define (shift-left row)
  (let ((non-zero (filter (fn (x) (!= x 0)) row))
        (zeroes (filter (fn (x) (= x 0)) row)))
    (extend non-zero zeroes)))
;
(define (matrix-left matrix) (map shift-left matrix))
;
(define (matrix-right matrix) (map shift-right matrix))
;
(define (matrix-down matrix)
  (let (trans (transpose matrix))
    (transpose (map shift-right trans))))
;
(define (matrix-up matrix)
  (let (trans (transpose matrix))
    (transpose (map shift-left trans))))
;
(define (merge-numbers row)
  (let ( (result '()) (idx 0) (len (length row)) )
    (while (< idx len)
      (if (and (< idx (- len 1)) (= (row idx) (row (+ idx 1))))
          (begin
            (push (* 2 (row idx)) result -1)
            (++ idx 2))
          (begin
            (push (row idx) result -1)
            (++ idx 1))))
    (extend result (dup 0 (- len (length result))))))
;
(define (matrix-merge matrix) (map merge-numbers matrix))
;
(define (right)
  (println "right")
  (setq grid (matrix-right grid))  ; move the numbers to right
  (setq grid (matrix-merge grid))  ; merge the numbers
  (setq grid (matrix-right grid))) ; move the numbers to right
;
(define (left)
  (println "left")
  (setq grid (matrix-left grid))
  (setq grid (matrix-merge grid))
  (setq grid (matrix-left grid)))
;
(define (up)
  (println "up")
  (setq grid (matrix-up grid))
  (setq grid (transpose (matrix-merge (transpose grid))))
  (setq grid (matrix-up grid)))
;
(define (down)
  (println "down")
  (setq grid (matrix-down grid))
  (setq grid (transpose (matrix-merge (transpose grid))))
  (setq grid (matrix-down grid)))
;
(new-game)

[itistoday]

Hah! This is pretty cool 

Some improvement suggestions: support for arrow keys and make `q` and ^C keys work to quit.