1 (in-package #:clnl-gltk-test)
3 (defvar *checksum-location* nil)
4 (defvar *checksums* 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
12 (defvar *height* 100) ; window height
14 (defun fail-test () (setf *test-success* nil))
16 (defun find-test (name)
18 (find name *tests* :test #'string= :key #'car)
19 (error "Couldn't find test with name: ~A" name)))
21 (defun run-and-print-test (test)
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)
29 (defun run-tests (tests)
34 :for result := (run-and-print-test test)
35 :do (setf final-result (and final-result result)))
38 (defun run-all-tests ()
39 (run-tests (reverse *tests*)))
41 (defmacro defsimpletest (name test-fn debug-fn scala-prog scala-input)
44 (list ,name ,test-fn ,debug-fn ,scala-prog ,scala-input)
47 (defun test-debug (name) (format t "----~%~A~%" (funcall (third (find-test name)))))
48 (defun test-run (name) (funcall (fourth (find-test name))))
50 (defun checksum= (name sum got)
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=))))))
58 (defmacro deftest (name sum &body commands)
66 (setf *commands* (lambda () ,@commands))
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)))))
76 (setf *commands* (lambda () ,@commands))
78 (format nil "~A" (checksum-view)))
81 (setf *commands* (lambda () ,@commands))
85 (defun render-scene ()
86 (gl:clear :color-buffer-bit :depth-buffer-bit)
88 (gl:matrix-mode :projection)
89 (gl:with-pushed-matrix
91 (gl:ortho 0 100 0 100 -100 100)
92 (gl:matrix-mode :modelview)
93 (gl:with-pushed-matrix
95 (gl:matrix-mode :modelview))
96 (gl:matrix-mode :projection)))
99 (sb-int:with-float-traps-masked (:invalid :inexact :divide-by-zero :overflow :underflow)
100 (when (not *glut-window-opened*)
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))
120 (setf *glut-window-opened* t))
121 (setf *inputbox* nil)))
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)))))))
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"))
134 (format t "/usr/bin/display not found, so you need to check cl.ppm manually. Hit enter when done.")
137 (delete-file "cl.ppm")
138 (when (and filename (probe-file filename))
139 (format t "If that looks good, enter y: ")
141 (when (char= #\y (read-char))
142 (format t "Updating ~S~%" filename)
144 ((assoc-list (with-open-file (str filename) (read str nil)))
145 (assoc-pair (assoc test-name assoc-list :test #'string=)))
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)))))
152 (defun output-view-as-bzip2 ()
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))
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)
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"
167 :if-exists :supersede
168 :if-does-not-exist :create
169 :element-type '(unsigned-byte 8))
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
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))))))
181 (defun save-view-to-ppm ()
182 (with-open-file (str "cl.ppm"
184 :if-exists :supersede
185 :if-does-not-exist :create
186 :element-type '(unsigned-byte 8))
187 (save-view-to-stream str)))
189 (defun save-view-to-stream (str)
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)
196 ((image-data (export-view)))
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))))))
203 (defun export-view ()
204 (sb-int:with-float-traps-masked (:invalid)
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*)
215 (gl:read-pixels 0 0 width *height* :rgba :unsigned-byte))))
218 (sb-ext:exit :code 0 :abort t))
220 (defun reshape (width height)
221 (when (and (/= 0 width) (/= 0 height))
222 (setf *height* height)
223 (gl:viewport 0 0 width *height*)))
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)))
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))))
236 (clnl-gltk:mousemove *mouse-reactor* x (- *height* y)))
239 (cl-glut:post-redisplay))
243 (cl-glut:swap-buffers))
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))
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))
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)))