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