;; 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
))