frontend/model.lisp

   1 (in-package :frontend)
   2
   3 (defclass sphere-model (raytrace:sphere-algebraic-model)
   4   ((spheres :accessor spheres :initarg :index-spheres
   5             :initform (make-array (list 0 0 0)
   6                                   :element-type '(complex psf:my-float))
   7             :type (simple-array (complex psf:my-float) 3))))
   8
   9 (defmethod initialize-instance :after
  10     ((model sphere-model) &key
  11      (filename-glob "/home/martin/tmp/xa*.pgm") (radius-pixels 12d0))
  12   (let ((radius-sf (coerce radius-pixels 'single-float)))
  13     (with-slots ((dx raytrace::dx)
  14                  (dy raytrace::dy)
  15                  (dz raytrace::dz)
  16                  (immersion-index raytrace::immersion-index)
  17                  (dimensions raytrace::dimensions)
  18                  (centers raytrace::centers)
  19                  (radii-mm raytrace::radii-mm)
  20                  (centers-mm raytrace::centers-mm) spheres) model
  21       (unless centers ;; read from files if centers aren't given
  22         (let* ((stack-byte (read-stack filename-glob))
  23                (dims (array-dimensions stack-byte))
  24                (stack (make-array dims :element-type '(complex my-float))))
  25          (destructuring-bind (z y x) dims
  26            (do-region ((k j i) (z y x))
  27              (setf (aref stack k j i) (complex
  28                                        (+ (* #.(coerce .43745 'my-float) k)
  29                                           (aref stack-byte k j i)))))
  30            ;; find centers of cells by convolving with sphere, actually an
  31            ;; oval because the z resolution is smaller than the transversal
  32            (let* ((conv (convolve-circ
  33                          stack
  34                          (#.(cond ((subtypep 'my-float 'single-float)
  35                                    'draw-oval-csf)
  36                                   ((subtypep 'my-float 'double-float)
  37                                    'draw-oval-cdf))
  38                             radius-sf z y x)))
  39                   (cv (convert conv 'sf 'realpart))
  40                   (rcenters nil))
  41              (save-stack-ub8 "/home/martin/tmp/stack-conv"
  42                              (normalize-3-sf/ub8 cv))
  43              (do-region ((k j i) ((- z 3) (- y 1) (- x 1)) (6 1 1))
  44                (macrolet ((c (a b c)
  45                             `(aref cv (+ k ,a) (+ j ,b) (+ i ,c))))
  46                  (let ((v (c 0 0 0)))
  47                    (when (and (< (c  0  0 -1) v) (< (c  0  0  1) v)
  48                               (< (c  0 -1  0) v) (< (c  0  1  0) v)
  49                               (< (c -1  0  0) v) (< (c  1  0  0) v))
  50                      (push (make-vec-i :z k :y j :x i) rcenters)))))
  51              (setf centers (nreverse rcenters)
  52                    dimensions dims)))))
  53      (destructuring-bind (z y x) dimensions
  54        (setf radii-mm (loop for i below (length centers) collect
  55                            (* 1d-3 immersion-index dx radius-pixels))
  56              centers-mm (mapcar #'(lambda (x)
  57                                     (let ((s (* 1d-3 immersion-index)))
  58                                       (make-vec (* s dx (vec-i-x x))
  59                                                 (* s dy (vec-i-y x))
  60                                                 (* s dz (vec-i-z x)))))
  61                                 centers)
  62              spheres (draw-ovals radius-sf centers z y x))))))
  63
  64 (defmethod print-object ((model sphere-model) stream)
  65   (with-slots (dimensions centers dx dy dz) model
  66    (format stream "<sphere-model ~dx~dx~d ~3,1fx~3,1fx~3,1f um^3 ~d nuclei>"
  67            (elt dimensions 2) (elt dimensions 1) (elt dimensions 0)
  68            (* dx (elt dimensions 2)) (* dy (elt dimensions 1)) (* dz (elt dimensions 0))
  69            (length centers))))
  70
  71 #+nil
  72 (make-instance 'sphere-model)
  73
  74 (defclass sphere-model-angular (sphere-model)
  75   (;; each nucleus drawn with its index+1
  76    (index-spheres :accessor index-spheres :initarg :index-spheres
  77                   :initform (make-array (list 0 0 0) :element-type 'my-float)
  78                   :type (simple-array my-float 3))))
  79
  80 (defmethod initialize-instance :after ((model sphere-model-angular) &key)
  81   (with-slots (dimensions centers index-spheres) model
  82    (destructuring-bind (z y x) dimensions
  83      (setf index-spheres (draw-indexed-ovals 12s0 centers z y x)))))
  84
  85 (defmethod print-object ((model sphere-model-angular) stream)
  86   (with-slots (dimensions centers dx dy dz) model
  87    (format stream "<sphere-model-angular ~dx~dx~d ~3,1fx~3,1fx~3,1f um^3 ~d nuclei>"
  88            (elt dimensions 2) (elt dimensions 1) (elt dimensions 0)
  89            (* dx (elt dimensions 2)) (* dy (elt dimensions 1)) (* dz (elt dimensions 0))
  90            (length centers))))
  91
  92 #+nil
  93 (make-instance 'sphere-model-angular)
  94
  95 (defun make-test-model ()
  96   (declare (values sphere-model-angular &optional))
  97   (let* ((centers nil)
  98          (nx 10)
  99          (ny 7)
 100          (z 20)
 101          (dx 30))
 102     (do-region ((i j) (nx ny))
 103       (let ((x (+ (floor dx 2) (* dx i)))
 104             (y (+ (floor dx 2) (* dx j))))
 105         (unless (and (= i 4) (= j 3))
 106           (push (make-vec-i :x x :y y :z z)
 107                 centers))))
 108     (push (make-vec-i :x 130 :y 100 :z 10) centers)
 109     (make-instance 'sphere-model-angular
 110                    :dimensions '(34 206 296)
 111                    :centers centers)))
 112
 113
 114 #+nil
 115 (make-test-model)