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