1
2;; Given a kernel moon object, find the gate associated with the current
3;; phase. This is for the benefit of moongates trying to find a destination
4;; gate.
5(define (moon-get-current-gate kmoon)
6  (let ((gates (gob-data (kern-astral-body-get-gob kmoon)))
7        (phase (kern-astral-body-get-phase kmoon)))
8    (safe-eval (list-ref gates phase))))
9
10(define (moon-signal-gate moon phase signal)
11  (let ((kgate (safe-eval (list-ref moon phase))))
12    (if (not (null? kgate))
13        (signal-kobj kgate signal kgate))))
14
15(define (moon-phase-change kmoon old-phase new-phase)
16  (let ((moon (gob-data (kern-astral-body-get-gob kmoon))))
17    (moon-signal-gate moon old-phase 'off)
18    (moon-signal-gate moon new-phase 'on)))
19
20(define source-moon-ifc
21  (ifc '()
22       (method 'phase-change moon-phase-change)))
23
24(define dest-moon-ifc nil)
25
26
27(define (mk-moon tag name hours-per-phase hours-per-rev arc phase ifc gates color)
28  (bind-astral-body (kern-mk-astral-body
29                     tag                          ; tag
30                     name                         ; name
31                     2                            ; relative distance
32                     (* hours-per-phase 60)       ; minutes per phase
33                     (/ (* hours-per-rev 60) 360) ; minutes per degree
34                     arc                          ; initial arc
35                     phase                        ; initial phase
36                     ifc                          ; script interface
37                     ;; phase sprites
38                     (cond ((string=? color "yellow")
39                            (list
40                             (list s_yellow_new_moon                0   "new")
41                             (list s_yellow_wax_quarter_moon        16  "1/4 waxing")
42                             (list s_yellow_wax_half_moon           32  "1/2 waxing")
43                             (list s_yellow_wax_three_quarter_moon  64  "3/4 waxing")
44                             (list s_yellow_full_moon               96 "full")
45                             (list s_yellow_wane_three_quarter_moon 64  "3/4 waning")
46                             (list s_yellow_wane_half_moon          32  "1/2 waning")
47                             (list s_yellow_wane_quarter_moon       16  "1/4 waning")))
48                           ((string=? color "blue")
49                            (list
50                             (list s_blue_new_moon                0   "new")
51                             (list s_blue_wax_quarter_moon        16  "1/4 waxing")
52                             (list s_blue_wax_half_moon           32  "1/2 waxing")
53                             (list s_blue_wax_three_quarter_moon  64  "3/4 waxing")
54                             (list s_blue_full_moon               96 "full")
55                             (list s_blue_wane_three_quarter_moon 64  "3/4 waning")
56                             (list s_blue_wane_half_moon          32  "1/2 waning")
57                             (list s_blue_wane_quarter_moon       16  "1/4 waning")))
58                           (else
59                            (list
60                             (list s_new_moon                0   "new")
61                             (list s_wax_quarter_moon        16  "1/4 waxing")
62                             (list s_wax_half_moon           32  "1/2 waxing")
63                             (list s_wax_three_quarter_moon  64  "3/4 waxing")
64                             (list s_full_moon               96 "full")
65                             (list s_wane_three_quarter_moon 64  "3/4 waning")
66                             (list s_wane_half_moon          32  "1/2 waning")
67                             (list s_wane_quarter_moon       16  "1/4 waning")))))
68                    gates))
69