3d-demo.lisp

;;;; Experimenting with 3D rendering in McCLIM

(ql:quickload '(mcclim 3d-matrices 3d-vectors 3d-quaternions))

(defpackage #:3d-test
  (:use #:clim #:clime #:clim-lisp #:org.shirakumo.flare.quaternion
        #:org.shirakumo.flare.matrix #:org.shirakumo.flare.vector))

(in-package :3d-test)

(let ((p000 (vec3 -1/2 -1/2 -1/2))
      (p001 (vec3 -1/2 -1/2 1/2))
      (p010 (vec3 -1/2 1/2 -1/2))
      (p011 (vec3 -1/2 1/2 1/2))
      (p100 (vec3 1/2 -1/2 -1/2))
      (p101 (vec3 1/2 -1/2 1/2))
      (p110 (vec3 1/2 1/2 -1/2))
      (p111 (vec3 1/2 1/2 1/2)))
  (define-application-frame 3d-demo ()
    ((points :initform (list p000 p001 p010 p011 p100 p101 p110 p111)
             :accessor points)
     (lines :initform `((,p000 . ,p001)
                        (,p001 . ,p011)
                        (,p011 . ,p010)
                        (,p010 . ,p000)
                        (,p100 . ,p101)
                        (,p101 . ,p111)
                        (,p111 . ,p110)
                        (,p110 . ,p100)
                        (,p000 . ,p100)
                        (,p001 . ,p101)
                        (,p011 . ,p111)
                        (,p010 . ,p110))
            :accessor lines)
     (faces :initform `((,p000 ,p001 ,p011 ,p010)
                        (,p100 ,p101 ,p111 ,p110)
                        (,p010 ,p011 ,p111 ,p110)
                        (,p000 ,p001 ,p101 ,p100)
                        (,p001 ,p011 ,p111 ,p101)
                        (,p000 ,p010 ,p110 ,p100))
            :accessor faces)
     (dragging-p :initform nil :accessor dragging-p)
     (camera-rotation :initform (quat) :accessor camera-rotation))
    (:pointer-documentation t)
    (:menu-bar t)
    (:panes
     (app :application
          :height 400
          :width 600
          :name "App"
          :display-function 'display-3d)
     (int :interactor
          :height 200
          :width 600))
    (:layouts (default (vertically () app int)))))

(defun display-3d (frame pane)
  (with-translation (pane (* 1/2 (bounding-rectangle-width pane))
                          (* 1/2 (bounding-rectangle-height pane)))
    (with-scaling (pane 100)
      (with-accessors ((points points) (lines lines) (camera camera-rotation)
                       (faces faces))
          frame
        (flet ((transform (point) (q*v camera point)))
          (loop for face in faces
                for colour in (list +red+ +orange+ +green+ +blue+ +purple+ +yellow+
                                    +red+ +orange+ +green+ +blue+ +purple+ +yellow+)
                do (let ((transformed-point (mapcar #'transform face)))
                     (destructuring-bind (p1 p2 p3 p4) transformed-point
                       (draw-polygon* pane (list (vx p1) (vy p1)
                                                 (vx p2) (vy p2)
                                                 (vx p3) (vy p3)
                                                 (vx p4) (vy p4))
                                      :ink
                                      (compose-over (compose-in colour (make-opacity 0.5))
                                                    +background-ink+)
                                      ))))
          (loop for (point1 . point2) in lines
                for colour in #1=(list +red+ +orange+ +green+ +blue+ +purple+ +yellow+
                                       +red+ +orange+ +green+ +blue+ +purple+ +yellow+)
                do
                   (let ((transformed-point1 (q*v camera point1))
                         (transformed-point2 (q*v camera point2)))
                     (draw-line* pane
                                 (vx transformed-point1) (vy transformed-point1)
                                 (vx transformed-point2) (vy transformed-point2)
                                 :ink colour
                                 :line-thickness 5)))
          (let ((transformed-points (mapcar (lambda (point) (q*v camera point)) points)))
            (map nil (lambda (point)
                       (draw-circle* pane (vx point) (vy point) 0.05))
                 transformed-points)))))))

;; TODO Do this with subclassing instead of after methods.
;; TODO Use tracking-pointer or drag-output-record instead?
(let ((last-x 0)
      (last-y 0))
  (defmethod handle-event :after ((pane application-pane) (event pointer-motion-event))
    (when (dragging-p *application-frame*)
      (let ((displacement-x (- (pointer-event-x event) last-x))
            (displacement-y (- (pointer-event-y event) last-y)))
        ;; TODO Improve the rotation? This seems to be liable to cause camera rolling.
        (nq* (camera-rotation *application-frame*) (q* (qfrom-angle +vy+ (* -0.01 displacement-x))
                                                       (qfrom-angle +vx+ (* 0.01 displacement-y))))
        (redisplay-frame-pane *application-frame* pane)
        (setf last-x (pointer-event-x event)
              last-y (pointer-event-y event)))))

  (defmethod handle-event :after ((pane application-pane) (event pointer-button-press-event))
    (setf (dragging-p *application-frame*) t
          last-x (pointer-event-x event)
          last-y (pointer-event-y event)))

  (defmethod handle-event :after ((pane application-pane) (event pointer-button-release-event))
    (setf (dragging-p *application-frame*) nil)))

(defun 3d-demo ()
  (run-frame-top-level (make-application-frame '3d-demo)))

(3d-demo)