--- a/.hgignore Thu Aug 25 00:05:28 2016 +0000
+++ b/.hgignore Thu Aug 25 03:03:47 2016 +0000
@@ -6,4 +6,5 @@
bench-results.txt
profile.out
contrib/gdl-benchmark/run_temperance
+contrib/gdl-benchmark/run_paip
contrib/gdl-benchmark/gdl.prof
--- a/contrib/gdl-benchmark/README.markdown Thu Aug 25 00:05:28 2016 +0000
+++ b/contrib/gdl-benchmark/README.markdown Thu Aug 25 03:03:47 2016 +0000
@@ -62,3 +62,16 @@
binary.
In practice this results in a speed increase of around 20%.
+
+PAIProlog
+---------
+
+A separate benchmark script that uses PAIProlog instead of Temperance is
+included.
+
+ cd ~/.roswell/local-projects/temperance/contrib/gdl-benchmark/
+
+ ros use sbcl
+ ros build paip.ros
+ ~/.roswell/local-projects/temperance/contrib/gdl-benchmark/run_paip 'dfs mc' 10 .../foo.gdl .../foo.trace
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/contrib/gdl-benchmark/run_paip.ros Thu Aug 25 03:03:47 2016 +0000
@@ -0,0 +1,466 @@
+#!/bin/sh
+#|-*- mode:lisp -*-|#
+#|
+exec ros -Q -- $0 "$@"
+|#
+
+;;;; Dependencies -------------------------------------------------------------
+(ql:quickload :uiop :silent t)
+(ql:quickload :unix-opts :silent t)
+(ql:quickload :split-sequence :silent t)
+(ql:quickload :losh :silent t)
+(ql:quickload :paiprolog :silent t)
+(ql:quickload :temperance :silent t)
+#+sbcl (require :sb-sprof)
+
+(defmacro shut-up (&body body)
+ `(let ((*standard-output* (make-broadcast-stream))
+ (*error-output* (make-broadcast-stream)))
+ ,@body))
+
+
+(defun load-paip ()
+ (if (string= "YES" (uiop:getenv "PLEASE_SEGFAULT"))
+ (declaim (optimize (debug 0) (safety 0) (speed 3)))
+ (declaim (optimize (debug 1) (safety 1) (speed 3))))
+ (shut-up
+ (asdf:load-system :paiprolog :force t))
+ (declaim (optimize (debug 3) (safety 1) (speed 1))))
+
+(load-paip)
+
+
+;;;; Package ------------------------------------------------------------------
+(defpackage #:temperance.contrib.gdl-benchmark
+ (:use
+ #:cl
+ #:losh
+ #:temperance.quickutils
+ #:paiprolog))
+
+(in-package #:temperance.contrib.gdl-benchmark)
+
+
+;;;; Config -------------------------------------------------------------------
+(defparameter *verbose* nil)
+(defparameter *profile* nil)
+
+
+;;;; Profiling ----------------------------------------------------------------
+#+sbcl
+(defmacro with-profiling (&body body)
+ ; (declare (optimize (speed 1) (debug 1) (safety 1)))
+ `(progn
+ (sb-ext:gc :full t)
+ (require :sb-sprof)
+ ; (sb-sprof::profile-call-counts "TEMPERANCE.WAM")
+ ; (sb-sprof::profile-call-counts "TEMPERANCE.CIRCLE")
+ ; (sb-sprof::profile-call-counts "TEMPERANCE.CONTRIB.GDL-BENCHMARK")
+ (sb-sprof::with-profiling (:max-samples 50000
+ :reset t
+ ; :mode :alloc
+ :mode :cpu
+ :sample-interval 0.006
+ :alloc-interval 1)
+ ,@body)
+ (with-open-file (*standard-output* "gdl.prof"
+ :direction :output
+ :if-exists :supersede)
+ (sb-sprof:report :type :graph
+ :sort-by :cumulative-samples
+ :sort-order :ascending)
+ (sb-sprof:report :type :flat
+ :min-percent 0.5))
+ nil))
+
+
+#-sbcl
+(defmacro with-profiling (&body body)
+ `(progn ,@body nil))
+
+
+;;;; Benchmarking -------------------------------------------------------------
+(defvar *roles* nil)
+(defun read-file (path)
+ (with-open-file (file path :direction :input)
+ (loop :for form = (read file nil 'eof)
+ :until (eq form 'eof)
+ :collect form)))
+
+(defun read-gdl (path)
+ (read-file path))
+
+(defun read-trace (path)
+ ;; (moves m1 m2 ...) -> (m1 m2 ...)
+ (mapcar #'rest (read-file path)))
+
+
+(defun paip-assert-dynamic (head body)
+ (paiprolog::add-clause
+ (paiprolog::make-anonymous (list* head body))))
+
+(defun load-gdl-preamble ()
+ (<- (not ?x) (call ?x) ! fail)
+ (<- (not ?x))
+ ; (<- (or ?x ?y) (call ?x))
+ ; (<- (or ?x ?y) (call ?y))
+ (<- (distinct ?x ?x) ! fail)
+ (<- (distinct ?x ?y)))
+
+(defun build-clause (clause)
+ (cond ((and (consp clause)
+ (eq (first clause) '<=))
+ (destructuring-bind (arrow head . body)
+ clause
+ (declare (ignore arrow))
+ (paip-assert-dynamic head body)))
+ ((and (consp clause)
+ (eq (first clause) 'role))
+ ;; the jank is real
+ (push (second clause) *roles*)
+ (paip-assert-dynamic clause nil))
+ (t (paip-assert-dynamic clause nil))))
+
+(defun build-database (gdl)
+ (setf *roles* nil)
+ (load-gdl-preamble)
+ (mapc #'build-clause gdl)
+ (setf *roles* (reverse *roles*))) ; please kill me
+
+
+(defun normalize-state (state)
+ ;; TODO: should this be excluded from the benchmark?
+ (remove-duplicates state :test 'equal))
+
+(defun initial-state ()
+ (normalize-state
+ (prolog-collect (?what) (init ?what))))
+
+(defun terminalp ()
+ (prolog terminal (lisp (return-from terminalp t))))
+
+(defun roles ()
+ (prolog-collect (?role) (role ?role)))
+
+(defun goal-values ()
+ (remove-duplicates (prolog-collect (?role ?goal) (goal ?role ?goal))
+ :test 'equal))
+
+
+(defun next-state ()
+ (normalize-state
+ (prolog-collect (?what) (next ?what))))
+
+
+(defun apply-state (state)
+ ; (sleep 0.00002)
+ (loop :for fact :in state
+ :do (paip-assert-dynamic `(true ,fact) nil)))
+
+(defun apply-moves (moves)
+ (loop :for (role action) :in moves
+ :do (paip-assert-dynamic `(does ,role ,action) nil)))
+
+
+(defun clear-state ()
+ (<-- (true nothing-at-all)))
+
+(defun clear-moves ()
+ (<-- (does noone anything-ever)))
+
+
+(defun move= (move1 move2)
+ (equal move1 move2))
+
+(defun move-role= (move1 move2)
+ (eq (car move1) (car move2)))
+
+
+(defun legal-moves ()
+ (let* ((individual-moves
+ (remove-duplicates
+ (prolog-collect (?role ?action)
+ (legal ?role ?action))
+ :test #'move=))
+ (player-moves
+ (equivalence-classes #'move-role= individual-moves))
+ (joint-moves
+ (apply #'map-product #'list player-moves)))
+ joint-moves))
+
+
+(defun build-traces (traces)
+ (loop
+ :with roles = *roles*
+ :for trace :in traces
+ :collect (loop :for move :in trace
+ :for role :in roles
+ :collect (list role move))))
+
+
+(defvar *update-count* 0)
+(defvar *legal-move-count* 0)
+(defvar *goal-state-count* 0)
+
+(defvar *deadline* nil)
+
+(defun calculate-deadline (seconds)
+ (setf *deadline* (+ (get-internal-real-time)
+ (* internal-time-units-per-second seconds))))
+
+(defun time-exceeded-p ()
+ (and *deadline* (> (get-internal-real-time) *deadline*)))
+
+
+(defun evaluate-goals ()
+ ; (sb-ext:enable-debugger)
+ ; (break)
+ (goal-values)
+ (incf *goal-state-count*))
+
+
+(defun run-random-simulation (state)
+ (apply-state state)
+ (if (terminalp)
+ (progn
+ (evaluate-goals)
+ (clear-state))
+ (let ((move (random-elt (legal-moves))))
+ (incf *legal-move-count*)
+ (apply-moves move)
+ (let ((next (next-state)))
+ (incf *update-count*)
+ (clear-moves)
+ (clear-state)
+ (run-random-simulation next)))))
+
+
+(defun run-monte-carlo (limit state)
+ (format t "Searching with Monte-Carlo search for ~D seconds.~%" limit)
+ (calculate-deadline limit)
+ (loop :for simulation-count :from 0
+ :until (time-exceeded-p)
+ :do (progn
+ (when (dividesp simulation-count 1000)
+ (format t "#simulations: ~D~%" simulation-count))
+ (run-random-simulation state))
+ :finally (format t "#simulations: ~D~%" simulation-count)))
+
+
+(defun minimax (state depth)
+ ;; I know this is horrible, but I wanted to do as straight a port of the other
+ ;; benchmarks as possible to minimize differences between benchmarks.
+ (block nil
+ (when (time-exceeded-p) (return))
+
+ (apply-state state)
+
+ (when (terminalp)
+ (when (time-exceeded-p) (clear-state) (return))
+ (evaluate-goals)
+ (clear-state)
+ (return t))
+
+ (when (<= depth 0)
+ (clear-state)
+ (return))
+
+ (loop
+ :with terminal = t
+ :with moves = (prog1 (legal-moves)
+ (incf *legal-move-count*)
+ (when (time-exceeded-p) (clear-state) (return)))
+ :for move :in moves
+ :for successor = (prog2 (apply-moves move)
+ (next-state)
+ (clear-moves)
+ (incf *update-count*))
+ :do (setf terminal (and (prog2
+ (clear-state)
+ (minimax successor (1- depth))
+ (apply-state state))
+ terminal))
+ :do (when (time-exceeded-p) (clear-state) (return))
+ :finally (progn
+ (clear-state)
+ (return terminal)))))
+
+
+(defun run-dfs (limit state)
+ (format t "Searching with DFS for at most ~D seconds.~%" limit)
+ (loop
+ :with finished = nil
+ :with deadline = (calculate-deadline limit)
+ :for depth :from 0
+ :until (or (> (get-internal-real-time) deadline)
+ finished)
+ :do (setf finished (minimax state depth))))
+
+
+(defun fixed-depth-dfs (limit state)
+ (setf *deadline* nil)
+ (loop
+ :with finished = nil
+ :for depth :from 0 :to limit
+ :until finished
+ ; :do (format t "depth ~D~%" depth)
+ :do (setf finished (minimax state depth))))
+
+
+(defun run-trace (trace algorithm)
+ (setf *update-count* 0
+ *legal-move-count* 0
+ *goal-state-count* 0)
+ (let ((start (get-internal-real-time)))
+ (recursively ((state (initial-state))
+ (trace trace)
+ (step 1))
+ (flet
+ ((handle-terminal ()
+ (clear-state)
+ (if trace
+ (progn
+ (format t "ERROR: Terminal state with trace of ~S remaining.~%"
+ trace)
+ (format t "Offending state:~%~{ ~S~%~}~%" state))
+ (evaluate-goals)))
+ (handle-non-terminal ()
+ (when (null trace)
+ (format t "ERROR: Non-terminal state with no trace remaining.~%")
+ (clear-state)
+ (return-from run-trace))
+ (format t "Step ~D~%" step)
+ ; (format t "Performing ~S~%" (first trace))
+ (apply-moves (first trace))
+ (let ((next (next-state)))
+ (clear-moves)
+ (clear-state)
+ (funcall algorithm state)
+ (incf *update-count*)
+ (format t "MOVE ~D #legals: ~D, #updates: ~D, #goals: ~D~%"
+ step *legal-move-count* *update-count* *goal-state-count*)
+ (recur next
+ (rest trace)
+ (1+ step)))))
+ (apply-state state)
+ (if (terminalp)
+ (handle-terminal)
+ (handle-non-terminal))))
+
+ (format t "FINAL #legals: ~D, #updates: ~D, #goals: ~D, seconds: ~F~%"
+ *legal-move-count* *update-count* *goal-state-count*
+ (/ (- (get-internal-real-time) start)
+ internal-time-units-per-second))))
+
+(defun run (modes limit gdl-file trace-file)
+ (build-database (read-gdl gdl-file))
+ (flet ((%run ()
+ (dolist (mode modes)
+ (run-trace (build-traces (read-trace trace-file))
+ (ecase mode
+ (:mc (curry #'run-monte-carlo limit))
+ (:dfs (curry #'run-dfs limit))
+ (:fdfs (curry #'fixed-depth-dfs limit)))))))
+ (if *profile*
+ (with-profiling (%run))
+ (%run))))
+
+
+;;;; CLI ----------------------------------------------------------------------
+(defun program-name ()
+ ;; dammit roswell
+ (let ((ros-opts (uiop:getenv "ROS_OPTS")))
+ (if ros-opts
+ (read-from-string (second (assoc "script"
+ (let ((*read-eval*))
+ (read-from-string ros-opts))
+ :test 'equal)))
+ (first (opts:argv)))))
+
+
+(opts:define-opts
+ (:name :help
+ :description "print this help text"
+ :short #\h
+ :long "help")
+ (:name :profile
+ :description "profile the run and dump the report to gdl.prof"
+ :short #\p
+ :long "profile")
+ (:name :verbose
+ :description "verbose output"
+ :short #\v
+ :long "verbose"))
+
+
+(defparameter *required-options*
+ (format nil "Required parameters:
+
+ SEARCH-MODES A space-separated list of one or more of {dfs, fdfs, mc}.
+
+ LIMIT A positive integer denoting the playclock limit (for dfs/mc)
+ or depth limit (for fdfs).
+
+ GDL-FILE Path to the GDL file to run. Does NOT need the version with the
+ extra base propositions.
+
+ TRACE-FILE Path to the corresponding trace file."))
+
+
+(defun usage ()
+ (let ((prog (program-name)))
+ (opts:describe
+ :prefix (format nil "~A - Benchmark PAIProlog (interpreted) for GDL reasoning." prog)
+ :suffix *required-options*
+ :usage-of prog
+ :args "SEARCH-MODES LIMIT GDL-FILE TRACE-FILE")))
+
+(defun die (message &rest args)
+ (terpri)
+ (apply #'format *error-output* message args)
+ #+sbcl (sb-ext:exit :code 1)
+ #-sbcl (quit))
+
+
+(defun parse-modes (modes)
+ (mapcar (compose #'ensure-keyword #'string-upcase)
+ (split-sequence:split-sequence
+ #\space modes
+ :remove-empty-subseqs t)))
+
+(defun parse-limit (limit)
+ (handler-case
+ (parse-integer limit)
+ (parse-error (e)
+ (declare (ignore e))
+ (die "ERROR: limit '~A' is not an integer.~%" limit))))
+
+
+(defun main (&rest argv)
+ (handler-bind
+ (#+sbcl (sb-kernel:redefinition-warning #'muffle-warning)
+ #+sbcl (sb-ext:compiler-note #'muffle-warning))
+
+ (multiple-value-bind (options arguments)
+ (opts:get-opts argv)
+
+ (setf *verbose* (getf options :verbose)
+ *profile* (getf options :profile))
+
+ (when (getf options :help)
+ (usage)
+ (return-from main))
+
+ (when (not (= 4 (length arguments)))
+ (usage)
+ (die "ERROR: All arguments are required.~%"))
+
+ (in-package :temperance.contrib.gdl-benchmark)
+ (destructuring-bind (modes limit gdl-file trace-file) arguments
+ (run (parse-modes modes)
+ (parse-limit limit)
+ gdl-file
+ trace-file)))))
+
+
+;;;; Scratch ------------------------------------------------------------------
--- a/contrib/gdl-benchmark/run_temperance.ros Thu Aug 25 00:05:28 2016 +0000
+++ b/contrib/gdl-benchmark/run_temperance.ros Thu Aug 25 03:03:47 2016 +0000
@@ -9,6 +9,7 @@
(ql:quickload :unix-opts :silent t)
(ql:quickload :split-sequence :silent t)
(ql:quickload :losh :silent t)
+(ql:quickload :temperance :silent t)
#+sbcl (require :sb-sprof)
(defmacro shut-up (&body body)
--- a/vendor/make-quickutils.lisp Thu Aug 25 00:05:28 2016 +0000
+++ b/vendor/make-quickutils.lisp Thu Aug 25 03:03:47 2016 +0000
@@ -6,6 +6,7 @@
:alist-plist
:alist-to-hash-table
+ :compose
:curry
:define-constant
:ensure-boolean
--- a/vendor/quickutils.lisp Thu Aug 25 00:05:28 2016 +0000
+++ b/vendor/quickutils.lisp Thu Aug 25 03:03:47 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:ALIST-PLIST :ALIST-TO-HASH-TABLE :CURRY :DEFINE-CONSTANT :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-KEYWORD :EQUIVALENCE-CLASSES :MAP-PRODUCT :MAP-TREE :ONCE-ONLY :RCURRY :READ-FILE-INTO-STRING :SET-EQUAL :SWITCH :TREE-MEMBER-P :UNTIL :WEAVE :WHEN-LET :WHILE :WITH-GENSYMS :ZIP) :ensure-package T :package "TEMPERANCE.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:ALIST-PLIST :ALIST-TO-HASH-TABLE :COMPOSE :CURRY :DEFINE-CONSTANT :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-KEYWORD :EQUIVALENCE-CLASSES :MAP-PRODUCT :MAP-TREE :ONCE-ONLY :RCURRY :READ-FILE-INTO-STRING :SET-EQUAL :SWITCH :TREE-MEMBER-P :UNTIL :WEAVE :WHEN-LET :WHILE :WITH-GENSYMS :ZIP) :ensure-package T :package "TEMPERANCE.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "TEMPERANCE.QUICKUTILS")
@@ -15,7 +15,7 @@
(when (boundp '*utilities*)
(setf *utilities* (union *utilities* '(:SAFE-ENDP :ALIST-PLIST
:ALIST-TO-HASH-TABLE :MAKE-GENSYM-LIST
- :ENSURE-FUNCTION :CURRY
+ :ENSURE-FUNCTION :COMPOSE :CURRY
:DEFINE-CONSTANT :ENSURE-BOOLEAN
:ENSURE-GETHASH :ENSURE-KEYWORD
:EQUIVALENCE-CLASSES :MAPPEND
@@ -84,6 +84,35 @@
(fdefinition function-designator)))
) ; eval-when
+ (defun compose (function &rest more-functions)
+ "Returns a function composed of `function` and `more-functions` that applies its ;
+arguments to to each in turn, starting from the rightmost of `more-functions`,
+and then calling the next one with the primary value of the last."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (reduce (lambda (f g)
+ (let ((f (ensure-function f))
+ (g (ensure-function g)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ (funcall f (apply g arguments)))))
+ more-functions
+ :initial-value function))
+
+ (define-compiler-macro compose (function &rest more-functions)
+ (labels ((compose-1 (funs)
+ (if (cdr funs)
+ `(funcall ,(car funs) ,(compose-1 (cdr funs)))
+ `(apply ,(car funs) arguments))))
+ (let* ((args (cons function more-functions))
+ (funs (make-gensym-list (length args) "COMPOSE")))
+ `(let ,(loop for f in funs for arg in args
+ collect `(,f (ensure-function ,arg)))
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ ,(compose-1 funs))))))
+
+
(defun curry (function &rest arguments)
"Returns a function that applies `arguments` and the arguments
it is called with to `function`."
@@ -538,10 +567,11 @@
(transpose lists))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(alist-plist plist-alist alist-to-hash-table curry define-constant
- ensure-boolean ensure-gethash ensure-keyword equivalence-classes
- map-product map-tree once-only rcurry read-file-into-string
- set-equal switch eswitch cswitch tree-member-p until weave when-let
- when-let* while with-gensyms with-unique-names zip)))
+ (export '(alist-plist plist-alist alist-to-hash-table compose curry
+ define-constant ensure-boolean ensure-gethash ensure-keyword
+ equivalence-classes map-product map-tree once-only rcurry
+ read-file-into-string set-equal switch eswitch cswitch
+ tree-member-p until weave when-let when-let* while with-gensyms
+ with-unique-names zip)))
;;;; END OF quickutils.lisp ;;;;