worlds/haxima-1.002/keep_crypt_mech.scm

   1 ;;----------------------------------------------------------------------------
   2 ;; Special mech for the Keep Crypt
   3 ;;
   4 ;;    When the lever is pulled, this mech engages. Every turn it picks a
   5 ;; random location from its region. If the location does not contain a being
   6 ;; but does contain a corpse it removes the corpse and creates a skeletal
   7 ;; warrior in its place.
   8 ;;----------------------------------------------------------------------------
   9
  10 (define (kcm-mk area)
  11   (list #f area))
  12 (define (kcm-set-on! kcm) (set-car! kcm #t))
  13 (define (kcm-on? kcm) (car kcm))
  14 (define (kcm-area kcm) (cadr kcm))
  15
  16 (define (kcm-exec-main kcm kplace)
  17
  18   (define (pick-loc)
  19     (let ((area (kcm-area kcm)))
  20       (let ((x (+ (rect-x area)
  21                   (modulo (random-next) (rect-w area))))
  22             (y (+ (rect-y area)
  23                   (modulo (random-next) (rect-h area)))))
  24         (mk-loc kplace x y))))
  25
  26   (define (get-corpse-at loc)
  27     ;;(display "get-corpse-at")(newline)
  28     (let ((corpses (find-object-types-at loc t_corpse)))
  29       (if (null? corpses)
  30           nil
  31           (car corpses))))
  32
  33   (let* ((loc (pick-loc))
  34          (corpse (get-corpse-at loc)))
  35
  36     ;;(display "loc:")(display loc)(newline)
  37     ;;(display "corpse:")(display corpse)(newline)
  38
  39     (define (corpse-at? loc)
  40       ;;(display "corpse-at?")(newline)
  41       (not (null? corpse)))
  42
  43     (define (remove-corpse loc)
  44       ;;(display "remove-corpse")(newline)
  45       (kern-obj-remove corpse))
  46
  47     (define (mk-skeleton)
  48       (if (> (modulo (random-next) 2) 0)
  49           (mk-npc 'skeletal-warrior (kern-dice-roll "1d3+4"))
  50           (mk-npc 'skeletal-spear-thrower (kern-dice-roll "1d3+4"))))
  51
  52     (define (put-skeleton loc)
  53       ;;(display "put-skeleton")(newline)
  54       (kern-obj-put-at (mk-skeleton) loc))
  55
  56     (define (good? loc)
  57       ;;(display "good?")(newline)
  58       (and (not (being-at? loc))
  59            (corpse-at? loc)))
  60
  61     (define (change-corpse-to-skeleton loc)
  62       ;;(display "change-corpse-to-skeleton")(newline)
  63       (kern-log-msg "You have disturbed the dead!")
  64       (remove-corpse loc)
  65       (put-skeleton loc))
  66
  67     (if (good? loc)
  68         (change-corpse-to-skeleton loc))))
  69
  70 (define (kcm-exec kself)
  71   (let ((kcm (kobj-gob-data kself)))
  72     (if (and (kcm-on? kcm)
  73              (> (modulo (random-next) 20) 16))
  74         (kcm-exec-main kcm
  75                        (loc-place (kern-obj-get-location kself))))))
  76
  77 (define (kcm-on kself ksender)
  78   (kcm-set-on! (kobj-gob-data kself)))
  79
  80 (define kcm-ifc
  81   (ifc '()
  82        (method 'on kcm-on)
  83        (method 'exec kcm-exec)))
  84
  85 (mk-obj-type 't_kcm nil nil layer-none kcm-ifc)
  86
  87 (define (mk-kcm area)
  88   (bind (kern-mk-obj t_kcm 1)
  89         (kcm-mk area)))