Guest User

2048.el

a guest
Mar 28th, 2014
230
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. ;;; 2048.el --- the 2048 game -*- lexical-binding: t; -*-
  2.  
  3. ;;; Commentary:
  4.  
  5. ;; https://github.com/gabrielecirulli/2048
  6.  
  7. ;; TODO:
  8. ;; * scoring
  9. ;; * fancy display
  10. ;; * animated display?
  11.  
  12. ;;; Code:
  13.  
  14. (require 'gv)
  15. (require 'cl-lib)
  16.  
  17. (defvar 2048-start-count 2
  18.   "Number of starting tiles in the game.")
  19.  
  20. (defvar 2048-orientation 'north
  21.   "Orientation of the board when using `2048-get' and `2048-put'.")
  22.  
  23. (cl-defstruct (\2048 (:constructor 2048--create))
  24.   "An instance of the game of 2048."
  25.   (size 4)
  26.   (grid nil)
  27.   (gravity-func #'2048--file-gravity)
  28.   (combine-func #'2048--file-combine))
  29.  
  30. (cl-defun 2048-create (&optional (size 4))
  31.   "Create a new instance of a game of 2048."
  32.   (let ((game (2048--create :size size :grid (make-vector (* size size) 0))))
  33.     (prog1 game
  34.       (cl-loop repeat 2048-start-count do (2048-add-random game)))))
  35.  
  36. (cl-defun 2048-clone (game)
  37.   "Return a full copy of GAME."
  38.   (let ((copy (copy-sequence game)))
  39.     (prog1 copy
  40.       (setf (2048-grid copy) (copy-sequence (2048-grid game))))))
  41.  
  42. (defun 2048--index (size x y)
  43.   "Return the index for X and Y for the current `2048-orientation'."
  44.   (cl-ecase 2048-orientation
  45.     (north (+ x (* y size)))
  46.     (east  (+ (- size y 1) (* x size)))
  47.     (west  (+ y (* (- size x 1) size)))
  48.     (south (+ (- size x 1) (* (- size y 1) size)))))
  49.  
  50. (defun 2048-get (game x y)
  51.   "Get the value in GAME at position X and Y."
  52.   (aref (2048-grid game) (2048--index (2048-size game) x y)))
  53.  
  54. (defun 2048-put (game x y value)
  55.   "Set the value in GAME at position X and Y to VALUE."
  56.   (setf (aref (2048-grid game) (2048--index (2048-size game) x y)) value))
  57.  
  58. (gv-define-simple-setter 2048-get 2048-put)
  59.  
  60. (defun 2048-empty (game)
  61.   "Return a list of empty cell positions in GAME."
  62.   (let ((empty ())
  63.         (size (2048-size game)))
  64.     (dotimes (x size)
  65.       (dotimes (y size)
  66.         (when (zerop (2048-get game x y)) (push (cons x y) empty))))
  67.     empty))
  68.  
  69. (defun 2048-add-random (game)
  70.   "Place a random value in an empty space in GAME."
  71.   (let ((value (if (< (cl-random 1.0) 0.9) 2 4))
  72.         (empty (2048-empty game)))
  73.     (unless (null empty)
  74.       (cl-destructuring-bind (x . y) (elt empty (cl-random (length empty)))
  75.         (setf (2048-get game x y) value)))))
  76.  
  77. (defun 2048--file-get (game x)
  78.   "Get the file along X."
  79.   (cl-loop for y from 0 below (2048-size game)
  80.            collect (2048-get game x y)))
  81.  
  82. (defun 2048--file-put (game x file)
  83.   "Set the file along X to list FILE."
  84.   (cl-loop for y from 0 below (2048-size game)
  85.            do (setf (2048-get game x y) (or (nth y file) 0))))
  86.  
  87. (defun 2048--file-apply (game func)
  88.   "Apply FUNC to the files of GAME, updating the files."
  89.     (let ((size (2048-size game)))
  90.     (dotimes (x size)
  91.       (let* ((file (2048--file-get game x))
  92.              (result (funcall func file)))
  93.         (2048--file-put game x result)))))
  94.  
  95. (defalias '2048--file-gravity (apply-partially #'remove 0)
  96.   "Slide the values in a file all the way down.")
  97.  
  98. (defun 2048--gravity (game)
  99.   "Slide all slots down as far as they can go (low-level)."
  100.   (2048--file-apply game (2048-gravity-func game)))
  101.  
  102. (defun 2048--file-combine (file)
  103.   "Combine numbers in FILE according to the rules of 2048."
  104.   (if (null file)
  105.       file
  106.     (cl-destructuring-bind (x . xs) file
  107.       (cond ((null xs) file)
  108.             ((= x (car xs)) (cons (* x 2) (2048--file-combine (cdr xs))))
  109.             ((cons x (2048--file-combine (cdr file))))))))
  110.  
  111. (defun 2048--combine (game)
  112.   "Combine slots downward where possible (low level)."
  113.   (2048--file-apply game (2048-combine-func game)))
  114.  
  115. (defun 2048-slide (game direction)
  116.   "Slide the slots of GAME in DIRECTION."
  117.   (let ((2048-orientation direction))
  118.     (2048--gravity game)
  119.     (2048--combine game)
  120.     (2048-add-random game)))
  121.  
  122. (defun 2048--has-moves-p (game)
  123.   "Return non-nil if GAME has moves available."
  124.   (or (cl-find 0 (2048-grid game))
  125.       (let ((copy (2048-clone game)))
  126.         (cl-loop for direction in '(north south east west)
  127.                  do (2048-slide game direction)
  128.                  unless (equal (2048-grid game) (2048-grid copy))
  129.                  return t))))
  130.  
  131. (defun 2048-state (game)
  132.   "Return the state of GAME (:win, :loss, or nil)."
  133.   (cond ((find 2048 (2048-grid game))   :win)
  134.         ((not (2048--has-moves-p game)) :loss)))
  135.  
  136. (defun 2048-print (game)
  137.   "Print the grid of GAME (for debugging)."
  138.   (let ((size (2048-size game)))
  139.     (dotimes (y size)
  140.       (dotimes (x size)
  141.         (let ((value (2048-get game x y)))
  142.           (princ (format "% 3d " value))))
  143.       (princ "\n"))))
  144.  
  145. ;; User Interface:
  146.  
  147. (defvar 2048-buffer-name "*2048*")
  148.  
  149. (defvar-local 2048-game nil
  150.   "The currently running game of 2048.")
  151.  
  152. (defvar 2048-mode-map
  153.   (let ((map (make-sparse-keymap)))
  154.     (prog1 map
  155.       (define-key map (kbd "<up>")    #'2048-mode-north)
  156.       (define-key map (kbd "<down>")  #'2048-mode-south)
  157.       (define-key map (kbd "<left>")  #'2048-mode-west)
  158.       (define-key map (kbd "<right>") #'2048-mode-east))))
  159.  
  160. (define-derived-mode 2048-mode nil "2048"
  161.   "A mode for playing 2048."
  162.   (when (null 2048-game)
  163.     (setf 2048-game (2048-create)))
  164.   (setf buffer-read-only t)
  165.   (suppress-keymap 2048-mode-map)
  166.   (2048-mode-draw))
  167.  
  168. (put '2048-mode 'mode-class 'special)
  169.  
  170. (defun \2048 ()
  171.   (interactive)
  172.   (switch-to-buffer 2048-buffer-name)
  173.   (2048-mode))
  174.  
  175. (defun 2048-mode-north ()
  176.   (interactive)
  177.   (2048-slide 2048-game 'north)
  178.   (2048-mode-draw))
  179.  
  180. (defun 2048-mode-south ()
  181.   (interactive)
  182.   (2048-slide 2048-game 'south)
  183.   (2048-mode-draw))
  184.  
  185. (defun 2048-mode-east  ()
  186.   (interactive)
  187.   (2048-slide 2048-game 'east)
  188.   (2048-mode-draw))
  189.  
  190. (defun 2048-mode-west  ()
  191.   (interactive)
  192.   (2048-slide 2048-game 'west)
  193.   (2048-mode-draw))
  194.  
  195. (defun 2048-mode-draw ()
  196.   (let ((buffer-read-only nil)
  197.         (standard-output (current-buffer)))
  198.     (erase-buffer)
  199.     (2048-print 2048-game)))
  200.  
  201. (provide '\2048)
  202.  
  203. ;;; 2048.el ends here
RAW Paste Data