--- a/package.lisp Thu Dec 15 18:53:10 2016 -0500
+++ b/package.lisp Fri Dec 16 21:59:36 2016 -0500
@@ -301,3 +301,12 @@
:iterate
:sand.quickutils
:sand.utils))
+
+(defpackage :sand.turing-omnibus.minimax
+ (:use
+ :cl
+ :losh
+ :iterate
+ :cl-arrows
+ :sand.quickutils
+ :sand.utils))
--- a/sand.asd Thu Dec 15 18:53:10 2016 -0500
+++ b/sand.asd Fri Dec 16 21:59:36 2016 -0500
@@ -73,4 +73,5 @@
(:module "turing-omnibus"
:serial t
:components ((:file "wallpaper")
- (:file "monte-carlo")))))))
+ (:file "monte-carlo")
+ (:file "minimax")))))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/turing-omnibus/minimax.lisp Fri Dec 16 21:59:36 2016 -0500
@@ -0,0 +1,146 @@
+(in-package :sand.turing-omnibus.minimax)
+
+(declaim (optimize (safety 1) (debug 3) (speed 3)))
+(declaim (optimize (safety 0) (debug 0) (speed 3)))
+
+
+;;;; API ----------------------------------------------------------------------
+(defgeneric initial-state (game)
+ (:documentation "Return the initial state of the game."))
+
+(defgeneric successor-states (game state)
+ (:documentation "Return the successor states of the game."))
+
+(defgeneric evaluate-state (game state role)
+ (:documentation "Return the value of `state` for `role`."))
+
+(defgeneric control (game state)
+ (:documentation "Return the role in control at the given `state`."))
+
+
+(defun minimax (game role)
+ (recursively ((path (list (initial-state game))))
+ (let* ((state (car path))
+ (control (control game state))
+ (successors (successor-states game state)))
+ (if (null successors)
+ (cons (evaluate-state game state role) path)
+ (iterate (for successor :in successors)
+ (for next = (recur (cons successor path)))
+ (finding next maximizing #'car :into max)
+ (finding next minimizing #'car :into min)
+ (finally (return (if (eql role control) max min))))
+ #+more-consing (extremum (-<> successors
+ (mapcar (rcurry #'cons path) <>)
+ (mapcar #'recur <>))
+ (if (eql role control) #'> #'<)
+ :key #'car)))))
+
+
+;;;; Tic Tac Toe --------------------------------------------------------------
+(defstruct (tic-tac-toe-state (:conc-name ttts-))
+ board control)
+
+(define-with-macro (tic-tac-toe-state :conc-name ttts)
+ board control)
+
+
+(defmethod initial-state ((game (eql 'tic-tac-toe)))
+ (make-tic-tac-toe-state
+ :board #2A((nil nil nil)
+ (nil nil nil)
+ (nil nil nil))
+ :control 'x))
+
+
+(defun ttt-all-role-p (board role indexes)
+ (every (lambda (index)
+ (eql role (apply #'aref board index)))
+ indexes))
+
+(defun ttt-line-p (board role)
+ (or (ttt-all-role-p board role '((0 0) (0 1) (0 2))) ; horizontal
+ (ttt-all-role-p board role '((1 0) (1 1) (1 2)))
+ (ttt-all-role-p board role '((2 0) (2 1) (2 2)))
+ (ttt-all-role-p board role '((0 0) (1 0) (2 0))) ; vertical
+ (ttt-all-role-p board role '((0 1) (1 1) (2 1)))
+ (ttt-all-role-p board role '((0 2) (1 2) (2 2)))
+ (ttt-all-role-p board role '((0 0) (1 1) (2 2))) ; diagonals
+ (ttt-all-role-p board role '((2 0) (1 1) (0 2)))))
+
+(defun ttt-other-role (role)
+ (ecase role
+ (x 'o)
+ (o 'x)))
+
+
+(defmethod evaluate-state ((game (eql 'tic-tac-toe)) state role)
+ (cond
+ ((ttt-line-p (ttts-board state) role) 1)
+ ((ttt-line-p (ttts-board state) (ttt-other-role role)) -1)
+ (t 0)))
+
+(defmethod successor-states ((game (eql 'tic-tac-toe)) state)
+ (with-tic-tac-toe-state (state)
+ (iterate
+ (with other-role = (ttt-other-role control))
+ (for (mark x y) :in-array board)
+ (when (null mark)
+ (let ((new-board (copy-array board)))
+ (setf (aref new-board x y) control)
+ (collect (make-tic-tac-toe-state :board new-board :control other-role)))))))
+
+(defmethod control ((game (eql 'tic-tac-toe)) state)
+ (ttts-control state))
+
+
+;;;; Nim -----------------------------------------------------------------------
+(defstruct (nim-state (:conc-name ns-))
+ piles control)
+
+(define-with-macro (nim-state :conc-name ns)
+ piles control)
+
+(defun nim-other-role (role)
+ (ecase role
+ (x 'o)
+ (o 'x)))
+
+
+(defmethod initial-state ((game (eql 'nim)))
+ (make-nim-state
+ :piles #(4 3 2 2)
+ :control 'x))
+
+(defmethod evaluate-state ((game (eql 'nim)) state role)
+ (with-nim-state (state)
+ (if (every #'zerop piles)
+ (if (eql role control)
+ 1
+ -1)
+ 0)))
+
+
+(defun take-from-pile (piles index amount)
+ (let ((piles (copy-array piles)))
+ ; (declare (type (simple-array fixnum (*)) piles)
+ ; (type fixnum index amount))
+ (decf (aref piles index) amount)
+ piles))
+
+
+(defmethod successor-states ((game (eql 'nim)) state)
+ (with-nim-state (state)
+ (iterate
+ (with other-role = (nim-other-role control))
+ (for (pile i) :in-array piles)
+ (appending (iterate
+ (for take :from 1 :to pile)
+ (collect (make-nim-state :piles (take-from-pile piles i take)
+ :control other-role)))))))
+
+(defmethod control ((game (eql 'nim)) state)
+ (ns-control state))
+
+; (start-profiling)
+; (stop-profiling)
--- a/vendor/make-quickutils.lisp Thu Dec 15 18:53:10 2016 -0500
+++ b/vendor/make-quickutils.lisp Fri Dec 16 21:59:36 2016 -0500
@@ -5,10 +5,12 @@
:utilities '(
:compose
+ :copy-array
:curry
:define-constant
:ensure-gethash
:ensure-list
+ :extremum
:hash-table-alist
:hash-table-keys
:hash-table-plist
--- a/vendor/quickutils.lisp Thu Dec 15 18:53:10 2016 -0500
+++ b/vendor/quickutils.lisp Fri Dec 16 21:59:36 2016 -0500
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :DEFINE-CONSTANT :ENSURE-GETHASH :ENSURE-LIST :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-PLIST :HASH-TABLE-VALUES :IOTA :N-GRAMS :ONCE-ONLY :RANGE :RCURRY :READ-FILE-INTO-STRING :REQUIRED-ARGUMENT :RIFFLE :SUBDIVIDE :SYMB :TREE-COLLECT :WITH-GENSYMS) :ensure-package T :package "SAND.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-ARRAY :CURRY :DEFINE-CONSTANT :ENSURE-GETHASH :ENSURE-LIST :EXTREMUM :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-PLIST :HASH-TABLE-VALUES :IOTA :N-GRAMS :ONCE-ONLY :RANGE :RCURRY :READ-FILE-INTO-STRING :REQUIRED-ARGUMENT :RIFFLE :SUBDIVIDE :SYMB :TREE-COLLECT :WITH-GENSYMS) :ensure-package T :package "SAND.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "SAND.QUICKUTILS")
@@ -14,8 +14,9 @@
(when (boundp '*utilities*)
(setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
- :COMPOSE :CURRY :DEFINE-CONSTANT
- :ENSURE-GETHASH :ENSURE-LIST
+ :COMPOSE :COPY-ARRAY :CURRY
+ :DEFINE-CONSTANT :ENSURE-GETHASH
+ :ENSURE-LIST :EXTREMUM
:HASH-TABLE-ALIST :MAPHASH-KEYS
:HASH-TABLE-KEYS :HASH-TABLE-PLIST
:MAPHASH-VALUES :HASH-TABLE-VALUES
@@ -79,6 +80,24 @@
,(compose-1 funs))))))
+ (defun copy-array (array &key (element-type (array-element-type array))
+ (fill-pointer (and (array-has-fill-pointer-p array)
+ (fill-pointer array)))
+ (adjustable (adjustable-array-p array)))
+ "Returns an undisplaced copy of `array`, with same `fill-pointer` and
+adjustability (if any) as the original, unless overridden by the keyword
+arguments."
+ (let* ((dimensions (array-dimensions array))
+ (new-array (make-array dimensions
+ :element-type element-type
+ :adjustable adjustable
+ :fill-pointer fill-pointer)))
+ (dotimes (i (array-total-size array))
+ (setf (row-major-aref new-array i)
+ (row-major-aref array i)))
+ new-array))
+
+
(defun curry (function &rest arguments)
"Returns a function that applies `arguments` and the arguments
it is called with to `function`."
@@ -153,6 +172,50 @@
(list list)))
+ (defun extremum (sequence predicate &key key (start 0) end)
+ "Returns the element of `sequence` that would appear first if the subsequence
+bounded by `start` and `end` was sorted using `predicate` and `key`.
+
+`extremum` determines the relationship between two elements of `sequence` by using
+the `predicate` function. `predicate` should return true if and only if the first
+argument is strictly less than the second one (in some appropriate sense). Two
+arguments `x` and `y` are considered to be equal if `(funcall predicate x y)`
+and `(funcall predicate y x)` are both false.
+
+The arguments to the `predicate` function are computed from elements of `sequence`
+using the `key` function, if supplied. If `key` is not supplied or is `nil`, the
+sequence element itself is used.
+
+If `sequence` is empty, `nil` is returned."
+ (let* ((pred-fun (ensure-function predicate))
+ (key-fun (unless (or (not key) (eq key 'identity) (eq key #'identity))
+ (ensure-function key)))
+ (real-end (or end (length sequence))))
+ (cond ((> real-end start)
+ (if key-fun
+ (flet ((reduce-keys (a b)
+ (if (funcall pred-fun
+ (funcall key-fun a)
+ (funcall key-fun b))
+ a
+ b)))
+ (declare (dynamic-extent #'reduce-keys))
+ (reduce #'reduce-keys sequence :start start :end real-end))
+ (flet ((reduce-elts (a b)
+ (if (funcall pred-fun a b)
+ a
+ b)))
+ (declare (dynamic-extent #'reduce-elts))
+ (reduce #'reduce-elts sequence :start start :end real-end))))
+ ((= real-end start)
+ nil)
+ (t
+ (error "Invalid bounding indexes for sequence of length ~S: ~S ~S, ~S ~S"
+ (length sequence)
+ :start start
+ :end end)))))
+
+
(defun hash-table-alist (table)
"Returns an association list containing the keys and values of hash table
`table`."
@@ -474,10 +537,10 @@
`(with-gensyms ,names ,@forms))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(compose curry define-constant ensure-gethash ensure-list
- hash-table-alist hash-table-keys hash-table-plist hash-table-values
- iota n-grams once-only range rcurry read-file-into-string
- required-argument riffle subdivide symb tree-collect with-gensyms
- with-unique-names)))
+ (export '(compose copy-array curry define-constant ensure-gethash ensure-list
+ extremum hash-table-alist hash-table-keys hash-table-plist
+ hash-table-values iota n-grams once-only range rcurry
+ read-file-into-string required-argument riffle subdivide symb
+ tree-collect with-gensyms with-unique-names)))
;;;; END OF quickutils.lisp ;;;;