# HG changeset patch # User Steve Losh # Date 1474034500 0 # Node ID 6281f855797188c6dfddbe297011ea40f7811891 # Parent 86ab44c2dfa80d59d1eae948527c679e09c8ebcc Add GDL-II player diff -r 86ab44c2dfa8 -r 6281f8557971 package.lisp --- 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 + )) diff -r 86ab44c2dfa8 -r 6281f8557971 scully.asd --- 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"))))))) diff -r 86ab44c2dfa8 -r 6281f8557971 src/players/random-ii.lisp --- /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*) diff -r 86ab44c2dfa8 -r 6281f8557971 src/reasoners/prolog.lisp --- 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))) diff -r 86ab44c2dfa8 -r 6281f8557971 vendor/make-quickutils.lisp --- 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") diff -r 86ab44c2dfa8 -r 6281f8557971 vendor/quickutils.lisp --- 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 ;;;;