#lang racket

(provide dependent-boxes agraph-topological-sort agraph-outnodes)

;for splicing-let
(require racket/splicing)

;for mcons and friends
(require racket/mpair)

;;; is any tree-element cmp-equivalent to element?
(define (tree-member? tree element cmp)
  (let loop ((tree tree))
    (if (null? tree) #f
	(let ((elt (car tree)))
	  (or (if (pair? elt) (loop elt) (cmp elt element))
	      (loop (cdr tree)))))))

;;; does the formula reference the variable?
(define (formula-refs-var? expr var)
  (tree-member? expr var eq?) )

;;; which of the variables in a list are referenced by the formula?
(define (formula-refs-vars formula vars)
  (filter (lambda (var) (formula-refs-var? formula var)) vars) )

;;; create an alist-represented graph with an outgoing link for each dependency present in the rules
(define (rules->deps rules)
  (let ((vars (map car rules)))
    (map (lambda (rule)
	   (cons (car rule) (formula-refs-vars (cdr rule) vars)))
	 rules)) )

;;; list of nodes in the alist-graph that satisfy the predicate
(define (agraph-find-nodes graph pred)
  (map car (filter pred graph)) )

;;; list of nodes in the alist-graph that link to node
(define (agraph-incoming-nodes graph node)
  (agraph-find-nodes graph (lambda (link) (memq node (cdr link)))) )

(define (agraph-outnodes graph node)
  (cdr (assoc node graph)) )

;;; invert an alist-represented graph
(define (agraph-invert graph)
  (map (lambda (link)
         (let ((node (car link)))
           (cons node (agraph-incoming-nodes graph node))))
       graph) )

;;; list of nodes in the alist-graph that are roots (nodes without incoming nodes)
(define (agraph-roots graph)
  (agraph-find-nodes graph (lambda (link) (null? (agraph-incoming-nodes graph (car link))))) )

;;; find the roots (nodes without incoming nodes) of a vector-graph
(define (vgraph-roots graph)
  (let ((roots (make-vector (vector-length graph) #t)))
    (for* ((node graph) (n node)) (vector-set! roots n #f))
    (for/list ((i (vector-length graph)) #:when (vector-ref roots i)) i)) )

;;; transform an agraph to a vgraph and a decode hash
(define (vgraph+decoding<-agraph agraph)
  (let-values
      (((encoding decoding node#)
	(for*/fold ((encoding (hash)) (decoding (hash)) (node# 0))
	    ((link agraph) (node link)
	     #:unless (hash-has-key? encoding node))
	  (values (hash-set encoding node node#)
		  (hash-set decoding node# node)
		  (+ 1 node#) ))))
    (define vgraph (make-vector node#))
    (define (encode n) (hash-ref encoding n))
    (for ((link agraph))
	 (vector-set! vgraph (encode (car link)) (map encode (cdr link))))
    (values vgraph decoding) ) )

(define (agraph<-vgraph+decoding vgraph decoding)
  (define (decode n) (hash-ref decoding n))
  (for/fold ((agraph '())) ((n (in-range (- (vector-length vgraph) 1) -1 -1)))
    (cons (cons (decode n) (map decode (vector-ref vgraph n))) agraph) ) )

;;; do a depth-first-traversal of a vector-represented graph
;;; each node is folded the first time it is visited (with pre-op)
;;; and again when its subforest has been visited (with post-op) over unit
(define (vgraph-depth-first-traversal graph roots pre-op post-op unit)
  (let ((visited? (make-vector (vector-length graph) #f)))
    (define (visit node ret)
      (vector-set! visited? node #t)
      (post-op node (visit*
		     (vector-ref graph node)
		     (pre-op node ret))))
    (define (visit* nodes ret)
      (if (null? nodes) ret
	  (let ((node (car nodes)))
	    (visit*
	     (cdr nodes)
	     (if (vector-ref visited? node) ret
		 (visit node ret))))))
    (visit* roots unit)))

;;; topologically sort a vector-represented graph
(define (vgraph-topological-sort vgraph)
  (reverse (vgraph-depth-first-traversal vgraph (vgraph-roots vgraph) (lambda (x y) y) cons '())))

;;; topologically sort an alist-represented graph
(define (agraph-topological-sort agraph)
  (let-values (((vgraph decoding) (vgraph+decoding<-agraph agraph)))
    (map (lambda (v) (hash-ref decoding v))
	 (vgraph-topological-sort vgraph))) )

;; (define-syntax (dependent-boxes stx)
;;   (syntax-case stx ()
;;     ((_ . x)
;;      #`(let-syntax
;; 	   ((with-variables 
;; 	     (syntax-rules #,(map car (syntax->list stx)
;; 	       (_ ))

#|
(define-syntax define-dependent-boxes
  (syntax-rules ()
    ((_ name ((variable . rule) ...))
     (define name
       (let*
	   ((value-store (list (mcons 'variable #f) ...))
	    (rules
	     (letrec-syntax
		 ((with-variables
		   (syntax-rules (variable ...)
		     ((_ (a (... ...))) ((with-variables a) (... ...)))
		     ((_ variable) (assoc 'variable value-store))
		     ...
		     ((_ non-variable) non-variable) ))
		  (rule-with-variables
		   (syntax-rules ()
		     ((_ ()) #f)
		     ((_ (r)) (lambda () (with-variables r))) )) )
	       (list `(variable ,(rule-with-variables rule)) ...) )) )
	 (cons value-store rules))))))
|#

;; (define-dependent-boxes
;;   box-rules
;;   ((a)
;;    (b (* 2 a))
;;    (c (+ 2 a b))))
;;
;; box-rules

(define-syntax dependent-boxes
  (syntax-rules ()
    ((_ ((_variable_ . _rule_) ...))
     (let ()

       (splicing-let ((value-store (mlist (mcons '_variable_ #f) ...)))
	 (define (show-value-store)
	   (mlist->list value-store))
	 (define (variable-ref variable)
	   (mcdr (massoc variable value-store)))
	 (define (variable-set! variable value)
	   (set-mcdr! (massoc variable value-store) value)))
     
       (splicing-let
	   ((rule-store
	     (letrec-syntax
		 ((with-variables
		   (syntax-rules (_variable_ ...)
		     ((_ (a (... ...))) ((with-variables a) (... ...)))
		     ((_ _variable_) (variable-ref '_variable_))
		     ...
		     ((_ non-variable) non-variable) ))
		  (rule-with-variables
		   (syntax-rules ()
		     ((_ ()) #f)
		     ((_ (rule)) (lambda () (with-variables rule))) )) )
	       (list `(_variable_ ,(rule-with-variables _rule_)) ...))))
	 (define (variable-rule-ref variable)
	   (cadr (assoc variable rule-store))))
       
       (define (update-variable variable value)
	 (when (not (variable-rule-ref variable))
	   (variable-set! variable value)
	   (propagate)))

       (define topological-order
	 (agraph-topological-sort (rules->deps '((_variable_ . _rule_) ...))))

       (define (propagate)
	 (for-each
	  (lambda (node)
	    (let ((rule (variable-rule-ref node)))
	      (when rule (variable-set! node (rule)))))
	  topological-order))
     
       (lambda args
	 (if (null? args)
	     (raise-arity-error '|<dependent-boxes-closure>| (arity-at-least 1))
	     (case (car args)
	       ((show) (show-value-store))
	       ((get-value) (variable-ref (cadr args)))
	       ((get-rule) (variable-rule-ref (cadr args)))
	       ((update-value) (apply update-variable (cdr args)))
	       ))) ))))
