fov.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: photo -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          fov.lisp
   6 ;;;; Purpose:       Field of view functions for cl-photo
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  April 2005
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of cl-photo, is Copyright (c) 2005 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; cl-photo users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the GNU General Public License v2
  16 ;;;; (http://www.gnu.org/licenses/gpl.html)
  17 ;;;;
  18 ;;;; *************************************************************************
  19
  20 (in-package #:photo)
  21
  22 (defun aov-one-dim (focal-length frame-size
  23                                  &key (projection :rectilinear)
  24                                  (magnification 0))
  25   "Returns the angle of view in one dimension. Default is infinity which
  26 has an magnification of 0."
  27   (ecase projection
  28     (:rectilinear
  29      (radians->degrees (* 2 (atan (/ frame-size 2 focal-length
  30                                      (1+ magnification))))))
  31     (:equisolid
  32      (radians->degrees (* 4 (asin (/ frame-size 4 focal-length)))))
  33     (:equidistance
  34      (radians->degrees (/ (* 2 frame-size) focal-length)))
  35     (:orthogonal
  36      (radians->degrees (* 2 (asin (/ frame-size 2 focal-length)))))
  37     (:stereographic
  38      (radians->degrees (* 4 (atan (/ frame-size 4 focal-length)))))
  39     ))
  40
  41
  42 (defun aov (focal-length frame-width frame-height
  43                          &key (projection :rectilinear)
  44                          (magnification 0))
  45   "Returns the angle of field of view for a focal length and frame size.
  46 Default is infinity (magnification 0)"
  47   (values
  48    (aov-one-dim focal-length frame-width :projection projection :magnification magnification)
  49    (aov-one-dim focal-length frame-height :projection projection :magnification magnification)
  50    (aov-one-dim focal-length (diagonal frame-width frame-height)
  51                 :projection projection :magnification magnification)))
  52
  53 (defun gaussian-lens (&key object-distance image-distance focal-length (units :mm))
  54   "object-distance is in units. image-distance and focal-length are in mm."
  55   (cond
  56    ((and object-distance image-distance (not focal-length))
  57     ;; Return focal length
  58     (float (/ 1 (+ (/ 1 (length->mm object-distance units)) (/ 1 image-distance)))))
  59    ((and object-distance focal-length (not image-distance))
  60     ;; Return image distance
  61     (cond
  62      ((= focal-length (length->mm object-distance units))
  63         most-positive-double-float)
  64      ((> focal-length (length->mm object-distance units))
  65       :error)
  66      (t
  67       (float (/ 1 (- (/ 1 focal-length) (/ 1 (length->mm object-distance units))))))))
  68    ((and image-distance focal-length (not object-distance))
  69     ;; Return object distance
  70     (cond
  71      ((= focal-length image-distance)
  72         most-positive-double-float)
  73      ((> focal-length image-distance)
  74       :error)
  75      (t
  76       (mm->length (float (/ 1 (- (/ 1 focal-length) (/ 1 image-distance)))) units))))
  77    (t
  78     (error "Must specify two, and only two, of the parameters: focal-length, image-distance, object-distance"))))
  79
  80
  81 (defun image-distance-magnification (focal-length magnification)
  82   "Returns the image distance for a focused object at distance using the Gaussian
  83 Lens Equation."
  84   (* focal-length (1+ magnification)))
  85
  86 (defun %fov (focal-length frame-width frame-height object-distance image-distance units
  87                           &optional (projection :rectilinear))
  88   "Returns the field of view (units), magnification ratio, object-distance (units),
  89 and image distance (mm) for a given image (mm) and object distance (mm)."
  90   (unless (numberp image-distance)
  91     (return-from %fov image-distance))
  92   (unless (numberp object-distance)
  93     (return-from %fov object-distance))
  94   (let ((mag (/ image-distance (length->mm object-distance units))))
  95     (multiple-value-bind (aov-width aov-height aov-diagonal)
  96         (aov focal-length frame-width frame-height :projection projection
  97              :magnification mag)
  98       (let* ((d-width (* 2 object-distance (tan (degrees->radians (/ aov-width 2)))))
  99              (d-height (* 2 object-distance (tan (degrees->radians (/ aov-height 2)))))
 100              (d-diagonal (* 2 object-distance (tan (degrees->radians (/ aov-diagonal 2))))))
 101         (values d-width d-height d-diagonal mag object-distance image-distance)))))
 102
 103 (defun fov (focal-length frame-width frame-height
 104                          &key object-distance image-distance magnification
 105                          (units :feet)
 106                          (projection :rectilinear))
 107   (cond
 108    ((and object-distance (not image-distance) (not magnification))
 109     (setq image-distance (gaussian-lens
 110                           :focal-length focal-length
 111                           :object-distance object-distance
 112                           :units units)))
 113    ((and (not object-distance) image-distance (not magnification))
 114     (setq object-distance (gaussian-lens
 115                            :focal-length focal-length
 116                            :image-distance image-distance
 117                            :units units)))
 118    ((and (not object-distance) (not image-distance) magnification)
 119     (setf image-distance (image-distance-magnification focal-length magnification)
 120           object-distance (when (numberp image-distance)
 121                             (mm->length (/ image-distance magnification) units))))
 122    (t
 123     (error "Must set one, and only one, of the parameters: image-distance, object-distance, or magnification.")))
 124
 125   (%fov focal-length frame-width frame-height object-distance image-distance units
 126         projection))
 127
 128 (defun aov-format (focal-length format &key (projection :rectilinear))
 129   "Returns the angle of field of view for a focal length and frame size at infinity"
 130   (let ((dim (imager-dimensions format)))
 131     (aov focal-length (car dim) (cdr dim) :projection projection)))
 132
 133 (defun magnification (&key focal-length object-distance image-distance (units :feet))
 134   "Returns the image magnification: the ratio of image size to object size.
 135 focal-length and image-distance are in mm, object-distance is in units"
 136   (when object-distance
 137     (setq object-distance (length->mm object-distance units)))
 138   (cond
 139    ((and (not focal-length) object-distance image-distance)
 140     (if (zerop object-distance)
 141         :error
 142       (float (/ image-distance object-distance))))
 143    ((and focal-length object-distance (not image-distance))
 144     (cond
 145      ((eql object-distance focal-length)
 146       most-positive-double-float)
 147      ((< object-distance focal-length)
 148       :error)
 149      (t
 150       (float (/ focal-length (- object-distance focal-length))))))
 151    ((and focal-length (not object-distance) image-distance)
 152     (cond
 153      ((eql image-distance focal-length)
 154       most-positive-double-float)
 155      ((< image-distance focal-length)
 156       :error)
 157      (t
 158       (float (1- (/ image-distance focal-length))))))
 159    (t
 160     (error "Must set two, and only two, of the parameters: image-distance, object-distance, and focal-length."))))
 161
 162 (defun close-up (&key focal-length object-distance image-distance magnification (units :feet))
 163   "Computes the parameters for focusing closer than infinity.
 164 Requires two, and only two, of the input parameters.
 165 Returns: focal-length object-distance image-distance magnification bellows-factor."
 166   (cond
 167     ((and focal-length object-distance (not image-distance) (not magnification))
 168      (setq magnification (magnification :focal-length focal-length
 169                                         :object-distance object-distance
 170                                         :units units))
 171      (setq image-distance (gaussian-lens :focal-length focal-length
 172                                          :object-distance object-distance
 173                                          :units units)))
 174     ((and focal-length (not object-distance) image-distance (not magnification))
 175      (setq magnification (magnification :focal-length focal-length
 176                                         :image-distance image-distance
 177                                         :units units))
 178      (setq object-distance (gaussian-lens :focal-length focal-length
 179                                          :image-distance image-distance
 180                                          :units units)))
 181     ((and (not focal-length) object-distance image-distance (not magnification))
 182      (setq magnification (magnification :object-distance object-distance
 183                                         :image-distance image-distance
 184                                         :units units))
 185      (setq focal-length (gaussian-lens :object-distance object-distance
 186                                        :image-distance image-distance
 187                                        :units units)))
 188     ((and focal-length (not object-distance) (not image-distance) magnification)
 189      (setq image-distance (image-distance-magnification focal-length magnification))
 190      (setq object-distance (gaussian-lens :focal-length focal-length
 191                                           :image-distance image-distance
 192                                           :units units)))
 193     ((and (not focal-length) object-distance (not image-distance) magnification)
 194      (setq image-distance (* magnification (length->mm object-distance units)))
 195      (setq focal-length (gaussian-lens :image-distance image-distance
 196                                        :object-distance object-distance
 197                                        :units units)))
 198     ((and (not focal-length) (not object-distance) image-distance magnification)
 199      (setq object-distance (mm->length (float (/ image-distance magnification)) units))
 200      (setq focal-length (gaussian-lens :image-distance image-distance
 201                                        :object-distance object-distance
 202                                        :units units)))
 203     (t
 204      (error "Must set two, and only two input parameters: focal-length, image-distance, object-distance, magnifcation.")))
 205   (values focal-length object-distance image-distance magnification (1+ magnification)))
 206
 207 (defun bellows-factor (focal-length object-distance)
 208   "Returns the bellows factor, the ratio of effective aperature to actual aperture."
 209   (1+ (magnification :focal-length focal-length :object-distance object-distance)))
 210
 211 (defun n-args-not-nil (n &rest args)
 212   "Returns T when count N of input args are not nil."
 213   (= n (count-if-not #'null args)))
 214
 215 (defun extension-tube (focal-length &key original-object-distance
 216                        original-image-distance original-magnification
 217                        new-object-distance new-image-distance
 218                        new-magnification extension-length (units :feet))
 219   "Computes the parameters for using extension tubes.
 220 Requires: 1. original-object-distance, original-image-distance, or original-magnification
 221           2. new-object-distance, new-image-distance, new-magnification, or extension-length
 222 Returns: original-object-distance, original-image-distance, original-magnification, original-bellows-factor
 223          new-object-distance, new-image-distance, new-magnification, extension-length."
 224
 225   (when (or (not focal-length) (not units)
 226             (not (n-args-not-nil 1 original-object-distance
 227                                  original-image-distance
 228                                  original-magnification))
 229             (not (n-args-not-nil 1 new-object-distance
 230                                  new-image-distance
 231                                  new-magnification
 232                                  extension-length)))
 233     (error "Invalid arguments.
 234 Must set 1 of the following original-object-distance, original-image-distance,
 235 or original-magnification parameters as well as one of the following parameters
 236 new-object-distance, new-image-distance, new-magnification, or extension-length."))
 237
 238   (flet ((ret (ood oid om obf nod nid nm nbf e)
 239            (list :focal-length focal-length :original-object-distance ood
 240                  :original-image-distance oid :original-magnification om
 241                  :original-bellows-factor obf :new-object-distance nod
 242                  :new-image-distance nid :new-magnification nm
 243                  :new-bellows-factor nbf :extension-length e)))
 244
 245   (multiple-value-bind (focal-length-original o-od o-id o-m o-bf)
 246       (close-up :focal-length focal-length :object-distance original-object-distance
 247                 :image-distance original-image-distance :magnification original-magnification :units units)
 248     (declare (ignore focal-length-original))
 249
 250     (cond
 251      (extension-length
 252       (multiple-value-bind (focal-length-new n-od n-id n-m n-bf)
 253           (close-up :focal-length focal-length :image-distance (+ o-id extension-length) :units units)
 254         (declare (ignore focal-length-new))
 255         (ret o-od o-id o-m o-bf n-od n-id n-m n-bf extension-length)))
 256      ((not extension-length)
 257       (multiple-value-bind (focal-length-new n-od n-id n-m n-bf)
 258           (close-up :focal-length focal-length :object-distance new-object-distance
 259                     :image-distance new-image-distance :magnification new-magnification :units units)
 260         (declare (ignore focal-length-new))
 261         (ret o-od o-id o-m o-bf n-od n-id n-m n-bf (- n-id o-id))))))))