--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/.lispwords Wed Sep 14 16:12:55 2016 +0000
@@ -0,0 +1,1 @@
+(1 push-logic-frame-with)
--- a/package.lisp Thu Sep 08 18:08:55 2016 +0000
+++ b/package.lisp Wed Sep 14 16:12:55 2016 +0000
@@ -1,19 +1,27 @@
-(defpackage #:scully.brains.random
+(defpackage #:scully.reasoners.prolog
(:use
#:cl
#:losh
#:iterate
#:cl-arrows
+ #:temperance
#:scully.quickutils)
(:export
- ))
+ #:prolog-reasoner
+ #:make-prolog-reasoner
+ #:load-rules
+ #:initial-state
+ #:terminalp
+ #:next-state
+ #:legal-moves-for))
-(defpackage #:scully.player
+(defpackage #:scully.players.random
(:use
#:cl
#:losh
#:iterate
#:cl-arrows
- #:scully.quickutils)
+ #:scully.quickutils
+ #:scully.reasoners.prolog)
(:export
))
--- a/scully.asd Thu Sep 08 18:08:55 2016 +0000
+++ b/scully.asd Wed Sep 14 16:12:55 2016 +0000
@@ -9,21 +9,19 @@
:depends-on (#:iterate
#:losh
+ #:temperance
+ #:hunchentoot
#:cl-arrows
- #:cl-ggp
- #:cl-conspack
- #:usocket)
+ #:cl-ggp)
:serial t
- :components ((:module "vendor"
- :serial t
+ :components ((:module "vendor" :serial t
:components ((:file "quickutils-package")
(:file "quickutils")))
(:file "package")
- (:module "src"
- :serial t
- :components ((:module "brains"
- :serial nil
- :components ((:file "random")))
- (:file "player")))))
+ (:module "src" :serial t
+ :components ((:module "reasoners" :serial t
+ :components ((:file "prolog")))
+ (:module "players" :serial t
+ :components ((:file "random")))))))
--- a/src/brains/random.lisp Thu Sep 08 18:08:55 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,81 +0,0 @@
-(in-package #:scully.brains.random)
-
-
-;;;; Data ---------------------------------------------------------------------
-(defparameter *brain* nil)
-(defparameter *server* nil)
-
-
-;;;; Random Brain -------------------------------------------------------------
-(defclass random-brain ()
- ((role :type symbol :accessor brain-role)
- (database :accessor brain-database)
- (state :accessor brain-state)))
-
-
-(defun start-game (brain rules role timeout)
- (setf (brain-role brain) role
- (brain-database brain) (make-database))
- (with-database (brain-database brain)
- (load-gdl-preamble)
- (push-logic-frame-with
- (load-rules rules))
- (setf (brain-state brain) (initial-state))))
-
-(defun stop-game (brain)
- (setf (brain-state brain) nil
- (brain-database brain) nil
- (brain-role brain) nil))
-
-(defun update-game (brain moves)
- (when moves
- (with-database (brain-database brain)
- (apply-state (brain-state brain))
- (apply-moves moves)
- (setf (brain-state brain) (next-state))
- (clear-moves)
- (clear-state))))
-
-(defun random-nth (list)
- (nth (random (length list)) list))
-
-(defun select-move (brain timeout)
- (with-database (brain-database brain)
- (prog2
- (apply-state (brain-state brain))
- (cdr (random-nth (legal-moves-for (brain-role brain))))
- (clear-state))))
-
-
-;;;; Sockets ------------------------------------------------------------------
-(defun read-message (stream)
- (conspack:decode-stream stream))
-
-(defun write-message (out stream &rest message)
- (format out "writing to stream... ~S~%" message)
- (conspack:encode message :stream stream)
- (finish-output stream))
-
-(defun handle (stream brain out)
- (loop
- (destructuring-bind (tag . arguments)
- (read-message stream)
- (case tag
- (:quit (return-from handle))
- (:double (write-message out stream (* 2 (car arguments))))
- (t (format out "Unknown message: ~S ~S~%" tag arguments))))))
-
-(defun run-brain-server (brain port)
- (setf *server*
- (usocket:socket-server
- "127.0.0.1" port
- 'handle (list brain *standard-output*)
- :in-new-thread t
- :protocol :stream
- :element-type '(unsigned-byte 8)
- :reuse-address t)))
-
-(defun run-brain (port)
- (let ((brain (make-instance 'random-brain)))
- (setf *brain* brain)
- (run-brain-server brain port)))
--- a/src/player.lisp Thu Sep 08 18:08:55 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,94 +0,0 @@
-(in-package #:scully.player)
-
-
-;;;; Brain Connections --------------------------------------------------------
-(defstruct (brain (:constructor %make-brain (name stream socket)))
- name stream socket)
-
-
-(defun make-brain (name port)
- (let ((socket (usocket:socket-connect "127.0.0.1" port
- :protocol :stream
- :element-type '(unsigned-byte 8))))
- (%make-brain name (usocket:socket-stream socket) socket)))
-
-
-(defun brain-send (brain tag &rest arguments)
- (conspack:encode (list* tag arguments)
- :stream (brain-stream brain))
- (finish-output (brain-stream brain))
- (values))
-
-(defun brain-read (brain)
- (values (conspack:decode-stream (brain-stream brain))))
-
-
-;;;; Player -------------------------------------------------------------------
-(defclass scully-player (ggp:ggp-player)
- ((brains :accessor player-brains :initarg :brains)))
-
-(defun make-player ()
- (make-instance 'scully-player
- :name "Scully"
- :port 5000
- :brains (list (make-brain :random 5001))))
-
-
-(defun broadcast-to-brains (player tag &rest arguments)
- (iterate (for brain :in (player-brains player))
- (apply #'brain-send brain tag arguments))
- (values))
-
-(defun gather-responses (player timeout)
- (iterate
- (with remaining = (player-brains player))
- (with results = nil)
- (when (null remaining)
- (return results))
- (for (values ready remaining-time) = (usocket:wait-for-input
- (mapcar #'brain-socket remaining)
- :timeout timeout
- :ready-only t))
- (if (null remaining-time)
- (return results)
- (progn
- (setf timeout remaining-time)
- (iterate
- (for brain :in (copy-list remaining))
- (when (member (brain-socket brain) ready)
- (push (cons (brain-name brain) (brain-read brain)) results)
- (setf remaining (remove brain remaining))))))))
-
-(defun select-move-response (responses)
- (let ((resp-random (assoc :random responses)))
- (cdr resp-random)))
-
-
-(defmethod ggp:player-start-game ((player scully-player) rules role timeout)
- (broadcast-to-brains player :start rules role timeout))
-
-(defmethod ggp:player-stop-game ((player scully-player))
- (broadcast-to-brains player :stop)
- (broadcast-to-brains player :quit))
-
-(defmethod ggp:player-update-game ((player scully-player) moves)
- (broadcast-to-brains player :update moves))
-
-(defmethod ggp:player-select-move ((player scully-player) timeout)
- (broadcast-to-brains player :start-thinking)
- (let ((seconds (* internal-time-units-per-second
- (- timeout (get-internal-real-time)))))
- (sleep (- seconds 2))
- (broadcast-to-brains player :request-move)
- (select-move-response (gather-responses player (- seconds 1)))))
-
-
-(defvar *player* nil)
-
-(defun start-player ()
- (setf *player* (make-player))
- (ggp:start-player *player*)
- *player*)
-
-; (ggp:start-player *player*)
-; (ggp:kill-player *player*)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/players/random.lisp Wed Sep 14 16:12:55 2016 +0000
@@ -0,0 +1,44 @@
+(in-package #:scully.players.random)
+
+
+;;;; Random Player ------------------------------------------------------------
+(defclass random-player (ggp:ggp-player)
+ ((role :type symbol :accessor rp-role)
+ (reasoner :accessor rp-reasoner)
+ (state :accessor rp-state)))
+
+(define-with-macro (random-player :conc-name rp)
+ role reasoner state)
+
+
+(defmethod ggp:player-start-game ((player random-player) rules role timeout)
+ (let ((reasoner (make-prolog-reasoner)))
+ (load-rules reasoner rules)
+ (setf (rp-role player) role
+ (rp-reasoner player) reasoner
+ (rp-state player) (initial-state reasoner))))
+
+(defmethod ggp:player-stop-game ((player random-player))
+ (setf (rp-state player) nil
+ (rp-reasoner player) nil
+ (rp-role player) nil))
+
+(defmethod ggp:player-update-game ((player random-player) moves)
+ (when moves
+ (with-random-player (player)
+ (setf state (next-state reasoner state moves)))))
+
+(defmethod ggp:player-select-move ((player random-player) timeout)
+ (with-random-player (player)
+ (random-elt (legal-moves-for reasoner role state))))
+
+
+;;;; Run ----------------------------------------------------------------------
+(setf hunchentoot:*default-connection-timeout* nil) ; its_fine
+
+(defvar *random-player* (make-instance 'random-player
+ :name "Scully-Random"
+ :port 5001))
+
+; (ggp:start-player *random-player* :server :hunchentoot)
+; (ggp:kill-player *random-player*)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/reasoners/prolog.lisp Wed Sep 14 16:12:55 2016 +0000
@@ -0,0 +1,149 @@
+(in-package #:scully.reasoners.prolog)
+
+
+;;;; Brute-Force Prolog Reasoner
+;;; This is the slow, naive way to play. It's here as a reference point.
+
+
+;;;; Reasoner -----------------------------------------------------------------
+(defun load-gdl-preamble (db)
+ (push-logic-frame-with db
+ (rule db (ggp-rules::not ?x) (call ?x) ! fail)
+ (fact db (ggp-rules::not ?x))
+
+ (rule db (ggp-rules::or ?x ?y) (call ?x))
+ (rule db (ggp-rules::or ?x ?y) (call ?y))
+
+ (rule db (ggp-rules::distinct ?x ?x) ! fail)
+ (fact db (ggp-rules::distinct ?x ?y))))
+
+(defun make-reasoner-database ()
+ (let ((db (make-database)))
+ (load-gdl-preamble db)
+ db))
+
+
+(defclass prolog-reasoner ()
+ ((database :initform (make-reasoner-database) :reader pr-database)
+ (current-state :initform nil :accessor pr-state)
+ (current-moves :initform nil :accessor pr-moves)))
+
+(defun make-prolog-reasoner ()
+ (make-instance 'prolog-reasoner))
+
+
+;;;; State Normalization ------------------------------------------------------
+(defun dedupe-state (state)
+ (iterate (for fact :in state)
+ (for prev :previous fact)
+ (when (not (eql fact prev))
+ (collect fact))))
+
+(defun fact-slow< (a b)
+ ;; numbers < symbols < conses
+ (etypecase a
+ (number (typecase b
+ (number (< a b))
+ (t t)))
+ (symbol (etypecase b
+ (number nil)
+ (cons t)
+ (symbol (string< (symbol-name a) (symbol-name b)))))
+ (cons (typecase b
+ (cons (cond
+ ((fact-slow< (car a) (car b)) t)
+ ((fact-slow< (car b) (car a)) nil)
+ (t (fact-slow< (cdr a) (cdr b)))))
+ (t nil)))))
+
+(defun fact< (a b)
+ (if (eql a b)
+ nil
+ (let ((ha (sxhash a))
+ (hb (sxhash b)))
+ (if (= ha hb)
+ (fact-slow< a b)
+ (< ha hb)))))
+
+(defun sort-state (state)
+ (sort state #'fact<))
+
+(defun normalize-state (state)
+ (dedupe-state (sort-state state)))
+
+
+;;;; Ugly State Management ----------------------------------------------------
+(defun apply-state (reasoner state)
+ (let ((db (pr-database reasoner)))
+ (push-logic-frame-with db
+ (loop :for fact :in state
+ :do (invoke-fact db `(ggp-rules::true ,fact)))))
+ (setf (pr-state reasoner) state))
+
+(defun apply-moves (reasoner moves)
+ (let ((db (pr-database reasoner)))
+ (push-logic-frame-with db
+ (loop :for (role . action) :in moves
+ :do (invoke-fact db `(ggp-rules::does ,role ,action)))))
+ (setf (pr-moves reasoner) moves))
+
+
+(defun clear-state (reasoner)
+ (pop-logic-frame (pr-database reasoner))
+ (setf (pr-state reasoner) nil))
+
+(defun clear-moves (reasoner)
+ (pop-logic-frame (pr-database reasoner))
+ (setf (pr-moves reasoner) nil))
+
+
+(defun ensure-state (reasoner state)
+ (when (not (eql state (pr-state reasoner)))
+ (when (not (null (pr-moves reasoner)))
+ (clear-moves reasoner))
+ (when (not (null (pr-state reasoner)))
+ (clear-state reasoner))
+ (apply-state reasoner state)))
+
+(defun ensure-moves (reasoner moves)
+ (when (not (eql moves (pr-moves reasoner)))
+ (when (not (null (pr-moves reasoner)))
+ (clear-moves reasoner))
+ (apply-moves reasoner moves)))
+
+
+;;;; API ----------------------------------------------------------------------
+(defun load-rules (reasoner rules)
+ (let ((db (pr-database reasoner)))
+ (push-logic-frame-with db
+ (mapc (lambda (rule)
+ (if (and (consp rule)
+ (eq (car rule) 'ggp-rules::<=))
+ (apply #'invoke-rule db (cdr rule))
+ (invoke-fact db rule)))
+ rules))))
+
+(defun initial-state (reasoner)
+ (normalize-state
+ (query-map (pr-database reasoner) (lambda (r) (getf r '?what))
+ (ggp-rules::init ?what))))
+
+(defun terminalp (reasoner)
+ (prove (pr-database reasoner) ggp-rules::terminal))
+
+(defun next-state (reasoner state moves)
+ (ensure-state reasoner state)
+ (ensure-moves reasoner moves)
+ (normalize-state
+ (query-map (pr-database reasoner)
+ (lambda (r) (getf r '?what))
+ (ggp-rules::next ?what))))
+
+(defun legal-moves-for (reasoner role state)
+ (ensure-state reasoner state)
+ (remove-duplicates
+ (invoke-query-map (pr-database reasoner)
+ (lambda (r) (getf r '?action))
+ `(ggp-rules::legal ,role ?action))
+ :test #'equal))
+
--- a/vendor/make-quickutils.lisp Thu Sep 08 18:08:55 2016 +0000
+++ b/vendor/make-quickutils.lisp Wed Sep 14 16:12:55 2016 +0000
@@ -4,8 +4,8 @@
"quickutils.lisp"
:utilities '(
+ :once-only
:with-gensyms
- :once-only
)
:package "SCULLY.QUICKUTILS")
--- a/vendor/quickutils.lisp Thu Sep 08 18:08:55 2016 +0000
+++ b/vendor/quickutils.lisp Wed Sep 14 16:12:55 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:WITH-GENSYMS :ONCE-ONLY) :ensure-package T :package "SCULLY.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:ONCE-ONLY :WITH-GENSYMS) :ensure-package T :package "SCULLY.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "SCULLY.QUICKUTILS")
@@ -13,52 +13,8 @@
(in-package "SCULLY.QUICKUTILS")
(when (boundp '*utilities*)
- (setf *utilities* (union *utilities* '(:STRING-DESIGNATOR :WITH-GENSYMS
- :MAKE-GENSYM-LIST :ONCE-ONLY))))
-
- (deftype string-designator ()
- "A string designator type. A string designator is either a string, a symbol,
-or a character."
- `(or symbol string character))
-
-
- (defmacro with-gensyms (names &body forms)
- "Binds each variable named by a symbol in `names` to a unique symbol around
-`forms`. Each of `names` must either be either a symbol, or of the form:
-
- (symbol string-designator)
-
-Bare symbols appearing in `names` are equivalent to:
-
- (symbol symbol)
-
-The string-designator is used as the argument to `gensym` when constructing the
-unique symbol the named variable will be bound to."
- `(let ,(mapcar (lambda (name)
- (multiple-value-bind (symbol string)
- (etypecase name
- (symbol
- (values name (symbol-name name)))
- ((cons symbol (cons string-designator null))
- (values (first name) (string (second name)))))
- `(,symbol (gensym ,string))))
- names)
- ,@forms))
-
- (defmacro with-unique-names (names &body forms)
- "Binds each variable named by a symbol in `names` to a unique symbol around
-`forms`. Each of `names` must either be either a symbol, or of the form:
-
- (symbol string-designator)
-
-Bare symbols appearing in `names` are equivalent to:
-
- (symbol symbol)
-
-The string-designator is used as the argument to `gensym` when constructing the
-unique symbol the named variable will be bound to."
- `(with-gensyms ,names ,@forms))
-
+ (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ONCE-ONLY
+ :STRING-DESIGNATOR :WITH-GENSYMS))))
(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`,
@@ -106,7 +62,51 @@
names-and-forms gensyms)
,@forms)))))
+
+ (deftype string-designator ()
+ "A string designator type. A string designator is either a string, a symbol,
+or a character."
+ `(or symbol string character))
+
+
+ (defmacro with-gensyms (names &body forms)
+ "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+ (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+ (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+ `(let ,(mapcar (lambda (name)
+ (multiple-value-bind (symbol string)
+ (etypecase name
+ (symbol
+ (values name (symbol-name name)))
+ ((cons symbol (cons string-designator null))
+ (values (first name) (string (second name)))))
+ `(,symbol (gensym ,string))))
+ names)
+ ,@forms))
+
+ (defmacro with-unique-names (names &body forms)
+ "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+ (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+ (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+ `(with-gensyms ,names ,@forms))
+
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(with-gensyms with-unique-names once-only)))
+ (export '(once-only with-gensyms with-unique-names)))
;;;; END OF quickutils.lisp ;;;;