File: fov.lisp

package info (click to toggle)
cl-photo 0.14-1
  • links: PTS
  • area: main
  • in suites: lenny
  • size: 116 kB
  • ctags: 66
  • sloc: lisp: 739; makefile: 49; sh: 28
file content (261 lines) | stat: -rw-r--r-- 13,377 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: photo -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          fov.lisp
;;;; Purpose:       Field of view functions for cl-photo
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  April 2005
;;;;
;;;; $Id$
;;;;
;;;; This file, part of cl-photo, is Copyright (c) 2005 by Kevin M. Rosenberg
;;;;
;;;; cl-photo users are granted the rights to distribute and use this software
;;;; as governed by the terms of the GNU General Public License v2
;;;; (http://www.gnu.org/licenses/gpl.html)
;;;;
;;;; *************************************************************************

(in-package #:photo)

(defun aov-one-dim (focal-length frame-size
                                 &key (projection :rectilinear)
                                 (magnification 0))
  "Returns the angle of view in one dimension. Default is infinity which
has an magnification of 0."
  (ecase projection
    (:rectilinear
     (radians->degrees (* 2 (atan (/ frame-size 2 focal-length
                                     (1+ magnification))))))
    (:equisolid
     (radians->degrees (* 4 (asin (/ frame-size 4 focal-length)))))
    (:equidistance
     (radians->degrees (/ (* 2 frame-size) focal-length)))
    (:orthogonal
     (radians->degrees (* 2 (asin (/ frame-size 2 focal-length)))))
    (:stereographic
     (radians->degrees (* 4 (atan (/ frame-size 4 focal-length)))))
    ))


(defun aov (focal-length frame-width frame-height
                         &key (projection :rectilinear)
                         (magnification 0))
  "Returns the angle of field of view for a focal length and frame size.
Default is infinity (magnification 0)"
  (values
   (aov-one-dim focal-length frame-width :projection projection :magnification magnification)
   (aov-one-dim focal-length frame-height :projection projection :magnification magnification)
   (aov-one-dim focal-length (diagonal frame-width frame-height)
                :projection projection :magnification magnification)))

(defun gaussian-lens (&key object-distance image-distance focal-length (units :mm))
  "object-distance is in units. image-distance and focal-length are in mm."
  (cond
   ((and object-distance image-distance (not focal-length))
    ;; Return focal length
    (float (/ 1 (+ (/ 1 (length->mm object-distance units)) (/ 1 image-distance)))))
   ((and object-distance focal-length (not image-distance))
    ;; Return image distance
    (cond
     ((= focal-length (length->mm object-distance units))
        most-positive-double-float)
     ((> focal-length (length->mm object-distance units))
      :error)
     (t
      (float (/ 1 (- (/ 1 focal-length) (/ 1 (length->mm object-distance units))))))))
   ((and image-distance focal-length (not object-distance))
    ;; Return object distance
    (cond
     ((= focal-length image-distance)
        most-positive-double-float)
     ((> focal-length image-distance)
      :error)
     (t
      (mm->length (float (/ 1 (- (/ 1 focal-length) (/ 1 image-distance)))) units))))
   (t
    (error "Must specify two, and only two, of the parameters: focal-length, image-distance, object-distance"))))


(defun image-distance-magnification (focal-length magnification)
  "Returns the image distance for a focused object at distance using the Gaussian
Lens Equation."
  (* focal-length (1+ magnification)))

(defun %fov (focal-length frame-width frame-height object-distance image-distance units
                          &optional (projection :rectilinear))
  "Returns the field of view (units), magnification ratio, object-distance (units),
and image distance (mm) for a given image (mm) and object distance (mm)."
  (unless (numberp image-distance)
    (return-from %fov image-distance))
  (unless (numberp object-distance)
    (return-from %fov object-distance))
  (let ((mag (/ image-distance (length->mm object-distance units))))
    (multiple-value-bind (aov-width aov-height aov-diagonal)
        (aov focal-length frame-width frame-height :projection projection
             :magnification mag)
      (let* ((d-width (* 2 object-distance (tan (degrees->radians (/ aov-width 2)))))
             (d-height (* 2 object-distance (tan (degrees->radians (/ aov-height 2)))))
             (d-diagonal (* 2 object-distance (tan (degrees->radians (/ aov-diagonal 2))))))
        (values d-width d-height d-diagonal mag object-distance image-distance)))))

(defun fov (focal-length frame-width frame-height
                         &key object-distance image-distance magnification
                         (units :feet)
                         (projection :rectilinear))
  (cond
   ((and object-distance (not image-distance) (not magnification))
    (setq image-distance (gaussian-lens
                          :focal-length focal-length
                          :object-distance object-distance
                          :units units)))
   ((and (not object-distance) image-distance (not magnification))
    (setq object-distance (gaussian-lens
                           :focal-length focal-length
                           :image-distance image-distance
                           :units units)))
   ((and (not object-distance) (not image-distance) magnification)
    (setf image-distance (image-distance-magnification focal-length magnification)
          object-distance (when (numberp image-distance)
                            (mm->length (/ image-distance magnification) units))))
   (t
    (error "Must set one, and only one, of the parameters: image-distance, object-distance, or magnification.")))

  (%fov focal-length frame-width frame-height object-distance image-distance units
        projection))

(defun aov-format (focal-length format &key (projection :rectilinear))
  "Returns the angle of field of view for a focal length and frame size at infinity"
  (let ((dim (imager-dimensions format)))
    (aov focal-length (car dim) (cdr dim) :projection projection)))

(defun magnification (&key focal-length object-distance image-distance (units :feet))
  "Returns the image magnification: the ratio of image size to object size.
focal-length and image-distance are in mm, object-distance is in units"
  (when object-distance
    (setq object-distance (length->mm object-distance units)))
  (cond
   ((and (not focal-length) object-distance image-distance)
    (if (zerop object-distance)
        :error
      (float (/ image-distance object-distance))))
   ((and focal-length object-distance (not image-distance))
    (cond
     ((eql object-distance focal-length)
      most-positive-double-float)
     ((< object-distance focal-length)
      :error)
     (t
      (float (/ focal-length (- object-distance focal-length))))))
   ((and focal-length (not object-distance) image-distance)
    (cond
     ((eql image-distance focal-length)
      most-positive-double-float)
     ((< image-distance focal-length)
      :error)
     (t
      (float (1- (/ image-distance focal-length))))))
   (t
    (error "Must set two, and only two, of the parameters: image-distance, object-distance, and focal-length."))))

(defun close-up (&key focal-length object-distance image-distance magnification (units :feet))
  "Computes the parameters for focusing closer than infinity.
Requires two, and only two, of the input parameters.
Returns: focal-length object-distance image-distance magnification bellows-factor."
  (cond
    ((and focal-length object-distance (not image-distance) (not magnification))
     (setq magnification (magnification :focal-length focal-length
                                        :object-distance object-distance
                                        :units units))
     (setq image-distance (gaussian-lens :focal-length focal-length
                                         :object-distance object-distance
                                         :units units)))
    ((and focal-length (not object-distance) image-distance (not magnification))
     (setq magnification (magnification :focal-length focal-length
                                        :image-distance image-distance
                                        :units units))
     (setq object-distance (gaussian-lens :focal-length focal-length
                                         :image-distance image-distance
                                         :units units)))
    ((and (not focal-length) object-distance image-distance (not magnification))
     (setq magnification (magnification :object-distance object-distance
                                        :image-distance image-distance
                                        :units units))
     (setq focal-length (gaussian-lens :object-distance object-distance
                                       :image-distance image-distance
                                       :units units)))
    ((and focal-length (not object-distance) (not image-distance) magnification)
     (setq image-distance (image-distance-magnification focal-length magnification))
     (setq object-distance (gaussian-lens :focal-length focal-length
                                          :image-distance image-distance
                                          :units units)))
    ((and (not focal-length) object-distance (not image-distance) magnification)
     (setq image-distance (* magnification (length->mm object-distance units)))
     (setq focal-length (gaussian-lens :image-distance image-distance
                                       :object-distance object-distance
                                       :units units)))
    ((and (not focal-length) (not object-distance) image-distance magnification)
     (setq object-distance (mm->length (float (/ image-distance magnification)) units))
     (setq focal-length (gaussian-lens :image-distance image-distance
                                       :object-distance object-distance
                                       :units units)))
    (t
     (error "Must set two, and only two input parameters: focal-length, image-distance, object-distance, magnifcation.")))
  (values focal-length object-distance image-distance magnification (1+ magnification)))

(defun bellows-factor (focal-length object-distance)
  "Returns the bellows factor, the ratio of effective aperature to actual aperture."
  (1+ (magnification :focal-length focal-length :object-distance object-distance)))

(defun n-args-not-nil (n &rest args)
  "Returns T when count N of input args are not nil."
  (= n (count-if-not #'null args)))

(defun extension-tube (focal-length &key original-object-distance
                       original-image-distance original-magnification
                       new-object-distance new-image-distance
                       new-magnification extension-length (units :feet))
  "Computes the parameters for using extension tubes.
Requires: 1. original-object-distance, original-image-distance, or original-magnification
          2. new-object-distance, new-image-distance, new-magnification, or extension-length
Returns: original-object-distance, original-image-distance, original-magnification, original-bellows-factor
         new-object-distance, new-image-distance, new-magnification, extension-length."

  (when (or (not focal-length) (not units)
            (not (n-args-not-nil 1 original-object-distance
                                 original-image-distance
                                 original-magnification))
            (not (n-args-not-nil 1 new-object-distance
                                 new-image-distance
                                 new-magnification
                                 extension-length)))
    (error "Invalid arguments.
Must set 1 of the following original-object-distance, original-image-distance,
or original-magnification parameters as well as one of the following parameters
new-object-distance, new-image-distance, new-magnification, or extension-length."))

  (flet ((ret (ood oid om obf nod nid nm nbf e)
           (list :focal-length focal-length :original-object-distance ood
                 :original-image-distance oid :original-magnification om
                 :original-bellows-factor obf :new-object-distance nod
                 :new-image-distance nid :new-magnification nm
                 :new-bellows-factor nbf :extension-length e)))

  (multiple-value-bind (focal-length-original o-od o-id o-m o-bf)
      (close-up :focal-length focal-length :object-distance original-object-distance
                :image-distance original-image-distance :magnification original-magnification :units units)
    (declare (ignore focal-length-original))

    (cond
     (extension-length
      (multiple-value-bind (focal-length-new n-od n-id n-m n-bf)
          (close-up :focal-length focal-length :image-distance (+ o-id extension-length) :units units)
        (declare (ignore focal-length-new))
        (ret o-od o-id o-m o-bf n-od n-id n-m n-bf extension-length)))
     ((not extension-length)
      (multiple-value-bind (focal-length-new n-od n-id n-m n-bf)
          (close-up :focal-length focal-length :object-distance new-object-distance
                    :image-distance new-image-distance :magnification new-magnification :units units)
        (declare (ignore focal-length-new))
        (ret o-od o-id o-m o-bf n-od n-id n-m n-bf (- n-id o-id))))))))