From 4860883d5bf05e9e7c83d4f16a001e4edd1d1cb2 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Tue, 26 Apr 2005 22:59:34 +0000 Subject: [PATCH] r10471: add tests, improve fov and magnification function --- cl-photo-tests.asd | 28 ++++++++++++ convert.lisp | 4 +- dof.lisp | 7 +++ fov.lisp | 112 ++++++++++++++++++++++++++++++++++++++------- package.lisp | 2 +- tests.lisp | 45 ++++++++++++++++++ 6 files changed, 179 insertions(+), 19 deletions(-) create mode 100644 cl-photo-tests.asd create mode 100644 tests.lisp diff --git a/cl-photo-tests.asd b/cl-photo-tests.asd new file mode 100644 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 b73595b..bb50942 100644 --- 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 5dfc5dd..ee9250a 100644 --- 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 572a55b..43d000f 100644 --- 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 7a337ac..a549fdc 100644 --- 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 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 -- 2.34.1