# HG changeset patch # User Steve Losh # Date 1481943576 18000 # Node ID 742629b88c9133e17c2365d8d631c4aca6b2e986 # Parent de58fc1af1e59794039f4e33f2987317fb100cdc Add TNTO minimaxing diff -r de58fc1af1e5 -r 742629b88c91 package.lisp --- 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)) diff -r de58fc1af1e5 -r 742629b88c91 sand.asd --- 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"))))))) diff -r de58fc1af1e5 -r 742629b88c91 src/turing-omnibus/minimax.lisp --- /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) diff -r de58fc1af1e5 -r 742629b88c91 vendor/make-quickutils.lisp --- 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 diff -r de58fc1af1e5 -r 742629b88c91 vendor/quickutils.lisp --- 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 ;;;;