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

   1 ; Copyright 2022 Frank Duncan (frank@consxy.com) under AGPL3.  See distributed LICENSE.txt.
   2 (in-package #:clnl-gltk-test)
   3
   4 (defvar *checksum-location* nil)
   5 (defvar *checksums* nil)
   6 (defvar *tests* nil)
   7 (defvar *test-success* nil)
   8 (defvar *glut-window-opened* nil)
   9 (defvar *commands* nil)
  10 (defvar *inputbox* nil) ; this can be more generalized later when there's multiple keyboard input widgets
  11 (defvar *mouse-reactor* nil) ; like similar, but at least a little more generalized
  12
  13 (defvar *height* 100) ; window height
  14
  15 (defun fail-test () (setf *test-success* nil))
  16
  17 (defun find-test (name)
  18  (or
  19   (find name *tests* :test #'string= :key #'car)
  20   (error "Couldn't find test with name: ~A" name)))
  21
  22 (defun run-and-print-test (test)
  23  (let
  24   ((green (format nil "~c[1;32m" #\Esc))
  25    (red (format nil "~c[1;31m" #\Esc))
  26    (result (funcall (cadr test))))
  27   (format t "~A- ~S ~A~c[0m~%" (if result green red) (car test) (if result "passed" "failed") #\Esc)
  28   result))
  29
  30 (defun run-tests (tests)
  31  (let
  32   ((final-result t))
  33   (loop
  34    :for test :in tests
  35    :for result := (run-and-print-test test)
  36    :do (setf final-result (and final-result result)))
  37   final-result))
  38
  39 (defun run-all-tests ()
  40  (run-tests (reverse *tests*)))
  41
  42 (defmacro defsimpletest (name test-fn debug-fn scala-prog scala-input)
  43  `(progn
  44    (push
  45     (list ,name ,test-fn ,debug-fn ,scala-prog ,scala-input)
  46     *tests*)))
  47
  48 (defun test-debug (name) (format t "----~%~A~%" (funcall (third (find-test name)))))
  49 (defun test-run (name) (funcall (fourth (find-test name))))
  50
  51 (defun checksum= (name sum got)
  52  (or
  53   (string= got sum)
  54   (progn
  55    (when (and (not *checksums*) *checksum-location* (probe-file *checksum-location*))
  56     (setf *checksums* (with-open-file (str *checksum-location*) (read str nil))))
  57    (string= got (cdr (assoc name *checksums* :test #'string=))))))
  58
  59 (defmacro deftest (name sum &body commands)
  60  `(push
  61    (list
  62     ,name
  63     (lambda ()
  64      (let
  65       ((*test-success* t))
  66       (setup)
  67       (setf *commands* (lambda () ,@commands))
  68       (let
  69        ((result-sum (checksum-view)))
  70        (when (not (checksum= ,name ,sum result-sum))
  71         (format t "~c[1;35m-- For ~A, got ~A but expected ~A~c[0m~%" #\Esc ,name result-sum ,sum #\Esc)
  72         (format t "To verify and update, run:~%~S~%"
  73          `(clnl-gltk-test:verify-and-update ,,name ,result-sum ,*checksum-location* ',(output-view-as-bzip2))))
  74        (and *test-success* (checksum= ,name ,sum result-sum)))))
  75     (lambda ()
  76      (setup)
  77      (setf *commands* (lambda () ,@commands))
  78      (save-view-to-ppm)
  79      (format nil "~A" (checksum-view)))
  80     (lambda ()
  81      (setup)
  82      (setf *commands* (lambda () ,@commands))
  83      (run)))
  84    *tests*))
  85
  86 (defun render-scene ()
  87  (gl:clear :color-buffer-bit :depth-buffer-bit)
  88  (gl:enable :blend)
  89  (gl:matrix-mode :projection)
  90  (gl:with-pushed-matrix
  91   (gl:load-identity)
  92   (gl:ortho 0 100 0 100 -100 100)
  93   (gl:matrix-mode :modelview)
  94   (gl:with-pushed-matrix
  95    (funcall *commands*)
  96    (gl:matrix-mode :modelview))
  97   (gl:matrix-mode :projection)))
  98
  99 (defun setup ()
 100  (sb-int:with-float-traps-masked (:invalid :inexact :divide-by-zero :overflow :underflow)
 101   (when (not *glut-window-opened*)
 102    (cl-glut:init)
 103    (cl-glut:init-window-size 100 100)
 104    (cl-glut:init-display-mode :double :rgba)
 105    (cl-glut:create-window "CLNL-GLTK Test Window")
 106    (gl:clear-depth 1.0f0)
 107    (gl:depth-func :lequal)
 108    (gl:blend-func :src-alpha :one-minus-src-alpha)
 109    (gl:shade-model :smooth)
 110    (gl:clear-color 0 0 0 0)
 111    (cl-glut:display-func (cffi:get-callback 'display))
 112    (cl-glut:reshape-func (cffi:callback reshape))
 113    (cl-glut:idle-func (cffi:get-callback 'idle))
 114    (cl-glut:close-func (cffi:get-callback 'close-func))
 115    (cl-glut:keyboard-func (cffi:get-callback 'key-pressed))
 116    (cl-glut:motion-func (cffi:get-callback 'motion))
 117    (cl-glut:passive-motion-func (cffi:get-callback 'motion))
 118    (cl-glut:mouse-func (cffi:get-callback 'mouse))
 119    (cl-glut:special-func (cffi:get-callback 'special-key-pressed))
 120    (clnl-gltk:setup)
 121    (setf *glut-window-opened* t))
 122   (setf *inputbox* nil)))
 123
 124 (defun checksum-view ()
 125  (format nil "~{~2,'0X~}"
 126   (map 'list #'identity
 127    (ironclad:digest-sequence :sha1 (coerce (export-view) '(vector (unsigned-byte 8)))))))
 128
 129 (defun verify-and-update (test-name sum filename img-data)
 130  (format t "Verifying ~S, you can probably see how it should look via bin/run-test ~S~%" test-name test-name)
 131  (save-bzip2-to-ppm img-data)
 132  (if (probe-file "/usr/bin/display" )
 133   (sb-ext:run-program "/usr/bin/display" (list "cl.ppm"))
 134   (progn
 135    (format t "/usr/bin/display not found, so you need to check cl.ppm manually.  Hit enter when done.")
 136    (force-output)
 137    (read-char)))
 138  (delete-file "cl.ppm")
 139  (when (and filename (probe-file filename))
 140   (format t "If that looks good, enter y: ")
 141   (force-output)
 142   (when (char= #\y (read-char))
 143    (format t "Updating ~S~%" filename)
 144    (let*
 145     ((assoc-list (with-open-file (str filename) (read str nil)))
 146      (assoc-pair (assoc test-name assoc-list :test #'string=)))
 147     (if assoc-pair
 148      (setf (cdr assoc-pair) sum)
 149      (setf assoc-list (sort (cons (cons test-name sum) assoc-list) #'string< :key #'car)))
 150     (with-open-file (str filename :direction :output :if-exists :supersede) (prin1 assoc-list str)))))
 151  nil)
 152
 153 (defun output-view-as-bzip2 ()
 154  (let
 155   ((proc (sb-ext:run-program "/bin/bzip2" nil :input :stream :output :stream :wait nil)))
 156   (save-view-to-stream (sb-ext:process-input proc))
 157   (close (sb-ext:process-input proc))
 158   (loop
 159    :for seq = (make-array 80 :element-type '(unsigned-byte 8))
 160    :for pos = (read-sequence seq (sb-ext:process-output proc))
 161    :collect (subseq seq 0 pos)
 162    :while (= pos 80))))
 163
 164 ; You can really only use what cames out of output-view-as-bzip2
 165 (defun save-bzip2-to-ppm (bzip2-data)
 166  (with-open-file (str "cl.ppm"
 167                   :direction :output
 168                   :if-exists :supersede
 169                   :if-does-not-exist :create
 170                   :element-type '(unsigned-byte 8))
 171   (let
 172    ((proc (sb-ext:run-program "/bin/bzip2" (list "-d") :input :stream :output :stream :wait nil)))
 173    (loop :for c :in bzip2-data :do (write-sequence c (sb-ext:process-input proc)))
 174    (close (sb-ext:process-input proc))
 175    (apply #'concatenate 'vector
 176     (loop
 177      :for seq = (make-array 1024 :element-type '(unsigned-byte 8))
 178      :for pos = (read-sequence seq (sb-ext:process-output proc))
 179      :do (write-sequence (subseq seq 0 pos) str)
 180      :while (= pos 1024))))))
 181
 182 (defun save-view-to-ppm ()
 183  (with-open-file (str "cl.ppm"
 184                   :direction :output
 185                   :if-exists :supersede
 186                   :if-does-not-exist :create
 187                   :element-type '(unsigned-byte 8))
 188   (save-view-to-stream str)))
 189
 190 (defun save-view-to-stream (str)
 191  (let
 192   ((width 100)) ; hardcoded in interface, hardcoded here, cry for me
 193   (write-sequence (map 'vector #'char-code (format nil "P6~%")) str)
 194   (write-sequence (map 'vector #'char-code (format nil "~A ~A~%" width *height*)) str)
 195   (write-sequence (map 'vector #'char-code (format nil "255~%")) str)
 196   (let
 197    ((image-data (export-view)))
 198    (dotimes (i width)
 199     (dotimes (j *height*)
 200      (write-byte (aref image-data (+ 0 (* 4 (+ (* (- (1- *height*) i) width) j)))) str)
 201      (write-byte (aref image-data (+ 1 (* 4 (+ (* (- (1- *height*) i) width) j)))) str)
 202      (write-byte (aref image-data (+ 2 (* 4 (+ (* (- (1- *height*) i) width) j)))) str))))))
 203
 204 (defun export-view ()
 205  (sb-int:with-float-traps-masked (:invalid)
 206   (let
 207    ((fbo (first (gl:gen-framebuffers 1)))
 208     (render-buf (first (gl:gen-renderbuffers 1)))
 209     (width 100))  ; Hard coded for now, yay v1 (if you see this comment in a year, please cry for me)
 210    (gl:bind-framebuffer :framebuffer fbo)
 211    (gl:bind-renderbuffer :renderbuffer render-buf)
 212    (gl:renderbuffer-storage :renderbuffer :rgba8 width *height*)
 213    (gl:framebuffer-renderbuffer :draw-framebuffer :color-attachment0 :renderbuffer render-buf)
 214    (gl:viewport 0 0 width *height*)
 215    (render-scene)
 216    (gl:read-pixels 0 0 width *height* :rgba :unsigned-byte))))
 217
 218 (defun close-func ()
 219  (sb-ext:exit :code 0 :abort t))
 220
 221 (defun reshape (width height)
 222  (when (and (/= 0 width) (/= 0 height))
 223   (setf *height* height)
 224   (gl:viewport 0 0 width *height*)))
 225
 226 (defun key-pressed (key x y)
 227  (declare (ignore x y))
 228  (when (eql 27 key) (close-func))
 229  (when *inputbox* (clnl-gltk:key-pressed *inputbox* key)))
 230
 231 (defun mouse (button state x y)
 232  (declare (ignore button))
 233  (when (eql state :down) (clnl-gltk:mousedown *mouse-reactor* x (- *height* y)))
 234  (when (eql state :up) (clnl-gltk:mouseup *mouse-reactor* x (- *height* y))))
 235
 236 (defun motion (x y)
 237  (clnl-gltk:mousemove *mouse-reactor* x (- *height* y)))
 238
 239 (defun idle ()
 240  (cl-glut:post-redisplay))
 241
 242 (defun display ()
 243  (render-scene)
 244  (cl-glut:swap-buffers))
 245
 246 (cffi:defcallback display :void () (display))
 247 (cffi:defcallback key-pressed :void ((key :uchar) (x :int) (y :int)) (key-pressed key x y))
 248 (cffi:defcallback mouse :void ((button cl-glut:mouse-button) (state cl-glut:mouse-button-state) (x :int) (y :int))
 249  (mouse button state x y))
 250
 251 (cffi:defcallback motion :void ((x :int) (y :int)) (motion x y))
 252 (cffi:defcallback special-key-pressed :void ((key glut:special-keys) (x :int) (y :int)) (key-pressed key x y))
 253 (cffi:defcallback idle :void () (idle))
 254 (cffi:defcallback close-func :void () (close-func))
 255 (cffi:defcallback reshape :void ((width :int) (height :int)) (reshape width height))
 256
 257 (defun run ()
 258  ; I do this because I don't know who or what in the many layers
 259  ; is causing the floating point errors, but I definitely don't
 260  ; want to investigate until simply ignoring them becomes a problem.
 261  (sb-int:with-float-traps-masked (:invalid :inexact :divide-by-zero :overflow :underflow)
 262   (cl-glut:main-loop)))