;;;; -*- Scheme -*-
;;
;;;; "find" example for HLSIM
;;
;; David DeRoure June 12 1997, revised Sep 10 1997
;; dder@martigny.ai.mit.edu
;;
;; This Gunk file should be compiled with (cps "find1") followed by
;; (cbf "find1").  It uses definitions in util1d.scm.  See find1s.scm
;; for simulation setup.  See the HLSIM documentation for further details.
;;
;; A "source" processor (processor 0) transmits an UP message containing
;; a "time-to-live" of 50 hops.  When a processor receives an UP message
;; it rebroadcasts it (with ttl decremented) iff the ttl is greater than 
;; anything previously rebroadcast and greater than zero; when rebroadcast 
;; occurs, the process remembers the ID of the processor from which the 
;; message was received (the UP neighbor).  Hence the UP message travels
;; away from the source, and each processor knows the id of its UP neighbor.
;; This is a similar algorithm to the potential example.
;;
;; When the message reaches the destination processor(s), the destination
;; processor sends a DOWN message carrying the id of its UP neighbor.  
;;
;; When a processor receives a DOWN message carrying its id, it
;; broadcasts a new DOWN message to its own UP neighbor, hence the
;; DOWN message travels back to the source, following the chain of
;; UP neighbors.  DOWN messages also carry the id of their sender.
;;
;; Whenever a message is broadcast, retries will occur automatically
;; until such time as they are turned off.  Retries UP cause chains to 
;; be optimised and they continue to be sent until any DOWN message is
;; received.  Retries DOWN are turned off when a DOWN message is received 
;; that was sent by the UP neighbor - this acknowledgement mechanism
;; assumes a symmetric communication model.  NB It is possible to leave 
;; UP retries running, perhaps delaying them rather than stopping them when
;; a DOWN has been seen, but beware that a processor's record of its
;; UP neighbor could then be updated while waiting for an acknowledgement,
;; which with the current program would prevent the acknowledgement 
;; being recognised.
;;
;; Processors change color to magenta when they rebroadcast UP, so that the
;; extent of propagation is evident.  As the DOWN message travels back from
;; destination(s) to source, the processors en route change color to
;; white.  Comms activity is shown by receives flashing green and collisions
;; flashing red.  The source is yellow and the destination white.

(declare (usual-integrations))

;; My processor ID

(define processor-id (random 1000000))

;; Is this a source processor?

(define source?
  (member (processor-number)
          (simulation.get (the-simulation) 'source-processors)))

;; Is this a destination processor?

(define destination?
  (member (processor-number)
          (simulation.get (the-simulation) 'destination-processors)))

;; The global timeout, at which event loop will stop

(define global-timeout (make-timeout-event 100000))

;; The continue event, which is signalled to trigger the event loop
;; to loop when we wish select to re-evaluate the events in each clause.

(define continue (make-event))

;; The break event, which is signalled to break the event-loop

(define break (make-event))

;; The never event, which is never signalled. 

(define never (make-event))

;; The transmit timers

(define retry-down-timer never)
(define retry-up-timer never)

;; Procedures to set timers.  The continue event is signaled
;; so that select re-evaluates the timer events.

(define (set-retry-down-timer! delay)
  (set! retry-down-timer
	(if delay (make-timeout-event delay) never))
  (event.signal! continue #T))

(define (set-retry-up-timer! delay)
  (set! retry-up-timer
	(if delay (make-timeout-event delay) never))
  (event.signal! continue #T))

(define primitive-message-event (make-event))

;; The event loop

(define (loop max-ttl up-neighbor down-neighbor)
  (color-me (if source? "yellow"
		(if down-neighbor "white" 
		    (if up-neighbor "magenta" "blue"))))
  (select
    (primitive-message-event
     => (lambda (message)
          (event.clear! primitive-message-event)
	  (color-me "green")
;;
;; Collision.  If sending UP messages, back off before trying again.
;;
          (cond ( (eq? message 'collision) 
		  (color-me "red")
		  (if up-neighbor
		      (set-retry-up-timer! (+ 1000 (random 5000))))
		  (loop max-ttl up-neighbor down-neighbor) )
;;
;; UP message with higher TTL than previously received.  Rebroadcast
;; it and record who sent it (as my up-neighbor) UNLESS I am the
;; destination, in which case pause for any more imminent UPs and then
;; commence DOWN messages.
;;
		( (and (eq? (first message) 'up) (> (second message) max-ttl))
		  (if destination?
		      (set-retry-down-timer! 500) ; wait before DOWN
		      (set-retry-up-timer! (random 100)))
		  (loop (second message) (third message) down-neighbor) )
;;
;; DOWN message.  Always disable UP messages when a DOWN message
;; has been received.
;;
		( (eq? (first message) 'down)
		  (set-retry-up-timer! #F)
;;
;; If this DOWN message is for me, rebroadcast it and record who
;; sent is (as my down-neighbor) UNLESS I am the source, in which
;; case do not rebroadcast.
;;
		  (cond ( (= (second message) processor-id) ; for me
			  (if source? (beep) (set-retry-down-timer! 100))
			  (loop max-ttl up-neighbor (third message)) )
;;
;; If I have sent a DOWN message to my up-neighbor, and the message
;; just received came from my up-neighbor, then treat this as an
;; acknowledgement and stop rebroadcasting.  Finish the loop.
;;
			( (and down-neighbor up-neighbor    ; acknowledgment
			       (= (third message) up-neighbor))
			  (set-retry-down-timer! #F)
			  (color-me "white")
			  (event.signal! break #T) )
;;
;; If none of the above, ignore this message and go round the loop again.
;;
			( else (loop max-ttl up-neighbor down-neighbor) )) )
		( else (loop max-ttl up-neighbor down-neighbor) ))))
;;
;; When the retry-down-timer times out, broadcast a DOWN message
;; and schedule the retry.
;;
    (retry-down-timer (broadcast `(down ,up-neighbor ,processor-id))
		      (set-retry-down-timer! (+ 100 (random 200)))
		      (loop max-ttl up-neighbor down-neighbor))
;;
;; When the retry-up-timer times out, broadcast an UP message
;; and schedule the retry.
;;
    (retry-up-timer   (broadcast `(up ,(-1+ max-ttl) ,processor-id))
		      (set-retry-up-timer! (+ 1000 (random 10000)))
		      (loop max-ttl up-neighbor down-neighbor))
;;
;; When the continue event is signaled, go round the loop.  This forces
;; select to re-evaluate the clauses, hence the mutated timers take effect.
;;
    (continue (event.clear! continue)
	      (loop max-ttl up-neighbor down-neighbor))
;;
;; The break event causes the loop to finish, as does gloabl-timeout.
;;
    ((or break global-timeout) 'done)))

;; Run the loop

;; loop max-ttl up-neighbor down-neighbor

(if source? (set-retry-up-timer! 0))

(loop (if source? 50 0) source? destination?)

;; end of find1.scm