;;;; -*- 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))))))))