--- a/package.lisp Wed Sep 14 16:12:55 2016 +0000
+++ b/package.lisp Fri Sep 16 14:01:40 2016 +0000
@@ -13,7 +13,10 @@
#:initial-state
#:terminalp
#:next-state
- #:legal-moves-for))
+ #:legal-moves-for
+ #:percepts-for
+ #:roles
+ ))
(defpackage #:scully.players.random
(:use
@@ -25,3 +28,14 @@
#:scully.reasoners.prolog)
(:export
))
+
+(defpackage #:scully.players.random-ii
+ (:use
+ #:cl
+ #:losh
+ #:iterate
+ #:cl-arrows
+ #:scully.quickutils
+ #:scully.reasoners.prolog)
+ (:export
+ ))
--- a/scully.asd Wed Sep 14 16:12:55 2016 +0000
+++ b/scully.asd Fri Sep 16 14:01:40 2016 +0000
@@ -23,5 +23,6 @@
:components ((:module "reasoners" :serial t
:components ((:file "prolog")))
(:module "players" :serial t
- :components ((:file "random")))))))
+ :components ((:file "random")
+ (:file "random-ii")))))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/players/random-ii.lisp Fri Sep 16 14:01:40 2016 +0000
@@ -0,0 +1,84 @@
+(in-package #:scully.players.random-ii)
+
+
+;;;; Random Incomplete-Information Player -------------------------------------
+(defclass random-ii-player (ggp:ggp-player)
+ ((role :type symbol :accessor rp-role)
+ (reasoner :accessor rp-reasoner)
+ (information-set :accessor rp-information-set)))
+
+(define-with-macro (random-ii-player :conc-name rp)
+ role reasoner information-set)
+
+
+(defun percepts-match-p (player state moves percepts)
+ (set-equal percepts
+ (percepts-for (rp-reasoner player) (rp-role player) state moves)
+ :test #'equal))
+
+(defun get-possible-moves (player state move)
+ (let* ((reasoner (rp-reasoner player))
+ (our-role (rp-role player))
+ (other-roles (remove our-role (roles reasoner)))
+ (other-moves (mapcar (lambda (role)
+ (mapcar (curry #'cons role)
+ (legal-moves-for reasoner role state)))
+ other-roles)))
+ (apply #'map-product #'list
+ (list (cons our-role move))
+ other-moves)))
+
+(defun get-next-states (player state move percepts)
+ (-<> (get-possible-moves player state move)
+ (mapcar (lambda (moves)
+ (when (percepts-match-p player state moves percepts)
+ (next-state (rp-reasoner player) state moves)))
+ <>)
+ (remove nil <>)
+ (remove-duplicates <> :test #'equal)))
+
+(defun get-next-information-set (player move percepts)
+ (iterate (for state :in (rp-information-set player))
+ (unioning (get-next-states player state move percepts)
+ :test #'equal)))
+
+
+(defmethod ggp:player-start-game ((player random-ii-player) rules role timeout)
+ (format t "Game Started~%")
+ (loop :repeat 300 :do (princ #\=))
+ (terpri)
+ (let ((reasoner (make-prolog-reasoner)))
+ (load-rules reasoner rules)
+ (setf (rp-role player) role
+ (rp-reasoner player) reasoner
+ (rp-information-set player) (list (initial-state reasoner)))))
+
+(defmethod ggp:player-stop-game ((player random-ii-player))
+ (setf (rp-role player) nil
+ (rp-reasoner player) nil
+ (rp-information-set player) nil))
+
+(defmethod ggp:player-update-game-ii ((player random-ii-player) move percepts)
+ (when move
+ (setf (rp-information-set player)
+ (get-next-information-set player move percepts))))
+
+(defmethod ggp:player-select-move ((player random-ii-player) timeout)
+ (with-random-ii-player (player)
+ (format t "Information set size: ~D~%" (length information-set))
+ ; (let ((*package* (find-package :ggp-rules)))
+ ; (iterate (for state :in information-set)
+ ; (format t " ~S~%" state)))
+ (format t "Selecting move...~%")
+ (random-elt (legal-moves-for reasoner role (first information-set)))))
+
+
+;;;; Run ----------------------------------------------------------------------
+(setf hunchentoot:*default-connection-timeout* nil) ; its_fine
+
+(defvar *player* (make-instance 'random-ii-player
+ :name "Scully-Random-II"
+ :port 5002))
+
+; (ggp:start-player *player* :server :hunchentoot :use-thread t)
+; (ggp:kill-player *player*)
--- a/src/reasoners/prolog.lisp Wed Sep 14 16:12:55 2016 +0000
+++ b/src/reasoners/prolog.lisp Fri Sep 16 14:01:40 2016 +0000
@@ -6,6 +6,34 @@
;;;; Reasoner -----------------------------------------------------------------
+(defun clean-or (gdl)
+ (destructuring-bind (or . arguments)
+ gdl
+ (case (length arguments)
+ (1 (first arguments))
+ (2 gdl)
+ (t (list or (first arguments)
+ (clean-or (cons or (rest arguments))))))))
+
+(defun clean-and (gdl)
+ (destructuring-bind (and . arguments)
+ gdl
+ (case (length arguments)
+ (1 (first arguments))
+ (2 gdl)
+ (t (list and (first arguments)
+ (clean-and (cons and (rest arguments))))))))
+
+(defun clean-gdl (gdl)
+ (if (consp gdl)
+ (case (car gdl)
+ (ggp-rules::or (clean-or gdl))
+ (ggp-rules::and (clean-and gdl))
+ (t (cons (clean-gdl (car gdl))
+ (clean-gdl (cdr gdl)))))
+ gdl))
+
+
(defun load-gdl-preamble (db)
(push-logic-frame-with db
(rule db (ggp-rules::not ?x) (call ?x) ! fail)
@@ -14,6 +42,8 @@
(rule db (ggp-rules::or ?x ?y) (call ?x))
(rule db (ggp-rules::or ?x ?y) (call ?y))
+ (rule db (ggp-rules::and ?x ?y) (call ?x) (call ?y))
+
(rule db (ggp-rules::distinct ?x ?x) ! fail)
(fact db (ggp-rules::distinct ?x ?y))))
@@ -121,11 +151,12 @@
(eq (car rule) 'ggp-rules::<=))
(apply #'invoke-rule db (cdr rule))
(invoke-fact db rule)))
- rules))))
+ (clean-gdl rules)))))
(defun initial-state (reasoner)
(normalize-state
- (query-map (pr-database reasoner) (lambda (r) (getf r '?what))
+ (query-map (pr-database reasoner)
+ (lambda (r) (getf r '?what))
(ggp-rules::init ?what))))
(defun terminalp (reasoner)
@@ -147,3 +178,16 @@
`(ggp-rules::legal ,role ?action))
:test #'equal))
+(defun percepts-for (reasoner role state moves)
+ (ensure-state reasoner state)
+ (ensure-moves reasoner moves)
+ (remove-duplicates
+ (invoke-query-map (pr-database reasoner)
+ (lambda (r) (getf r '?what))
+ `(ggp-rules::sees ,role ?what))
+ :test #'equal))
+
+(defun roles (reasoner)
+ (query-map (pr-database reasoner)
+ (lambda (r) (getf r '?role))
+ (ggp-rules::role ?role)))
--- a/vendor/make-quickutils.lisp Wed Sep 14 16:12:55 2016 +0000
+++ b/vendor/make-quickutils.lisp Fri Sep 16 14:01:40 2016 +0000
@@ -6,6 +6,10 @@
:once-only
:with-gensyms
+ :map-product
+ :curry
+ :rcurry
+ :set-equal
)
:package "SCULLY.QUICKUTILS")
--- a/vendor/quickutils.lisp Wed Sep 14 16:12:55 2016 +0000
+++ b/vendor/quickutils.lisp Fri Sep 16 14:01:40 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:ONCE-ONLY :WITH-GENSYMS) :ensure-package T :package "SCULLY.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:ONCE-ONLY :WITH-GENSYMS :MAP-PRODUCT :CURRY :RCURRY :SET-EQUAL) :ensure-package T :package "SCULLY.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "SCULLY.QUICKUTILS")
@@ -14,7 +14,9 @@
(when (boundp '*utilities*)
(setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ONCE-ONLY
- :STRING-DESIGNATOR :WITH-GENSYMS))))
+ :STRING-DESIGNATOR :WITH-GENSYMS
+ :ENSURE-FUNCTION :CURRY :MAPPEND
+ :MAP-PRODUCT :RCURRY :SET-EQUAL))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun make-gensym-list (length &optional (x "G"))
"Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
@@ -107,6 +109,93 @@
`(with-gensyms ,names ,@forms))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(once-only with-gensyms with-unique-names)))
+ ;;; To propagate return type and allow the compiler to eliminate the IF when
+ ;;; it is known if the argument is function or not.
+ (declaim (inline ensure-function))
+
+ (declaim (ftype (function (t) (values function &optional))
+ ensure-function))
+ (defun ensure-function (function-designator)
+ "Returns the function designated by `function-designator`:
+if `function-designator` is a function, it is returned, otherwise
+it must be a function name and its `fdefinition` is returned."
+ (if (functionp function-designator)
+ function-designator
+ (fdefinition function-designator)))
+ ) ; eval-when
+
+ (defun curry (function &rest arguments)
+ "Returns a function that applies `arguments` and the arguments
+it is called with to `function`."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ ;; Using M-V-C we don't need to append the arguments.
+ (multiple-value-call fn (values-list arguments) (values-list more)))))
+
+ (define-compiler-macro curry (function &rest arguments)
+ (let ((curries (make-gensym-list (length arguments) "CURRY"))
+ (fun (gensym "FUN")))
+ `(let ((,fun (ensure-function ,function))
+ ,@(mapcar #'list curries arguments))
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest more)
+ (apply ,fun ,@curries more)))))
+
+
+ (defun mappend (function &rest lists)
+ "Applies `function` to respective element(s) of each `list`, appending all the
+all the result list to a single list. `function` must return a list."
+ (loop for results in (apply #'mapcar function lists)
+ append results))
+
+
+ (defun map-product (function list &rest more-lists)
+ "Returns a list containing the results of calling `function` with one argument
+from `list`, and one from each of `more-lists` for each combination of arguments.
+In other words, returns the product of `list` and `more-lists` using `function`.
+
+Example:
+
+ (map-product 'list '(1 2) '(3 4) '(5 6))
+ => ((1 3 5) (1 3 6) (1 4 5) (1 4 6)
+ (2 3 5) (2 3 6) (2 4 5) (2 4 6))"
+ (labels ((%map-product (f lists)
+ (let ((more (cdr lists))
+ (one (car lists)))
+ (if (not more)
+ (mapcar f one)
+ (mappend (lambda (x)
+ (%map-product (curry f x) more))
+ one)))))
+ (%map-product (ensure-function function) (cons list more-lists))))
+
+
+ (defun rcurry (function &rest arguments)
+ "Returns a function that applies the arguments it is called
+with and `arguments` to `function`."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ (multiple-value-call fn (values-list more) (values-list arguments)))))
+
+
+ (defun set-equal (list1 list2 &key (test #'eql) (key nil keyp))
+ "Returns true if every element of `list1` matches some element of `list2` and
+every element of `list2` matches some element of `list1`. Otherwise returns false."
+ (let ((keylist1 (if keyp (mapcar key list1) list1))
+ (keylist2 (if keyp (mapcar key list2) list2)))
+ (and (dolist (elt keylist1 t)
+ (or (member elt keylist2 :test test)
+ (return nil)))
+ (dolist (elt keylist2 t)
+ (or (member elt keylist1 :test test)
+ (return nil))))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(once-only with-gensyms with-unique-names map-product curry rcurry
+ set-equal)))
;;;; END OF quickutils.lisp ;;;;