2048.el

;;; 2048.el --- the 2048 game -*- lexical-binding: t; -*-

;;; Commentary:

;; https://github.com/gabrielecirulli/2048

;; TODO:
;; * scoring
;; * fancy display
;; * animated display?

;;; Code:

(require 'gv)
(require 'cl-lib)

(defvar 2048-start-count 2
  "Number of starting tiles in the game.")

(defvar 2048-orientation 'north
  "Orientation of the board when using `2048-get' and `2048-put'.")

(cl-defstruct (\2048 (:constructor 2048--create))
  "An instance of the game of 2048."
  (size 4)
  (grid nil)
  (gravity-func #'2048--file-gravity)
  (combine-func #'2048--file-combine))

(cl-defun 2048-create (&optional (size 4))
  "Create a new instance of a game of 2048."
  (let ((game (2048--create :size size :grid (make-vector (* size size) 0))))
    (prog1 game
      (cl-loop repeat 2048-start-count do (2048-add-random game)))))

(cl-defun 2048-clone (game)
  "Return a full copy of GAME."
  (let ((copy (copy-sequence game)))
    (prog1 copy
      (setf (2048-grid copy) (copy-sequence (2048-grid game))))))

(defun 2048--index (size x y)
  "Return the index for X and Y for the current `2048-orientation'."
  (cl-ecase 2048-orientation
    (north (+ x (* y size)))
    (east  (+ (- size y 1) (* x size)))
    (west  (+ y (* (- size x 1) size)))
    (south (+ (- size x 1) (* (- size y 1) size)))))

(defun 2048-get (game x y)
  "Get the value in GAME at position X and Y."
  (aref (2048-grid game) (2048--index (2048-size game) x y)))

(defun 2048-put (game x y value)
  "Set the value in GAME at position X and Y to VALUE."
  (setf (aref (2048-grid game) (2048--index (2048-size game) x y)) value))

(gv-define-simple-setter 2048-get 2048-put)

(defun 2048-empty (game)
  "Return a list of empty cell positions in GAME."
  (let ((empty ())
        (size (2048-size game)))
    (dotimes (x size)
      (dotimes (y size)
        (when (zerop (2048-get game x y)) (push (cons x y) empty))))
    empty))

(defun 2048-add-random (game)
  "Place a random value in an empty space in GAME."
  (let ((value (if (< (cl-random 1.0) 0.9) 2 4))
        (empty (2048-empty game)))
    (unless (null empty)
      (cl-destructuring-bind (x . y) (elt empty (cl-random (length empty)))
        (setf (2048-get game x y) value)))))

(defun 2048--file-get (game x)
  "Get the file along X."
  (cl-loop for y from 0 below (2048-size game)
           collect (2048-get game x y)))

(defun 2048--file-put (game x file)
  "Set the file along X to list FILE."
  (cl-loop for y from 0 below (2048-size game)
           do (setf (2048-get game x y) (or (nth y file) 0))))

(defun 2048--file-apply (game func)
  "Apply FUNC to the files of GAME, updating the files."
    (let ((size (2048-size game)))
    (dotimes (x size)
      (let* ((file (2048--file-get game x))
             (result (funcall func file)))
        (2048--file-put game x result)))))

(defalias '2048--file-gravity (apply-partially #'remove 0)
  "Slide the values in a file all the way down.")

(defun 2048--gravity (game)
  "Slide all slots down as far as they can go (low-level)."
  (2048--file-apply game (2048-gravity-func game)))

(defun 2048--file-combine (file)
  "Combine numbers in FILE according to the rules of 2048."
  (if (null file)
      file
    (cl-destructuring-bind (x . xs) file
      (cond ((null xs) file)
            ((= x (car xs)) (cons (* x 2) (2048--file-combine (cdr xs))))
            ((cons x (2048--file-combine (cdr file))))))))

(defun 2048--combine (game)
  "Combine slots downward where possible (low level)."
  (2048--file-apply game (2048-combine-func game)))

(defun 2048-slide (game direction)
  "Slide the slots of GAME in DIRECTION."
  (let ((2048-orientation direction))
    (2048--gravity game)
    (2048--combine game)
    (2048-add-random game)))

(defun 2048--has-moves-p (game)
  "Return non-nil if GAME has moves available."
  (or (cl-find 0 (2048-grid game))
      (let ((copy (2048-clone game)))
        (cl-loop for direction in '(north south east west)
                 do (2048-slide game direction)
                 unless (equal (2048-grid game) (2048-grid copy))
                 return t))))

(defun 2048-state (game)
  "Return the state of GAME (:win, :loss, or nil)."
  (cond ((find 2048 (2048-grid game))   :win)
        ((not (2048--has-moves-p game)) :loss)))

(defun 2048-print (game)
  "Print the grid of GAME (for debugging)."
  (let ((size (2048-size game)))
    (dotimes (y size)
      (dotimes (x size)
        (let ((value (2048-get game x y)))
          (princ (format "% 3d " value))))
      (princ "\n"))))

;; User Interface:

(defvar 2048-buffer-name "*2048*")

(defvar-local 2048-game nil
  "The currently running game of 2048.")

(defvar 2048-mode-map
  (let ((map (make-sparse-keymap)))
    (prog1 map
      (define-key map (kbd "<up>")    #'2048-mode-north)
      (define-key map (kbd "<down>")  #'2048-mode-south)
      (define-key map (kbd "<left>")  #'2048-mode-west)
      (define-key map (kbd "<right>") #'2048-mode-east))))

(define-derived-mode 2048-mode nil "2048"
  "A mode for playing 2048."
  (when (null 2048-game)
    (setf 2048-game (2048-create)))
  (setf buffer-read-only t)
  (suppress-keymap 2048-mode-map)
  (2048-mode-draw))

(put '2048-mode 'mode-class 'special)

(defun \2048 ()
  (interactive)
  (switch-to-buffer 2048-buffer-name)
  (2048-mode))

(defun 2048-mode-north ()
  (interactive)
  (2048-slide 2048-game 'north)
  (2048-mode-draw))

(defun 2048-mode-south ()
  (interactive)
  (2048-slide 2048-game 'south)
  (2048-mode-draw))

(defun 2048-mode-east  ()
  (interactive)
  (2048-slide 2048-game 'east)
  (2048-mode-draw))

(defun 2048-mode-west  ()
  (interactive)
  (2048-slide 2048-game 'west)
  (2048-mode-draw))

(defun 2048-mode-draw ()
  (let ((buffer-read-only nil)
        (standard-output (current-buffer)))
    (erase-buffer)
    (2048-print 2048-game)))

(provide '\2048)

;;; 2048.el ends here