1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: photo -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Field of view functions for cl-photo
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: April 2005
12 ;;;; This file, part of cl-photo, is Copyright (c) 2005 by Kevin M. Rosenberg
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)
18 ;;;; *************************************************************************
22 (defun aov-one-dim (focal-length frame-size
23 &key (projection :rectilinear)
25 "Returns the angle of view in one dimension. Default is infinity which
26 has an magnification of 0."
29 (radians->degrees (* 2 (atan (/ frame-size 2 focal-length
30 (1+ magnification))))))
32 (radians->degrees (* 4 (asin (/ frame-size 4 focal-length)))))
34 (radians->degrees (/ (* 2 frame-size) focal-length)))
36 (radians->degrees (* 2 (asin (/ frame-size 2 focal-length)))))
38 (radians->degrees (* 4 (atan (/ frame-size 4 focal-length)))))
42 (defun aov (focal-length frame-width frame-height
43 &key (projection :rectilinear)
45 "Returns the angle of field of view for a focal length and frame size.
46 Default is infinity (magnification 0)"
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)))
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."
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
62 ((= focal-length (length->mm object-distance units))
63 most-positive-double-float)
64 ((> focal-length (length->mm object-distance units))
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
71 ((= focal-length image-distance)
72 most-positive-double-float)
73 ((> focal-length image-distance)
76 (mm->length (float (/ 1 (- (/ 1 focal-length) (/ 1 image-distance)))) units))))
78 (error "Must specify two, and only two, of the parameters: focal-length, image-distance, object-distance"))))
81 (defun image-distance-magnification (focal-length magnification)
82 "Returns the image distance for a focused object at distance using the Gaussian
84 (* focal-length (1+ magnification)))
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
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)))))
103 (defun fov (focal-length frame-width frame-height
104 &key object-distance image-distance magnification
106 (projection :rectilinear))
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
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
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))))
123 (error "Must set one, and only one, of the parameters: image-distance, object-distance, or magnification.")))
125 (%fov focal-length frame-width frame-height object-distance image-distance units
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)))
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)))
139 ((and (not focal-length) object-distance image-distance)
140 (if (zerop object-distance)
142 (float (/ image-distance object-distance))))
143 ((and focal-length object-distance (not image-distance))
145 ((eql object-distance focal-length)
146 most-positive-double-float)
147 ((< object-distance focal-length)
150 (float (/ focal-length (- object-distance focal-length))))))
151 ((and focal-length (not object-distance) image-distance)
153 ((eql image-distance focal-length)
154 most-positive-double-float)
155 ((< image-distance focal-length)
158 (float (1- (/ image-distance focal-length))))))
160 (error "Must set two, and only two, of the parameters: image-distance, object-distance, and focal-length."))))
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."
167 ((and focal-length object-distance (not image-distance) (not magnification))
168 (setq magnification (magnification :focal-length focal-length
169 :object-distance object-distance
171 (setq image-distance (gaussian-lens :focal-length focal-length
172 :object-distance object-distance
174 ((and focal-length (not object-distance) image-distance (not magnification))
175 (setq magnification (magnification :focal-length focal-length
176 :image-distance image-distance
178 (setq object-distance (gaussian-lens :focal-length focal-length
179 :image-distance image-distance
181 ((and (not focal-length) object-distance image-distance (not magnification))
182 (setq magnification (magnification :object-distance object-distance
183 :image-distance image-distance
185 (setq focal-length (gaussian-lens :object-distance object-distance
186 :image-distance image-distance
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
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
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
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)))
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)))
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)))
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."
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
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."))
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)))
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))
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))))))))