File: dof.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 (159 lines) | stat: -rw-r--r-- 7,520 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
;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: photo -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          dof.lisp
;;;; Purpose:       Depth of field 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 sort-size (size)
  "Returns a cons pair with the smaller size first."
  (if (>= (car size) (cdr size))
      (cons (cdr size) (car size))
      (cons (car size) (cdr size))))

(defun print-magnification (imager-size print-size)
  "Returns the magnification required between an imager and print sizes
while taking crop into consideration."
  (setf imager-size (sort-size imager-size))
  (setf print-size (sort-size print-size))
  (float (max (/ (car print-size) (car imager-size))
              (/ (cdr print-size) (cdr print-size)))))

(defun coc (imager-size &key (lpm 5) (minimum-distance 250)
                   (viewing-distance 250)
                   (print-size (output-dimensions :8x10in)))
  "Returns circle of confusion in mm and print magnification for a format.
Default resolving power is 5 lpm at 25cm."
  (let* ((magnification (print-magnification imager-size print-size))
         (resolution-factor (/ (* magnification lpm minimum-distance) viewing-distance))
         (coc (/ 1.0d0 resolution-factor)))
    (values coc magnification)))

(defun coc-format (format &key (lpm 5) (minimum-distance 250)
                          (viewing-distance 250)
                          (print-size (output-dimensions :8x10in)))
  "Returns circle of confusion in mm and print magnification for a format.
Default resolving power is 5 lpm at 25cm."

  (let* ((format-size (imager-dimensions format))
         (format-diagonal (diagonal (car format-size) (cdr format-size)))
         (print-diagonal (diagonal (car print-size) (cdr print-size)))
         (resolution-factor (/ (* lpm print-diagonal minimum-distance)
                               (* format-diagonal viewing-distance)))
         (coc (/ 1.0d0 resolution-factor))
         (print-magnification (/ print-diagonal format-diagonal)))
    (values coc print-magnification)))

(defun coc-pixels (imager pixels)
  "Returns lpm and circle of confusion based on pixel size."
  (when (and (consp imager) (consp pixels))
    (let ((coc-w (float (* 2 (/ (car imager) (car pixels)))))
          (coc-h (float (* 2 (/ (cdr imager) (cdr pixels))))))
    (values coc-w coc-h (/ 1. coc-w) (/ 1. coc-h)))))

(defun coc-pixels-format (format)
  "Returns circle of confusion based on pixel size."
  (coc-pixels (imager-dimensions format) (pixel-dimensions format)))

(defun coc-airy (f-stop &optional (wavelength 0.000512))
  "Return the circle of confusion based on the airy disk."
  (float (/ 1 (rayleigh-limit f-stop wavelength))))

(defun rayleigh-limit (f-stop &optional (wavelength 0.0005))
  "Returns the rayleigh limit in line pairs per mm (MTF 9%) as well as the MTF50"
  (let ((rayleigh (float (/ 1 1.22 f-stop wavelength))))
    (values rayleigh (* 0.46 rayleigh))))

(defun maximum-sharpness-aperture (format &optional (wavelength 0.0005))
  (multiple-value-bind (coc-w coc-h lpm-w lpm-h) (coc-pixels-format format)
    (declare (ignore coc-w coc-h))
    (/ 1. (* 1.22 wavelength (/ (min lpm-w lpm-h) 0.46)))))

(defun dof-mm (focal-length f-stop distance coc &key (pupil-factor 1))
  "Returns depth of field based on focal-length, f-stop, distance, and coc.
Six values are returned:
near point, far point, total dof, magnification, blur size at infinity (mm).
Circle of confusion can either be a number or keyword designating format.
Reference: http://www.vanwalree.com/optics/dofderivation.html"
  (let* ((aperture (/ focal-length f-stop))
         (hyperfocal (hyperfocal focal-length f-stop coc))
         (numerator-1 (* (- pupil-factor 1) (- distance focal-length)
                         coc focal-length))
         (numerator-2 (* pupil-factor aperture focal-length distance))
         (denominator-1 (* pupil-factor coc (- distance focal-length)))
         (denominator-2 (* pupil-factor aperture focal-length))
         (near (/ (+ numerator-1 numerator-2)
                  (+ denominator-1 denominator-2)))
         (far (when (/= denominator-1 denominator-2)
                (/ (- numerator-1 numerator-2)
                   (- denominator-1 denominator-2))))
         (mag (float (/ focal-length (- distance focal-length))))
         (infinity-blur-diameter (/ (* mag focal-length) f-stop))
         (depth (when far (- far near))))
    (when (or (>= distance hyperfocal)
               (and (null far) (>= distance (* hyperfocal 0.99))))
      (setq near (/ hyperfocal 2)
            far most-positive-short-float
            depth most-positive-short-float))
    (values near far depth mag infinity-blur-diameter)))

;; Simplified calculation for symmetric lens
(defun dof-symmetric-mm (focal-length f-stop distance coc)
  "Returns depth of field based on focal-length, f-stop, distance, and coc.
Six values are returned:
near point, far point, total dof, near point, far point, magnification,
blur size at infinity (mm).
Circle of confusion can either be a number or keyword designating format."
  (let* ((aperture (/ focal-length f-stop))
         (hyperfocal (hyperfocal focal-length f-stop coc))
         (numerator (* distance coc (- distance focal-length)))
         (factor-1 (* focal-length aperture))
         (factor-2 (* coc (- distance focal-length)))
         (near (- distance (/ numerator (+ factor-1 factor-2))))
         (far (when (/= factor-1 factor-2)
                (+ distance (/ numerator (- factor-1 factor-2)))))
         (mag (magnification :focal-length focal-length :object-distance distance :units :mm))
         (infinity-blur-diameter (/ (* mag focal-length) f-stop))
         (depth (when far (- far near))))
    (when (or (>= distance hyperfocal)
               (and (null far) (>= distance (* hyperfocal 0.99))))
      (setq near (/ hyperfocal 2)
            far most-positive-short-float
            depth most-positive-short-float))
    (values near far depth mag infinity-blur-diameter)))

(defun dof (focal-length f-stop distance coc &key (units :mm) (pupil-factor 1))
  "Returns the Depth of Field.
Input: FOCAL-LENGTH, F-STOP, DISTANCE, CIRCLE-OF-CONFUSION.
Output: NEAR-POINT, FAR-POINT, TOTAL-DOF, MAGNIFICATION, BLUR-SIZE-OF-INFINITY-POINT-IN-MM."
  (multiple-value-bind (near-point far-point total-dof mag blur)
      (dof-mm focal-length f-stop (length->mm distance units) coc
              :pupil-factor pupil-factor)
    (values (mm->length near-point units)
            (mm->length far-point units)
            (mm->length total-dof units)
            mag blur)))

(defun hyperfocal (focal-length f-stop coc &key (units :mm))
  (mm->length (+ focal-length (/ (* focal-length focal-length) f-stop coc)) units))

(defun effective-aperture (focal-length distance aperture)
  (* aperture (bellows-factor focal-length distance)))

(defun mtf-scanner (freq dscan-freq &optional (order 3))
  (abs (expt (kmrcl:sinc (* pi (/ freq dscan-freq))) order)))