;; Gradients
;; ----------
;; A gradient from a source essentially produces a breadth first search tree
;; rooted at the source. Each processor receives a value that represents the
;; shortest path length from the source to that processor. It is possible to
;; implement gradients such that each processor gets the correct path length
;; with extremely high probability (talk to me if you don't buy it) - the real
;; error arises when using the path length as an estimate of DISTANCE from the
;; source. The denser the processors the more likely the path length reresents
;; the straight line distance and even then there is error because of the path
;; length is an integer. Smoothing can correct that to some extent - to understand
;; the effect of processor density and layout on the error see AI Memo 1666
;;
;; This file implements gradients without using messages, to speed up simulations.
;; As explained above, this does not buy you immunity from the real error.
;; The gradient appears all at once after *gradient-delay*, but you could trivially
;; implement a timing delay proportional to the path length so that the gradient
;; appears with more delay as one moves away from the source.
;;

;; Smoothing:: 
;; Smoothed gradients (averaged gradient value) are also implemented
;; and a processor receives both the non-smoothed and smoothed
;; gradient value.

;; Multiple Gradients:: 
;; Deals with multiple gradients. The events from different gradients
;; (i.e. with different names) do not clobber each other. Ideally
;; instead of a single GRADIENT-EVENT each gradient X would have its
;; own event called X.

;; Multiple Sources:: 
;; This file implements a cheat for multiple sources emitting the same
;; gradient.  Say a processor creates a gradient named A. If within a
;; *gradient-delay* time, another processor creates a gradient A then
;; the delivery of the gradient is delayed. This continues until no
;; new source appears. Then the final gradient is delivered.  The
;; final gradient is equivalent to the min (shortest paths to any of
;; the source processors). This is roughly equivalent to a single
;; processor implementing a cascading timer (i.e.  each time a new
;; gradient message is heard a timer gets reset and the gradient value
;; is considered finalized when no new messages appear). Also this
;; depends on *gradient-delay* as a measure of how far two consecutive
;; sources can get before the processor accepts the gradient value -
;; hence one may want to redefine this to be more appropriate value
;; for their program.

;;-----------------------------------------------------------------------------------------
;;
;; How To Use
;;------------
;; The following procedure must be added to the init.scm file (cheat procedures file)
;; 	(define (create-gradient cont fuel store name)
;;  	    (%create-gradient cont fuel store name))
;; Within the processor's program must include
;; 	(define gradient-event (make-event))
;; To create a gradient named g1 call
;;	(create-gradient 'g1)
;; Processors receive an event called gradient-event, with the value
;;	('g1 integer-gradient-value smoothed-fp-gradient-value)
;;
;; ** Must call (reset-gradient-storage) before running the simulation **
;; ** Would be nice to have this happen automatically 
;;-----------------------------------------------------------------------------------------



(declare (usual-integrations))

(define *gradient-delay* 1000)
(define *resend-gradient-delay* 100)

; Create a gradient with the name NAME
(define (%create-gradient cont fuel store name)
  (define (time) (vector-ref store store:counter)) ; not working at delivery
  (let ((sim   (store.simulation store))
	(my-id (store.index store))
	(local-id 0))

    (add-src name my-id)
    (set! local-id (current-id name))
    (notify-gradient-creation name my-id (time))

    ; At delivery time, send a gradient event (name & value) to every processor
    ; Only deliver gradient-event if no new srcs have been added
    (define (delivery)
      (if (= local-id (current-id name))
	  (let ((event-cache (make-cache 'GRADIENT-EVENT))
		(n (simulation.n-processors sim))
		(gradient-storage (compute-gradient 
				   (cdr (find-name name)) ; gradient source list
				   (simulation.neighbours sim))))

	    (notify-gradient-delivery name (time))

	    (define (deliver-to-proc index)
	      (let ((pstore (processor.store (vector-ref (simulation.processors sim) index)))
		    (gradient-value (vector-ref (car gradient-storage) index))
		    (smoothed-value (vector-ref (cdr gradient-storage) index)))
		(define (try-to-deliver)
		  (let ((event (global-ref pstore event-cache)))
		    (if (event? event) ; check if processor defined gradient-event
			(if (event.signalled? event)
			    ; prevent multiple gradients from clobbering each other
			    (simulation.enqueue+ sim *resend-gradient-delay* try-to-deliver)
			    ; deliver (name value smoothed-value)
			    (event.signal! event (list name gradient-value smoothed-value))
			    ))))
		(try-to-deliver)
		))

	    (do ((i 0 (+ i 1))) ((= i n))
	      (deliver-to-proc i))

	    ))); end delivery

    ; Queue delivery of the gradient after a delay period
    (simulation.enqueue+ sim *gradient-delay* delivery))

  (cont unspecific (fix:- fuel 1) store))

(define (notify-gradient-creation name id time)
  (pp `(Creating gradient ,name by ,id at time = ,time)))

(define (notify-gradient-delivery name time)
  (pp `(Delivering gradient ,(find-name name) at time = ,time)))

;; Managing multiple sources
;;---------------------------
; gradient srclist is a list of entries
; entry = (cons name (list src1 src2 ...))

(define *gradient-srclist* '())

(define (reset-gradient-storage) (set! *gradient-srclist* '()))

(define (current-id name)
  (length (cdr (find-name name))))

(define (add-src name src)
  (let ((entry (find-name name)))
    (if entry
	(set-cdr! entry (cons src (cdr entry)))
        (set! *gradient-srclist* (cons (cons name (list src)) *gradient-srclist*))
	)))

(define (find-name name)
  (let lp ((slist *gradient-srclist*))
    (cond ((null? slist) #f)
	  ((equal? (car (first slist)) name)
	   (first slist))
	  (else (lp (cdr slist)))
	  )))

;; Computing the Gradient
;;------------------------

(define (compute-gradient srclist nbr-list)
  (let ((t (compute-best-integral-gradient srclist nbr-list)))
    (cons t (compute-smoothed-gradient t nbr-list))
    ))

(define (compute-best-integral-gradient srclist nbr-list)
  ; For each processor, find the min (shortest paths to any src in srclist)
  (let lp ((best (compute-bfs (first srclist) nbr-list))
	   (remaining-srcs (cdr srclist)))
    (if (null? remaining-srcs)
	best
	(lp (compute-better best (compute-bfs (first remaining-srcs) nbr-list))
	    (cdr remaining-srcs)))
    ))

(define (compute-better v1 v2)
  (make-initialized-vector (vector-length v1)
	(lambda (i) (let ((a (vector-ref v1 i)) (b (vector-ref v2 i)))
		      (if (not a) b ; case where unconnected to the src
			  (if (< a b) a b)))
		)))
			  

; Compute shortest paths by Breadth First Search O(V+E)
; later when edges are weighted may move to Djikstra O(V^2 + E)

(define (compute-bfs src-index adjacency-list)
  ; basic algorithm - 
  ; maintain a list of vertices (start with src node)
  ; for each vertex in that list, check all nbrs(v)
  ; if the shortest path for the nbr is unassigned then 
  ;  s(nbr) = s(vertex)+1 & add nbr to the list of vertices
  ;  to be explored next time
  (let* ((n (vector-length adjacency-list))
	 (shortest-paths (make-initialized-vector n (lambda (i) i #f))) )

    (define (s v) (vector-ref shortest-paths v))
    (define (set-s! v l) (vector-set! shortest-paths v l))

    (set-s! src-index 0)

    (let lp ((check-vertices (list src-index)))
      (if (null? check-vertices)
	  'done
	  (let ((new '()))
	    (for-each 
	     (lambda (vertex) ; update the shortest path for its neighbors
	       (for-each-vector-element ; dumb, the arguments are switched
		(vector-ref adjacency-list vertex)
		(lambda (nbr)
		  (if (not (s nbr)) ; unassigned
		      ; s(nbr) = s(v) + 1, add nbr to list
		      (begin (set-s! nbr (+ (s vertex) 1))
			     (set! new (cons nbr new)))))
		))
	     check-vertices)
	    ; redo for all newly assigned nodes
	    (lp new))
	  )) ; end loop

    shortest-paths
    ))


(define (compute-smoothed-gradient shortest-paths adjacency-list)
  (let* ((n (vector-length adjacency-list))
	 (smoothed (make-initialized-vector n (lambda (i) i #f))) )

    (do ((i 0 (+ i 1))) ((= i n))
      (let ((adjlist (vector->list (vector-ref adjacency-list i))))
	; average neighbor and self shortest paths
	(vector-set! smoothed i
	     (if (not (vector-ref shortest-paths i))
		 #f ; not connected to the source
		 (exact->inexact
		  (/ (+ (vector-ref shortest-paths i)
			(reduce + 0 (map (lambda (a) (vector-ref shortest-paths a))
					 adjlist)))
		     (+ 1 (length adjlist))))
		 ))
	))
    smoothed
    ))