You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

213 lines
6.6 KiB

  1. (defmacro restartable (&body body)
  2. "Helper macro since we use continue restarts a lot
  3. (remember to hit C in slime or pick the restart so errors don't kill the app"
  4. `(restart-case
  5. (progn ,@body)
  6. (continue () :report "Continue")))
  7. (defun make-2d-array (h w contents)
  8. (let ((arr (make-array h)))
  9. (do ((i 0 (incf i))
  10. (rest-list contents (rest rest-list)))
  11. ((eql i h))
  12. (setf (aref arr i) (make-array w :initial-contents (car rest-list))))
  13. arr))
  14. (defparameter *n* (make-array 3 :initial-contents '(0 0 1)))
  15. (defparameter *v* (make-2d-array 24 3 '(
  16. (0.0 1 0) (-0.5 0 0.5) (0.5 0 0.5)
  17. (0.0 1 0) (0.5 0 -0.5) (-0.5 0 -0.5)
  18. (0.0 1 0) (0.5 0 0.5) (0.5 0 -0.5)
  19. (0.0 1 0) (-0.5 0 -0.5) (-0.5 0 0.5)
  20. (0.0 -1 0) (-0.5 0 0.5) (0.5 0 0.5)
  21. (0.0 -1 0) (0.5 0 -0.5) (-0.5 0 -0.5)
  22. (0.0 -1 0) (0.5 0 0.5) (0.5 0 -0.5)
  23. (0.0 -1 0) (-0.5 0 -0.5) (-0.5 0 0.5)
  24. )))
  25. (defparameter *faces* (make-2d-array 8 3 '((0 1 2) (3 4 5) (6 7 8) (9 10 11)
  26. (13 12 14) (16 15 17) (19 18 20) (22 21 23))))
  27. (defparameter *position* (make-array 3 :initial-contents
  28. '(0 0 -3)))
  29. (let ((time-units (/ 1.0 internal-time-units-per-second)))
  30. (defun wall-time (&key (offset 0))
  31. (+ (* (get-internal-real-time) time-units)
  32. offset)))
  33. (defparameter *start-time* (wall-time))
  34. (defparameter *last-time* nil)
  35. (defparameter *num-frames* 0)
  36. ;;(defparameter *t1* '( (-0.5 -0.5 0) (0 0.5 0) (0.5 -0.5 0)))
  37. (defun get-vertecies (faces)
  38. (make-array (length faces) :initial-contents
  39. (loop for i across faces collecting (aref *v* i))))
  40. (defun shift-color (time)
  41. (values
  42. ;;; red
  43. (/ (+ (* (sin (+ (* 0.3 time) 0)) 127) 128) 255)
  44. ;;; green
  45. (/ (+ (* (sin (+ (* 0.3 time) (* 2/3 PI))) 127 ) 128) 255)
  46. ;;; blue
  47. (/ (+ (* (sin (+ (* 0.3 time) (* 4/3 PI))) 127) 128) 255)))
  48. (defun make-rotation-matrix (xa ya za)
  49. (let ((sxa (sin xa))
  50. (cxa (cos xa))
  51. (sya (sin ya))
  52. (cya (cos ya))
  53. (sza (sin za))
  54. (cza (cos za)))
  55. (make-array '(3 3) :initial-contents (list (list (* cya cza) (+ (- (* cxa sza)) (* sxa sya cza)) (+ (* sxa sza) (* cxa sya cza)))
  56. (list (* cya sza) (+ (* cxa cza) (* sxa sya sza)) (+ (- (* sxa cza)) (* cxa sya sza)))
  57. (list (- sya) (* sxa cya) (* cxa cya))))))
  58. (defun rotate* (m v)
  59. (let ((result (make-array 3 :initial-element 0)))
  60. (dotimes (x 3)
  61. (dotimes (y 3)
  62. (incf (aref result x) (* (aref v y) (aref m x y)))))
  63. result))
  64. (defun translate-point (v1 v2 &optional (fn #'+))
  65. (let ((result (make-array 3)))
  66. (dotimes (i 3)
  67. (setf (aref result i) (funcall fn (aref v1 i) (aref v2 i))))
  68. result))
  69. (defun translate-triangle (tri position)
  70. (make-array (length tri) :initial-contents
  71. (loop for v across tri collecting (translate-point position v))))
  72. ;(defun rotate-vertex-2d (v rM)
  73. ; v)
  74. ;; (let ((result (lm:* rM (lm:vector (first v) (second v)))))
  75. ;; (list (lm:elt result 0) (lm:elt result 1))))
  76. ;; (let* ((x (first v))
  77. ;; (y (second v))
  78. ;; (theta (atan (if (eql 0 x) 1000000 (/ y x))))
  79. ;; (hyp (sqrt (+ (* x x) (* y y)))))
  80. ;; (list (/ (cos (+ theta time)) hyp) (/ (sin (+ theta time)) hyp) (third v))))
  81. ; (list (+ (first v) (/ (sin time) 2)) (+ (second v) (/ (cos time) 2)) (third v)))
  82. (defun rotate-triangle (tri m)
  83. (make-array (length tri) :initial-contents
  84. (loop for v across tri collecting (rotate* m v))))
  85. ; (let* ((angle (/ time 1000))
  86. ; (cos-a (cos angle))
  87. ; (sin-a (sin angle))
  88. ; (rM nil)) ;lm:make-matrix 2 2 :initial-elements
  89. ; ; '(cos-a sin-a
  90. ; ; (- sin-a) cos-a))))
  91. ; (list (append (rotate-vertex-2d (first tri) rM) '((third (firt tri))))
  92. ; (append (rotate-vertex-2d (second tri) rM) '((third (second tri))))
  93. ; (append (rotate-vertex-2d (third tri) rM) (third (third tri))))))
  94. ;
  95. (defun draw-triangle (tri time)
  96. (gl:with-primitive :triangles
  97. (multiple-value-bind (red green blue) (shift-color time)
  98. (gl:color red green blue))
  99. (let ((v (aref tri 0)))
  100. (gl:vertex (aref v 0) (aref v 1) (aref v 2)))
  101. (multiple-value-bind (green blue red) (shift-color time)
  102. (gl:color red green blue))
  103. (let ((v (aref tri 1)))
  104. (gl:vertex (aref v 0) (aref v 1) (aref v 2)))
  105. (multiple-value-bind (blue green red) (shift-color time)
  106. (gl:color red green blue))
  107. (let ((v (aref tri 2)))
  108. (gl:vertex (aref v 0) (aref v 1) (aref v 2)))))
  109. (defun draw ()
  110. "draw a frame"
  111. (let* ((time (- (wall-time) *start-time*)))
  112. (gl:clear :color-buffer-bit)
  113. ;;; draw a triangle
  114. (loop for face-list across *faces* do
  115. (let ((rt (translate-triangle (rotate-triangle (get-vertecies face-list) (make-rotation-matrix 0 (* 2 time) 0)) (rotate* (make-rotation-matrix 0 time 0) *position*))))
  116. (draw-triangle rt time)))
  117. ;; finish the frame
  118. (gl:flush)
  119. (sdl:update-display)
  120. (incf *num-frames*)
  121. (if (not (eql (floor *last-time*) (floor time)))
  122. (let* ((short-interval (- time *last-time* ))
  123. (long-interval time)
  124. (short-fps (floor (if (zerop short-interval) 0 (/ 1 short-interval))))
  125. (long-fps (floor (if (zerop long-interval) 0 (/ *num-frames* long-interval)))))
  126. (format t "FPS since last:~a since start:~a~%" short-fps long-fps)))
  127. (setf *last-time* time)))
  128. (defun reshape ()
  129. (gl:shade-model :smooth)
  130. (gl:clear-color 0 0 0 0)
  131. (gl:clear-depth 1)
  132. ; (gl:enable :depth-test)
  133. ; (gl:depth-func :lequal)
  134. (gl:enable :cull-face)
  135. (gl:hint :perspective-correction-hint :nicest)
  136. (gl:matrix-mode :projection)
  137. (gl:load-identity)
  138. (glu:perspective 50; 45 ;; FOV
  139. 1.0 ;; aspect ratio(/ width (max height 1))
  140. 1/10 ;; z near
  141. 100 ;; z far
  142. )
  143. (gl:matrix-mode :modelview)
  144. (gl:load-identity)
  145. (glu:look-at 0 2 7 ;; eye
  146. 0 0 0 ;; center
  147. 0 1 0 ;; up in y pos
  148. )
  149. )
  150. (defun init ()
  151. (setf *start-time* (wall-time))
  152. (setf *num-frames* 0)
  153. (setf *last-time* 0)
  154. (reshape)
  155. )
  156. (defun main-loop ()
  157. (init)
  158. (sdl:with-init ()
  159. (sdl:window 320 240 :flags sdl:sdl-opengl)
  160. ;; cl-opengl needs platform specific support to be able to load GL
  161. ;; extensions, so we need to tell it how to do so in lispbuilder-sdl
  162. (reshape)
  163. (setf cl-opengl-bindings:*gl-get-proc-address* #'sdl-cffi::sdl-gl-get-proc-address)
  164. (sdl:with-events ()
  165. (:quit-event () t)
  166. (:idle ()
  167. ;; this lets slime keep working while the main loop is running
  168. ;; in sbcl using the :fd-handler swank:*communication-style*
  169. ;; (something similar might help in some other lisps, not sure which though)
  170. #+(and sbcl (not sb-thread)) (restartable
  171. (sb-sys:serve-all-events 0))
  172. (restartable (draw))))))