emacs/lisp/2048.el

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

;; Copyright  2014 Mark Burger
;; 2023 additions by Mitchell Marquez

;; Author: Mark Burger
;; Maintainer: Mitchell Marquez
;; Version: 0.2
;; Package-Requires: ((dash))
;; Keywords: games

;; This file is not part of GNU Emacs.

;;; Commentary:
;;                   E  L  I  S  P        ,6*"*VA.
;;                                       dN     V8
;;         pd*"*b.  ,pP""Yq.       ,AM   `MN.  ,g9
;;        (O)   j8 6W'    `Wb     AVMM    ,MMMMq.
;;            ,;j9 8M      M8   ,W' MM   6P   `YMb
;;         ,-='    YA.    ,A9 ,W'   MM   8b    `M9
;;        Ammmmmmm  'Ybmmd7*  AmmmmmMMmm `MmmmmM9
;;                                  MM
;;             Mark Burger, 2014    MM
;;
;; 1. Load this up with M-x eval-buffer OR put (load ".../2048.el") in your
;;       ~/.emacs file
;; 2. Use M-x play-2048 to start playing.
;;
;; Features:
;; - NxN board size rather than hard-coded 4x4 (customize `2048--board-size')
;;

;; edits made by Mitchell Marquez <dr.m.perseos@gmail.com> on 2023-01-11 

;;; Code:

(require 'dash)

(defgroup 2048 nil
  "Play a game of 2048."
  :prefix "2048--"
  :group 'games)
(defvar 2048--cell-width 6
  "Width of number cells for 2048. Should be at least 4 to fit \"2048\".

Values other than 6 are not currently supported.")
(defcustom 2048--board-size 4
  "Number of tiles on the board for 2048. 4 is the default.  Can be any number."
  :type 'integer
  :group '2048)

(defcustom 2048--vertical-sep-char ?│ ; 9478
  "Character to use as a vertical border for 2048 cells."
  :type 'character
  :group '2048)
(defcustom 2048--horizontal-sep-char ?─ ; 9472
  "Character to use as a horizontal border for 2048 cells."
  :type 'character
  :group '2048)
(defcustom 2048--corner-sep-char ?+
  ;; ?╬ ; needlessly fancy version
  "Intersection of `2048--vertical-sep-char'and `2048--horizontal-sep-char'."
  :type 'character
  :group '2048)

(defun 2048--make-sep-times (delimiter filler cells cellwidth)
  "Return a string of CELLS number of cells, each with width CELLWIDTH.
The cells consist of FILLER and are separated by DELIMITER."
  (let* ((filler-list (make-list cellwidth filler))
	 (rh-list (append filler-list delimiter))
	 (skeleton-list (make-list cells nil))
	 (almost-done-list (-replace nil rh-list skeleton-list)))
    (concat (flatten-tree (list delimiter almost-done-list)))))
;; (2048--make-sep-times ?> ?- 5 2)

(defvar 2048-plus-sep (2048--make-sep-times
		     2048--corner-sep-char 2048--horizontal-sep-char
		     2048--board-size 2048--cell-width))
(defvar 2048-space-sep (2048--make-sep-times
		      2048--vertical-sep-char (string-to-char " ")
		      2048--board-size 2048--cell-width))
(defun 2048--pad (number)
  "Pad NUMBER with spaces, to fit inside the 2048 grid.

TODO: rewrite with calculations based on `2048--cell-width's other than 6."
  (cond
   ((= number 0)  "      ") 
   ((< number 10) (format "   %i  " number))
   ((< number 100) (format "  %i  " number))
   ((< number 1000) (format "  %i " number))
   (t (format " %i " number))) )

(defface 2048-2
  '((t :weight bold
       :foreground "#888"))
  "Face for number 2 in 2048."
  :group '2048-mode)
(defface 2048-4
  '((t :weight bold
       :foreground "#666"))
  "Face for number 4 in 2048."
  :group '2048-mode)
(defface 2048-8
  '((t :weight bold
       :foreground "#FA3"))
  "Face for number 8 in 2048."
  :group '2048-mode)
(defface 2048-16
  '((t :weight bold
       :foreground "#F99"))
  "Face for number 16 in 2048."
  :group '2048-mode)
(defface 2048-32
  '((t :weight bold
       :foreground "#F66"))
  "Face for number 32 in 2048."
  :group '2048-mode)
(defface 2048-64
  '((t :weight bold
       :foreground "#F00"))
  "Face for number 64 in 2048."
  :group '2048-mode)
(defface 2048-128
  '((t :weight bold
       :foreground "#AA8"))
  "Face for number 128 in 2048."
  :group '2048-mode)
(defface 2048-256
  '((t :weight bold
       :foreground "#CC6"))
  "Face for number 256 in 2048."
  :group '2048-mode)
(defface 2048-512
  '((t :weight bold
       :foreground "#AA4"))
  "Face for number 512 in 2048."
  :group '2048-mode)
(defface 2048-1024
  '((t :weight bold
       :foreground "#883"))
  "Face for number 1024 in 2048."
  :group '2048-mode)
(defface 2048-2048
  '((t :weight bold
       :foreground "#0A6"))
  "Face for number 2048 in 2048."
  :group '2048-mode)
(defface 2048-4096
  '((t :weight bold
       :foreground "#0F0"))
  "Face for number 4096 in 2048."
:group '2048-mode)
(setq 2048-highlights
      '(
	(" 2 " . '2048-2)
	(" 4 " . '2048-4)
	(" 8 " . '2048-8)
	(" 16 " . '2048-16)
	(" 32 " . '2048-32)
	(" 64 " . '2048-64)
	(" 128 " . '2048-128)
	(" 256 " . '2048-256)
	(" 512 " . '2048-512)
	(" 1024 " . '2048-1024)
	(" 2048 " . '2048-2048)
	(" 4096 " . '2048-4096)
	))

(defun 2048-draw-board ()
  "Draws the 4x4 gaming grid."
  (dotimes (j 2048--board-size)
    (insert (concat 2048-plus-sep "\n") )
    (insert (concat 2048-space-sep "\n") )
    (dotimes (i 2048--board-size)
      (let ( (k (2048-get-num-at i j)) (o "")  )
	(insert 2048--vertical-sep-char)
	(setq o (2048--pad k))
	(insert o)
	)
      )
    (insert				;(concat "|\n" 2048-space-sep "\n")
     (concat (string 2048--vertical-sep-char ?\n) 2048-space-sep "\n")
     )
    )
  (insert 2048-plus-sep)
  )

(defun 2048-get-num-at (x y) "0, 0 is top-left" (aref (aref 2048-board y) x) )

(defun 2048-slide-single-piece (x y direction)
  "Handles the movement of a single block at x,y in direction passed from
the 2048-shift function. Slides and merges for four directions."
  ;; THIS IS THE MOST TEDIUS THING FUCKING EVER.
  (catch 'breaker
    (when (2048-check-diff x y) (throw 'breaker 0))
    (let ((i x)
	  (j y))
      (cond 
       ;; DONE. Blessed?
       ((string= direction "r")
	(while (< i (1- 2048--board-size))
	  (cond 
	   ;; Next space is empty
	   ((= (2048-get-num-at (+ i 1) j) 0)
	    (aset (aref 2048-board j) (+ i 1) 
		  (2048-get-num-at i j))
	    (aset (aref 2048-board j) i 0))
	   ;; Next space is not current space (stop)
	   ((/= (2048-get-num-at i j) 
		(2048-get-num-at (+ i 1) j))
	    (throw 'breaker 0))
	   ;; Otherwise, squish the blocks
	   (t (aset (aref 2048-board j) (+ i 1) 
		    (* (2048-get-num-at i j) 2))
	      (aset (aref 2048-board j) i 0)
	      (throw 'breaker 0)))
	  (setq i (+ i 1))))
       ;; This 'un looks good, too.
       ((string= direction "l")
	(while (> i 0)
	  (cond 
	   ;; Next space is empty
	   ((= (2048-get-num-at (- i 1) j) 0)
	    (aset (aref 2048-board j) (- i 1) 
		  (2048-get-num-at i j))
	    (aset (aref 2048-board j) i 0))
	   ;; Next space is not current space (stop)
	   ((/= (2048-get-num-at i j) 
		(2048-get-num-at (- i 1) j))
	    (throw 'breaker 0))
	   ;; Otherwise, squish the blocks
	   (t (aset (aref 2048-board j) (- i 1) 
		    (* (2048-get-num-at i j) 2))
	      (aset (aref 2048-board j) i 0)
	      (throw 'breaker 0)))
	  (setq i (- i 1))))
       ;; Up! Lookin' OK
       ((string= direction "u")
	(while (> j 0)
	  (cond 
	   ;; Next space is empty
	   ((= (2048-get-num-at i (- j 1) ) 0)
	    (aset (aref 2048-board (- j 1) ) i
		  (2048-get-num-at i j))
	    (aset (aref 2048-board j) i 0))
	   ;; Next space is not current space (stop)
	   ((/= (2048-get-num-at i j) 
		(2048-get-num-at i (- j 1) ))
	    (throw 'breaker 0))
	   ;; Otherwise, squish the blocks
	   (t (aset (aref 2048-board (- j 1)) i
		    (* (2048-get-num-at i j) 2))
	      (aset (aref 2048-board j) i 0)
	      (throw 'breaker 0)))
	  (setq j (- j 1))))
       ;; Down! Test.
       ((string= direction "d")
	(while (< j (1- 2048--board-size))
	  (cond 
	   ;; Next space is empty
	   ((= (2048-get-num-at i (+ j 1) ) 0)
	    (aset (aref 2048-board (+ j 1) ) i
		  (2048-get-num-at i j))
	    (aset (aref 2048-board j) i 0))
	   ;; Next space is not current space (stop)
	   ((/= (2048-get-num-at i j) 
		(2048-get-num-at i (+ j 1) ))
	    (throw 'breaker 0))
	   ;; Otherwise, squish the blocks
	   (t (aset (aref 2048-board (+ j 1)) i
		    (* (2048-get-num-at i j) 2))
	      (aset (aref 2048-board j) i 0)
	      (throw 'breaker 0)))
	  (setq j (+ j 1))))))))

(defun 2048-count-empties ()
  "Return the number of non-zero spaces in 2048-board array."
  (let ((k 0))
    (dotimes (j 2048--board-size)
      (dotimes (i 2048--board-size)
	(when (= (2048-get-num-at i j) 0) (setq k (+ k 1)))
	)
      )
    k
    )
  )

(defun 2048-check-total-diff ()
  "Run 2048-check-diff on the whole board.

Return t/nil if board has changed or not.  Only relevant after
2048-push-board is called and modifications are made to the
2048-board array."
  (catch 'breaker
    (dotimes (j 2048--board-size)
      (dotimes (i 2048--board-size)
	(when (2048-check-diff i j) (throw 'breaker t))
	)
      )
    (throw 'breaker nil)
    )
  )

(defun 2048-check-diff (x y)
  "Returns t if board has changed since beginning of shift."
  (/= (aref (aref 2048-board y) x)
      (aref (aref 2048-board-old y) x))
  )

(defun 2048-push-board()
  "Push 2048-board to 2048-board-old. Essentially makes a snapshot of the
game board to detect modifications later."
  (dotimes (j 2048--board-size)
    (dotimes (i 2048--board-size)
      (aset (aref 2048-board-old j) i (aref (aref 2048-board j) i))
      )
    )
  )

(defun 2048-spawn ()
  "Add either a 2 or 4 to the 2048-board array at a random, free space."
  (catch 'breaker
    (when (= (2048-count-empties) 0) (throw 'breaker 0))
    (let ((j (random 2048--board-size)) (i (random 2048--board-size)) (k (random 100)))
      (while (/= (2048-get-num-at i j) 0)
	(setq i (random 2048--board-size))
	(setq j (random 2048--board-size))
	)
      (cond ( (< k 75) (aset (aref 2048-board j) i 2 ))
	    ( t (aset (aref 2048-board j) i 4)))
      )
    )
  )

(defun 2048-shift (direction)
  "Entry point for shifting. All the keypresses get mapped to this function with
different arguments. This iterates across the board and slides the tiles
individually."
  (2048-push-board)
  (cond
   ((or (string= direction "l") (string= direction "u"))
    (dotimes (j 2048--board-size)
      (dotimes (i 2048--board-size)
	(2048-slide-single-piece i j direction)
	)
      )
    )

   ((or (string= direction "r") (string= direction "d"))
    (dotimes (j 2048--board-size)
      (dotimes (i 2048--board-size)
	(2048-slide-single-piece (- (1- 2048--board-size) i) (- (1- 2048--board-size) j) direction)
	)
      )
    )
   )

  (when 
      (2048-check-total-diff) (2048-spawn))
  ;; Redraw... even if stuff don't need it.
  (erase-buffer)
  (2048-draw-board)
  )

(defun 2048-shift-left () (interactive) (2048-shift "l")  ) 
(defun 2048-shift-right () (interactive) (2048-shift "r"))
(defun 2048-shift-up () (interactive) (2048-shift "u"))
(defun 2048-shift-down () (interactive) (2048-shift "d"))

(defun 2048-startup ()
  "Starts up the game mode for 2048!"
  (interactive)
  (setq 2048-board (make-vector 2048--board-size 0))
  (dotimes (i 2048--board-size) (aset 2048-board i (make-vector 2048--board-size 0)) )
  (setq 2048-board-old (make-vector 2048--board-size 0))
  (dotimes (i 2048--board-size) (aset 2048-board-old i (make-vector 2048--board-size 0)) )
  (dotimes (i 2) (2048-spawn))
  (2048-draw-board)
  )

(define-derived-mode 2048-mode fundamental-mode "2048"
  "Major mode for playing 2048 in Emacs."
  (random t) ;; Start up the RNG
  (local-set-key (kbd "<left>") '2048-shift-left)
  (local-set-key (kbd "<right>") '2048-shift-right)
  (local-set-key (kbd "<down>") '2048-shift-down)
  (local-set-key (kbd "<up>") '2048-shift-up)
  (2048-startup)
  (setq font-lock-defaults '(2048-highlights))
  )

(defun play-2048 ()
    "Play 2048 in Emacs!"
  (switch-to-buffer (get-buffer-create "*2048*"))
  (2048-mode)
  )
(provide '2048)
;;; 2048.el ends here