added phase of the moon.lisp

Pascal J. Bourguignon [2014-03-08 14:01]
added phase of the moon.lisp
Filename
small-cl-pgms/moon.lisp
diff --git a/small-cl-pgms/moon.lisp b/small-cl-pgms/moon.lisp
new file mode 100644
index 0000000..2155736
--- /dev/null
+++ b/small-cl-pgms/moon.lisp
@@ -0,0 +1,179 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               pom.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This package computes and ascii-draw the phase of the Moon.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2013-11-10 <PJB> Created (converted from newmoon.c)
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2013 - 2013
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program 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.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+
+(defpackage "COM.INFORMATIMAGO.COMMON-LISP.MOON"
+  (:use "COMMON-LISP")
+  (:export "PHASE-OF-THE-MOON" "DRAW-PHASE"
+           "DRAW-PHASE-OF-THE-MOON")
+  (:documentation "
+
+This package computes and ascii-draw the phase of the Moon.
+
+
+Copyright Pascal J. Bourguignon 2013 - 2013
+
+This program is free software: you can redistribute it and/or modify
+it under the terms of the GNU Affero General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+This program 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.  See the
+GNU Affero General Public License for more details.
+
+You should have received a copy of the GNU Affero General Public License
+along with this program.  If not, see <http://www.gnu.org/licenses/>.
+"))
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.MOON")
+
+
+(defun phase-of-the-moon (time)
+  "
+DO:     Compute the phase of the moon.
+RETURN: fraction; day; hour; minute; name.
+"
+  ;; This is most certainly wrong.  Converted from a function written
+  ;; in C that had been massaged to work first in seconds, then in
+  ;; minutes using assumedly originally a base time 13:23 10/1/78,
+  ;; then 15:19 GMT 2/5/85 but using actually the values coded here.
+  (let* ((base         (encode-universal-time 0 59 11 21 3 1985 0))
+         (difference   (truncate (- time base) 60))
+         (phase-length (+ 44 (* 60 (+ 12 (* 24 29)))))
+         (phase        (mod difference phase-length))
+         (fraction     (/ phase phase-length))
+         (phase-length (truncate phase-length 4))
+         (phase        (truncate phase phase-length))
+         (difference   (truncate difference phase-length)))
+    (multiple-value-bind (hour-diff minute) (truncate difference 60)
+      (multiple-value-bind (day hour) (truncate hour-diff 24)
+        (values fraction day hour minute (aref #("New Moon "
+                                                 "First Quarter "
+                                                 "Full Moon "
+                                                 "Last Quarter ")
+                                               phase))))))
+
+#-(and)  #("New Moon"
+           "Waxing Crescent"
+           "First Quarter"
+           "Waxing Gibbous"
+           "Full Moon"
+           "Waning Gibbous"
+           "Last Quarter"
+           "Waning Crescent")
+
+
+
+(defvar *default-screen-aspect* 0.5)
+(defvar *default-screen-height* 25)
+(defvar *default-screen-width*  80)
+(defvar *default-fill-pattern*  "*")
+
+
+(defun draw-phase (phase name &key
+                                (height *default-screen-height*)
+                                (width *default-screen-width*)
+                                (screen-aspect *default-screen-aspect*))
+  "
+Draws in ASCII art (over HEIGHT lines of WIDTH characters), a circle
+with the phase highlighed with characters from the NAME string.
+
+SCREEN-ASPECT: the ratio of the height of a character over the width of a
+               character.
+"
+  (let* ((full-moon     0.5) ; the new moon is 0.0
+         (fuzz          0.03) ; how far off we must be from an even 0.0
+         (1-fuzz        (- 1.0 fuzz))
+         (xmin          0) ; x position of leftmost edge of moon (not line)
+         (xoffset       (truncate width 2))
+         (vdiameter     (min (* width screen-aspect) height))
+         (cheight       (/ 2 vdiameter)) ; character height in a circle of radius 1.0
+         (xscale        (/ (* cheight screen-aspect))) ; x stretch factor
+         (beforep       (< phase full-moon))
+         (squisher      (if beforep
+                            (cos (* 2 pi phase))
+                            (cos (* 2 pi (- phase full-moon))))))
+    (flet ((charpos (x xscale xoffset) (max 1 (+ xoffset (round (* x xscale)))))
+           (pixel   (i)                (aref name (mod (- i xmin) (length name))))
+           (draw    (buffer i p)       (when (< -1 i (length buffer))
+                                         (setf (aref buffer i) p))))
+      (loop
+        :for y = (- 1.0 (/ cheight 2.0)) :then (- y cheight)
+        :while (and (< -1.0 y) (< (abs (- y cheight)) y))
+        :finally (let ((horizon (sqrt (- 1.0 (* y y)))))
+                   (setf xmin (charpos (- horizon) xscale xoffset))))
+      (loop
+        :for y = (- 1.0 (/ cheight 2))
+        :then (- y cheight)
+        :while (< -1.0 y)
+        :do (let* ((buffer     (make-string width :initial-element #\space))
+                   (horizon    (sqrt (- 1.0 (* y y))))
+                   (terminator (* squisher horizon))
+                   (left       (if beforep terminator (- horizon)))
+                   (right      (if beforep  horizon terminator)))
+              (let ((i (charpos    horizon  xscale xoffset))) (draw buffer i (pixel i)))
+              (let ((i (charpos (- horizon) xscale xoffset))) (draw buffer i (pixel i)))
+              (when (< fuzz phase 1-fuzz)
+                (loop
+                  :for i :from (charpos left xscale xoffset) :to (charpos right xscale xoffset)
+                  :do (draw buffer i (pixel i))))
+              (write-line buffer))))))
+
+
+(defun draw-phase-of-the-moon (&key
+                                 (name *default-fill-pattern*)
+                                 (height *default-screen-height*)
+                                 (width *default-screen-width*)
+                                 (screen-aspect *default-screen-aspect*))
+  (multiple-value-bind (fraction day hour minute phase-name) (phase-of-the-moon (get-universal-time))
+    (draw-phase fraction
+                (cond
+                  ((vectorp name) name)
+                  ((eq name :time) (format nil "~2D ~2,'0D:~2,'0D" day hour minute))
+                  (t phase-name))
+                :height height :width width :screen-aspect screen-aspect)))
+
+
+
+(defun pdraw/test ()
+  (multiple-value-bind (fraction day hour minute name) (phase-of-the-moon (get-universal-time))
+    (format t "~2D ~2,'0D:~2,'0D~%" day hour minute)
+    (draw-phase fraction name)
+    (draw-phase fraction "*"))
+  (loop
+    :for fraction :from 0.0 to 1.0 by (/ 1.0 29)
+    :do (draw-phase fraction "#") (terpri) (terpri)))
+
+
+;;;; THE END ;;;;
ViewGit