code.consxy.com Git - clnl/blob - src/test/clnl/main.lisp

   1 ; Copyright 2022 Frank Duncan (frank@consxy.com) under AGPL3.  See distributed LICENSE.txt.
   2 (in-package #:clnl-test)
   3
   4 (defparameter *tests* nil)
   5
   6 (defun run-and-print-test (test)
   7  (let
   8   ((green (format nil "~c[1;32m" #\Esc))
   9    (red (format nil "~c[1;31m" #\Esc))
  10    (result (funcall (cadr test))))
  11   (format t "~A- ~S ~A~c[0m~%" (if result green red) (car test) (if result "passed" "failed") #\Esc)
  12   result))
  13
  14 (defun run-tests (tests)
  15  (let
  16   ((final-result t))
  17   (loop
  18    :for test :in tests
  19    :for result := (run-and-print-test test)
  20    :do (setf final-result (and final-result result)))
  21   final-result))
  22
  23 (defun run-all-tests ()
  24  (run-tests (reverse *tests*)))
  25
  26 (defun run-tests-matching (match)
  27  (run-tests
  28   (remove-if-not (lambda (test-name) (cl-ppcre:scan (format nil "^~A$" match) test-name)) *tests* :key #'car)))
  29
  30 (defun find-test (name)
  31  (or
  32   (find name *tests* :test #'string= :key #'car)
  33   (error "Couldn't find test with name: ~A" name)))
  34
  35 (defun test-debug (name) (format t "----~%~A~%" (funcall (third (find-test name)))))
  36 (defun test-scala-prog (name) (format t "----~%~A~%" (fourth (find-test name))))
  37 (defun test-scala-input (name) (format t "----~%~A~%" (fifth (find-test name))))
  38
  39 (defun clnl-commands (commands) (if (listp commands) (car commands) commands))
  40 (defun scala-commands (commands) (if (listp commands) (cadr commands) commands))
  41
  42 (defmacro defsimpletest (name test-fn debug-fn scala-prog scala-input)
  43  `(progn
  44    ;(when (find-test ,name) (error "Test with name ~S already exists, abort, abort" ,name))
  45    (push
  46     (list ,name ,test-fn ,debug-fn ,scala-prog ,scala-input)
  47     *tests*)))
  48
  49 (defun checksum= (expected got)
  50  (if (stringp expected)
  51   (string= got expected)
  52   (find got expected :test #'string=)))
  53
  54 ; To be used only with the simplest of tests, just a list of commands and a checksum of the
  55 ; world after they've been run.
  56 (defmacro defsimplecommandtest (name commands checksum)
  57  `(defsimpletest
  58    (format nil "Simple Command - ~A" ,name)
  59    (lambda ()
  60     (clnl:boot "resources/clnl/empty.nlogo" t)
  61     (clnl:run-commands ,commands)
  62     (checksum= ,checksum (checksum-world)))
  63    (lambda ()
  64     (clnl:boot "resources/clnl/empty.nlogo" t)
  65     (clnl:run-commands ,commands)
  66     (format nil "~A~A"
  67      (clnl-nvm:export-world)
  68      (checksum-world)))
  69    "bin/runcmd.scala"
  70    (format nil "~A~%" ,commands)))
  71
  72 (defmacro defsimplereportertest (name reporter value checksum)
  73  `(defsimpletest
  74    (format nil "Simple Reporter - ~A" ,name)
  75    (lambda ()
  76     (clnl:boot "resources/clnl/empty.nlogo" t)
  77     (and
  78      (string= (funcall (intern "DUMP-OBJECT" :clnl-nvm) (clnl:run-reporter ,reporter)) ,value)
  79      (checksum= ,checksum (checksum-world))))
  80    (lambda ()
  81     (clnl:boot "resources/clnl/empty.nlogo" t)
  82     (format nil "~A~%~A~A"
  83      (funcall (intern "DUMP-OBJECT" :clnl-nvm) (clnl:run-reporter ,reporter))
  84      (clnl-nvm:export-world)
  85      (checksum-world)))
  86    "bin/runcmd.scala"
  87    (format nil "@#$#@#$#@~A" ,reporter)))
  88
  89 (defmacro defreportertestwithsetup (name setup reporter value checksum)
  90  `(defsimpletest
  91    (format nil "Reporter With Setup - ~A" ,name)
  92    (lambda ()
  93     (clnl:boot "resources/clnl/empty.nlogo" t)
  94     (clnl:run-commands ,setup)
  95     (and
  96      (string= (funcall (intern "DUMP-OBJECT" :clnl-nvm) (clnl:run-reporter ,reporter)) ,value)
  97      (checksum= ,checksum (checksum-world))))
  98    (lambda ()
  99     (clnl:boot "resources/clnl/empty.nlogo" t)
 100     (clnl:run-commands ,setup)
 101     (format nil "~A~%~A~A"
 102      (funcall (intern "DUMP-OBJECT" :clnl-nvm) (clnl:run-reporter ,reporter))
 103      (clnl-nvm:export-world)
 104      (checksum-world)))
 105    "bin/runcmd.scala"
 106    (format nil "~A@#$#@#$#@~A" ,setup ,reporter)))
 107
 108 (defun model-code->nlogo (code)
 109  (format nil
 110   "~A
 111 @#$#@#$#@
 112 GRAPHICS-WINDOW~%210~%10~%649~%470~%-1~%-1~%13.0~%1~%10~%1~%1~%1~%0~%1~%1~%1~%-1~%1~%-1~%1~%0~%0~%1~%ticks~%30.0~%
 113 @#$#@#$#@
 114 "
 115   code))
 116
 117 (defmacro defmodeltest (name model commands reporter value checksum)
 118  `(defsimpletest
 119    ,name
 120    (lambda ()
 121     (let
 122      ((model (with-input-from-string (str ,(model-code->nlogo model)) (clnl-model:read-from-nlogo str))))
 123      (and
 124       (let
 125        ((callback nil))
 126        (declaim (sb-ext:muffle-conditions cl:warning))
 127        (eval (clnl:model->single-form-lisp model :netlogo-callback (lambda (f) (setf callback f))))
 128        (when ,commands (funcall callback ,commands))
 129        (and
 130         (or (not ,reporter) (string= (funcall (intern "DUMP-OBJECT" :clnl-nvm) (funcall callback ,reporter)) ,value))
 131         (checksum= ,checksum (checksum-world))))
 132       (let*
 133        ((pkg (make-package (gensym)))
 134         (clnl:*model-package* pkg)
 135         (prev-package *package*))
 136        (eval
 137         (cons
 138          'progn
 139          (clnl:model->multi-form-lisp model (intern "BOOT-ME" pkg)
 140           :netlogo-callback-fn (intern "NETLOGO-CALLBACK" pkg))))
 141        (eval `(in-package ,(package-name prev-package)))
 142        (funcall (symbol-function (intern "BOOT-ME" pkg)))
 143        (when ,commands (funcall (symbol-function (intern "NETLOGO-CALLBACK" pkg)) ,commands))
 144        (and
 145         (or
 146          (not ,reporter)
 147          (string=
 148           (funcall (intern "DUMP-OBJECT" :clnl-nvm) (funcall (intern "NETLOGO-CALLBACK" pkg) ,reporter))
 149           ,value))
 150         (checksum= ,checksum (checksum-world)))))))
 151    (lambda ()
 152     (let
 153      ((callback nil))
 154      (declaim (sb-ext:muffle-conditions cl:warning))
 155      (eval
 156       (clnl:model->single-form-lisp
 157        (with-input-from-string (str ,(model-code->nlogo model)) (clnl-model:read-from-nlogo str))
 158        :netlogo-callback (lambda (f) (setf callback f))))
 159      (when ,commands (funcall callback ,commands))
 160      (format nil "~A~A~A"
 161       (if ,reporter (format nil "~A~%" (funcall (intern "DUMP-OBJECT" :clnl-nvm) (funcall callback ,reporter))) "")
 162       (clnl-nvm:export-world)
 163       (checksum-world))))
 164    "bin/runcmd.scala"
 165    (format nil "~A@#$#@#$#@~A@#$#@#$#@~A" ,commands (or ,reporter "") ,model)))
 166
 167 (defmacro defmodelcommandtest (name model commands checksum)
 168  `(defmodeltest (format nil "Model Command - ~A" ,name) ,model ,commands nil nil ,checksum))
 169
 170 (defmacro defmodelreportertest (name model commands reporter value checksum)
 171  `(defmodeltest (format nil "Model Reporter - ~A" ,name) ,model ,commands ,reporter ,value ,checksum))
 172
 173 (defun wait-for-forever ()
 174  (loop
 175   :while
 176   (find-if
 177    (lambda (name) (cl-ppcre:scan "Forever button:" name))
 178    (mapcar #'sb-thread:thread-name (sb-thread:list-all-threads)))
 179   :do (sleep .1)))
 180
 181 (defmacro defmodelfiletest (name file commands checksum &optional wait-for-forever)
 182  `(defsimpletest
 183    ,(format nil "File Model - ~A" name)
 184    (lambda ()
 185     (let
 186      ((model (with-open-file (str ,file) (clnl-model:read-from-nlogo str))))
 187      (and
 188       (let
 189        ((callback nil))
 190        (declaim (sb-ext:muffle-conditions cl:warning))
 191        (eval (clnl:model->single-form-lisp model :netlogo-callback (lambda (f) (setf callback f))))
 192        (when ,(clnl-commands commands) (funcall callback ,(clnl-commands commands)))
 193        ,(when wait-for-forever `(wait-for-forever))
 194        (checksum= ,checksum (checksum-world)))
 195       (let*
 196        ((pkg (make-package (gensym)))
 197         (clnl:*model-package* pkg)
 198         (prev-package *package*))
 199        (eval
 200         (cons
 201          'progn
 202          (clnl:model->multi-form-lisp model (intern "BOOT-ME" pkg)
 203           :netlogo-callback-fn (intern "NETLOGO-CALLBACK" pkg))))
 204        (eval `(in-package ,(package-name prev-package)))
 205        (funcall (symbol-function (intern "BOOT-ME" pkg)))
 206        (when ,(clnl-commands commands)
 207         (funcall (symbol-function (intern "NETLOGO-CALLBACK" pkg)) ,(clnl-commands commands)))
 208        ,(when wait-for-forever `(wait-for-forever))
 209        (checksum= ,checksum (checksum-world))))))
 210    (lambda ()
 211     (let
 212      ((callback nil))
 213      (declaim (sb-ext:muffle-conditions cl:warning))
 214      (eval
 215       (clnl:model->single-form-lisp
 216        (with-open-file (str ,file) (clnl-model:read-from-nlogo str))
 217        :netlogo-callback (lambda (f) (setf callback f))))
 218      (when ,(clnl-commands commands) (funcall callback ,(clnl-commands commands)))
 219      ,(when wait-for-forever `(wait-for-forever))
 220      (format nil "~A~A"
 221       (clnl-nvm:export-world)
 222       (checksum-world))))
 223    "bin/runcmd.scala"
 224    (format nil "~A@#$#@#$#@@#$#@#$#@@#$#@#$#@~A" ,(scala-commands commands) ,file)))
 225
 226 (defmacro defviewtest (name commands checksum)
 227  `(defsimpletest
 228    (format nil "Simple View - ~A" ,name)
 229    (lambda ()
 230     (clnl:boot "resources/clnl/empty55.nlogo")
 231     (clnl:run-commands ,commands)
 232     (let
 233      ((viewsum (checksum-view)))
 234      (when (not (checksum= ,checksum viewsum))
 235       (format t "~c[1;35m-- For ~A, got ~A but expected ~A~c[0m~%" #\Esc ,name viewsum ,checksum #\Esc))
 236      (checksum= ,checksum (checksum-view))))
 237    (lambda ()
 238     (clnl:boot "resources/clnl/empty55.nlogo")
 239     (clnl:run-commands ,commands)
 240     (save-view-to-ppm)
 241     (format nil "~A" (checksum-view)))
 242    ""
 243    (format nil "~A~%" ,commands)))
 244
 245 (defun checksum-world ()
 246  (format nil "~{~2,'0X~}"
 247   (map 'list #'identity
 248    (ironclad:digest-sequence
 249     :sha1
 250     (map '(vector (unsigned-byte 8)) #'char-code (clnl-nvm:export-world))))))
 251
 252 (defun checksum-view ()
 253  (format nil "~{~2,'0X~}"
 254   (map 'list #'identity
 255    (ironclad:digest-sequence :sha1 (coerce (clnl-interface:export-view) '(vector (unsigned-byte 8)))))))
 256
 257 (defun save-view-to-ppm ()
 258  (let
 259   ((height 143) (width 143)) ; hardcoded in interface, hardcoded here, cry for me
 260   (with-open-file (str "cl.ppm"
 261                    :direction :output
 262                    :if-exists :supersede
 263                    :if-does-not-exist :create
 264                    :element-type '(unsigned-byte 8))
 265    (write-sequence (map 'vector #'char-code (format nil "P6~%")) str)
 266    (write-sequence (map 'vector #'char-code (format nil "143 143~%")) str)
 267    (write-sequence (map 'vector #'char-code (format nil "255~%")) str)
 268    (let
 269     ((image-data (clnl-interface:export-view)))
 270     (dotimes (i width)
 271      (dotimes (j height)
 272       (write-byte (aref image-data (+ 0 (* 4 (+ (* (- (1- height) i) width) j)))) str)
 273       (write-byte (aref image-data (+ 1 (* 4 (+ (* (- (1- height) i) width) j)))) str)
 274       (write-byte (aref image-data (+ 2 (* 4 (+ (* (- (1- height) i) width) j)))) str)))))))
 275
 276 (defun run ()
 277  (loop
 278   :for str := (progn (format t "> ") (force-output) (read-line))
 279   :while str
 280   :do
 281   (handler-case
 282    (progn
 283     (asdf:load-system :clnl-test)
 284     (run-tests-matching str))
 285    (error (e) (format t "Ok, something went wrong: ~A~%" e)))))