worlds/haxima-1.002/moon.scm

   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))