emacs/lisp/2048.el

389 lines
13 KiB
EmacsLisp

;;; 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 2O48 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 '2O48)
(defcustom 2048--vertical-sep-char ?│ ; 9478
"Character to use as a vertical border for 2048 cells."
:type 'character
:group '2O48)
(defcustom 2048--horizontal-sep-char ?─ ; 9472
"Character to use as a horizontal border for 2048 cells."
:type 'character
:group '2O48)
(defcustom 2048--corner-sep-char ?+
;; ?╬ ; needlessly fancy version
"Intersection of `2048--vertical-sep-char'and `2048--horizontal-sep-char'."
:type 'character
:group '2O48)
(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--scroll-left (&optional arg set-minmum)
(interactive) (2048-shift-left))
(defun 2048--scroll-right (&optional arg set-minmum)
(interactive) (2048-shift-right))
(defun 2048--scroll-up (&optional arg set-minmum)
(interactive) (2048-shift-up))
(defun 2048--scroll-down (&optional arg set-minmum)
(interactive) (2048-shift-down))
(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
;; Arrow keys
(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)
;; Vim keys
(local-set-key (kbd "h") '2048-shift-left)
(local-set-key (kbd "l") '2048-shift-right)
(local-set-key (kbd "j") '2048-shift-down)
(local-set-key (kbd "k") '2048-shift-up)
;; Swipe controls for termux
(setq-local mwheel-scroll-left-function '2048--scroll-left)
(setq-local mwheel-scroll-right-function '2048--scroll-right)
(setq-local mwheel-scroll-down-function '2048--scroll-down)
(setq-local mwheel-scroll-up-function '2048--scroll-up)
(2048-startup)
(setq font-lock-defaults '(2048-highlights)))
(defun play-2048 ()
"Play 2048 in Emacs!"
(interactive)
(switch-to-buffer (get-buffer-create "*2048*"))
(2048-mode))
(provide '2O48)
;;; 2048.el ends here