# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1473869575 0
# Node ID 86ab44c2dfa80d59d1eae948527c679e09c8ebcc
# Parent  77db7de3a21c44087cdb2ee67ae87abe322be2f6
Tear out socket bullshit and implement the random player

diff -r 77db7de3a21c -r 86ab44c2dfa8 .lispwords
--- /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)
diff -r 77db7de3a21c -r 86ab44c2dfa8 package.lisp
--- 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
     ))
diff -r 77db7de3a21c -r 86ab44c2dfa8 scully.asd
--- 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")))))))
 
diff -r 77db7de3a21c -r 86ab44c2dfa8 src/brains/random.lisp
--- 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)))
diff -r 77db7de3a21c -r 86ab44c2dfa8 src/player.lisp
--- 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*)
diff -r 77db7de3a21c -r 86ab44c2dfa8 src/players/random.lisp
--- /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*)
diff -r 77db7de3a21c -r 86ab44c2dfa8 src/reasoners/prolog.lisp
--- /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))
+
diff -r 77db7de3a21c -r 86ab44c2dfa8 vendor/make-quickutils.lisp
--- 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")
diff -r 77db7de3a21c -r 86ab44c2dfa8 vendor/quickutils.lisp
--- 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 ;;;;