"Fossies" - the Fresh Open Source Software Archive

Member "snd-20.9/reactive.scm" (15 Mar 2020, 14873 Bytes) of package /linux/misc/snd-20.9.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Lisp source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file.

    1 ;;; reactive.scm
    2 ;;;
    3 ;;; reimplementation of code formerly in stuff.scm
    4 
    5 (provide 'reactive.scm)
    6 ;(set! (*s7* 'gc-stats) #t)
    7 
    8 (define (symbol->let symbol env)
    9   ;(format *stderr* "symbol->let ~S~%" symbol)
   10   ;; return let in which symbol lives (not necessarily curlet)
   11   (if (defined? symbol env #t)
   12       env   
   13       (if (eq? env (rootlet))
   14       #<undefined>
   15       (symbol->let symbol (outlet env)))))
   16 
   17 (define (gather-symbols expr ce lst ignore)
   18   ;; collect settable variables in expr
   19   (cond ((symbol? expr)
   20      (if (or (memq expr lst)
   21          (memq expr ignore)
   22          (procedure? (symbol->value expr ce))
   23          (eq? (symbol->let expr ce) (rootlet)))
   24          lst
   25          (cons expr lst)))
   26 
   27     ((not (pair? expr)) lst)
   28 
   29     ((not (and (pair? (cdr expr)) (pair? (cddr expr))))
   30      (gather-symbols (cdr expr) ce (gather-symbols (car expr) ce lst ignore) ignore))
   31 
   32     ((pair? (cadr expr))
   33      (gather-symbols (case (car expr)
   34                ((let let* letrec letrec* do)
   35                 (values (cddr expr) ce lst (append ignore (map car (cadr expr)))))
   36                ((lambda) 
   37                 (values (cddr expr) ce lst (append ignore (cadr expr))))
   38                ((lambda*)
   39                 (values (cddr expr) ce lst (append ignore (map (lambda (a) (if (pair? a) (car a) a)) (cadr expr)))))
   40                (else
   41                 (values (cdr expr) ce (gather-symbols (car expr) ce lst ignore) ignore)))))
   42 
   43     ((and (eq? (car expr) 'lambda)
   44           (symbol? (cadr expr)))
   45      (gather-symbols (cddr expr) ce lst (append ignore (list (cadr expr)))))
   46 
   47     (else 
   48      (gather-symbols (cdr expr) ce (gather-symbols (car expr) ce lst ignore) ignore))))
   49 
   50 ;;; c-pointer used to hold symbol+let info so that the lets can be a "weak references"
   51 (define slot-symbol c-pointer-type)
   52 (define slot-expr c-pointer-info)
   53 (define slot-env c-pointer-weak1)
   54 (define slot-expr-env c-pointer-weak2)
   55 (define (slot symbol expr env expr-env) (c-pointer 0 symbol expr env expr-env))
   56 
   57 (define (setter-update cp)            ; cp: (slot var expr env expr-env)
   58   ;; when var set, all other vars dependent on it need to be set also, watching out for GC'd followers
   59   (when (and (let? (slot-env cp))
   60          (let? (slot-expr-env cp)))     ; when slot-env is GC'd, the c-pointer field is set to #f (by the GC)
   61     (let ((val (eval (slot-expr cp) (slot-expr-env cp))))
   62       (when (let? (slot-env cp))      ; same as above, but eval may trigger gc
   63     (let-set! (slot-env cp)
   64           (slot-symbol cp)
   65           val)))))
   66 
   67 
   68 (define (slot-equal? cp1 cp2)
   69   (and (eq? (slot-symbol cp1) (slot-symbol cp2))
   70        (eq? (slot-env cp1) (slot-env cp2))))
   71 
   72 (define (setter-remove cp lst)
   73   ;; if reactive-set! called again on a variable, its old setters need to remove the now obsolete set of that variable
   74   (map (lambda (c)
   75      (if (slot-equal? cp c)
   76          (values)
   77          c))
   78        lst))
   79 
   80 
   81 (define* (make-setter var env (followers ()) (setters ()) (expr ()) expr-env)
   82   ;; return a new setter with closure containing the followers and setters of var, and the c-pointer holding its name, environment, and expression
   83   (let ((followers followers)
   84     (setters setters)
   85     (cp (slot var expr env expr-env)))
   86     (lambda (sym val)
   87       ;(format *stderr* "make-setter ~S ~S~%" sym val)
   88       (let-temporarily (((setter (slot-symbol cp) (slot-env cp)) #f))
   89              ;(setter (c-pointer-type cp) (c-pointer-weak1 cp)) #f))
   90     (let-set! (slot-env cp) (slot-symbol cp) val) ; set new value without retriggering the setter
   91     (for-each setter-update followers)            ; set any variables dependent on var
   92     val))))
   93 
   94 (define (update-setters setters cp e)
   95   ;; add the slot to the followers setter list of each variable in expr
   96   (for-each (lambda (s)
   97           (unless (and (setter s e)
   98                (defined? 'followers (funclet (setter s e))))
   99         (set! (setter s e) (make-setter s e)))
  100           (let ((setter-followers (let-ref (funclet (setter s e)) 'followers)))
  101         (unless (member cp setter-followers slot-equal?)
  102           (let-set! (funclet (setter s e))
  103                 'followers
  104                 (cons cp setter-followers)))))
  105         setters))
  106 
  107 (define (clean-up-setter old-setter old-followers lt place e)
  108   ;; if previous set expr, remove it from setters' followers lists
  109   (when (and old-setter
  110          (defined? 'followers (funclet old-setter))
  111          (defined? 'setters (funclet old-setter)))
  112     (set! old-followers ((funclet old-setter) 'followers))
  113     (for-each (lambda (s)
  114         (when (and (setter s e)
  115                (defined? 'followers (funclet (setter s e))))
  116           (let ((setter-followers (let-ref (funclet (setter s e)) 'followers)))
  117             (let-set! (funclet (setter s e))
  118                   'followers 
  119                   (setter-remove (slot place 0 lt e) setter-followers)))))
  120           (let-ref (funclet old-setter) 'setters)))
  121   old-followers)
  122 
  123 (define-bacro (reactive-set! place value)
  124   (with-let (inlet 'place place                       ; with-let here gives us control over the names
  125            'value value 
  126            'e (outlet (curlet)))              ; the run-time (calling) environment
  127     `(let ((old-followers ())
  128        (old-setter (setter ',place))
  129        (lt (symbol->let ',place ,e)))
  130        (set! old-followers (clean-up-setter old-setter old-followers lt ',place ,e))
  131        ;; set up new setter
  132        (let ((setters (gather-symbols ',value ,e () ())))
  133      (when (pair? setters)
  134        (let ((expr (if (pair? ',value) (copy ',value :readable) ',value)))
  135          (let ((cp (slot ',place expr lt ,e)))
  136            (set! (setter ',place lt)
  137              (make-setter ',place lt old-followers setters expr ,e))
  138            (update-setters setters cp ,e)))))
  139        (set! ,place ,value))))
  140 
  141 
  142 
  143 ;; --------------------------------------------------------------------------------
  144 #|
  145 (let ()
  146 (define a 2)
  147 (define b 1)
  148 (define x 0)
  149 (reactive-set! x (+ a b))
  150 
  151 (set! a 3)
  152 (format *stderr* "x: ~A~%" x)
  153 (set! b 4)
  154 (format *stderr* "x: ~A~%" x)
  155 
  156 (format *stderr* "x setter: ~S ~S~%" (setter 'x) (funclet (setter 'x)))
  157 (format *stderr* "a setter: ~S ~S~%" (setter 'a) (funclet (setter 'a)))
  158 ;; x setter: #<lambda (sym val)> (inlet 'followers () 'setters (b a) 'cp #<x (nil)>)
  159 ;; a setter: #<lambda (sym val)> (inlet 'followers (#<x (nil)>) 'setters () 'cp #<a (nil)>)
  160 
  161 (reactive-set! a (* b 2))
  162 (set! b 5)
  163 (format *stderr* "x: ~A, a: ~A, b: ~A~%" x a b)
  164 ;; x: 15, a: 10, b: 5
  165 )
  166 
  167 (let ((x 0))
  168   (do ((i 0 (+ i 1)))
  169       ((= i 100))
  170     (let ((a 1))
  171       (reactive-set! x (* 2 a)))
  172     (let ((a 3))
  173       (set! a 2))
  174     (if (zero? (modulo i 10))
  175     (gc))))
  176 
  177 (define-macro (test a b)
  178   ;(display a) (newline)
  179   `(if (not (equal? ,a ,b))
  180        (format *stderr* "~S -> ~S?~%" ',a ,b)))
  181 
  182 
  183 (test (let ((a 1) (b 2) (c 3)) (reactive-set! a (+ b c)) (set! b 4) (set! c 5) a) 9)
  184 (test (let ((a 1) (b 2) (c 3)) (reactive-set! b (+ c 4)) (reactive-set! a (+ b c)) (set! c 5) a) 14)
  185 (test (let ((expr 21) (symbol 1)) (reactive-set! expr (* symbol 2)) (set! symbol 3) expr) 6)
  186 (test (let ((a 21) (b 1)) (reactive-set! a (* b 2)) (set! b 3) a) 6)
  187 (test (let ((s 21) (v 1)) (reactive-set! s (* v 2)) (set! v 3) s) 6)
  188 (test (let ((a 21) (v 1)) (reactive-set! a (* v 2)) (set! v 3) a) 6)
  189 (test (let ((symbol 21) (nv 1)) (reactive-set! symbol (* nv 2)) (set! nv 3) symbol) 6)
  190 (test (let ((outer 0)) (let ((nv 21) (sym 1)) (let ((inner 1)) (reactive-set! nv (* sym 2)) (set! sym 3) nv))) 6)
  191 (test (let ((a 1) (b 2)) (reactive-set! b (+ a 4)) (let ((a 10)) (set! a (+ b 5)) (list a b))) '(10 5))
  192 (test (let ((a 1) (b 2)) (reactive-set! b (+ a 4)) (list (let ((b 10)) (set! a (+ b 5)) a) b)) '(15 19))
  193 
  194 (test (let ((a 1) (b 2) (c 3)) (reactive-set! b (+ c 4)) (let ((a 0)) (reactive-set! a (+ b c)) (set! c 5) a)) 14)
  195 (test (let ((a 1) (b 2) (c 3)) (reactive-set! a (reactive-set! b (+ c 4))) (list a b c)) '(7 7 3))
  196 (test (let ((a 1) (b 2) (c 3)) (reactive-set! a (+ 1 (reactive-set! b (+ c 4)))) (list a b c)) '(8 7 3))
  197 
  198 (test (let ((a 1) (x 0)) (reactive-set! x (* a 2)) (reactive-set! a (* x 2)) (set! x 2) a) 4)
  199 (test (let ((a 1)) (let ((b 0) (c 0)) (reactive-set! b (* a 2)) (reactive-set! c (* a 3)) (let ((x 0)) (reactive-set! x (+ a b c)) (set! a 2) x))) 12)
  200 (test (let ((x 0)) (let ((a 1)) (reactive-set! x (* 2 a)) (set! a 2)) x) 4)
  201 
  202 (test (let ((x 0) (a 1)) (reactive-set! x (+ a 1)) (reactive-set! a (+ x 2)) (set! a 3) (set! x 4) (list x a)) (list 4 6))
  203 (test (let ((x 0) (a 1) (b 0)) (reactive-set! x (+ a 2)) (let ((x 2)) (reactive-set! x (+ a 1)) (set! a 4) (set! b x)) (list x a b)) (list 6 4 5))
  204 (test (let ((x 0)) (reactive-set! x (* 3 2)) x) 6)
  205 (test (let ((x 0)) (reactive-set! x (* pi 2)) x) (* pi 2))
  206 (test (let ((x 0)) (let ((a 1)) (reactive-set! x a) (set! a 2)) x) 2)
  207 
  208 ;;; (define-macro (with-setters vars . body) `(let-temporarily (,(map (lambda (var) `((setter ',var) #f)) vars)) ,@body))
  209 
  210 (let ((x 0))
  211   (do ((i 0 (+ i 1)))
  212       ((= i 100))
  213     (let ((a 1))
  214       (reactive-set! a (* 2 x))
  215       (set! x 2)
  216       (if (zero? (modulo i 10))
  217       (gc)))))
  218 
  219 (let ((x 0))
  220   (do ((i 0 (+ i 1)))
  221       ((= i 100))
  222     (let ((a 1))
  223       (reactive-set! x (* 2 a))
  224       (set! a 2))))
  225 
  226 (test (let ((a 21) (b 1)) (set! (setter 'b) (lambda (x y) (* 2 y))) (reactive-set! a (* b 2)) (set! b 3) a) 6) ; old setter ignored
  227 (test (let ((a 21) (b 1)) (set! (setter 'b) (lambda (x y) (* 2 y))) (let ((b 2)) (reactive-set! a (* b 2)) (set! b 3) a)) 6)
  228 
  229 ;; also place as generalized set: (reactive-set! (v 0) (* a 2)) -- does v get the setter?
  230 |#
  231 ;;; --------------------------------------------------------------------------------
  232 
  233 (define-bacro (reactive-let vars/inits . body)
  234   (with-let (inlet 'vars/inits vars/inits 
  235            'body body
  236            'e (outlet (curlet)))
  237     (let ((vars (map car vars/inits))
  238       (inits (map cadr vars/inits)))
  239       (let ((reacts (map (lambda (var init)
  240                `(let ((setters (gather-symbols ',init ,e () ())))
  241                   (when (pair? setters)
  242                 (let ((expr (if (pair? ',init) (copy ',init :readable) ',init))
  243                       (lt (curlet)))
  244                   (let ((cp (slot ',var expr lt ,e)))
  245                     (set! (setter ',var lt)
  246                       (make-setter ',var lt () setters expr ,e))
  247                     (for-each (lambda (s)
  248                         (unless (and (setter s)
  249                                  (defined? 'followers (funclet (setter s))))
  250                           (set! (setter s) (make-setter s lt)))
  251                         (let ((setter-followers (let-ref (funclet (setter s)) 'followers)))
  252                           (unless (member cp setter-followers slot-equal?)
  253                             (let-set! (funclet (setter s))
  254                                   'followers
  255                                   (cons cp setter-followers)))))
  256                           setters))))))
  257              vars inits)))
  258     (cons 'let (cons vars/inits (append reacts body)))))))
  259 
  260 
  261 ;;; --------------------------------------------------------------------------------
  262 #|
  263   (test (reactive-let () 3) 3)
  264   (test (let ((a 1)) (reactive-let ((b (+ a 1))) b)) 2)
  265   (test (let ((a 1)) (+ (reactive-let ((b (+ a 1))) (set! a 3) b) a)) 7)
  266   (test (let ((a 1)) (+ (reactive-let ((b (+ a 1)) (a 0)) (set! a 3) b) a)) 3)
  267   (test (let ((a 1)) (reactive-let ((a 2) (b (* a 3))) (set! a 3) b)) 3)
  268   (test (let ((a 1) (b 2)) (reactive-let ((a (* b 2)) (b (* a 3))) (set! a 3) b)) 3)
  269   (test (let ((a 1) (b 2)) (reactive-let ((a (* b 2)) (b (* a 3))) (set! b 3) a)) 4)
  270   (test (let ((a 1) (b 2)) (reactive-let ((a (* b 2))) (set! b 3) a)) 6)
  271   (test (let ((a 1)) (reactive-let ((b (+ a 1))) (set! a 3) b)) 4)
  272   (test (let ((a 1)) (reactive-let ((b (+ a 1)) (c (* a 2))) (set! a 3) (+ c b))) 10)
  273   (test (let ((a 1) (d 2)) (reactive-let ((b (+ a d)) (c (* a d)) (d 0)) (set! a 3) (+ b c))) 11)
  274   (test (let ((a 1) (d 2)) (reactive-let ((b (+ a d)) (c (* a d)) (d 0)) (set! a 3)) (setter 'a)) #f)
  275   (test (let ((a 1) (d 2)) (reactive-let ((b (+ a d)) (c (* a d)) (d 0)) (set! a 3) (set! d 12) (+ b c))) 11)
  276   (test (let ((a 1) (b 2)) (+ (reactive-let ((b (+ a 1)) (c (* b 2))) (set! a 3) (+ b c)) a b)) 13)  ;c=4 because it watches the outer b
  277   (test (let ((a 1)) (reactive-let ((b (* a 2))) (reactive-let ((c (* a 3))) (set! a 2) (+ b c)))) 10)
  278   (test (let ((a 1)) (reactive-let ((b (* a 2))) (let ((d (reactive-let ((c (* a 3))) c))) (set! a 2) (+ b d)))) 7)
  279   (test (let ((a 1)) (reactive-let ((b (* a 2))) (+ (reactive-let ((c (* a 3))) c) (set! a 2) b))) 9) ; a=2 is added to b=4 and c=3
  280   (test (let ((a 1)) (reactive-let ((b (+ a 1))) (reactive-let ((c (* b 2))) (begin (set! a 3) (+ c b))))) 12)
  281   (test (reactive-let ((a (lambda (b) b))) (a 1)) 1)
  282   (test (reactive-let ((a (let ((b 1) (c 2)) (+ b c)))) a) 3)
  283   (test (let ((b 1)) (reactive-let ((a (let ((b 1) (c 2)) (+ b c))) (c (* b 2))) (set! b 43) c)) 86)
  284   (test (let ((x 0.0)) (reactive-let ((y (sin x))) (set! x 1.0) y)) (sin 1.0))
  285   (test (let ((a 1)) (reactive-let ((b a) (c a)) (set! a 3) (list b c))) '(3 3))
  286   (test (let ((a 1)) (reactive-let ((b a)) (reactive-let ((c (* b a))) (set! a 3) (list b c)))) '(3 9))
  287   (test (let ((a 1) (b 2)) (reactive-let ((c a) (d (* b a))) (set! a 3) (list a b c d))) '(3 2 3 6))
  288   (test (let ((a 1)) (reactive-let ((b (* a 2)) (c (* a 3)) (d (* a 4))) (set! a 2) (list a b c d))) '(2 4 6 8))
  289   (test (let ((b 2)) (reactive-let ((a (* b 2))) (+ (reactive-let ((a (* b 3))) (set! b 3) a) a))) 15)
  290 |#
  291 ;;; --------------------------------------------------------------------------------
  292 
  293 (define-macro (reactive-let* vars . body)
  294   (let add-let ((v vars))
  295     (if (pair? v)
  296     `(reactive-let ((,(caar v) ,(cadar v)))
  297        ,(add-let (cdr v)))
  298     (cons 'begin body))))
  299 
  300 
  301 ;;; --------------------------------------------------------------------------------
  302 #|
  303   (test (let ((a 1)) (reactive-let* ((b a) (c (* b a))) (set! a 3) (list b c))) '(3 9))
  304   (test (let ((a 1)) (reactive-let* ((b a) (x (+ a b))) (set! a 3) (list b x))) '(3 6))
  305   (test (let ((x 0.0)) (reactive-let* ((y x) (z (* y (cos x)))) (set! x 1.0) z)) (cos 1.0))
  306 |#
  307 ;;; --------------------------------------------------------------------------------
  308 
  309 #|
  310 (let ()
  311   (define xyzzy (let ((x 0)) 
  312           (dilambda 
  313            (lambda () 
  314              x) 
  315            (lambda (val)
  316              (set! x val)))))
  317   (let ((a 1)) 
  318     (reactive-set! (xyzzy) (+ a 1))
  319     (set! a 2)
  320     (xyzzy))
  321 
  322   (let ((a 1))
  323     (reactive-set! a (+ (xyzzy) 1))
  324     (set! (xyzzy) 2)
  325     a)
  326 
  327   (reactive-let ((a (+ (xyzzy) 1)))
  328     (set! (xyzzy) 2)
  329     a))
  330 
  331 ;;; not different?:
  332 
  333 (let ((v (vector 1 2 3)))
  334   (let ((a 1))
  335     (reactive-set! (v 0) (+ a 1))
  336     (set! a 2)
  337     (v 0)))
  338 
  339 ;;; but where to place the setter in either case -- on 'a and save the location, but then how to erase if reset?
  340 ;;;   and how to ignore if xyzzy arg not the same?
  341 ;;; insist that (f) f be a thunk/dilambda, and in the (set! (f)...) case, put the setter on the setter? (set! (setter (setter f)) ...)
  342 
  343 
  344 <p>Here's the standard example of following the mouse (assuming you're using Snd and glistener):
  345 </p>
  346 <pre class="indented">
  347 (let ((*mouse-x* 0) (*mouse-y* 0)
  348       (x 0) (y 0))
  349 
  350   (reactive-set! x (let ((val (round *mouse-x*))) 
  351              (format *stderr* "mouse: ~A ~A~%" x y) 
  352              val))
  353   (reactive-set! y (round *mouse-y*))
  354 
  355   (g_signal_connect (G_OBJECT (listener-text-widget *listener*)) "motion_notify_event" 
  356             (lambda (w e d) 
  357               (let ((mxy (cdr (gdk_event_get_coords (GDK_EVENT e)))))
  358             (set! *mouse-x* (car mxy))
  359             (set! *mouse-y* (cadr mxy))))))
  360 </pre>
  361 |#