worlds/haxima-1.002/kobj.scm

   1 ;; ----------------------------------------------------------------------------
   2 ;; kobj.scm - utilities related to kernel-objects
   3 ;; ----------------------------------------------------------------------------
   4 (define (kobj-ktype kobj) (kern-obj-get-type kobj))
   5 (define (kobj-ifc kobj) ( kern-type-get-gifc (kobj-ktype kobj)))
   6 (define (kobj-gob kobj) (kern-obj-get-gob kobj))
   7 (define (kobj-gob-data kobj) (gob-data (kobj-gob kobj)))
   8
   9 ;; gob -- convenience accessor for getting the interesting part of a gob from
  10 ;; the kernel object
  11 (define (gob kobj) (gob-data (kobj-gob kobj)))
  12
  13 (define (signal-kobj kobj sig . args)
  14   ;;(display "signal-kobj")(newline)
  15   (if (not (null? (kobj-ifc kobj)))
  16         (apply (kobj-ifc kobj) (cons sig args))
  17   ))
  18
  19 (define (kobj-can? kobj signal)
  20   (let ((gifc (kobj-ifc kobj)))
  21     (cond ((null? gifc) #f)
  22           (else (gifc 'can signal)))))
  23
  24 (define (ktype-can? ktype signal)
  25   (let ((gifc (kern-type-get-gifc  ktype)))
  26     (cond ((null? gifc) #f)
  27           (else (gifc 'can signal)))))
  28
  29 (define (kobj-place kobj)
  30   (loc-place (kern-obj-get-location kobj)))
  31
  32 (define (can-be-dropped? obj loc max_difficulty)
  33         (let ((mcost (kern-place-get-movement-cost loc obj)))
  34                 (and (not (eqv? mcost 0))
  35                         (< mcost max_difficulty))))
  36