From 42dd76880254cba467bda0aad218a98ab8ee4983 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Thu, 2 Feb 2006 20:46:04 +0000 Subject: [PATCH] r10884: not verified to be working --- fov.lisp | 46 ++++++++++++++++++++++++++++++++++++---------- 1 file changed, 36 insertions(+), 10 deletions(-) diff --git a/fov.lisp b/fov.lisp index 80c8f5b..64bbe80 100644 --- a/fov.lisp +++ b/fov.lisp @@ -208,28 +208,54 @@ Returns: focal-length object-distance image-distance magnification bellows-facto "Returns the bellows factor, the ratio of effective aperature to actual aperture." (1+ (magnification :focal-length focal-length :object-distance object-distance))) -(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)) +(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." - (multiple-value-bind (focal-length o-od o-id o-m o-bf) + (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 n-od n-id n-m n-bf) + (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) - (values o-od o-id o-m o-bf n-od n-id n-m n-bf extension-length))) + (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 n-od n-id n-m n-bf) + (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) - (values o-od o-id o-m o-bf n-od n-id n-m n-bf (- n-id o-id))))))) - - - + (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)))))))) -- 2.34.1