(declare (usual-integrations))

;; Processor state

(define id (random 1000000))

(define receptor-table (make-eqv-hash-table 9))
(define my-color "blue")
(define running? #T)

;; Events

(define finish (make-timeout-event 100000))
(define primitive-message-event (make-event))
(define unknown (make-event))
(define slow (make-event))
(define fast (make-event))
(define always (make-event))
(event.signal! always #T)

;; Receive loop

(define (rx-loop)
  (color-me my-color)
  (let ((message (wait primitive-message-event)))
    (event.clear! primitive-message-event)
    (if (eq? message 'collision)
	(color-me "red")
	(begin (color-me "green")
	       (event.signal!
		(hash-table/get receptor-table (car message) unknown)
		(cdr message)))))
  (if running? (rx-loop)))

(define (make-receptor key)
  (let ((e (make-event)))
    (hash-table/put! receptor-table key e)
    e))

;; Transmit loop

(define (tx-loop)
  (wait (make-timeout-event 300))
  (if (zero? (random 10)) 
      (event.signal! slow #T)
      (event.signal! fast #T))
  (if running? (tx-loop)))

;; Receptor-Producer loop

(define (make-loop up-event down-event up-message down-message)	 
  (define (loop ttl up down ack)
    (set! my-color (or (and source? "yellow")
		       (and destination? "yellow")
		       (and down "white")
		       (and up "magenta")
		       "blue"))
    (color-me my-color)
    (select
     ;;
     ;; receptors
     ;;
     ((and (not destination?) up-event)
      => (lambda (m)
	   (event.clear! up-event)
	   (if (> (first m) ttl)
	       (loop (first m) (second m) down ack))))
     ((and destination? up-event)
      => (lambda (m)
	   (event.clear! up-event)
	   (loop (first m) (second m) #T (second m))))
     ((and up (not down) down-event)
      => (lambda (m)
	   (event.clear! down-event)
	   (if (= (first m) id)
	       (loop ttl up (second m) (if source? #F up)))))
     ((and ack down-event)
      => (lambda (m)
	   (event.clear! down-event)
	   (if (= (second m) ack)
	       (loop ttl up down #F))))
     ;;
     ;; producers
     ;;
     ((and up (not ack) slow) (event.clear! slow)
			      (broadcast (list up-message (- ttl 1) id)))
     
     ((and ack fast) (event.clear! fast)
		     (broadcast (list down-message ack id)))
     ;;
     ;; shutdown
     ;;
     ((and (not up) down-event) (event.signal! finish #T))
     ((and up down (not ack) always) (event.signal! finish #T))
     (finish (set! running? #F)))
     
    (if running? (loop ttl up down ack)))
  loop)

;; RGB color support

(define rgb.red (make-rgb-accessor 16 24))  ; #xRR0000
(define rgb.green (make-rgb-accessor 8 16)) ; #x00GG00
(define rgb.blue (make-rgb-accessor 0 8))   ; #x0000BB

(define (make-rgb-accessor start end)
  (lambda (rgb)
    (bit-string->unsigned-integer 
     (bit-substring (unsigned-integer->bit-string 24 rgb) 
		    start end))))  ; NB start is inclusive, end is exclusive

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

;; Run the loops

(define color (read-sensor 'light-sensor))

(if (positive? (rgb.red color))
    (make&start-thread 
     (lambda ()
       ((make-loop (make-receptor 'red-up)
		   (make-receptor 'red-down)
		   'red-up
		   'red-down) (if source? 50 0) source? destination? #F))))

(if (positive? (rgb.green color))
    (make&start-thread 
     (lambda ()
       ((make-loop (make-receptor 'green-up)
		   (make-receptor 'green-down)
		   'green-up
		   'green-down) (if source? 50 0) source? destination? #F))))

(if (positive? (rgb.blue color))
    (make&start-thread 
     (lambda ()
       ((make-loop (make-receptor 'blue-up)
		   (make-receptor 'blue-down)
		   'blue-up
		   'blue-down) (if source? 50 0) source? destination? #F))))
      
(if (positive? color) (parallel (rx-loop) (tx-loop)))

;; end of find2.scm