# HG changeset patch # User Steve Losh # Date 1472094227 0 # Node ID 9b7638f642a082b60ca2058a3d632935236a6381 # Parent cbfb813a3f82a65b86cac71dc4f37e680b6609b2 Add PAIProlog GDL benchmark diff -r cbfb813a3f82 -r 9b7638f642a0 .hgignore --- 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 diff -r cbfb813a3f82 -r 9b7638f642a0 contrib/gdl-benchmark/README.markdown --- 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 + diff -r cbfb813a3f82 -r 9b7638f642a0 contrib/gdl-benchmark/run_paip.ros --- /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 ------------------------------------------------------------------ diff -r cbfb813a3f82 -r 9b7638f642a0 contrib/gdl-benchmark/run_temperance.ros --- 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) diff -r cbfb813a3f82 -r 9b7638f642a0 vendor/make-quickutils.lisp --- 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 diff -r cbfb813a3f82 -r 9b7638f642a0 vendor/quickutils.lisp --- 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 ;;;;