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