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