frontend/draw-model.lisp

   1 (in-package :frontend)
   2
   3 (defmethod draw-hidden-spheres ((model sphere-model))
   4   (with-slots (centers-mm radii-mm) model
   5     (gl:with-pushed-matrix
   6       (gl:line-width 1)
   7       (let ((n 4))
   8        (loop for c in centers-mm and r in radii-mm do
   9             (gl:with-pushed-matrix
  10               (translate-v c)
  11               (let ((c .13))
  12                (gl:color c c c))
  13               (glut:solid-sphere r (* 2 n) n)
  14               (gl:color .2 .2 .2)
  15               (gl:line-width 5)
  16               (glut:wire-sphere (* 1.06 r) (* 2 n) n)
  17               (gl:color .5 .5 .5)
  18               (gl:line-width 1)
  19               (glut:wire-sphere (* 1.12 r) (* 2 n) n)))))))
  20
  21 ;; sketch of the coordinate system:
  22 ;;
  23 ;; the objective sits below the sample. its (thin) lens has a distance
  24 ;; nf to the in-focus plane. z is directed from the objective towards
  25 ;; the sample. the first slice of the stack is nearest to the
  26 ;; objective.  in the test sample the single sphere is centered on
  27 ;; slice 10, the plane of spheres is in slice 20.
  28 ;;
  29 ;;                     ^ z
  30 ;;                     |
  31 ;;                     |   /
  32 ;;               +-----+-/----+
  33 ;;       --------+-----/------+---------    z-plane-mm = z_slice * n * dz * 1d-3
  34 ;;               +---/-+------+       --  0
  35 ;;                  /  |
  36 ;;     \          /-   |               /
  37 ;;      \       /-     |              / principal
  38 ;;       -\   /-       |            /-    sphere
  39 ;;         --/         |         /--
  40 ;;           |---\     |     /---
  41 ;;           |    -----+-----------------    - nf + z-plane-mm
  42 ;;           |         |
  43 ;;           |         |
  44 ;;           |         |
  45 ;;           |         |
  46 ;;       ----+---------+-----------------   - f - nf + z-plane-mm
  47 ;;           |         |   back focal plane
  48 ;;                     |
  49
  50 (defmacro pop-until-end (l)
  51     `(if (cdr ,l)
  52          (pop ,l) ;; needs to be a macro so that pop has an effect
  53          (car ,l)))
  54
  55 (let ((rot 0)
  56       (tex nil)
  57       (new-tex nil)
  58       (scale '(300))
  59       (view-center (list (v))))
  60   (defun update-tex (data)
  61     "Supply either an image or a volume of unsigned-byte. It will be
  62 displayed as a texture."
  63     (setf new-tex data))
  64   (defun ensure-uptodate-tex ()
  65     "Call this function within an OpenGL context to check for new
  66 texture data."
  67     (when new-tex
  68       (when tex
  69         (destroy tex)
  70         (setf tex nil))
  71       (setf tex (make-instance 'texture-luminance-ub8 :data new-tex))
  72       (setf new-tex nil)))
  73   (defun update-scale (target-value &optional (steps 10))
  74     "Smooth zooming. Meant to enable viewing of the microscopic sample
  75 as well as the macroscopic objective with its back focal plane."
  76     (let* ((current (car scale)))
  77       (setf scale
  78             (loop for i from 1 upto steps collect
  79                  (let* ((x (/ (* 1d0 i) steps)))
  80                    (+ (* (- 1 x) current) (* x target-value)))))))
  81   (defun update-view-center (target-value &optional (steps 10))
  82     "Create smooth transition to different view center. This is meant
  83 to shift the current nucleus into view."
  84     (let ((current (car view-center)))
  85       (setf view-center
  86             (loop for i from 1 upto steps collect
  87                  (let* ((x (/ (* 1d0 i) steps)))
  88                    (v+ (v* current (- 1 x)) (v* target-value x)))))))
  89   (defun rotate-translate-sample-space ()
  90     "Wiggle sample around a point that has been set via
  91 update-view-center."
  92      (when (< 360 (incf rot 10))
  93        (setf rot 0))
  94      (let ((center (pop-until-end view-center))
  95            (angle (+ 120 (* 15 (expt (* .5
  96                                         (1+ (sin (* 2 pi
  97                                                     (/ rot 360)))))
  98                                      3.3)))))
  99        (translate-v center)
 100        (gl:rotate angle 0 0 1)
 101        (translate-v (v* center -1d0))))
 102   (defmethod draw ((model sphere-model) &key (nucleus 0)
 103                    (objective (lens:make-objective :normal (v 0 0 1)
 104                                                    :center (v)))
 105                    (win-x/r 0d0) (win-y/r 0d0)
 106                    (win-r/r .02d0)
 107                    (z-plane-mm (vec-z (elt
 108                                        (raytrace::centers-mm model) nucleus)))
 109                    (nr-ffp 2)
 110                    (nr-bfp 3)
 111                    (nr-theta 1))
 112     (declare (fixnum nucleus)
 113              (lens:objective objective)
 114              (double-float win-x/r win-y/r win-r/r))
 115     (gl:clear-color 1 1 1 1)
 116     (with-slots (dimensions spheres centers-mm centers dx dy dz) model
 117       (with-slots ((f lens::focal-length)
 118                    (bfp-radius lens::bfp-radius)
 119                    (center lens::center)
 120                    (na lens::numerical-aperture)
 121                    (ri lens::immersion-index)) objective
 122         (setf center (make-vec 0d0 0d0 (+ (- (* ri f)) z-plane-mm)))
 123         (destructuring-bind (z y x)
 124             dimensions
 125           (let* ((cent (elt centers-mm nucleus))
 126                  (y-mm (vec-y cent))
 127                  (ez (v 0 0 1)))
 128             (progn
 129               (gl:enable :depth-test)
 130               (let ((s (pop-until-end scale)))
 131                 (gl:scale s s s))
 132               #+nil (gl:translate 0 0 (- nf))
 133               (rotate-translate-sample-space)
 134               (draw-axes) ;; move axes into focal plane
 135               (draw-hidden-spheres model)
 136               (let ((lens (make-instance 'lens:disk :center center
 137                                          :radius bfp-radius))
 138                     (bfp (make-instance 'lens:disk :center
 139                                         (v- center (make-vec 0d0 0d0 f))
 140                                         :radius bfp-radius)))
 141                 (gl:color .4 .4 .4) ;; draw planes defining the objective
 142                 (gui::draw lens)
 143                 (gui::draw bfp))
 144               (labels ((plane (direction position)
 145                          "Define a plane that is perpendicular to
 146 an axis and crosses it at POSITION."
 147                          (declare ((member :x :y :z) direction)
 148                                   (double-float position))
 149                          (let* ((normal (ecase direction
 150                                           (:x (v 1))
 151                                           (:y (v 0 1))
 152                                           (:z (v 0 0 1)))))
 153                            (let* ((center (v* normal position))
 154                                   (outer-normal (normalize center)))
 155                              (make-instance 'lens:disk
 156                                             :radius (* ri .01)
 157                                             :normal outer-normal
 158                                             :center center)))))
 159                 (let* ((z+ 0d0)
 160                        (z- (* 1d-3 ri dz z))
 161                        (p-z (plane :z z-)) ;; slice that's furthest from objective
 162                        (x+ (* 1d-3 ri dx x))
 163                        (y+ (* 1d-3 ri dy x)))
 164                   (let* ((start (make-vec 0d0 0d0 z+)) ;; draw bounding box
 165                          (dim (make-vec x+ y+ z-)))
 166                     (gl:color .6 .6 .6)
 167                     (draw-wire-box start (v+ start dim)))
 168                   ;; rays from back focal plane through sample
 169                   (loop for (exit enter) in
 170                        (make-rays objective model nucleus
 171                                   (sample-circles nr-ffp nr-bfp nr-theta)
 172                                   win-x/r win-y/r win-r/r) do
 173                        (let ((h-z (lens:intersect exit p-z)))
 174                          (gl:line-width 3)
 175                          (gl:color .2 .6 .8)
 176                          (gl:with-primitive :line-strip
 177                            (vertex-v (vector::start enter))
 178                            (vertex-v (vector::start exit))
 179                            (vertex-v h-z))))
 180                   (let* ((ty (/ (* 1d0 (vec-i-y (elt centers 0)))
 181                                 y)))
 182                     (gl:color 1 1 1 1) ;; load and display the 3d texture
 183                     (ensure-uptodate-tex)
 184                     (when tex
 185                       (draw-xz tex x+ 0d0 z+ z- :ty ty :y y-mm))))))))))))
 186 #+nil
 187 (defparameter *look*
 188  (loop for (exit enter) in
 189       (make-rays (lens:make-objective) *model* 0 (sample-circles 2 2 1)
 190                  0d0 0d0 .1d0)
 191       collect
 192       (vector::start enter)))
 193
 194 #+nil
 195 (defparameter *look*
 196  (list (lens:make-objective) (sample-circles 2 2 2)))