1;; bim - binary mechanism 2 3(define (state-mk sprite-tag opacity pclass light) 4 (list sprite-tag opacity pclass light)) 5(define (state-sprite state) (eval (car state))) 6(define (state-opacity state) (cadr state)) 7(define (state-pclass state) (caddr state)) 8(define (state-light state) (cadddr state)) 9 10;; ctor 11(define (bim-mk on? port members) 12 ;;(display "bim-mk")(newline) 13 (list on? port #f members)) 14 15;; accessors 16(define (bim-on? bim) (car bim)) 17(define (bim-port bim) (cadr bim)) 18(define (bim-active? bim) (caddr bim)) 19(define (bim-members bim) (cadddr bim)) 20 21;; mutators 22(define (bim-set-on! bim val) (set-car! bim val)) 23(define (bim-set-active! bim val) (set-car! (cddr bim) val)) 24 25;; helpers 26(define (bim-send-signal kobj sig) 27 (let ((bim (gob-data (kobj-gob kobj)))) 28 (if (not (bim-active? bim)) 29 (let ((port (bim-port bim))) 30 (if (and (not (null? port)) 31 (defined? port)) 32 (begin 33 (bim-set-active! bim #t) 34 ((kobj-ifc (eval port)) sig (eval port) kobj) 35 (bim-set-active! bim #f))))))) 36 37(define (bim-change-state kobj khandler on?) 38 ;;(display "bim-change-state")(newline) 39 (let ((bim (gob-data (kobj-gob kobj)))) 40 (bim-set-on! bim on?) 41 (let ((state ((kobj-ifc kobj) 'state on? kobj))) 42 ;;(display "state:")(display state)(newline) 43 (kern-obj-set-sprite kobj (state-sprite state)) 44 (kern-obj-set-opacity kobj (state-opacity state)) 45 (kern-obj-set-pclass kobj (state-pclass state)) 46 (kern-obj-set-light kobj (state-light state)) 47 ))) 48 49;; handlers 50(define (bim-on kobj khandler) 51 ;(display "bim-on")(newline) 52 (bim-change-state kobj khandler #t 'on) 53 (bim-send-signal kobj 'on) 54 ) 55 56(define (bim-off kobj khandler) 57 ;(display "bim-off")(newline) 58 (bim-change-state kobj khandler #f 'on) 59 (bim-send-signal kobj 'off) 60 ) 61 62(define (bim-toggle kobj khandler) 63 ;;(display "bim-toggle")(newline) 64 (let ((bim (gob-data (kobj-gob kobj)))) 65 (if (bim-on? bim) 66 (bim-off kobj khandler) 67 (bim-on kobj khandler)))) 68 69(define (bim-init kobj) 70 (let ((bim (gob-data (kobj-gob kobj)))) 71 (if (bim-on? bim) 72 (bim-on kobj '()) 73 (bim-off kobj '())))) 74 75(define (bim-is-on? kobj) 76 (let ((bim (kobj-gob-data kobj))) 77 (bim-on? bim))) 78 79;; ifc - extensions must add a 'state message handler 80(define bim-ifc 81 (ifc '() 82 (method 'on bim-on) 83 (method 'off bim-off) 84 (method 'toggle bim-toggle) 85 (method 'init bim-init) 86 (method 'is-on? bim-is-on?) 87 )) 88 89