1;; ----------------------------------------------------------------------------
2;; ifc.scm - kernel-to-object interface
3;; ----------------------------------------------------------------------------
4
5;; Define a vtable scheme - a list of (<name> <body>) pairs
6(define (vtable-call vtable method args)
7  ;;(println method ":" args)
8  (let ((proc (assoc method vtable)))
9    (if (eq? #f proc)
10        ;; If we fail to find the desired method then see if there's a default
11        ;; method
12        (let ((proc (assoc 'default vtable)))
13          (if (eq? #f proc)
14              '()
15              (apply (cdr proc) args)))
16        (apply (cdr proc) args))))
17
18;; Each entry in a vtable is a tagged procedure
19(define (method name body) (cons name body))
20
21;; Implement method inheritance by merging the new methods with the parent
22;; class's vtable
23(define (inherit parent methods)
24  (if (null? parent)
25      methods
26      (append methods (parent 'vtable))))
27
28;; ----------------------------------------------------------------------------
29;; The purpose of this list is to prevent the scheme gc from harvesting the
30;; scroll interfaces which are created on-the-fly in mk-scroll. Without this
31;; I'd have to explicitly assign a variable to each ifc, which is needlessly
32;; verbose.
33;;
34;; The scheme interpreter reclaims any cells not referred to by another cell,
35;; recursively. It can't detect cells that are only referred to by kernel data
36;; structures, and will reclaim them. To prevent this, I add all ifcs to this
37;; list. The list is referred to by the scheme top-level environment, and it
38;; refers to all ifcs that are added to it.
39;; ----------------------------------------------------------------------------
40(define ifc-list '())
41
42(define (ifc-protect ifc)
43  (set! ifc-list (cons ifc ifc-list))
44  ifc)
45
46;; Define a dispatch for a list of methods
47(define (ifc parent . methods)
48  (let ((vtable (inherit parent methods)))
49    (ifc-protect
50     (lambda (op . args)
51       ;;(display op)(newline)
52       (cond ((eq? op 'vtable) vtable)
53             ((eq? op 'can)
54              (begin
55                (not (eq? #f (assoc (car args) vtable)))))
56             (else (vtable-call vtable op args)))))))
57
58;; Map standard interface calls to a bitmap for fast lookup in the kernel
59(define (ifc-cap ifc)
60  (define (cap ifc calls)
61    (if (null? calls) 0
62        (+ (* 2 (cap ifc (cdr calls)))
63           (if (ifc 'can (car calls)) 1 0))))
64  (if (null? ifc) 0
65      (cap ifc (list 'get 'use 'exec 'open 'handle 'step 'attack 'mix
66                     'enter 'cast 'bump 'hit-loc 'buy 'search 'sense 'xamine 'describe 'on-attack
67                     'describe))))
68
69;; The gob internal api:
70(define (gob-mk kobj members) (list kobj members))
71(define (gob-kobj gob) (car gob))
72(define (gob-ifc gob) (kobj-ifc (gob-kobj gob)))
73(define (gob-data gob) (if (null? gob) nil (cadr gob)))
74
75;; Bind a kernel object to a gob and initialize it
76(define (bind kobj gob-data)
77  (kern-obj-set-gob kobj (gob-mk kobj gob-data))
78  (let ((ifc (kobj-ifc kobj)))
79    (cond ((null? ifc) '())
80          (else (ifc 'init kobj))))
81  kobj)
82
83(define (bind-astral-body kobj gob-data)
84  (kern-astral-body-set-gob kobj (gob-mk kobj gob-data)))
85
86;; Make a wrapper for kern-mk-obj-type which inserts the ifc cap info
87(define (mk-obj-type tag name sprite layer ifc)
88  (kern-mk-obj-type tag name sprite layer (ifc-cap ifc) ifc mmode-smallobj))
89
90;; Same as mk-obj-type but flag this type as critical for a quest
91(define (mk-quest-obj-type tag name sprite layer ifc)
92  (kern-type-set-quest-item-flag (mk-obj-type tag name sprite layer ifc)
93                                 #t))
94
95;; ----------------------------------------------------------------------------
96;; send-signal - send a signal to an object. ksender is nil or a pointer to a
97;; kernel object, tag is the tag of the target object (eg 'door-1) and sig is
98;; the symbol of the signal to send (eg 'lock). Examples:
99;;   (send-signal nil 'door-1 'lock)
100;;   (send-signal kplayer 'handle-1b 'on)
101;; ----------------------------------------------------------------------------
102(define (send-signal ksender kobj sig)
103  ((kobj-ifc kobj) sig kobj ksender))
104
105;;----------------------------------------------------------------------------
106;; Yet Another Way to Send a Signal. This one works with arbitrary-length
107;; parameters, so it is more generally applicable to a variety of signals than
108;; previous efforts. It automatically repackages the kobj itself as the first
109;; parameter, so make sure the designated signal handlers expect this.
110;;----------------------------------------------------------------------------
111(define (ifccall kobj sig . parms)
112  (apply (kobj-ifc kobj) (cons sig (cons kobj parms))))
113
114;;----------------------------------------------------------------------------
115;; This returns #t iff kobj has an interface and it has a handler for the sig.
116;;----------------------------------------------------------------------------
117(define (handles? kobj sig)
118  (let ((ifc (kobj-ifc kobj)))
119    (and (not (null? ifc))
120         (ifc 'can sig))))