A REPL-friendly implementation of Tactics.

018-solving-tactics.lisp

(defpackage #:snippets/rubyquiz/018-solving-tactics
  (:documentation
   "A REPL-friendly implementation of Tactics.

Some day I need to actually solve the RubyQuiz task, but that day is
not today.")
  (:use #:cl)
  (:shadow #:ed #:fill)
  (:import-from #:alexandria
                #:xor
                #:random-elt)
  (:export
   #:new-game
   #:fill
   #:grid
   #:winner
   #:loser
   #:human
   #:random-square
   #:pass-play))

(in-package #:snippets/rubyquiz/018-solving-tactics)

;; There is a little pencil and paper game, Tactics, played on a 4x4
;; grid.

(defclass grid ()
  ((array :initarg :array :accessor grid-array)
   (squares-filled :initform 0)
   (player :initform 0)
   (players :initarg :players)))

;; The play starts with an empty grid.

(defun make-grid ()
  (make-instance 'grid
                 :array (make-array '(4 4)
                                    :initial-element nil)))

(defvar *grid*
  (make-grid))

(defmacro define-repl-friendly-slot-accessor (name slot-name object-name object-default-form)
  `(progn
     (defun ,name (&optional (,object-name ,object-default-form))
       (slot-value ,object-name ',slot-name))
     (defun (setf ,name) (new-value &optional (,object-name ,object-default-form))
       (setf (slot-value ,object-name ',slot-name) new-value))
     ',name))

(defmacro define-grid-slot-accessor (name &optional (slot-name name))
  `(define-repl-friendly-slot-accessor ,name ,slot-name grid *grid*))

(define-grid-slot-accessor squares-filled)
(define-grid-slot-accessor player)
(define-grid-slot-accessor players)

(defun copy-grid (source target)
  (copy-grid-array (grid-array source)
                   (grid-array target))
  (setf (squares-filled target)
        (squares-filled source))
  (setf (player target)
        (player source))
  (setf (players target)
        (copy-seq (players source))))

(defun copy-grid-array (source target)
  (dotimes (r 4)
    (dotimes (c 4)
      (setf (aref target r c)
            (aref source r c)))))

(defun clone (&optional (grid *grid*))
  (let ((copy (make-grid)))
    (copy-grid grid copy)
    copy))

(defun ensure-player (player)
  (if (symbolp player)
      (make-instance player)
      player))

(define-modify-macro ensure-playerf () ensure-player)

(defclass player ()
  ())

(defgeneric choose-move (player grid))

(defclass human (player)
  ())

(defmethod choose-move ((player human) (grid grid))
  nil)

(defun new-game (&key (first-player 'human)
                      (second-player 'human)
                      (grid *grid*))
  (ensure-playerf first-player)
  (ensure-playerf second-player)
  (setf (players grid)
        (vector first-player second-player))
  (setf (player grid) 0)
  (fill-all nil grid)
  (new-move grid))

(defun fill-all (value &optional (grid *grid*))
  (dotimes (r 4)
    (dotimes (c 4)
      (fill-one value r c grid)))
  grid)

(defun new-move (&optional (grid *grid*))
  (unless (all-filled-p grid)
    (let ((player (aref (players grid) (player grid))))
      (let ((move (choose-move player grid)))
        (when move
          (destructuring-bind (r-start c-start r-end c-end) move
            (fill-generic t r-start c-start r-end c-end grid))))))
  grid)

;; On each turn, a player can fill in one to four adjacent squares,
;; either horizontally or vertically.

(defun fill (from to &optional (grid *grid*))
  (let ((copy (clone)))
    (handler-bind ((error (lambda (condition)
                            (copy-grid copy grid))))
      (multiple-value-bind (r-start c-start) (coord from)
        (multiple-value-bind (r-end c-end) (coord to)
          (fill-generic t r-start c-start r-end c-end grid))))))

(defmacro define-grid-positions ()
  (let ((position-symbols '())
        (position-symbols-alias '())
        (position-coords '()))
    (loop for r in '(a b c d)
          for ri upfrom 0
          do (loop for c in '(e f g h)
                   for ci upfrom 0
                   do (let ((symbol (intern (format nil "~A~A" r c)))
                            (alias (intern (format nil "~A~A" c r))))
                        (push symbol position-symbols)
                        (push alias position-symbols-alias)
                        (push (list ri ci) position-coords))))
    `(progn
       ,@(loop for symbol in (append position-symbols position-symbols-alias)
               collect `(defconstant ,symbol ',symbol))
       (defun coord (pos)
         (ecase pos
           ,@(loop for symbol in (append position-symbols position-symbols-alias)
                   for coord in (append position-coords position-coords)
                   collect `(,symbol (values ,@coord)))))
       (defun square-name (r c)
         (cond ,@(loop for symbol in position-symbols
                       for (ri ci) in position-coords
                       collect `((and (= r ,ri) (= c ,ci))
                                 ,symbol))))
       (export '(,@position-symbols ,@position-symbols-alias))
       'ok)))

(define-grid-positions)

(defun fill-generic (value r-start c-start r-end c-end &optional (grid *grid*))
  (let ((h-eq (= r-start r-end))
        (v-eq (= c-start c-end)))
    (cond (h-eq
           (fill-vertical value r-start c-start c-end grid))
          (v-eq
           (fill-horizontal value c-start r-start r-end grid))
          (t
           (error "Only horizontal or vertical fills are supported.")))
    (setf (player grid) (logxor (player grid) 1))
    (new-move grid))
  grid)

(defun fill-vertical (value r c-start c-end &optional (grid *grid*))
  (when (> c-start c-end)
    (rotatef c-start c-end))
  (do ((c c-start (1+ c)))
      ((> c c-end) grid)
    (fill-one value r c grid)))

(defun fill-horizontal (value c r-start r-end &optional (grid *grid*))
  (when (> r-start r-end)
    (rotatef r-start r-end))
  (do ((r r-start (1+ r)))
      ((> r r-end) grid)
    (fill-one value r c grid)))

(defun fill-one (value r c &optional (grid *grid*))
  (let ((previous-value (aref (grid-array grid) r c)))
    (setf (aref (grid-array grid) r c) value)
    (cond ((xor value previous-value)
           (incf (squares-filled grid)
                 (if value +1 -1)))
          ((and value previous-value)
           (error "Square ~A is already filled." (square-name r c))))
    grid))

(defun print-grid (&optional (stream *standard-output*) (grid *grid*))
  (format stream "  E F G H  P~D~:[~; WINS~]~%"
          (1+ (player grid))
          (all-filled-p grid))
  (loop for r in '(a b c d)
        for ri upfrom 0
        do (format stream "~A " r)
        do (loop repeat 4
                 for ci upfrom 0
                 do (format stream "~C "
                            (if (aref (grid-array grid) ri ci) #\* #\.)))
        do (terpri stream)))

(set-pprint-dispatch 'grid 'print-grid)

(define-symbol-macro grid *grid*)

;; The player who fills in the last square loses.

(defun all-filled-p (&optional (grid *grid*))
  (= (squares-filled grid) 16))

(defun winner (&optional (grid *grid*))
  (when (all-filled-p grid)
    (aref (players grid) (player grid))))

(defun loser (&optional (grid *grid*))
  (when (all-filled-p grid)
    (aref (players grid)
          (logxor (player grid) 1))))

(defclass random-square (player grid)
  ()
  (:documentation
   "Always choosing a single random square."))

(defmethod choose-move ((player random-square) (grid grid))
  (let ((candidates '()))
    (dotimes (r 4)
      (dotimes (c 4)
        (when (emptyp r c grid)
          (push (list r c r c) candidates))))
    (random-elt candidates)))

(defun emptyp (r c &optional (grid *grid*))
  (null (aref (grid-array grid) r c)))

(defun pass-play (player &optional (grid *grid*))
  (ensure-playerf player)
  (setf (aref (players grid) (player grid)) player)
  (new-move grid))