mirror of
https://github.com/PDP-10/its.git
synced 2026-01-19 01:27:05 +00:00
237 lines
7.7 KiB
Plaintext
237 lines
7.7 KiB
Plaintext
|
|
;;; TIMESTAMP uses DATIMPRINC, SUNPOSPRINC, PHASEPRINC to print three sentences
|
|
;;; describing the current day and date, position of sun, and phase of moon.
|
|
;;; The sentences are each preceded by a terpri-semicolon sequence.
|
|
;;; No trailing terpri is printed.
|
|
;;; An optional argument specifies which files to print on.
|
|
|
|
;;; DATIMPRINC prints a sentence describing the current day and date.
|
|
;;; An optional argument specifies one of two forms of sentence to print.
|
|
;;; A file specification may also be supplied as an argument, but defaults
|
|
;;; to the default output files.
|
|
|
|
;;; PHASEPRINC prints a single sentence describing the phase of the moon.
|
|
;;; The sentence is neither preceded or followed by a terpri.
|
|
;;; It takes zero to two arguments describing the phase to print and the
|
|
;;; files to print onto. If the former is not specified, the MOONPHASE
|
|
;;; function is called to determine the current phase of the moon.
|
|
;;; If the latter is not specified, the default output files are used.
|
|
;;; The one-argument case may specify either, and the argument is
|
|
;;; classified as being a phase or a file specification. The two-argument
|
|
;;; case takes the phase first and file specification second.
|
|
|
|
;;; SUNPOSPRINC prints a sentence describing the position of the sun.
|
|
;;; It takes zero to two arguments, one being the sun position
|
|
;;; (the output of SUN in BKPH's SUN package), and the other a file.
|
|
|
|
(declare (*lexpr timestamp datimprinc phaseprinc sunposprinc)
|
|
;;;(newio t)
|
|
)
|
|
|
|
(defprop moonphase (phase fasl dsk liblsp) autoload)
|
|
(defprop sun-now-here (sun fasl dsk liblsp) autoload)
|
|
|
|
(defun timestamp nargs
|
|
((lambda (terpri)
|
|
(cond ((= nargs 0)
|
|
(terpri)
|
|
(tyo 73)
|
|
(phaseprinc)
|
|
(terpri)
|
|
(tyo 73)
|
|
(sunposprinc)
|
|
(terpri)
|
|
(tyo 73)
|
|
(datimprinc 'hack))
|
|
((= nargs 1)
|
|
(terpri (arg 1))
|
|
(tyo 73 (arg 1))
|
|
(phaseprinc (arg 1))
|
|
(terpri (arg 1))
|
|
(tyo 73 (arg 1))
|
|
(sunposprinc (arg 1))
|
|
(terpri (arg 1))
|
|
(tyo 73 (arg 1))
|
|
(datimprinc 'hack (arg 1)))
|
|
(t (error '|more than 1 argument|
|
|
(cons 'timestamp (listify nargs))
|
|
'wrng-no-args))))
|
|
t))
|
|
|
|
(defun datimprinc nargs
|
|
(prog (file filep hack)
|
|
(cond ((= nargs 0))
|
|
((= nargs 1)
|
|
(cond ((eq (typep (arg 1)) 'array)
|
|
(setq file (arg 1))
|
|
(setq filep t))
|
|
(t (setq hack (arg 1)))))
|
|
((= nargs 2)
|
|
(setq hack (arg 1))
|
|
(setq file (arg 2))
|
|
(setq filep t))
|
|
(t (error '|More than 2 arguments|
|
|
(cons 'datimprinc (listify nargs))
|
|
'wrng-no-args)))
|
|
((lambda (dat tim)
|
|
(cond (hack
|
|
(phaseprinc1 file filep '|That means it is now |))
|
|
(t (phaseprinc1 file filep '|It is now |)))
|
|
(phaseprinc1 file filep (+ (\ (+ (car tim) 11.) 12.) 1))
|
|
(phaseprinc1 file filep '|:|)
|
|
(and (< (cadr tim) 10.) (phaseprinc1 file filep '|0|))
|
|
(phaseprinc1 file filep (cadr tim))
|
|
(cond ((< (car tim) 12.)
|
|
(phaseprinc1 file filep '| AM on |))
|
|
(t (phaseprinc1 file filep '| PM on |)))
|
|
((lambda (day)
|
|
(phaseprinc1 file filep (ascii (car day)))
|
|
(mapc '(lambda (n)
|
|
(phaseprinc1 file filep (ascii (+ n 40))))
|
|
(cdr day)))
|
|
(exploden (status dow)))
|
|
(phaseprinc1 file filep '|, |)
|
|
(phaseprinc1 file filep (do ((i (cadr dat) (1- i))
|
|
(m '(|January| |February| |March|
|
|
|April| |May| |June|
|
|
|July| |August| |September|
|
|
|October| |November| |December|)
|
|
(cdr m)))
|
|
((= i 1) (car m))))
|
|
(phaseprinc1 file filep '| |)
|
|
(phaseprinc1 file filep (caddr dat))
|
|
(phaseprinc1 file filep '|, |)
|
|
(phaseprinc1 file filep (car dat))
|
|
(phaseprinc1 file filep '|.|))
|
|
(status date)
|
|
(status daytime))))
|
|
|
|
(defun phaseprinc nargs
|
|
(prog (file filep phase units)
|
|
(cond ((= nargs 0)
|
|
(setq phase (moonphase)))
|
|
((= nargs 1)
|
|
(cond ((or (atom (arg 1))
|
|
(not (numberp (car (arg 1)))))
|
|
(setq phase (moonphase))
|
|
(setq file (arg 1))
|
|
(setq filep t))
|
|
(t (setq phase (arg 1)))))
|
|
((= nargs 2)
|
|
(setq phase (arg 1))
|
|
(setq file (arg 2))
|
|
(setq filep t))
|
|
(t (error '|More than 2 arguments|
|
|
(cons 'phaseprinc (listify nargs))
|
|
'wrng-no-args)))
|
|
(setq units
|
|
(do ((x (cdr phase) (cdr x))
|
|
(u '(| day| | hour| | minute| | second|) (cdr u))
|
|
(z nil (cond ((plusp (car x))
|
|
(cons (cons (car x) (car u)) z))
|
|
(t z))))
|
|
((or (null x) (null u)) (nreverse z))))
|
|
(cond ((oddp (car phase))
|
|
(phaseprinc1 file filep '|The moon is |))
|
|
(t (phaseprinc1 file filep '|It is |)))
|
|
(do ((u units (cdr u))
|
|
(f 0 (+ f 1)))
|
|
((null u))
|
|
(cond ((> f 0)
|
|
(cond ((cdr u)
|
|
(phaseprinc1 file filep '|, |))
|
|
((> f 1)
|
|
(phaseprinc1 file filep '|, and |))
|
|
(t (phaseprinc1 file filep '| and |)))))
|
|
(phaseprinc1 file filep (caar u))
|
|
(phaseprinc1 file filep (cdar u))
|
|
(or (= (caar u) 1)
|
|
(phaseprinc1 file filep '|s|)))
|
|
(phaseprinc1 file filep '| past the |)
|
|
(cond ((= (car phase) 0)
|
|
(phaseprinc1 file filep '|new moon.|))
|
|
((= (car phase) 1)
|
|
(phaseprinc1 file filep '|first quarter.|))
|
|
((= (car phase) 2)
|
|
(phaseprinc1 file filep '|full moon.|))
|
|
(t (phaseprinc1 file filep '|last quarter.|)))))
|
|
|
|
(defun phaseprinc1 (file filep item)
|
|
((lambda (base *nopoint)
|
|
(cond (filep (princ item file))
|
|
(t (princ item))))
|
|
10.
|
|
t))
|
|
|
|
(defun sunposprinc nargs
|
|
(prog (file filep sunpos)
|
|
(cond ((= nargs 0)
|
|
(setq sunpos (sun-now-here)))
|
|
((= nargs 1)
|
|
(cond ((or (atom (arg 1))
|
|
(atom (car (arg 1)))
|
|
(not (numberp (caar (arg 1)))))
|
|
(setq sunpos (sun-now-here))
|
|
(setq file (arg 1))
|
|
(setq filep t))
|
|
(t (setq sunpos (arg 1)))))
|
|
((= nargs 2)
|
|
(setq sunpos (arg 1))
|
|
(setq file (arg 2))
|
|
(setq filep t))
|
|
(t (error '|More than 2 arguments|
|
|
(cons 'sunposprinc (listify nargs))
|
|
'wrng-no-args)))
|
|
(phaseprinc1 file filep '|The sun is |)
|
|
(do ((i (// (cadadr sunpos) 45.) (- i 1))
|
|
(x '(|east| |north| |south| |east| |west| |south| |north| |west|) (cdr x))
|
|
(y '(|north| |east| |east| |south| |south| |west| |west| |north|) (cdr y))
|
|
(z (\ (cadadr sunpos) 45.)))
|
|
((= i 0)
|
|
(cond ((oddp (// (cadadr sunpos) 45.))
|
|
(degreeprinc file
|
|
filep
|
|
(degreediff '(45. 0 0)
|
|
(cons z (cddadr sunpos)))))
|
|
(t (degreeprinc file filep (cons z (cddadr sunpos)))))
|
|
(phaseprinc1 file filep '| |)
|
|
(phaseprinc1 file filep (car x))
|
|
(phaseprinc1 file filep '| of |)
|
|
(phaseprinc1 file filep (car y))))
|
|
(phaseprinc1 file filep '|, |)
|
|
(degreeprinc file filep (cdar sunpos))
|
|
(phaseprinc1 file filep (cond ((eq (caar sunpos) '-)
|
|
'| below |)
|
|
(t '| above |)))
|
|
(phaseprinc1 file filep '|the horizon.|)))
|
|
|
|
(defun degreeprinc (file filep deg)
|
|
(phaseprinc1 file filep (car deg))
|
|
(phaseprinc1 file filep '|*|)
|
|
(phaseprinc1 file filep (cadr deg))
|
|
(phaseprinc1 file filep '|'|)
|
|
(phaseprinc1 file filep (caddr deg))
|
|
(phaseprinc1 file filep '|"|))
|
|
|
|
(defun degreediff (x y)
|
|
(do ((a (reverse x) (cdr a))
|
|
(b (reverse y) (cdr b))
|
|
(w '(60. 60. 360.) (cdr w))
|
|
(borrow 0)
|
|
(z nil))
|
|
((null a)
|
|
(or (zerop borrow)
|
|
(error '|Losing degree difference|
|
|
(list 'degreediff x y)
|
|
'fail-act))
|
|
z)
|
|
(cond ((minusp (- (car a) (car b) borrow))
|
|
(setq z (cons (- (+ (car a) (car w))
|
|
(car b)
|
|
borrow)
|
|
z))
|
|
(setq borrow 1))
|
|
(t (setq z (cons (- (car a) (car b) borrow) z))
|
|
(setq borrow 0)))))
|
|
|
|
|