pom.clj

(ns pom
  [:use clojure.test]
  [:import java.util.Calendar java.util.Date java.util.TimeZone])

;; /*
;;  * Phase of the Moon.  Calculates the current phase of the moon.
;;  * Based on routines from `Practical Astronomy with Your Calculator',
;;  * by Duffett-Smith.  Comments give the section from the book that
;;  * particular piece of code was adapted from.
;;  *
;;  * -- Keith E. Brandt  VIII 1984
;;  *
;;  * Updated to the Third Edition of Duffett-Smith's book, IX 1998
;;  *
;;  */

(def EPOCH 1990)
(def EPSILONg 279.403303) ; solar ecliptic long at EPOCH
(def RHOg 282.768422) ; solar ecliptic long of perigee at EPOCH
(def ECCEN 0.016713) ; solar orbit eccentricity
(def lzero 318.351648) ; lunar mean long at EPOCH
(def Pzero 36.340410) ; lunar mean long of perigee at EPOCH
(def Nzero 318.510107) ; lunar mean long of node at EPOCH

(defn- adj360 [deg]
  (cond (< deg 0) (recur (+ deg 360))
        (> deg 360) (recur (- deg 360))
        true deg))

(defn- sin [value] (Math/sin value))
(defn- cos [value] (Math/cos value))
(defn- dtor [value] (/ (* value Math/PI) 180))

(defn- -days-since-epoch [cal]
  (+ (.get cal Calendar/DAY_OF_YEAR)
     (/ (- (+ (.get cal Calendar/HOUR_OF_DAY)
              (/ (.get cal Calendar/MINUTE) 60)
              (/ (.get cal Calendar/SECOND) 3600))
           (/ (+ (.get cal Calendar/ZONE_OFFSET)
                 (.get cal Calendar/DST_OFFSET))
              3600000))
        24)
     (reduce + (map #(if (. cal isLeapYear %) 366 365)
                    (range EPOCH (.get cal Calendar/YEAR))))))

(defmulti days-since-epoch class)

(defmethod days-since-epoch Calendar [cal]
  (-days-since-epoch cal))

(defmethod days-since-epoch Date [date]
  (-days-since-epoch (doto (Calendar/getInstance) (.setTime date))))

(defmethod days-since-epoch Long [millis]
  (-days-since-epoch (doto (Calendar/getInstance) (.setTimeInMillis millis))))

(defn- pom [days]
  (let [N (adj360 (/ (* 360 days) 365.242191))
        Msol (adj360 (- (+ N EPSILONg) RHOg))
        Ec (adj360 (* (/ 360 Math/PI) ECCEN (sin (dtor Msol))))
	LambdaSol (adj360 (+ N Ec EPSILONg))
	l (adj360 (+ (* 13.1763966 days) lzero))
        Mm (adj360 (- l (* 0.1114041 days) Pzero))
	Nm (adj360 (- Nzero (* 0.0529539 days)))
        Ev (* 1.2739 (sin (dtor (- (* 2 (- l LambdaSol)) Mm))))
	Ac (* 0.1858 (sin (dtor Msol)))
	A3 (* 0.37 (sin (dtor Msol)))
	Mmprime (- (+ Mm Ev) Ac A3)
	Ecc (* 6.2886 (sin (dtor Mmprime)))
	A4 (* 0.214 (sin (dtor (* 2 Mmprime))))
	lprime (- (+ l Ev Ecc) (+ Ac A4))
	V (* 0.6583 (sin (dtor (* 2 (- lprime LambdaSol)))))
	ldprime (+ lprime V)
	D (- ldprime LambdaSol)]
    (* 50.0 (- 1 (cos (dtor D))))))

(defn phase-of-the-moon
  "Phase of the moon in percentage of full."
  ([] (pom (days-since-epoch (Calendar/getInstance))))
  ([time] (pom (days-since-epoch time))))

(defn waxing?
  "Waxing moon?"
  ([] (waxing? (Calendar/getInstance)))
  ([time] (let [days (days-since-epoch time)]
            (> (pom (inc days)) (pom days)))))

(defn waning?
  "Waning moon?"
  [& args] (not (apply waxing? args)))

(defn full?
  "Full moon?"
  ([& args] (= 100 (Math/round (apply phase-of-the-moon args)))))

(defn new?
  "New moon?"
  ([& args] (= 0 (Math/round (apply phase-of-the-moon args)))))

(defn quarter?
  "Quarter moon?"
  ([& args] (= 50 (Math/round (apply phase-of-the-moon args)))))

(defn first-quarter?
  "First quarter moon?"
  ([& args] (and (apply quarter? args)
                 (apply waxing? args))))

(defn last-quarter?
  "Last quarter moon?"
  ([& args] (and (apply quarter? args)
                 (apply waning? args))))


(defn message []
  (str
   "The Moon is "
   (cond (full?)          "Full"
         (new?)           "New"
         (first-quarter?) "at the First Quarter"
         (last-quarter?)  "at the Last Quarter"
         :else            (str
                           (if (waxing?) "Waxing" "Waning")
                           " "
                           (let [today (phase-of-the-moon)]
                             (format "%s (%1.0f%% of Full)"
                                     (if (> today 50) "Gibbous" "Crescent")
                                     today))))))

(defn main [] (println (message)))

;; Some test data from emacs phases-of-moon.
(deftest test-pom
  (let [new-moon (doto (Calendar/getInstance (TimeZone/getTimeZone "CET"))
                   (.set 2010 11 5 18 37))
        first-quarter (doto (Calendar/getInstance (TimeZone/getTimeZone "CET"))
                        (.set 2010 11 13 14 59))
        full-moon (doto (Calendar/getInstance (TimeZone/getTimeZone "CET"))
                    (.set 2010 11 21 9 12))
        last-quarter (doto (Calendar/getInstance (TimeZone/getTimeZone "CET"))
                       (.set 2010 11 28 5 24))]
    (is (new? new-moon))
    (is (waxing? new-moon))
    (is (first-quarter? first-quarter))
    (is (full? full-moon))
    (is (waning? full-moon))
    (is (last-quarter? last-quarter))))

;; Original:
;;
;; /*	$OpenBSD: pom.c,v 1.12 2005/11/05 21:25:00 jmc Exp $	*/
;; /*    $NetBSD: pom.c,v 1.6 1996/02/06 22:47:29 jtc Exp $      */

;; /*
;;  * Copyright (c) 1989, 1993
;;  *	The Regents of the University of California.  All rights reserved.
;;  *
;;  * This code is derived from software posted to USENET.
;;  *
;;  * Redistribution and use in source and binary forms, with or without
;;  * modification, are permitted provided that the following conditions
;;  * are met:
;;  * 1. Redistributions of source code must retain the above copyright
;;  *    notice, this list of conditions and the following disclaimer.
;;  * 2. Redistributions in binary form must reproduce the above copyright
;;  *    notice, this list of conditions and the following disclaimer in the
;;  *    documentation and/or other materials provided with the distribution.
;;  * 3. Neither the name of the University nor the names of its contributors
;;  *    may be used to endorse or promote products derived from this software
;;  *    without specific prior written permission.
;;  *
;;  * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
;;  * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;  * ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
;;  * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
;;  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;;  * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;;  * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
;;  * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
;;  * SUCH DAMAGE.
;;  */