(eval-when (:compile-toplevel :load-toplevel)
(require :gl)
(require :xlib-gl))
(use-package 'cl)
;(use-package 'alien)
(use-package 'gl)
(use-package 'xlib-gl)
(use-package 'jpeg)
(defvar *animate?*)
(defvar *display* nil)
(defvar *context*)
(defvar *window*)
(defvar *debug* nil)
(defvar *height* 900)
(defvar *width* 1400)
(defvar *frame-count* 0)
(defvar v-off '(0.0 0.0 0.0 1.0))
(defvar v-lo '(0.25 0.25 0.25 1.0))
(defvar v-med '(0.5 0.5 0.5 1.0))
(defvar v-hi '(0.75 0.75 0.75 1.0))
(defvar v-on '(1.0 1.0 1.0 1.0))
(defvar *lights* (make-array 8 :initial-contents (list GL_LIGHT0 GL_LIGHT1 GL_LIGHT2 GL_LIGHT3 GL_LIGHT4 GL_LIGHT5 GL_LIGHT6 GL_LIGHT7)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun sind (x)
(coerce (sin (* x (/ pi 180.))) 'single-float))
(defun cosd (x)
(coerce (cos (* x (/ pi 180.))) 'single-float))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun make-ball (&key (r 0.2) (g 0.2) (b 0.2) (strips 8))
(let ((da (/ 90.0 strips))
(db (/ 90.0 strips))
(radius 1.0)
(color nil))
(setf r (coerce r 'single-float))
(setf g (coerce g 'single-float))
(setf b (coerce b 'single-float))
(do ((a -90.0 (+ a da))) ((> (+ a da) 90.0))
(glBegin GL_QUAD_STRIP)
(do ((c 0.0 (+ c db))) ((> c 360.0))
(if color
(glColor3f r g b)
(glColor3f 1.0 1.0 1.0))
(let ((x (* radius (cosd c) (cosd a)))
(y (* radius (sind c) (cosd a)))
(z (* radius (sind a))))
(glNormal3f x z y)
(glVertex3f x z y))
(let ((x (* radius (cosd c) (cosd (+ a da))))
(y (* radius (sind c) (cosd (+ a da))))
(z (* radius (sind (+ a da)))))
(glNormal3f x z y)
(glVertex3f x z y))
(setq color (not color)))
(glEnd))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass b3-texture ()
((data :reader data :initarg :data)
(width :reader width :initarg :width)
(height :reader height :initarg :height)))
(defun jpeg-to-texture (jpeg)
(let* ((data (alien:alien-sap (alien:slot jpeg 'data)))
(height (alien:slot jpeg 'height))
(width (alien:slot jpeg 'width))
(size (* 3 height width))
(new-data (make-array size :element-type '(unsigned-byte 8))))
(dotimes (i size)
(setf (aref new-data i) (system:sap-ref-8 data i)))
(make-instance 'b3-texture :data new-data :width width :height height)))
(defun make-jpeg-texture (fn)
(let ((jpeg (jpeg-read fn)))
(if (eql (alien:slot jpeg 'bad) 1)
(progn
(jpeg-free jpeg)
nil)
(let ((texture (jpeg-to-texture jpeg)))
(jpeg-free jpeg)
texture))))
(defun make-texture (fn)
(make-jpeg-texture fn))
(defun set-texture (texture)
(glPixelStorei GL_UNPACK_ALIGNMENT 1)
(glTexImage2D GL_TEXTURE_2D 0 3 (width texture) (height texture) 0 GL_RGB GL_UNSIGNED_BYTE (system:sap-int (system:vector-sap (data texture))))
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR)
(glTexEnvi GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE GL_MODULATE)
; (glTexEnvi GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE GL_DECAL)
(glEnable GL_TEXTURE_2D))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar *textures* ())
(defvar *texture-assets* '((girls . "textures/tex1.jpg")
(earth . "textures/earth.jpg")))
(defun get-texture (name)
(let ((pair (assoc name *textures*)))
(when (null pair)
(let ((texture (make-texture (cdr (assoc name *texture-assets*)))))
(setf pair (cons name texture))
(push pair *textures*)))
(cdr pair)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass scene-graph-node ()
((parent :accessor parent :initarg :parent :initform ())))
(defclass leaf-node (scene-graph-node))
(defclass point-node (leaf-node))
(defclass ticker-node (leaf-node)
((target :accessor target :initarg :target)
(func :accessor func :initarg :func)))
(defclass internal-node (scene-graph-node)
((child :accessor child :initarg :child)))
(defclass scene-node (internal-node)
((active-camera :accessor active-camera :initarg :active-camera :initform ())))
(defclass display-list-node (internal-node)
((display-list :accessor display-list :initarg :display-list :initform ())))
(defclass light-node (leaf-node)
((ambient :accessor ambient :initarg :ambient)
(diffuse :accessor diffuse :initarg :diffuse)
(specular :accessor specular :initarg :specular)))
(defclass camera-node (leaf-node)
((fov :accessor fov :initarg :fov)
(interest :accessor interest :initarg :interest)))
(defclass geometry-node (internal-node))
(defclass rotate-node (geometry-node)
((angle :accessor angle :initarg :angle)
(x :accessor x :initarg :x)
(y :accessor y :initarg :y)
(z :accessor z :initarg :z)))
(defclass translate-node (geometry-node)
((x :accessor x :initarg :x)
(y :accessor y :initarg :y)
(z :accessor z :initarg :z)))
(defclass scale-node (geometry-node)
((x :accessor x :initarg :x)
(y :accessor y :initarg :y)
(z :accessor z :initarg :z)))
(defclass group-node (scene-graph-node)
((children :accessor children :initarg :children :initform ())))
(defclass torus-node (leaf-node)
((inner-radius :accessor inner-radius :initarg :inner-radius)
(outer-radius :accessor outer-radius :initarg :outer-radius)
(sides :accessor sides :initarg :sides)
(rings :accessor rings :initarg :rings)))
(defclass teapot-node (leaf-node)
((size :accessor size :initarg :size)))
(defclass quadric-node (leaf-node)
((normals :accessor normals :initarg :normals :initform nil)
(use-texture :accessor use-texture :initarg :use-texture :initform nil)
(orientation :accessor orientation :initarg :orientation :initform nil)
(draw-style :accessor draw-style :initarg :draw-style :initform nil)))
(defclass cylinder-node (quadric-node)
((base-radius :accessor base-radius :initarg :base-radius)
(top-radius :accessor top-radius :initarg :top-radius)
(height :accessor height :initarg :height)
(slices :accessor slices :initarg :slices)
(stacks :accessor stacks :initarg :stacks)))
(defclass sphere-node (quadric-node)
((radius :accessor radius :initarg :radius)
(slices :accessor slices :initarg :slices)
(stacks :accessor stacks :initarg :stacks)))
(defclass partial-disk-node (quadric-node)
((inner-radius :accessor inner-radius :initarg :inner-radius)
(outer-radius :accessor outer-radius :initarg :outer-radius)
(slices :accessor slices :initarg :slices)
(loops :accessor loops :initarg :loops)
(start-angle :accessor start-angle :initarg :start-angle)
(sweep-angle :accessor sweep-angle :initarg :sweep-angle)))
(defclass texture-node (internal-node)
((data :reader data :initarg :data)))
(defclass texture-transform-node (internal-node)
((x :accessor x :initarg :x)
(y :accessor y :initarg :y)
(xsz :accessor xsz :initarg :xsz)
(ysz :accessor ysz :initarg :ysz)))
(defclass ball-node (leaf-node)
((strips :accessor strips :initarg :strips)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun set-parent (child parent)
(if (parent child)
(error "child is already parented"))
(setf (parent child) parent))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric opengl-func (node))
(defclass property-node (internal-node)
((value :accessor value :initarg :value)))
(defmacro def-property (func-name initial-value opengl-func)
(let ((class-name (intern (symbol-name (gensym (symbol-name func-name))))))
`(progn
(defclass ,class-name (property-node)
((state :accessor state :allocation :class)))
(setf (state (make-instance ',class-name)) ,initial-value)
(format t "made state for ~A~%" ',class-name)
(format t "state is ~A~%" (state (make-instance ',class-name)))
(defmethod draw ((node ,class-name))
(let ((old (state node)))
(setf (state node) (value node))
(,opengl-func (value node))
(call-next-method)
(setf (state node) old)
(,opengl-func old)))
(defun ,func-name (value child)
(let ((node (make-instance ',class-name :value value :child child)))
(set-parent child node)
node)))))
(def-property shade-model GL_FLAT glShadeModel)
(def-property mat-shininess 0.0 (lambda (v) (glMaterialf GL_FRONT GL_SHININESS v)))
(def-property mat-ambient '(0.0 0.0 0.0 1.0) (lambda (v) (glMaterialfv GL_FRONT GL_AMBIENT (make-array 4 :element-type 'single-float :initial-contents v))))
(def-property mat-diffuse '(0.0 0.0 0.0 1.0) (lambda (v) (glMaterialfv GL_FRONT GL_DIFFUSE (make-array 4 :element-type 'single-float :initial-contents v))))
(def-property mat-specular '(0.0 0.0 0.0 1.0) (lambda (v) (glMaterialfv GL_FRONT GL_SPECULAR (make-array 4 :element-type 'single-float :initial-contents v))))
(def-property mat-emission '(0.0 0.0 0.0 1.0) (lambda (v) (glMaterialfv GL_FRONT GL_EMISSION (make-array 4 :element-type 'single-float :initial-contents v))))
(defclass bool-property-node (internal-node)
((value :accessor value :initarg :value)))
(defmacro def-bool-property (func-name id)
(let ((class-name (intern (symbol-name (gensym (symbol-name func-name))))))
`(progn
(defclass ,class-name (bool-property-node)
((state :accessor state :allocation :class)))
(setf (state (make-instance ',class-name)) nil)
(format t "made state for ~A~%" ',class-name)
(format t "state is ~A~%" (state (make-instance ',class-name)))
(defmethod draw ((node ,class-name))
(let ((old (state node)))
(setf (state node) (value node))
(if (value node)
(glEnable ,id)
(glDisable ,id))
(call-next-method)
(setf (state node) old)
(if old
(glEnable ,id)
(glDisable ,id))))
(defun ,func-name (value child)
(let ((node (make-instance ',class-name :value value :child child)))
(set-parent child node)
node)))))
(def-property shade-model GL_FLAT glShadeModel)
(def-property mat-shininess 0.0 (lambda (v) (glMaterialf GL_FRONT GL_SHININESS v)))
(def-property mat-ambient '(0.0 0.0 0.0 1.0) (lambda (v) (glMaterialfv GL_FRONT GL_AMBIENT (make-array 4 :element-type 'single-float :initial-contents v))))
(def-property mat-diffuse '(0.0 0.0 0.0 1.0) (lambda (v) (glMaterialfv GL_FRONT GL_DIFFUSE (make-array 4 :element-type 'single-float :initial-contents v))))
(def-property mat-specular '(0.0 0.0 0.0 1.0) (lambda (v) (glMaterialfv GL_FRONT GL_SPECULAR (make-array 4 :element-type 'single-float :initial-contents v))))
(def-property mat-emission '(0.0 0.0 0.0 1.0) (lambda (v) (glMaterialfv GL_FRONT GL_EMISSION (make-array 4 :element-type 'single-float :initial-contents v))))
(def-bool-property lighting GL_LIGHTING)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun scene (camera child)
(let ((node (make-instance 'scene-node :active-camera camera :child child)))
(set-parent child node)
node))
(defun point-of-interest ()
(make-instance 'point-node))
(defun ticker (target func)
(make-instance 'ticker-node :target target :func func))
(defun camera (interest &key (fov 50.0d0))
(make-instance 'camera-node :interest interest :fov fov))
(defun light (&key (ambient '(0.0 0.0 0.0 0.0)) (diffuse '(0.0 0.0 0.0 0.0)) (specular '(0.0 0.0 0.0 0.0)))
(make-instance 'light-node
:ambient (make-array 4 :element-type 'single-float :initial-contents ambient)
:diffuse (make-array 4 :element-type 'single-float :initial-contents diffuse)
:specular (make-array 4 :element-type 'single-float :initial-contents specular)))
(defun material (&key ambient diffuse specular emission shininess child)
(let* ((n1 (if shininess
(mat-shininess shininess child)
child))
(n2 (if emission
(mat-emission emission n1)
n1))
(n3 (if specular
(mat-specular specular n2)
n2))
(n4 (if diffuse
(mat-diffuse diffuse n3)
n3))
(n5 (if ambient
(mat-ambient ambient n4)
n4)))
n5))
(defun compile-list (child)
(let ((node (make-instance 'display-list-node :child child)))
(set-parent child node)
node))
(defun rotate (angle x y z child)
(let ((node (make-instance 'rotate-node :angle angle :x x :y y :z z :child child)))
(set-parent child node)
node))
(defun translate (x y z child)
(let ((node (make-instance 'translate-node :x x :y y :z z :child child)))
(set-parent child node)
node))
(defun scale (x y z child)
(let ((node (make-instance 'scale-node :x x :y y :z z :child child)))
(set-parent child node)
node))
(defun group (&rest children)
(let ((node (make-instance 'group-node :children children)))
(mapc (lambda (child)
(set-parent child node))
children)
node))
(defun group-l (children)
(let ((node (make-instance 'group-node :children children)))
(mapc (lambda (child)
(set-parent child node))
children)
node))
(defun torus (inner-radius outer-radius sides rings)
(make-instance 'torus-node :inner-radius inner-radius :outer-radius outer-radius :sides sides :rings rings))
(defun teapot (size)
(make-instance 'teapot-node :size size))
(defun cylinder (base-radius top-radius height slices stacks &key normals texture)
(make-instance 'cylinder-node :base-radius base-radius :top-radius top-radius :height height :slices slices :stacks stacks :normals normals :use-texture texture))
(defun sphere (radius slices stacks &key normals texture)
(make-instance 'sphere-node :radius radius :slices slices :stacks stacks :normals normals :use-texture texture))
(defun partial-disk (inner-radius outer-radius slices loops start-angle sweep-angle &key normals texture)
(make-instance 'partial-disk-node
:inner-radius inner-radius
:outer-radius outer-radius
:slices slices
:loops loops
:start-angle start-angle
:sweep-angle sweep-angle
:normals normals :use-texture texture))
(defun texture (name child)
(let* ((texture (get-texture name))
(node (make-instance 'texture-node :data texture :child child)))
(set-parent child node)
node))
(defun texture-transform (x y xsz ysz child)
(let ((node (make-instance 'texture-transform-node :x x :y y :xsz xsz :ysz ysz :child child)))
(set-parent child node)
node))
(defun ball (strips)
(make-instance 'ball-node :strips strips))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod transform-to-world-location ((node scene-graph-node))
(if (parent node)
(transform-to-world-location (parent node)))
(transform node))
(defmethod world-location ((node scene-graph-node))
(glPushMatrix)
(glLoadIdentity)
(transform-to-world-location node)
(let ((model-matrix (make-array 16 :element-type 'single-float)))
(glgetfloatv GL_MODELVIEW_MATRIX model-matrix)
(let ((x (coerce (aref model-matrix 12) 'double-float))
(y (coerce (aref model-matrix 13) 'double-float))
(z (coerce (aref model-matrix 14) 'double-float)))
(glPopMatrix)
(values x y z))))
(defmethod world-location-f ((node scene-graph-node))
(glPushMatrix)
(glLoadIdentity)
(transform-to-world-location node)
(let ((model-matrix (make-array 16 :element-type 'single-float)))
(glgetfloatv GL_MODELVIEW_MATRIX model-matrix)
(let ((x (aref model-matrix 12))
(y (aref model-matrix 13))
(z (aref model-matrix 14)))
(glPopMatrix)
(values x y z))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod transform ((node scene-graph-node)))
(defmethod transform ((node translate-node))
(glTranslatef (coerce (x node) 'single-float)
(coerce (y node) 'single-float)
(coerce (z node) 'single-float)))
(defmethod transform ((node scale-node))
(glScalef (coerce (x node) 'single-float)
(coerce (y node) 'single-float)
(coerce (z node) 'single-float)))
(defmethod transform ((node rotate-node))
(glRotated (coerce (angle node) 'double-float)
(coerce (x node) 'double-float)
(coerce (y node) 'double-float)
(coerce (z node) 'double-float)))
(defmethod set-quadric-state ((node quadric-node) quadric)
(if (normals node)
(gluQuadricNormals quadric (normals node)))
(if (use-texture node)
(gluQuadricTexture quadric (use-texture node)))
(if (orientation node)
(gluQuadricOrientation quadric (orientation node)))
(if (draw-style node)
(gluQuadricDrawStyle quadric (draw-style node))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod get-all-lights ((node scene-graph-node))
'())
(defmethod get-all-lights ((node light-node))
(list node))
(defmethod get-all-lights ((node group-node))
(mapcan #'get-all-lights (children node)))
(defmethod get-all-lights ((node internal-node))
(get-all-lights (child node)))
(defmethod add-light ((node light-node) index)
(multiple-value-bind (x y z)
(world-location-f node)
(let ((light (aref *lights* index)))
(glEnable light)
(glLightf light GL_CONSTANT_ATTENUATION 1.0)
(glLightf light GL_LINEAR_ATTENUATION 0.0)
(glLightf light GL_QUADRATIC_ATTENUATION 0.0)
(glLightfv light GL_SPECULAR (specular node))
(glLightfv light GL_AMBIENT (ambient node))
(glLightfv light GL_DIFFUSE (diffuse node))
(glLightfv light GL_POSITION (make-array 4 :element-type 'single-float :initial-contents (list x y z 0.0))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod draw ((node leaf-node)))
(defmethod draw ((node scene-node))
(let ((camera (active-camera node))
(lights (get-all-lights node)))
(multiple-value-bind (cam-x cam-y cam-z)
(world-location camera)
(multiple-value-bind (interest-x interest-y interest-z)
(world-location (interest camera))
(glMatrixMode GL_PROJECTION)
(glLoadIdentity)
(let ((aspect (coerce (/ *width* *height*) 'double-float))
(fovy (fov camera)))
(gluPerspective fovy aspect 1d0 10000d0))
(glMatrixMode GL_MODELVIEW)
(glLoadIdentity)
(gluLookAt cam-x cam-y cam-z interest-x interest-y interest-z 0d0 1d0 0d0)))
(mapc #'add-light lights '(0 1 2 3 4 5 6 7))
(call-next-method node)))
(defmethod draw ((node internal-node))
(draw (child node)))
(defmethod draw ((node group-node))
(mapc #'draw (children node)))
(defmethod draw ((node geometry-node))
(glPushMatrix)
(transform node)
(call-next-method node)
(glPopMatrix))
(defmethod draw ((node display-list-node))
(when (null (display-list node))
(let ((list (glGenLists 1)))
(glNewList list GL_COMPILE)
(call-next-method)
(glEndList)
(setf (display-list node) list)))
(glCallList (display-list node)))
(defmethod draw ((node torus-node))
(glutSolidTorus (inner-radius node) (outer-radius node) (sides node) (rings node)))
(defmethod draw ((node teapot-node))
(glutSolidTeapot (size node)))
(defmethod draw ((node cylinder-node))
(let ((q (gluNewQuadric)))
(set-quadric-state node q)
(gluCylinder q (base-radius node) (top-radius node) (height node) (slices node) (stacks node))
(gluDeleteQuadric q)))
(defmethod draw ((node sphere-node))
(let ((q (gluNewQuadric)))
(set-quadric-state node q)
(gluSphere q (radius node) (slices node) (stacks node))
(gluDeleteQuadric q)))
(defmethod draw ((node partial-disk-node))
(let ((q (gluNewQuadric)))
(set-quadric-state node q)
(gluPartialDisk q (inner-radius node) (outer-radius node) (slices node) (loops node) (start-angle node) (sweep-angle node))
(gluDeleteQuadric q)))
(defmethod draw ((node texture-node))
(set-texture (data node))
(call-next-method))
(defmethod draw ((node texture-transform-node))
(glMatrixMode GL_TEXTURE)
(glPushMatrix)
(glTranslatef (coerce (x node) 'single-float)
(coerce (y node) 'single-float)
0.0)
(glScalef (coerce (xsz node) 'single-float)
(coerce (ysz node) 'single-float)
1.0)
(glMatrixMode GL_MODELVIEW)
(call-next-method)
(glMatrixMode GL_TEXTURE)
(glPopMatrix)
(glMatrixMode GL_MODELVIEW))
(defmethod draw ((node ball-node))
(make-ball :strips (strips node)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod tick ((node scene-graph-node)))
(defmethod tick ((node ticker-node))
(funcall (func node) (target node) (/ 1.0 60.0)))
(defmethod tick ((node group-node))
(mapc #'tick (children node)))
(defmethod tick ((node internal-node))
(tick (child node)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun reshape (width height)
(when *debug* (format t "RESHAPE. WIDTH:~a, HEIGHT:~a~%" width height))
(setf *width* width)
(setf *height* height)
(glViewport 0 0 width height))
(defmethod draw-scene ((scene scene-node))
(when *debug* (format t "Callback DRAW.~%"))
(incf *frame-count*)
(glClearColor 0.0 0.0 0.0 0.0)
(glClear GL_COLOR_BUFFER_BIT)
(glClear GL_DEPTH_BUFFER_BIT)
(draw scene)
(glFlush)
(when *debug* (format t "swapbuffers~%"))
(glXSwapBuffers *display* *window*))
(defun idle (scene)
(when *debug* (format t "Callback IDLE.~%"))
(tick scene)
(draw-scene scene))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun event-loop (scene display)
(extensions:gc)
(let ((done? nil)
(debug nil)
(event (make-xevent)))
(loop
(when *animate?*
(when debug (format t "Animate...~%"))
(loop
(idle scene)
(when (> (xpending display) 0)
(return))))
(when debug (format t "Waiting for event...~%"))
(xnextevent display event)
(let ((event-type (xanyevent-type event)))
(when debug (format t "Event:~a~%" event-type))
(cond
((eq event-type expose)
(loop ;; gobble expose events...
(when (zerop (xpending display))
(return))
(xnextevent display event)
(let ((event-type (xanyevent-type event)))
(unless (eq event-type expose)
(xputbackevent display event)
(return)))
(when debug (format t "Gobble event:~a~%" event-type)))
(draw-scene scene))
((eq event-type configurenotify) ;; resize
(reshape (xconfigureevent-width event)
(xconfigureevent-height event)))
((eq event-type buttonpress)
(let ((button (xbuttonevent-button event)))
(when debug (format t "Button:~a~%" button))
(cond ((eq button button1)
(setf *animate?* (not *animate?*)))
((eq button button2)
(format t "button2 ~A ~A!~%" (xbuttonevent-x event) (xbuttonevent-y event)))
((eq button button3)
(setf done? t)))))))
(when done? (return)))
(free-xevent event)))
(defun create-gl-window (display width height)
(let* ((screen (XDefaultScreen display))
(root (XRootWindow display screen))
(attrib (make-array 9
:element-type
#+cmu '(signed-byte 32) #-cmu 'fixnum
:initial-contents
(list GLX_RGBA GLX_RED_SIZE 1
GLX_GREEN_SIZE 1 GLX_BLUE_SIZE 1
GLX_DOUBLEBUFFER None)))
(visinfo (glXChooseVisual display screen attrib)))
(when (zerop visinfo)
(error "CREATE-GL-WINDOW: Couldn't get an RGB, double-buffered visual"))
(let ((attr (make-xsetwindowattributes)))
(set-xsetwindowattributes-background_pixel! attr 0)
(set-xsetwindowattributes-border_pixel! attr 0)
(set-xsetwindowattributes-colormap!
attr (XcreateColormap display root
(XVisualInfo-visual visinfo) AllocNone))
(set-xsetwindowattributes-event_mask!
attr (+ StructureNotifyMask ExposureMask ButtonPressMask))
(let* ((mask (+ CWBackPixel CWBorderPixel CWColormap CWEventMask))
(window (XCreateWindow display root 0 0 width height
0
(XVisualInfo-depth visinfo)
InputOutput
(XVisualInfo-visual visinfo)
mask attr))
(glxcontext (setf *context* (glXCreateContext
display visinfo NULL 1))))
(glXMakeCurrent display window glxcontext)
(XMapWindow display window)
window))))
(defun ssg-init ()
(unless *display* (setq *display* (xopendisplay "")))
(setq *window* (create-gl-window *display* *width* *height*))
; (glLightModeli GL_LIGHT_MODEL_TWO_SIDE GL_TRUE)
(glLightModeli GL_LIGHT_MODEL_TWO_SIDE GL_FALSE)
; (glLightModelfv GL_LIGHT_MODEL_AMBIENT (make-array 4 :element-type 'single-float :initial-contents '(0.0 0.0 0.0 1.0)))
;
; (glEnable GL_LIGHTING)
; (glColorMaterial
; (glEnable GL_COLOR_MATERIAL)
(glDisable GL_COLOR_MATERIAL)
;
(glDepthFunc GL_LEQUAL)
(glenable GL_DEPTH_TEST)
(gldisable GL_CULL_FACE)
(gldisable GL_DITHER)
(glshademodel GL_FLAT)
)
(defun animate (scene)
(ssg-init)
(setf *animate?* t)
(setf *frame-count* 0)
(let ((t1 (get-internal-real-time)))
(time
(unwind-protect
(event-loop scene *display*)
(glxdestroycontext *display* *context*)
(xdestroywindow *display* *window*)
;; Closing and reopening the display seems to be a problem on some systems;
;; instead flush all events so that the window will close
(let ((event (make-xevent)))
(do ()
((zerop (xpending *display*)))
(xnextevent *display* event))
(free-xevent event))))
(let ((secs (/ (- (get-internal-real-time) t1) (* internal-time-units-per-second 1.0))))
(format t "Frames: ~A (~A fps)~%" *frame-count* (/ *frame-count* secs )))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun light1 ()
(translate 0.0 200.0 0.0
(light :specular '(0.0 0.0 0.0 1.0) :diffuse '(0.0 0.0 1.0 1.0))))
(defun light2 ()
(translate -100.0 50.0 30.0
(light :specular v-med :ambient v-med :diffuse v-med)))
(defun light2-red ()
(translate -100.0 50.0 30.0
(light :specular v-med :ambient v-med :diffuse '(1.0 0.0 0.0 1.0))))
(defun light3 ()
(translate 100.0 0.0 200.0
(light :specular '(0.0 1.0 0.0 1.0)
:diffuse '(0.0 0.5 0.0 1.0))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun test1 ()
(let* ((camera-1 (camera (point-of-interest)))
(scene (scene camera-1
(lighting t
(group
(light1)
(light2-red)
(translate 0.0 0.0 15.0 camera-1)
(material :diffuse v-med :specular v-med :ambient v-lo :shininess 10.0 :child
(group (translate 4.5 0.0 0.0
(rotate -30.0 1.0 0.0 0.0 (torus 1d0 3d0 40 50)))
(translate -4.5 0.0 0.0
(rotate -30.0 1.0 0.0 0.0 (torus 1d0 3d0 40 50)))
(rotate 30.0 1.0 0.0 0.0
(torus 1d0 4.5d0 40 50)))))))))
(animate scene)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun test1a ()
(labels ((make-torus () (torus 0.4d0 1.2d0 40 40))
(make-line (f)
(group-l (mapcar (lambda (l x)
(funcall f l (translate x 0.0 0.0 (rotate -30.0 1.0 0.0 0.0 (make-torus)))))
(list v-off v-lo v-med v-hi v-on)
'( -7.0 -3.5 0.0 3.5 7.0)))))
(let* ((camera-1 (camera (point-of-interest) :fov 5.0d0))
(scene (scene camera-1
(lighting t
(group
(translate -100.0 0.0 10.0 (light :specular v-on :ambient v-on :diffuse v-on))
(translate 0.0 0.0 150.0 camera-1)
(material :specular v-lo :diffuse v-lo :ambient v-lo :child
(shade-model GL_SMOOTH
(compile-list
(group
(translate 0.0 0.0 0.0 (make-line #'mat-diffuse))
(translate 0.0 4.0 0.0 (make-line #'mat-specular))
(translate 0.0 -4.0 0.0 (make-line #'mat-ambient)))))))))))
(animate scene))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun rotating-sphere ()
(let* ((sphere
(rotate 90.0 1.0 0.0 0.0
(sphere 1d0 30 30 :normals GLU_SMOOTH :texture GL_TRUE )))
(rotator (rotate 0.0 0.0 1.0 0.0 sphere))
(spinner (ticker rotator (lambda (node delta-time)
(incf (angle node) (* 30.0 delta-time))))))
(group rotator spinner)))
(defun rotating-cylinder ()
(let* ((obj (cylinder 1d0 0d0 (* 2 PI) 30 30 :normals GLU_SMOOTH :texture GL_TRUE ))
(rotator (rotate 0.0 0.0 0.0 1.0 obj))
(spinner (ticker rotator (lambda (node delta-time)
(incf (angle node) (* 30.0 delta-time))))))
(group rotator spinner)))
(defun rotating-disk ()
(let* ((obj (partial-disk 1d0 3d0 10 10 0d0 270d0 :normals GLU_SMOOTH :texture GL_TRUE ))
(rotator (rotate 0.0 1.0 0.0 0.0 obj))
(spinner (ticker rotator (lambda (node delta-time)
(incf (angle node) (* 30.0 delta-time))))))
(group rotator spinner)))
(defun test2 ()
(let* ((poi-1 (point-of-interest))
(camera-1 (camera poi-1))
(scene (scene camera-1
(lighting nil
(texture 'girls
(group
(translate 0.0 0.0 9.0 camera-1)
(translate 2.5 2.5 0.0 (rotating-sphere))
(translate 0.0 2.5 0.0 (rotating-sphere))
(translate -2.5 2.5 0.0 (rotating-sphere))
(translate 2.5 0.0 0.0 (rotating-cylinder))
(translate 0.0 0.0 0.0 (rotating-cylinder))
(translate -2.5 0.0 0.0 (rotating-cylinder))
(translate 2.5 -2.5 0.0 (scale .3 .3 .3 (rotating-disk)))
(translate 0.0 -2.5 0.0 (scale .4 .4 .4 (rotating-disk)))
(translate -2.5 -2.5 0.0 (scale .3 .3 .3 (rotating-disk)))
poi-1))))))
(animate scene)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun test3 ()
(let* ((poi (point-of-interest))
(camera-1 (camera poi))
(day-rot (rotate 0.0 0.0 1.0 0.0
(rotate 90.0 1.0 0.0 0.0
(sphere 4d0 30 30 :normals GLU_SMOOTH :texture GL_TRUE ))))
(rotator (rotate 0.0 0.0 1.0 0.0
(translate 15.0 0.0 0.0
day-rot)))
(day-spinner (ticker day-rot (lambda (node delta-time)
(incf (angle node) (* 30.0 delta-time)))))
(year-spinner (ticker rotator (lambda (node delta-time)
(incf (angle node) (* 15.0 delta-time)))))
(scene (scene camera-1
(texture 'earth
(texture-transform 1.0 0.0 -1.0 1.0
(group camera-1
year-spinner
day-spinner
(translate 0.0 0.0 -30.0
(group poi rotator))))))))
(animate scene)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun test4 ()
(let* ((camera-1 (camera (point-of-interest) :fov 5.0d0))
(scene (scene camera-1
(lighting t
(shade-model GL_SMOOTH
(group
(light1)
(light2)
(translate 0.0 0.0 200.0 camera-1)
(material :ambient v-lo :shininess 3.0 :child
(group-l
(mapcar (lambda (specular y)
(translate 0.0 y 0.0
(mat-specular specular
(group-l
(mapcar (lambda (diffuse x)
(translate x 0.0 0.0
(mat-diffuse diffuse (teapot 1d0))))
(list v-off v-lo v-med v-hi v-on)
'(-8.0 -4.0 0.0 4.0 8.0))))))
(list v-off v-lo v-med v-hi v-on)
'(-6.0 -3.0 0.0 3.0 6.0))))))))))
(animate scene)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun test5 ()
(let* ((camera-1 (camera (point-of-interest) :fov 5.0d0))
(scene (scene camera-1
(lighting t
(shade-model GL_SMOOTH
(group
(light1)
(light2)
(translate 0.0 0.0 200.0 camera-1)
(material :ambient v-lo :shininess 100.0 :child
(group-l
(mapcar (lambda (specular y)
(translate 0.0 y 0.0
(mat-specular specular
(group-l
(mapcar (lambda (diffuse x)
(translate x 0.0 0.0
(mat-diffuse diffuse
(compile-list
(teapot 1d0)))))
(list v-off v-lo v-med v-hi v-on)
'(-8.0 -4.0 0.0 4.0 8.0))))))
(list v-off v-lo v-med v-hi v-on)
'(-6.0 -3.0 0.0 3.0 6.0))))))))))
(animate scene)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun test-all ()
(test1)
(test1a)
(test2)
(test3)
(test4)
(test5)
)