3 (defmethod draw-hidden-spheres ((model sphere-model
))
4 (with-slots (centers-mm radii-mm
) model
8 (loop for c in centers-mm and r in radii-mm do
13 (glut:solid-sphere r
(* 2 n
) n
)
16 (glut:wire-sphere
(* 1.06 r
) (* 2 n
) n
)
19 (glut:wire-sphere
(* 1.12 r
) (* 2 n
) n
)))))))
21 ;; sketch of the coordinate system:
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
32 ;; --------+-----/------+--------- nf
40 ;; | -----+----------------- 0
45 ;; ----+---------+----------------- -f
46 ;; | | back focal plane
53 ;; call update-tex from anywhere to upload image data, the closure
54 ;; stores the data until ensure-uptodate-tex is called from within
56 (defun update-tex (data)
58 (defun ensure-uptodate-tex ()
63 (setf tex
(make-instance 'texture-luminance-ub8
:data new-tex
))
65 (defun update-scale (target-value &optional
(steps 10))
66 (let* ((current (car scale
))
67 (exponent (if (< target-value current
)
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)
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
)
88 (let* ((cent (elt centers-mm nucleus
))
94 (gl:enable
:depth-test
)
95 (when (< 360 (incf rot
10))
97 (gl:rotate
(+ 120 (* 15 (expt (* .5
101 (gl:translate
0 0 (- nf
))
102 (let ((s (if (cdr scale
)
107 (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
)))
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
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
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
))
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
)))
145 (let* ((start (make-vec 0d0
0d0 z
+))
146 (dim (make-vec x
+ y
+ (* 1d-3 ri dz z
))))
148 (draw-wire-box start
(v+ start dim
)))
150 (loop for bfp-pos in bfps and sample-pos in samples do
151 (multiple-value-bind (exit enter
)
152 (make-ray objective model
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
)))
161 (gl:with-primitive
:lines
163 (vertex-v (vector::start enter
))
164 (vertex-v (vector::start exit
))
166 (vertex-v (vector::start exit
))
174 (let* ((ty (/ (* 1d0
(vec-i-y (elt centers
0)))
176 (progn ;; load and display the 3d texture
178 (ensure-uptodate-tex)
180 (draw-xz tex x
+ 0d0 z
+ z-
:ty ty
:y y-mm
))))))))))))