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 furthest from the
  26 ;; objective.
  27 ;;
  28 ;;                     ^ z
  29 ;;                     |
  30 ;;                     |   /
  31 ;;               +-----+-/----+
  32 ;;       --------+-----/------+---------    nf
  33 ;;               +---/-+------+
  34 ;;                  /  |
  35 ;;     \          /-   |               /
  36 ;;      \       /-     |              / principal
  37 ;;       -\   /-       |            /-    sphere
  38 ;;         --/         |         /--
  39 ;;           |---\     |     /---
  40 ;;           |    -----+-----------------    0
  41 ;;           |         |
  42 ;;           |         |
  43 ;;           |         |
  44 ;;           |         |
  45 ;;       ----+---------+-----------------   -f
  46 ;;           |         |   back focal plane
  47 ;;                     |
  48
  49 (defmacro pop-until-end (l)
  50     `(if (cdr ,l)
  51          (pop ,l)
  52          (car ,l)))
  53
  54 (let ((rot 0)
  55       (tex nil)
  56       (new-tex nil)
  57       (scale '(100))
  58       (view-center (list (v))))
  59   ;; call update-tex from anywhere to upload image data, the closure
  60   ;; stores the data until ensure-uptodate-tex is called from within
  61   ;; an opengl context
  62   (defun update-tex (data)
  63     (setf new-tex data))
  64   (defun ensure-uptodate-tex ()
  65     (when new-tex
  66       (when tex
  67         (destroy tex)
  68         (setf tex nil))
  69       (setf tex (make-instance 'texture-luminance-ub8 :data new-tex))
  70       (setf new-tex nil)))
  71   (defun update-scale (target-value &optional (steps 10))
  72     (let* ((current (car scale)))
  73       (setf scale
  74             (loop for i from 1 upto steps collect
  75                 (let* ((x (/ (* 1d0 i) steps)))
  76                   (+ (* (- 1 x) current) (* x target-value)))))))
  77   (defun update-view-center (target-value &optional (steps 10))
  78     (let ((current (car view-center)))
  79       (setf view-center
  80             (loop for i from 1 upto steps collect
  81                  (let* ((x (/ (* 1d0 i) steps)))
  82                    (v+ (v* current (- 1 x)) (v* target-value x)))))))
  83   (defun rotate-translate-sample-space ()
  84      (when (< 360 (incf rot 10))
  85        (setf rot 0))
  86
  87      (let ((center (pop-until-end view-center))
  88            (angle (+ 120 (* 15 (expt (* .5
  89                                         (1+ (sin (* 2 pi
  90                                                     (/ rot 360)))))
  91                                      3.3)))))
  92        (translate-v center)
  93        (gl:rotate rot #+nil angle  0 0 1)
  94        (translate-v (v* center -1d0))))
  95   (defmethod draw ((model sphere-model) &key (nucleus 0)
  96                    (objective (lens:make-objective :normal (v 0 0 1)
  97                                                    :center (v)))
  98                    (bfp-ratio-x 0d0)(bfp-ratio-y 0d0))
  99     (declare (fixnum nucleus)
 100              (lens:objective objective))
 101     (gl:clear-color .32 .3 .3 1)
 102     (with-slots (dimensions spheres centers-mm centers dx dy dz) model
 103       (with-slots ((f lens::focal-length)
 104                    (bfp-radius lens::bfp-radius)
 105                    (na lens::numerical-aperture)
 106                    (ri lens::immersion-index)) objective
 107         (destructuring-bind (z y x)
 108             dimensions
 109           (let* ((cent (elt centers-mm nucleus))
 110                  (y-mm (vec-y cent))
 111                  (z-mm (vec-z cent))
 112                  (nf (* ri f))
 113                  (ez (v 0 0 1)))
 114             (progn
 115               (gl:enable :depth-test)
 116
 117               (let ((s (pop-until-end scale)))
 118                 (gl:scale s s s))
 119
 120               (gl:translate 0 0 (- nf))
 121
 122               (rotate-translate-sample-space)
 123               (gl:with-pushed-matrix
 124                 (gl:translate 0 0 nf)
 125                 (draw-axes))
 126               (gl:with-pushed-matrix
 127                 (translate-v (v* ez (- nf z-mm)))
 128                 (draw-hidden-spheres model))
 129               (let ((lens (make-instance 'lens:disk :center (v)
 130                                          :radius bfp-radius))
 131                     (bfp (make-instance 'lens:disk :center (make-vec 0d0 0d0 (- f))
 132                                         :radius bfp-radius)))
 133                 (gl:color .4 .4 .4)
 134                 (gui::draw lens)
 135                 (gui::draw bfp))
 136               (macrolet ((plane (direction position)
 137                            ;; for defining a plane that is perpendicular to an
 138                            ;; axis and crosses it at POSITION
 139                            (declare (type (member :x :y :z) direction))
 140                            (let* ((normal (ecase direction
 141                                             (:x (v 1))
 142                                             (:y (v 0 1))
 143                                             (:z (v 0 0 1)))))
 144                              `(let* ((pos ,position)
 145                                      (center (v* ,normal pos))
 146                                      (outer-normal (normalize center)))
 147                                 (declare (type double-float pos))
 148                                 (make-instance 'lens:disk
 149                                                :radius (* ri .01)
 150                                                :normal outer-normal
 151                                                :center center)))))
 152                 (let* ((z+ (- nf z-mm))
 153                        (z- (+ nf (- (* 1d-3 ri dz z) z-mm)))
 154                        (x+ (* 1d-3 ri dx x))
 155                        (y+ (* 1d-3 ri dy x))
 156                        (p+z (plane :z z+))
 157                        (p-z (plane :z z-))
 158                        (bfps '(:left :left :right :right :top :top :bottom :bottom
 159                                :left :right :bottom :top))
 160                        (samples '(:left :right :right :left :bottom :top :bottom :top
 161                                   :center :center :center :center)))
 162                   #+nil(gui::draw p+z)
 163                   #+nil(gui::draw p-z)
 164                   (let* ((start (make-vec 0d0 0d0 z+))
 165                          (dim (make-vec x+ y+ (* 1d-3 ri dz z))))
 166                     (gl:color .6 .6 .6)
 167                     (draw-wire-box start (v+ start dim)))
 168                   (handler-case
 169                       (loop for bfp-pos in bfps and sample-pos in samples do
 170                            (multiple-value-bind (exit enter)
 171                                (make-ray objective model
 172                                          nucleus sample-pos
 173                                          bfp-ratio-x
 174                                          bfp-ratio-y
 175                                          .02d0 bfp-pos)
 176                              ;; draw light ray from back focal plane through sample
 177                              (let ((h+z (lens:intersect exit p+z))
 178                                    (h-z (lens:intersect exit p-z)))
 179                                (gl:line-width 7)
 180                                (gl:with-primitive :lines
 181                                  (gl:color .8 .3 .3)
 182                                  (vertex-v (vector::start enter))
 183                                  (vertex-v (vector::start exit))
 184
 185                                  (vertex-v (vector::start exit))
 186                                  (vertex-v h+z)
 187
 188                                  (gl:color .3 .8 .3)
 189                                  (vertex-v h+z)
 190                                  (vertex-v h-z)))))
 191                     (ray-lost () nil))
 192
 193                   (let* ((ty (/ (* 1d0 (vec-i-y (elt centers 0)))
 194                                 y)))
 195                     (progn ;; load and display the 3d texture
 196                       (gl:color 1 1 1 1)
 197                       (ensure-uptodate-tex)
 198                       (when tex
 199                         (draw-xz tex x+ 0d0 z+ z- :ty ty :y y-mm)))))))))))))