cl-photo-0.14/0000755000175000017500000000000010671072005012173 5ustar kevinkevincl-photo-0.14/LICENSE0000644000175000017500000000062610667175332013220 0ustar kevinkevinCL-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) CL-Photo is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. cl-photo-0.14/README0000644000175000017500000000006110667175332013064 0ustar kevinkevinSee doc/readme.html for a brief introduction. cl-photo-0.14/cl-photo-tests.asd0000644000175000017500000000157610667175332015576 0ustar kevinkevin;;;; -*- 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"))) cl-photo-0.14/cl-photo.asd0000644000175000017500000000301010667175332014417 0ustar kevinkevin;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: cl-photo.asd ;;;; Purpose: ASDF definition file for Lisp Markup Language Version 2 ;;;; 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 #:cl-user) (defpackage #:cl-photo-system (:use #:asdf #:cl)) (in-package #:cl-photo-system) (defsystem cl-photo :name "cl-photo" :author "Kevin M. Rosenberg " :version "1.0" :maintainer "Kevin M. Rosenberg " :licence "GNU General Public License" :description "Lisp Markup Language" :long-description "cl-photo calculates photography values." :depends-on (kmrcl) :components ((:file "package") (:file "convert" :depends-on ("package")) (:file "cameras" :depends-on ("convert")) (:file "fov" :depends-on ("cameras")) (:file "dof" :depends-on ("fov")) (:file "tables" :depends-on ("dof" "fov")))) (defmethod perform ((o test-op) (c (eql (find-system 'cl-photo)))) (operate 'load-op 'cl-photo-tests) (operate 'test-op 'cl-photo-tests)) cl-photo-0.14/convert.lisp0000644000175000017500000000344110667175332014562 0ustar kevinkevin;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: photo -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: convert.lisp ;;;; Purpose: Conversions 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) (defconstant +radian->degrees+ (/ 360d0 pi 2)) (defconstant +inches->mm+ 25.4d0) (declaim (inline diagonal)) (defun diagonal (x y) (sqrt (+ (* x x) (* y y)))) (declaim (inline radians->degrees)) (defun radians->degrees (r) (* +radian->degrees+ r)) (declaim (inline degrees->radians)) (defun degrees->radians (r) (/ r +radian->degrees+)) (declaim (inline mm->feet)) (defun mm->feet (d) (/ d +inches->mm+ 12)) (declaim (inline feet->mm)) (defun feet->mm (d) (* d 12 +inches->mm+)) (declaim (inline inches->mm)) (defun inches->mm (d) (* d +inches->mm+)) (declaim (inline mm->inches)) (defun mm->inches (d) (/ d +inches->mm+)) (defun length->mm (d units) "Convert a length in units to mm." (ecase units (:mm d) (:inches (inches->mm d)) (:feet (inches->mm (* d 12))) (:yards (inches->mm (* d 36))) (:meters (* 1000 d)))) (defun mm->length (d units) "Convert a number of mm to units." (ecase units (:mm d) (:inches (mm->inches d)) (:feet (/ (mm->inches d) 12)) (:yards (/ (mm->inches d) 36)) (:meters (/ d 1000)))) cl-photo-0.14/doc/0000755000175000017500000000000010667175332012754 5ustar kevinkevincl-photo-0.14/doc/Makefile0000644000175000017500000000015510667175332014415 0ustar kevinkevin.PHONY: site all clean all: site site: clisp -i "`pwd`/make.lisp" clean: @rm -f *~ \#*\# .\#* memdump cl-photo-0.14/doc/make.lisp0000644000175000017500000000024410667175332014562 0ustar kevinkevin#+cmu (setq ext:*gc-verbose* nil) (asdf:operate 'asdf:load-op 'lml2) (in-package #:lml2) (let ((cwd (parse-namestring (lml-cwd)))) (process-dir cwd)) (lml-quit) cl-photo-0.14/doc/readme.html0000644000175000017500000000432710671072004015070 0ustar kevinkevin CL-PHOTO README

CL-Photo Documentation

Overview

CL-Photo is a Common Lisp package for calculation functions used in photography. CL-Photo is written and Copyright © 2005 by Kevin Rosenberg.

The home page for CL-Photo is http://files.b9.com/cl-photo.

Prerequisites

Installation

The easiest way to install CL-Photo is to use the Debian GNU/Linux operating system. You can then use the command apt-get install cl-photo to automatically download and install the CL-Photo package.

On a non-Debian system, you need to have ASDF installed to load the system definition file. You will need to change the source pathname in the system file to match the location where you have installed CL-Photo.

Usage

Currently, there is no documentation on the functions provided by CL-Photo. However, the source code is instructive.

cl-photo-0.14/doc/readme.lml0000755000175000017500000000470210667175332014725 0ustar kevinkevin;;; -*- Mode: Lisp -*- (in-package #:lml2) (html-file-page ("readme") (html (:head (:title "CL-PHOTO README") ((:meta :http-equiv "Content-Type" :content "text/html; charset=iso-8859-1")) ((:meta :name "Copyright" :content "Kevin Rosenberg 2002 ")) ((:meta :name "description" :content "CL-Photo Documentation")) ((:meta :name "author" :content "Kevin Rosenberg")) ((:meta :name "keywords" :content "Common Lisp, Photography, Calculator"))) (:body (:h1 "CL-Photo Documentation") (:h2 "Overview") (:p ((:a :href "http://files.b9.com/cl-photo/") "CL-Photo") " is a Common Lisp package for calculation functions used in photography. " ((:a :href "http://files.b9.com/cl-photo") "CL-Photo") " is written and Copyright © 2005 by " ((:a :href "mailto:kevin@rosenberg.net") "Kevin Rosenberg") ".") (:p "The home page for CL-Photo is " ((:a :href "http://files.b9.com/cl-photo") "http://files.b9.com/cl-photo") ".") (:h2 "Prerequisites") (:ul (:li ((:a :href "http://cliki.net/asdf") "ASDF")) (:h2 "References") (:ul (:li ((:a :href "http://www.normankoren.com/Tutorials/MTF.html") "http://www.normankoren.com/Tutorials/MTF.html")) (:li ((:a :href "http://www.vanwalree.com/optics/dofderivation.html") "http://www.vanwalree.com/optics/dofderivation.html")) (:li ((:a :href "http://www.photo.net/learn/optics/lensFAQ") "http://www.photo.net/learn/optics/lensFAQ")) (:li ((:a :href "http://www.mhohner.de/formulas.php") "http://www.mhohner.de/formulas.php")) )) (:h2 "Installation") (:p "The easiest way to install CL-Photo is to use the " ((:a :href "http://www.debian.org/") "Debian") " GNU/Linux operating system. You can then use the command " (:tt "apt-get install cl-photo") " to automatically download and install the CL-Photo package.") (:p "On a non-Debian system, you need to have " ((:a :href "http://cclan.sourceforge.net/") "ASDF") " installed to load the system definition file. You will need to change the source pathname in the system file to match the location where you have installed CL-Photo.") (:h2 "Usage") (:p "Currently, there is no documentation on the functions provided by CL-Photo. However, the source code is instructive.") ))) cl-photo-0.14/fov.lisp0000644000175000017500000003210110667175332013667 0ustar kevinkevin;;;; -*- 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)))))))) cl-photo-0.14/package.lisp0000644000175000017500000000257510667175332014504 0ustar kevinkevin;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: package.lisp ;;;; Purpose: Package file 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 #:cl-user) (defpackage #:cl-photo (:use #:common-lisp #:kmrcl) (:nicknames #:photo) (:export ;; cameras.lisp #:pixel-dimensions #:pixel-size #:imager-dimensions #:output-dimensions #:*digital-cameras* #:*cameras* ;; fov.lisp #:aov #:aov-format #:fov #:magnification #:bellows-factor #:gaussian-lens #:close-up #:extension-tube ;; dof.lisp #:print-magnification #:coc #:coc-format #:coc-pixels #:coc-pixels-format #:coc-airy #:dof #:hyperfocal #:effective-aperture #:rayleigh-limit #:maximum-sharpness-aperture ;; tables.lisp #:hyperfocal-table #:aov-table #:fov-table #:dof-table )) cl-photo-0.14/tables.lisp0000644000175000017500000000707210667175332014360 0ustar kevinkevin;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: photo -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: tables.lisp ;;;; Purpose: Returns tables of values ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: April 2005 ;;;; ;;;; $Id: dof.lisp 10436 2005-04-21 15:36:01Z kevin $ ;;;; ;;;; 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) (defparameter +f-stops+ '(1.4 2.0 2.8 4.0 5.6 8 11 16 22 32)) (defparameter +focal-lengths+ '(12 24 35 50 70 85 105 135 200 300 400 500 600)) (defparameter +distances-feet+ '(0.5 1 3 8 15 25 50 100 200)) (defun hyperfocal-table (focal-length coc &key (units :feet) (output *standard-output*)) (loop for f-stop in +f-stops+ do (format output "~4,1F ~,1F~%" f-stop (hyperfocal focal-length f-stop coc :units units))) (values)) (defun aov-table (imager &key (output *standard-output*) (projection :rectilinear)) (let ((imager-dim (etypecase imager (cons imager) (symbol (imager-dimensions imager))))) (format output "~5A ~5A ~5A ~5A~%" "FOCAL" "AOV-W" "AOV-H" "AOV-D") (loop for focal-length in +focal-lengths+ do (let ((aov (multiple-value-list (aov focal-length (car imager-dim) (cdr imager-dim) :projection projection)))) (format output "~5D ~5,1F ~5,1F ~5,1F~%" focal-length (nth 0 aov) (nth 1 aov) (nth 2 aov))))) (values)) (defun fov-table (imager focal-length &key (output *standard-output*) (projection :rectilinear) (units :feet)) (let ((imager-dim (etypecase imager (cons imager) (symbol (imager-dimensions imager)))) (distances (mapcar 'feet->mm +distances-feet+))) (format output "~8A ~6A ~6A ~6A ~6A~%" "DISTANCE" "WIDTH" "HEIGHT" "DIAGON" "MAG") (loop for distance in distances do (let ((fov (multiple-value-list (fov focal-length (car imager-dim) (cdr imager-dim) distance :projection projection)))) (format output "~8F: ~6F ~6F ~6F ~6F~%" (mm->length distance units) (nth 0 fov) (nth 1 fov) (nth 2 fov) (nth 3 fov))))) (values)) (defun dof-table (focal-length coc &key (output *standard-output*) (units :feet)) (let ((distances (mapcar (lambda (mm) (mm->length mm units)) (mapcar 'feet->mm +distances-feet+)))) (format output "~&~5A " "FStop") (dolist (distance distances) (format output " ~10F " distance)) (format output "~%") (dolist (f-stop +f-stops+) (format output "~5,1F " f-stop) (dolist (distance distances) (multiple-value-bind (near far dof mag blur) (dof focal-length f-stop distance coc :units units) (declare (ignorable dof mag blur)) (when (minusp far) (setq far "Inf ")) (format output "~5F/~5F " near far))) (format output "~%"))) (values)) cl-photo-0.14/tests.lisp0000644000175000017500000000756710667175332014261 0ustar kevinkevin;;;; -*- 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.01)) 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 :fov.1 (fov 50 24 16 :magnification 1 :units :mm) 24 16 28.8444 1 100 100) (def-numeric-test :fov.2 (fov 50 24 16 :magnification 1 :units :feet) 0.07874 0.052494 0.094634 1 0.328084 100) (def-numeric-test :fov.3 (fov 50 24 16 :image-distance 100 :units :mm) 24 16 28.8444 1 100 100) (def-numeric-test :fov.4 (fov 50 24 16 :image-distance 100 :units :feet) 0.07874 0.052494 0.094634 1 0.328084 100) (def-numeric-test :fov.5 (fov 50 24 16 :object-distance 100 :units :mm) 24 16 28.8444 1 100 100) (def-numeric-test :fov.6 (fov 50 24 16 :object-distance (cl-photo::mm->feet 100) :units :feet) 0.07874 0.052494 0.094634 1 0.328084 100) (def-numeric-test :mag.1 (magnification :focal-length 50 :image-distance 100 :units :mm) 1) (def-numeric-test :mag.2 (magnification :focal-length 50 :image-distance 100 :units :feet) 1) (def-numeric-test :mag.3 (magnification :focal-length 50 :object-distance 100 :units :mm) 1) (def-numeric-test :mag.4 (magnification :focal-length 50 :object-distance (cl-photo::mm->feet 100) :units :feet) 1) (def-numeric-test :mag.5 (magnification :image-distance 100 :object-distance 100 :units :mm) 1) (def-numeric-test :mag.6 (magnification :image-distance 100 :object-distance (cl-photo::mm->feet 100) :units :feet) 1) (def-numeric-test :cu.1 (close-up :focal-length 65 :magnification 5 :units :mm) 65 78 390 5 6) (def-numeric-test :cu.2 (close-up :focal-length 65 :object-distance 78 :units :mm) 65 78 390 5 6) (def-numeric-test :cu.3 (close-up :focal-length 65 :image-distance 390 :units :mm) 65 78 390 5 6) (def-numeric-test :cu.4 (close-up :object-distance 78 :image-distance 390 :units :mm) 65 78 390 5 6) (def-numeric-test :cu.5 (close-up :object-distance 78 :magnification 5 :units :mm) 65 78 390 5 6) (def-numeric-test :cu.6 (close-up :image-distance 390 :magnification 5 :units :mm) 65 78 390 5 6) (def-numeric-test :cu.7 (close-up :focal-length 65 :magnification 5 :units :feet) 65 0.2559055 390 5 6) (def-numeric-test :cu.8 (close-up :focal-length 65 :object-distance 0.2559055 :units :feet) 65 0.2559055 390 5 6) (def-numeric-test :cu.9 (close-up :focal-length 65 :image-distance 390 :units :feet) 65 0.2559055 390 5 6) (def-numeric-test :cu.10 (close-up :object-distance 0.2559055 :image-distance 390 :units :feet) 65 0.2559055 390 5 6) (def-numeric-test :cu.11 (close-up :object-distance 0.2559055 :magnification 5 :units :feet) 65 0.2559055 390 5 6) (def-numeric-test :cu.12 (close-up :image-distance 390 :magnification 5 :units :feet) 65 0.2559055 390 5 6) cl-photo-0.14/cameras.lisp0000644000175000017500000002451310671044774014520 0ustar kevinkevin;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: photo -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: cameras.lisp ;;;; Purpose: Camera-specific data for cl-photo ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: April 2005 ;;;; ;;;; $Id: dof.lisp 10421 2005-04-19 21:57:00Z kevin $ ;;;; ;;;; 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 sensor-dimensions-megapixels (format megapixels) (let* ((dim (imager-dimensions format)) (aspect-ratio (/ (car dim) (cdr dim))) (width (round (sqrt (* aspect-ratio 1000000 megapixels))))) (cons width (round (/ width aspect-ratio))))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun make-output-format (w h &key (units :inches)) (let ((name (format nil "~Dx~D~A" w h (ecase units (:inches "in") (:mm "mm") (:cm "cm") (:m "m") (:feet "ft"))))) (list :format (kmrcl:ensure-keyword name) :output (cons (length->mm w units) (length->mm h units)) :name name :nicks (list (kmrcl:ensure-keyword (format nil "~Dx~D" w h))))))) (defparameter +format-db+ '( (:format :dcs3 :make "Canon" :pixels (1268 . 1012) :imager (20.5 . 16.4) :name "EOS DCS1") (:format :dcs1 :make "Canon" :pixels (3060 . 2036) :imager (27.6 . 18.4) :name "EOS DCS3") (:format :d2000 :make "Canon" :pixels (1728 . 1152) :imager (22.8 . 15.5) :name "EOS D2000") (:format :d6000 :make "Canon" :pixels (3040 . 2008) :imager (27.6 . 18.4) :name "EOS D6000") (:format :d30 :make "Canon" :pixels (2160 . 1440) :imager (22 . 14.9) :name "D30") (:format :d60 :make "Canon" :pixels (3072 . 2048) :imager (22.7 . 15.1) :name "D60") (:format :10d :make "Canon" :pixels (3072 . 2048) :imager (22.7 . 15.1) :name "10D") (:format :20d :make "Canon" :pixels (3456 . 2304) :imager (22.5 . 15) :name "20D") (:format :5d :make "Canon" :pixels (4368 . 2912) :imager (35.8 . 23.9) :name "5D") (:format :300d :make "Canon" :pixels (3072 . 2048) :imager (22.7 . 15.1) :name "300D") (:format :350d :make "Canon" :pixels (3456 . 2304) :imager (22.2 . 14.8) :name "350D") (:format :1d :make "Canon" :pixels (2464 . 1648) :imager (27 . 17.8) :name "1D") (:format :1dmkii :make "Canon" :pixels (3504 . 2336) :imager (28.7 . 19.1) :name "1D Mark II" :nicks (:1d2 :1dii :1dmkii)) (:format :1dmkiii :make "Canon" :pixels (3888 . 2592) :imager (28.1 . 18.7) :name "1D Mark III" :nicks (:1d3 :1diii :1dmkiii)) (:format :1ds :make "Canon" :pixels (4064 . 3328) :imager (36 . 24) :name "1Ds") (:format :1dsmkii :make "Canon" :pixels (4992 . 3328) :imager (36 . 24) :name "1Ds Mark II" :nicks (:1ds2 :1dsii)) (:format :1dsmkiii :make "Canon" :pixels (5616 . 3744) :imager (36 . 24) :name "1Ds Mark III" :nicks (:1ds3 :1dsiii)) (:format :g7 :make "Canon" :pixels (3648 . 2736) :imager (7.2 . 5.3) :name "PowerShot G7") (:format :ndigital :make "Contax" :pixels (3040 . 2008) :imager (36 . 24) :name "N Digital") (:format :s1pro :make "FujiFilm" :pixels (3040 . 2016) :imager (23 . 15.5) :name "FinePix S1 Pro") (:format :s2pro :make "FujiFilm" :pixels (4256 . 2848) :imager (23 . 15.5) :name "FinePix S2 Pro") (:format :s3pro :make "FujiFilm" :pixels (4256 . 2848) :imager (23 . 15.5) :name "FinePix S2 Pro") (:format :dcs100 :make "Kodak" :pixels (1280 . 1024) :imager (20.5 . 16.4) :name "DCS 100") (:format :dcs200 :make "Kodak" :pixels (1524 . 1008) :imager (14 . 9.3) :name "DCS 200") (:format :dcs315 :make "Kodak" :pixels (1520 . 1008) :imager nil :name "DCS 315") (:format :dcs330 :make "Kodak" :pixels (2008 . 1504) :imager nil :name "DCS 330") (:format :dcs420 :make "Kodak" :pixels (1524 . 1012) :imager (14 . 9.3) :name "DCS 420") (:format :dcs460 :make "Kodak" :pixels (3060 . 2036) :imager (27.6 . 18.4) :name "DCS 460") (:format :dcs520 :make "Kodak" :pixels (1728 . 1152) :imager (22.8 . 15.5) :name "DCS 520") (:format :dcs560 :make "Kodak" :pixels (3040 . 2008) :imager (27.6 . 18.4) :name "DCS 560") (:format :dcs620 :make "Kodak" :pixels (1728 . 1152) :imager (22.8 . 15.5) :name "DCS 620") (:format :dcs660 :make "Kodak" :pixels (3040 . 2008) :imager (27.6 . 18.4) :name "DCS 660") (:format :dcs720x :make "Kodak" :pixels (1728 . 1152) :imager (22.8 . 15.5) :name "DCS 720x") (:format :dcs760 :make "Kodak" :pixels (3040 . 2008) :imager (27.6 . 18.4) :name "DCS 760") (:format :dcsslr/n :make "Kodak" :pixels (4500 . 3000) :imager (36 . 24) :name "DCS SLR/n") (:format :dcsslr/c :make "Kodak" :pixels (4500 . 3000) :imager (36 . 24) :name "DCS SLR/n") (:format :dcs14n :make "Kodak" :pixels (4536 . 3024) :imager (36 . 24) :name "DCS 14n") (:format :maxxum7d :make "Konica Minolta" :pixels (3008 . 2000) :imager (23.5 . 15.5) :name "Maxxum 7D") (:format :d1 :make "Nikon" :pixels (2000 . 1312) :imager (23.7 . 15.6) :name "D1") (:format :d1x :make "Nikon" :pixels (4028 . 1324) :imager (23.7 . 15.6) :name "D1X") (:format :d100 :make "Nikon" :pixels (3037 . 2024) :imager (23.7 . 15.6) :name "D100") (:format :d200 :make "Nikon" :pixels (3872 . 2592) :imager (23.6 . 15.8) :name "D200") (:format :d300 :make "Nikon" :pixels (4288 . 2848) :imager (23.6 . 15.8) :name "D300") (:format :d50 :make "Nikon" :pixels (3008 . 2000) :imager (23.7 . 15.6) :name "D50") (:format :d70 :make "Nikon" :pixels (3008 . 2000) :imager (23.7 . 15.6) :name "D70") (:format :d70s :make "Nikon" :pixels (3008 . 2000) :imager (23.7 . 15.6) :name "D70s") (:format :d2h :make "Nikon" :pixels (2464 . 1632) :imager (23.3 . 15.5) :name "D2H") (:format :d2hs :make "Nikon" :pixels (2464 . 1632) :imager (23.3 . 15.5) :name "D2Hs") (:format :d2x :make "Nikon" :pixels (4288 . 2848) :imager (23.7 . 15.6) :name "D2X") (:format :d3 :make "Nikon" :pixels (4256 . 2832) :imager (36 . 23.9) :name "D3") (:format :cp5900 :make "Nikon" :pixels (2592 . 1944) :imager (7.18 . 5.32) :name "Coolpix 5900") (:format :cp7900 :make "Nikon" :pixels (3072 . 2304) :imager (7.18 . 5.32) :name "Coolpix 7900") (:format :cp8800 :make "Nikon" :pixels (3264 . 2448) :imager (8.8 . 6.6) :name "Coolpix 8800") (:format :*ist-d :make "Pentax" :pixels (3008 . 2008) :imager (36 . 24) :name "*ist D") (:format :*ist-ds :make "Pentax" :pixels (3008 . 2008) :imager (36 . 24) :name "*ist DS") (:format :sd9 :make "Sigma" :pixels (2268 . 1512) :imager (20.7 . 13.8) :name "SD9") (:format :sd10 :make "Sigma" :pixels (2268 . 1512) :imager (20.7 . 13.8) :name "SD10") (:format :1/1.8in :imager (7.18 . 5.32) :name "1/1.8\"") (:format :dx :imager (24 . 16) :name "DX") (:format :35mm :imager (36 . 24) :name "35mm") (:format :6x4.5cm :imager (60 . 45) :name "6x4.5cm" :nicks (:\645)) (:format :6x6cm :imager (60 . 60) :name "6x6cm" :nicks (:6x6)) (:format :6x7cm :imager (60 . 70) :name "6x7cm" :nicks (:6x7)) (:format :6x9cm :imager (60 . 90) :name "6x9cm" :nicks (:6x9)) (:format :6x12cm :imager (60 . 120) :name "6x12cm" :nicks (:6x12)) #.(make-output-format 4 5) #.(make-output-format 5 7) #.(make-output-format 8 10) #.(make-output-format 11 13.75) #.(make-output-format 11 16.5) #.(make-output-format 13 16.25) #.(make-output-format 13 19) #.(make-output-format 16 20) #.(make-output-format 16 24) #.(make-output-format 18 22.5) #.(make-output-format 18 24) #.(make-output-format 24 30) #.(make-output-format 24 36) )) (defun sort-formats (formats) (sort formats (lambda (a b) (block nil (cond ((and (null (getf a :make)) (getf b :make)) (return nil)) ((and (getf a :make) (null (getf b :make))) (return t)) ((string-lessp (getf a :make) (getf b :make)) (return t)) ((string-greaterp (getf a :make) (getf b :make)) (return nil))) (when (and (getf a :name) (getf b :name)) (cond ((string-lessp (getf a :name) (getf b :name)) (return t)) ((string-greaterp (getf a :name) (getf b :name)) (return nil)))))))) (defvar *digital-cameras* (sort-formats (loop for format in +format-db+ when (getf format :pixels) collect format))) (defvar *cameras* (sort-formats (loop for format in +format-db+ when (getf format :imager) collect format))) (defun format-match-p (format-spec format) (let ((key (ensure-keyword format-spec))) (when (or (eql key (getf format :format)) (member key (getf format :nicks))) t))) (defun find-format (format-spec) (find format-spec +format-db+ :test 'format-match-p)) (defun pixel-dimensions (sensor-spec &key (format :35mm)) "Returns the number of pixels for a format. CAMERA-SPEC is either a keyword designating the camera or the number of megapixels of the sensor. FORMAT should be defined if the CAMERA-SPEC is the number of megapixels so the proper aspect ratio is used." (etypecase sensor-spec ((or string keyword) (getf (find-format sensor-spec) :pixels)) (number (sensor-dimensions-megapixels format sensor-spec)))) (defun imager-dimensions (format-spec) "Returns the imager dimensions in mm of a FORMAT." (getf (find-format format-spec) :imager)) (defun pixel-size (format-spec) "Return pixel size in micrometers." (let ((pixel-dim (pixel-dimensions format-spec)) (imager-dim (imager-dimensions format-spec))) (when (and pixel-dim imager-dim) (values (* 1000 (/ (car imager-dim) (car pixel-dim))) (* 1000 (/ (cdr imager-dim) (cdr pixel-dim))))))) (defun output-dimensions (format-spec) "Returns the output dimensions in mm of a FORMAT." (getf (find-format format-spec) :output)) cl-photo-0.14/dof.lisp0000644000175000017500000001654010671071606013650 0ustar kevinkevin;;;; -*- 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)))