Rock-Paper-Scissors Game

rps-grid.el

;;; Commentary:

;; * r -- rock
;; * p -- paper
;; * s -- scissors
;; * e -- empty

;; References:
;; * http://games.thomashunter.name/tictactoe/
;; * http://www.reddit.com/r/gamedev/comments/10smgz/

;;; Code:

(require 'cl)

;; Grid functions

(defun* make-grid (&optional (size 3) (fill 'e))
  (make-vector (* size size) fill))

(defun copy-grid (grid)
  (copy-seq grid))

(defun grid-size (grid)
  (floor (sqrt (length grid))))

(defun grid-get (grid x y)
  (aref grid (+ x (* y (grid-size grid)))))

(defsetf grid-get (grid x y) (store)
  `(aset ,grid (+ ,x (* ,y (grid-size ,grid))) ,store))

(defun grid-set (grid x y value)
  (let ((new (copy-grid grid)))
    (setf (grid-get new x y) value)
    new))

(defun grid-eq (grid x y value)
  (let ((size (grid-size grid)))
    (and (>= x 0) (>= y 0) (< x size) (< y size)
         (eq (grid-get grid x y) value))))

(defun grid-princ (grid)
  (let ((size (grid-size grid)))
    (dotimes (y size)
      (dotimes (x size)
        (princ (grid-get grid x y)))
      (terpri))))

(defun grid-empty-p (grid)
  (let ((size (grid-size grid)))
    (block top
      (dotimes (y size t)
        (dotimes (x size)
          (unless (grid-eq grid x y 'e) (return-from top nil)))))))

(defun grid-full-p (grid)
  (let ((size (grid-size grid)))
    (block top
      (dotimes (y size t)
        (dotimes (x size)
          (when (grid-eq grid x y 'e) (return-from top nil)))))))

;; RPS functions

(defun rps-beats (symbol)
  "Return the symbol this symbol beats in rock-paper-scissors."
  (cadr (member symbol '#1=(s p r . #1#))))

;; Generation functions

(defun reverse-grid (grid)
  "Return a list of previous game states for this grid."
  (let ((size (grid-size grid))
        (next ()))
    (dotimes (y size next)
      (dotimes (x size)
        (unless (grid-eq grid x y 'e)
          (dolist (p '((-1 . 0) (1 . 0) (0 . -1) (0 . 1)))
            (when (grid-eq grid (+ x (car p)) (+ y (cdr p)) 'e)
              (let ((this (grid-get grid x y))
                    (new (copy-grid grid)))
                (setf (grid-get new x y) (rps-beats this))
                (setf (grid-get new (+ x (car p)) (+ y (cdr p))) this)
                (push new next)))))))))

(defun* gen-end-states (&optional (size 3))
  "Generate a list of all possible win grids."
  (let ((ends ())
        (empty (make-grid size)))
    (dotimes (y size ends)
      (dotimes (x size)
        (dolist (symbol '(r p s))
          (push (grid-set empty x y symbol) ends))))))

(defun realize (grid)
  "Return all the possible start states for the given grid."
  (if (grid-full-p grid)
      (list grid)
    (mapcan #'realize (reverse-grid grid))))

(defun* gen-solvable (file &optional (size 3))
  "Generate all solvable start states and store the output in FILE."
  (let ((m (make-hash-table :test #'equal))
        (cull ()))
    (dolist (grid (mapcan #'realize (gen-end-states size)))
      (puthash grid t m))
    (maphash (lambda (k v) (push k cull)) m)
    (with-temp-file file
      (let ((standard-output (current-buffer)))
        (princ (format "Count: %d\n\n" (length cull)))
        (dolist (grid cull)
          (grid-princ grid)
          (terpri))))
    (length cull)))

;(gen-solvable "/tmp/list4.txt" 4)
;(mapatoms 'byte-compile)

rps-grid.lisp

;;; Commentary:

;; * r -- rock
;; * p -- paper
;; * s -- scissors
;; * e -- empty

;; References:
;; * http://games.thomashunter.name/tictactoe/
;; * http://www.reddit.com/r/gamedev/comments/10smgz/

(defpackage :rps-grid
  (:use :common-lisp)
  (:export :gen-solvable))

(in-package :rps-grid)

;; Grid functions

(defun make-grid (&optional (size 3) (fill 'e))
  (make-array (* size size) :initial-element fill))

(defun copy-grid (grid)
  (copy-seq grid))

(defun grid-size (grid)
  (floor (sqrt (length grid))))

(defun grid-get (grid x y)
  (aref grid (+ x (* y (grid-size grid)))))

(defsetf grid-get (grid x y) (store)
  `(setf (aref,grid (+ ,x (* ,y (grid-size ,grid)))) ,store))

(defun grid-set (grid x y value)
  (let ((new (copy-grid grid)))
    (setf (grid-get new x y) value)
    new))

(defun grid-eq (grid x y value)
  (let ((size (grid-size grid)))
    (and (>= x 0) (>= y 0) (< x size) (< y size)
         (eq (grid-get grid x y) value))))

(defun grid-princ (grid)
  (let ((size (grid-size grid)))
    (dotimes (y size)
      (dotimes (x size)
        (princ (grid-get grid x y)))
      (terpri))))

(defun grid-full-p (grid)
  (let ((size (grid-size grid)))
    (block top
      (dotimes (y size t)
        (dotimes (x size)
          (when (grid-eq grid x y 'e) (return-from top nil)))))))

;; RPS functions

(defun rps-beats (symbol)
  "Return the symbol this symbol beats in rock-paper-scissors."
  (cadr (member symbol '#1=(s p r . #1#))))

;; Generation functions

(defun reverse-grid (grid)
  "Return a list of previous game states for this grid."
  (let ((size (grid-size grid))
        (next ()))
    (dotimes (y size next)
      (dotimes (x size)
        (unless (grid-eq grid x y 'e)
          (dolist (p '((-1 . 0) (1 . 0) (0 . -1) (0 . 1)))
            (when (grid-eq grid (+ x (car p)) (+ y (cdr p)) 'e)
              (let ((this (grid-get grid x y))
                    (new (copy-grid grid)))
                (setf (grid-get new x y) (rps-beats this))
                (setf (grid-get new (+ x (car p)) (+ y (cdr p))) this)
                (push new next)))))))))

(defun gen-end-states (&optional (size 3))
  "Generate a list of all possible win grids."
  (let ((ends ())
        (empty (make-grid size)))
    (dotimes (y size ends)
      (dotimes (x size)
        (dolist (symbol '(r p s))
          (push (grid-set empty x y symbol) ends))))))

(defun realize (grid)
  "Return all the possible start states for the given grid."
  (if (grid-full-p grid)
      (list grid)
    (mapcan #'realize (reverse-grid grid))))

(defun gen-solvable (file &optional (size 3))
  "Generate all solvable start states and store the output in FILE."
  (let ((m (make-hash-table :test #'equalp))
        (cull ()))
    (dolist (grid (mapcan #'realize (gen-end-states size)))
      (setf (gethash grid m) t))
    (maphash (lambda (k v) (declare (ignore v)) (push k cull)) m)
    (with-open-stream (*standard-output* (open file :direction :output
                                               :if-exists :supersede))
      (format t "Count: ~:d~%~%" (length cull))
      (dolist (grid cull)
        (grid-princ grid)
        (terpri)))
    (length cull)))

;(gen-solvable "/tmp/list4.txt" 4)
;(mapatoms 'byte-compile)