202 lines
6.9 KiB
Common Lisp
202 lines
6.9 KiB
Common Lisp
(ql:quickload '(cffi alexandria))
|
|
|
|
(defpackage :2048-lisp
|
|
(:use :common-lisp :cffi :alexandria))
|
|
|
|
(in-package :2048-lisp)
|
|
|
|
(defvar *lib-loaded* nil)
|
|
|
|
(unless *lib-loaded*
|
|
;; Load msvcrt.dll to access _getch.
|
|
(define-foreign-library msvcrt
|
|
(:windows (:default "msvcrt")))
|
|
|
|
(use-foreign-library msvcrt)
|
|
|
|
(defcfun "_getch" :int)
|
|
|
|
(setf *lib-loaded* t))
|
|
|
|
(defun read-arrow ()
|
|
"Get an arrow key from input as UP, DOWN, LEFT, or RIGHT, otherwise
|
|
return a char of whatever was pressed."
|
|
(let ((first-char (-getch)))
|
|
(if (= 224 first-char)
|
|
(case (-getch)
|
|
(75 'left)
|
|
(80 'down)
|
|
(77 'right)
|
|
(72 'up))
|
|
(code-char first-char))))
|
|
|
|
(defmacro swap (place1 place2)
|
|
"Exchange the values of two places."
|
|
(let ((temp (gensym "TEMP")))
|
|
`(cl:let ((,temp ,place1))
|
|
(cl:setf ,place1 ,place2)
|
|
(cl:setf ,place2 ,temp))))
|
|
|
|
(defun nflip (board &optional (left-right t))
|
|
"Flip the elements of a BOARD left and right or optionally up and down."
|
|
(let* ((y-len (array-dimension board 0))
|
|
(x-len (array-dimension board 1))
|
|
(y-max (if left-right y-len (truncate y-len 2)))
|
|
(x-max (if left-right (truncate x-len 2) x-len)))
|
|
(loop for y from 0 below y-max
|
|
for y-place = (- y-len 1 y) do
|
|
(loop for x from 0 below x-max
|
|
for x-place = (- x-len 1 x) do
|
|
(if left-right
|
|
(swap (aref board y x) (aref board y x-place))
|
|
(swap (aref board y x) (aref board y-place x)))))
|
|
board))
|
|
|
|
(defun flip (board &optional (left-right t))
|
|
"Flip the elements of a BOARD left and right or optionally up and down.
|
|
Non-destructive version."
|
|
(nflip (copy-array board) left-right))
|
|
|
|
(defun transpose (board)
|
|
"Transpose the elements of BOARD into a new array."
|
|
(let* ((y-len (array-dimension board 0))
|
|
(x-len (array-dimension board 1))
|
|
(new-board (make-array (reverse (array-dimensions board)))))
|
|
(loop for y from 0 below y-len do
|
|
(loop for x from 0 below x-len do
|
|
(setf (aref new-board x y) (aref board y x))))
|
|
new-board))
|
|
|
|
(defun add-random-piece (board)
|
|
"Find a random empty spot on the BOARD to add a new piece.
|
|
Return T if successful, NIL otherwise."
|
|
(loop
|
|
for x from 0 below (array-total-size board)
|
|
unless (row-major-aref board x)
|
|
count 1 into count
|
|
and collect x into indices
|
|
finally
|
|
(unless (= 0 count)
|
|
(setf (row-major-aref board (nth (random count) indices))
|
|
(if (= 0 (random 10)) 4 2))
|
|
(return t))))
|
|
|
|
(defun squash-line (line)
|
|
"Reduce a sequence of numbers from left to right according to
|
|
the rules of 2048. Return the score of squashing as well."
|
|
(let* ((squashed
|
|
(reduce
|
|
(lambda (acc x)
|
|
(if (equal x (car acc))
|
|
(cons (list (* 2 x)) (cdr acc))
|
|
(cons x acc)))
|
|
(nreverse (remove-if #'null line))
|
|
:initial-value nil))
|
|
(new-line (flatten squashed)))
|
|
(list (append (make-list (- (length line) (length new-line))) new-line)
|
|
(reduce #'+ (flatten (remove-if-not #'listp squashed))))))
|
|
|
|
(defun squash-board (board)
|
|
"Reduce each row of a board from left to right according to
|
|
the rules of 2048. Return the total score of squashing the board as well."
|
|
(let ((y-len (array-dimension board 0))
|
|
(x-len (array-dimension board 1))
|
|
(total 0))
|
|
(list (make-array (array-dimensions board) :initial-contents
|
|
(loop for y from 0 below y-len
|
|
for (line score) =
|
|
(squash-line
|
|
(make-array x-len
|
|
:displaced-to board
|
|
:displaced-index-offset
|
|
(array-row-major-index board y 0)))
|
|
collect line
|
|
do (incf total score)))
|
|
total)))
|
|
|
|
(defun make-move (board direction)
|
|
"Make a move in the given DIRECTION on a new board."
|
|
;; Move by always squashing right, but transforming the board as needed.
|
|
(destructuring-bind (new-board score)
|
|
(case direction
|
|
(up (squash-board (flip (transpose board))))
|
|
(down (squash-board (flip (transpose board) nil)))
|
|
(left (squash-board (nflip (flip board nil))))
|
|
(right (squash-board board)))
|
|
(let ((new-board
|
|
;; Reverse the transformation.
|
|
(case direction
|
|
(up (transpose (nflip new-board)))
|
|
(down (transpose (nflip new-board nil)))
|
|
(left (nflip (nflip new-board nil)))
|
|
(right new-board))))
|
|
(unless (equalp board new-board)
|
|
(add-random-piece new-board)
|
|
(list new-board score)))))
|
|
|
|
(defun winp (board winning-tile)
|
|
"Determine if a BOARD is in a winning state."
|
|
(loop for x from 0 below (array-total-size board)
|
|
for val = (row-major-aref board x)
|
|
when (eql val winning-tile) do (return t)))
|
|
|
|
(defun game-overp (board)
|
|
"Determine if a BOARD is in a game over state."
|
|
;; If a move is simulated in every direction and nothing changes,
|
|
;; then we can assume there are no valid moves left.
|
|
(notany (lambda (dir) (car (make-move board dir)))
|
|
'(up down left right)))
|
|
|
|
(defun print-divider (cells cell-size)
|
|
"A print helper function for PRINT-BOARD."
|
|
(dotimes (_ cells)
|
|
(princ "+")
|
|
(dotimes (_ cell-size)
|
|
(princ "-")))
|
|
(princ "+")
|
|
(terpri))
|
|
|
|
(defun print-board (board cell-size)
|
|
"Pretty print the given BOARD with a particular CELL-SIZE."
|
|
(let* ((y-len (array-dimension board 0))
|
|
(x-len (array-dimension board 1))
|
|
(super-size (+ 2 cell-size)))
|
|
(loop for y from 0 below y-len do
|
|
(print-divider x-len super-size)
|
|
(loop for x from 0 below x-len
|
|
for val = (aref board y x)
|
|
do
|
|
(princ "|")
|
|
(if val
|
|
(format t " ~VD " cell-size val)
|
|
(dotimes (_ super-size) (princ " "))))
|
|
(princ "|")
|
|
(terpri))
|
|
(print-divider x-len super-size)))
|
|
|
|
(defun init-board ()
|
|
(let ((board (make-array '(4 4) :initial-element nil)))
|
|
(setf (row-major-aref board (random (array-total-size board))) 2)
|
|
board))
|
|
|
|
(defun prompt-input (board score &optional (check t))
|
|
(cond
|
|
((and check (winp board 2048)) (format t "You win!"))
|
|
((and check (game-overp board)) (format t "Game over..."))
|
|
(t (let ((choice (read-arrow)))
|
|
(cond
|
|
((symbolp choice)
|
|
(destructuring-bind (&optional move (new-score 0))
|
|
(make-move board choice)
|
|
(if move
|
|
(prompt move (+ score new-score))
|
|
(prompt-input board score))))
|
|
((find choice "qQ")
|
|
(format t "Quitting."))
|
|
(t (prompt-input board score nil)))))))
|
|
|
|
(defun prompt (&optional (board (init-board)) (score 0))
|
|
(format t "~% Score: ~D~%" score)
|
|
(print-board board 4)
|
|
(prompt-input board score))
|