#lang scheme/base


;; Reactive programming.

;; The idea behind this abstraction is to allow for a simple form of
;; pull-based reactive programming which essentially serves as a cache
;; for a web application.  All relations are essentially functional
;; where source data is compiled into view.

;; In short: this is `make' with some additional constraints to
;; provide consistency (i.e. what happens when a source changes during
;; a computation?).

;; A simple way to solve the RP problem is to combine push and pull.

;;   - PUSH: do not propagate invalid inputs past invalid nodes; a
;;           network invariant is that
;;
;;   - PULL: only compute what is necessary

;;   Network invariant: a valid node can never depend on an invalid one.


(provide

 rv-delay

 rv-force
 rv-erase
 
 rv-apply  ;; function
 rv-app    ;; macro for application

 ;; Some instantiations of `rv-app' for common access patterns.
 rv-dict
 rv-foldl

 ;; debug: never use these directly!
 rv-value
 
 )

(require
 scheme/dict)

;; If value is void the node needs to be recomputed.  Otherwise it can
;; be safely reused.

(define-struct rv (value thunk children) #:mutable)
(define rv-sem (make-semaphore 1))

;; To keep track of all intermediates for debugging.
(define *rv-pool* (make-weak-hasheq))
(define (rv-panic)
  (for ((n (in-hash-keys *rv-pool*))) (rv-erase-nolock n)))

;; Root value constructor
(define (rv-root-value thunk)
  (let ((node
         (make-rv (rv-invalid)
                  thunk
                  (make-weak-hasheq)
                  )))
    (hash-set! *rv-pool* node #t)
    node))


(define-values
  (rv-invalid? rv-invalid)
  (let ((rvv (vector 'rv-invalid)))
    (values
     (lambda (x) (eq? x rvv))
     (lambda () rvv))))
             

;; PULL: default evaluation is lazy; evaluate once then cache.
(define (rv-force-nolock n)
  (when (rv-invalid? (rv-value n))
    (set-rv-value! n ((rv-thunk n))))
  (rv-value n))

;; PUSH: invalid inputs propagate up to invalid intermediates.
(define (rv-erase-nolock n)
  (let ((v (rv-value n)))
    ;; Propagate only to valid nodes to avoid exponential behaviour.
    (set-rv-value! n (rv-invalid))
    (unless (rv-invalid? v)
      (for ((child (in-hash-keys (rv-children n))))
        (rv-erase-nolock child)))))


;; Create a suspended computation and its dependency structure.
(define-syntax-rule (rv-app fn . parents)
  (rv-apply fn (list . parents)))


(define (rv-register-child! p node)
  (hash-set! (rv-children p) node #t))

(define (rv-apply fn parents)
  (let ((node
         (rv-delay
          (apply fn (map rv-force-nolock parents)))))
    (for ((p parents))
      (rv-register-child! p node))
    node))


(define-syntax-rule (rv-delay expr)
  (rv-root-value (lambda () expr)))



;; An interesting problem is how to represent a list of reactive
;; values; especially a list that can have variable contents.

;; It can not be represented as a concrete list structure (i.e. the
;; length is unknown), so it has to be a finite function.

;; Two methods are necesary:
;;   - element access
;;   - traversal


;; Let's skip the implementation of a list for element access as it is
;; not so useful, and work with dictionaries instead.

;; Take an RV that represents a PLT Scheme dictionary, and represent
;; it as a finite function that returns RVs that depend on the dict.

;; The lookup should probably be memoized to make the resulting RVs
;; unique.  However, that's not done here as we might want to
;; postprocess items before caching.


(define (rv-dict rv)
  (lambda (key)
    (rv-app
     (lambda (dict)
       (dict-ref dict key (lambda () #f)))
     rv)))



;; Folds are straightforward.  Force list, apply fold and wrap in
;; value depending on the original.
(define (rv-foldl fn init rv-lst)
  (rv-app (lambda (lst) (foldl fn init lst)) rv-lst))
      
      
;; (define x (rv-delay 123))
;; (define y (rv-app + x x x))
;; (define (! x) (rv-force x))
;; (define-syntax-rule (@ . a) (rv-app @ . a))

;; (define d (rv-delay '((a . 123))))
;; (define v (rv-dict-ref d 'a))



(define (exclusive fn post)
  (lambda rvs
    (call-with-semaphore
     rv-sem
     (lambda ()
       (apply post
              ;; Perform multiple ops in one transaction
              (map fn rvs))))))

;; Force and invalidate are the "2 sides" of the network and need to
;; be exclusive wrt themselves and each other.
(define rv-force (exclusive rv-force-nolock values))
(define rv-erase (exclusive rv-erase-nolock void))