Guest User

2048.el

a guest
Mar 28th, 2014
279
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

Adblocker detected! Please consider disabling it...

We've detected AdBlock Plus or some other adblocking software preventing Pastebin.com from fully loading.

We don't have any obnoxious sound, or popup ads, we actively block these annoying types of ads!

Please add Pastebin.com to your ad blocker whitelist or disable your adblocking software.

×