mir/emacs
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add 2048.el file - see https://github.com/ScottishPig/Elisp/blob/master/2048.el

Browse Source
This commit is contained in:
MitchMarq42 2023-01-12 08:48:36 -09:00
parent 700d0da6b7
commit 0333a3ccd3
1 changed files with 360 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

360
lisp/2048.el Normal file
View File

@ -0,0 +1,360 @@
;; -*- lexical-binding: t -*-
;; 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.
;;
;; Possible future additions: NxN board size rather than hard-coded 4x4
;;
;; edits made by Mitchell Marquez <dr.m.perseos@gmail.com> on 2023-01-11
(defvar 2048--cell-width 6
"Width of number cells for 2048. Should be at least 4 to fit \"2048\".")
(defvar 2048--board-size 4
"Number of tiles on the board for 2048. 4 is the default.")
(defvar 2048--vertical-sep-char ?│
"Character to use as a vertical border for 2048 cells.")
(defvar 2048--horizontal-sep-char ?─
"Character to use as a horizontal border for 2048 cells.")
(defvar 2048--corner-sep-char ?+
"Character to use as the intersection between `2048--vertical-sep-char'
and `2048--horizontal-sep-char'.")
(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)
(setq 2048-plus-sep (2048--make-sep-times
2048--corner-sep-char 2048--horizontal-sep-char
;; ?╬ ?─ ; needlessly fancy version
2048--board-size 2048--cell-width))
(setq 2048-space-sep (2048--make-sep-times
2048--vertical-sep-char (string-to-char " ")
2048--board-size 2048--cell-width))
(defun 2048--pad (number)
(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)
)