contrib/gdl-benchmark/run_paip.ros @ 221dc09d73f9

#!/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 ------------------------------------------------------------------