/usr/share/common-lisp/source/cl-photo/fov.lisp is in cl-photo 0.14-4.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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))))))))
|