r10471: add tests, improve fov and magnification function

diff --git a/cl-photo-tests.asd b/cl-photo-tests.asd
new file mode 100644 (file)
index 0000000..6e9de35
--- /dev/null
+++ b/cl-photo-tests.asd
@@ -0,0 +1,28 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          cl-photo-tests.asd
+;;;; Purpose:       ASDF system definitionf for cl-photo testing package
+;;;; Author:        Kevin M. Rosenberg
+;;;; Date Started:  Apr 2003
+;;;;
+;;;; $Id$
+;;;; *************************************************************************
+
+(defpackage #:cl-photo-tests-system
+  (:use #:asdf #:cl))
+(in-package #:cl-photo-tests-system)
+
+(operate 'load-op 'cl-photo)
+
+
+(defsystem cl-photo-tests
+    :depends-on (cl-photo rt)
+    :components ((:file "tests")))
+
+(defmethod perform ((o test-op) (c (eql (find-system :cl-photo-tests))))
+  (operate 'load-op 'cl-photo)
+  (or (funcall (intern (symbol-name '#:do-tests)
+                      (find-package '#:regression-test)))
+      (error "test-op failed")))

diff --git a/convert.lisp b/convert.lisp
index b73595b56dff828f3ab74490a4d74f983a1118c3..bb5094264a051365e1573a41e413931cc9e49ded 100644 (file)
--- a/convert.lisp
+++ b/convert.lisp
@@ -55,8 +55,8 @@
   (ecase units
     (:mm d)
     (:inches (inches->mm d))
-    (:feet (* 12 (inches->mm d)))
-    (:yards (* 36 (inches->mm d)))
+    (:feet (inches->mm (* d 12)))
+    (:yards (inches->mm (* d 36)))
     (:meters (* 1000 d))))
 
 (defun mm->length (d units)

diff --git a/dof.lisp b/dof.lisp
index 5dfc5dd06e0dac523d29400f0bc58dd9f2152444..ee9250a745c0d613716cdc405e798f8a8e191019 100644 (file)
--- a/dof.lisp
+++ b/dof.lisp
@@ -70,6 +70,7 @@ Default resolving power is 5 lpm at 25cm."
 
 (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))
@@ -128,3 +129,9 @@ Output: NEAR-POINT, FAR-POINT, TOTAL-DOF, MAGNIFICATION, BLUR-SIZE-OF-INFINITY-P
 
 (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)))
+
+(defun freq-mtf-scanner (dscan-freq mtf &optional (order 3))
+  (* dscan-freq (/ (asin (* x (exp  (/ (log mtf) order)))) pi)))

diff --git a/fov.lisp b/fov.lisp
index 572a55b256652cd2e2dad18d4351de7f3fbdd6c1..43d000fa4006e5d80a928d398af975c78e40a21a 100644 (file)
--- a/fov.lisp
+++ b/fov.lisp
@@ -50,36 +50,116 @@ Default is infinity (magnification 0)"
    (aov-one-dim focal-length (diagonal frame-width frame-height)
                 :projection projection :magnification magnification)))
 
-(defun image-distance (focal-length object-distance)
+(defun gaussian-lens (&key object-distance image-distance focal-length)
+  (cond
+   ((and object-distance image-distance (not focal-length))
+    (float (/ 1 (+ (/ 1 object-distance) (/ 1 image-distance)))))
+   ((and object-distance focal-length (not image-distance))
+    (cond
+     ((= focal-length object-distance)
+        most-positive-double-float)
+     ((> focal-length object-distance)
+      :error)
+     (t
+      (float (/ 1 (- (/ 1 focal-length) (/ 1 object-distance)))))))
+   ((and image-distance focal-length (not object-distance))
+    (cond
+     ((= focal-length image-distance)
+        most-positive-double-float)
+     ((> focal-length image-distance)
+      :error)
+     (t
+      (float (/ 1 (- (/ 1 focal-length) (/ 1 image-distance)))))))
+   (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."
-  (if (= focal-length object-distance)
-      0
-    (float (/ 1 (- (/ 1 focal-length) (/ 1 object-distance))))))
+  (* focal-length (1+ magnification)))
 
-(defun fov (focal-length frame-width frame-height object-distance
-                         &key (projection :rectilinear))
-  "Returns the field of view and image magnificaion ratio at a given distance."
-  (let* ((image-distance (image-distance focal-length object-distance))
-         (magnification (/ image-distance object-distance)))
+(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 magnification)
+             :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 magnification)))))
+        (values (mm->length d-width units)
+                (mm->length d-height units)
+                (mm->length d-diagonal units)
+                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 (length->mm object-distance units))))
+   ((and (not object-distance) image-distance (not magnification))
+    (setq object-distance (mm->length (gaussian-lens
+                                       :focal-length focal-length
+                                       :image-distance image-distance)
+                                      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 (focal-length distance)
-  "Returns the image magnification: the ratio of image size to objecct size."
-  (float (/ focal-length (- distance focal-length))))
+(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 bellows-factor (focal-length distance)
+(defun bellows-factor (focal-length object-distance)
   "Returns the bellows factor, the ratio of effective aperature to actual aperture."
-  (1+ (magnification focal-length distance)))
+  (1+ (magnification :focal-length focal-length :object-distance object-distance)))
 

diff --git a/package.lisp b/package.lisp
index 7a337ac02dbb8a6794ec3616e8f385e8d589c7f8..a549fdca5fe80e504afe9528b651c4326a8e8ab3 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -38,7 +38,7 @@
    #:fov
    #:magnification
    #:bellows-factor
-   #:image-distance
+   #:gaussian-lens
 
    ;; dof.lisp
    #:coc

diff --git a/tests.lisp b/tests.lisp
new file mode 100644 (file)
index 0000000..605e288
--- /dev/null
+++ b/tests.lisp
@@ -0,0 +1,45 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          cl-photo-tests.lisp
+;;;; Purpose:       Cl-Photo tests file
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2003
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
+;;;; *************************************************************************
+
+(defpackage #:cl-photo-tests
+  (:use #:cl-photo #:cl #:rtest #:kmrcl))
+(in-package #:cl-photo-tests)
+
+(rem-all-tests)
+
+(defun verify-results (alist blist)
+  (every #'identity
+         (mapcar
+          (lambda (a b) (numbers-within-percentage a b 0.001))
+          alist blist)))
+
+(defmacro def-numeric-test (name test &rest values)
+  `(deftest ,name
+            (let ((results (multiple-value-list ,test)))
+              (verify-results results ',values))
+            t))
+
+(def-numeric-test
+ :gl.1 (gaussian-lens :focal-length 50 :object-distance 100) 100)
+
+(def-numeric-test
+ :gl.2 (gaussian-lens :focal-length 50 :image-distance 200) 66.66667)
+
+(def-numeric-test
+ :gl.3 (gaussian-lens :object-distance 100 :image-distance 100) 50)
+
+(def-numeric-test
+ :aov.1 (aov 50 36 24) 39.5977 26.9915 46.7930)
+ 
+(def-numeric-test 
\ No newline at end of file