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

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