FPOOP

fpoop.lisp

;;;; fpoop.lisp
;;
;;;; Copyright (c) 2021 Christopher Hebert

(cl:defpackage #:fpoop
  (:use #:coalton #:coalton-library))

(cl:in-package #:fpoop)

;; Conventions:
;;   type constructors prefixed with an _ to avoid name conflicts with variables
;;   % postfix means the function performs an update on an internal data member of the object
;;   ? postfix means the variable/function is/returns a boolean
;;   data-type.field are accessors
;;   data-type.field% are modifiers

;; NOTE: Continuation passing style is used to provide a kind of multiple value return semantics.
;; This enables the algorithm to be broken up into bite-sized chunks, but it may be confusing at first.
;; One can think of a continuation as a return statement with multiple values.
;; Also, by providing multiple continuations, different numbers/types of values can be returned.

;; Consider:
#+nil
(coalton-toplevel
  (define-type specific-result-type
    ((_specific-result-type Integer Integer Integer Integer)
     (_alternate-result-type String String)))
  (define (returns-specific-result-type a)
    (if a
	(_specific-result-type 1 2 3 4)
	(_alternate-result-type "uh" "oh")))

  ;; TO use this:
  (match (returns-specific-result-type true)
    ((_specific-result-type a b c d) ...)
    ((_alternate-result-type s1 s2) ...)))

;; vs. continuation-passing-style
#+nil
(coalton-toplevel
  (define (returns-results a succeed fail)
    (if a
	(succeed 1 2 3 4)
	(fail "uh" "oh")))
  (returns-results
   true
   (fn (a b c d) ...)
   (fn (s1 s2) ...)))

;; Sometimes a group of return values don't deserve a type or a name. I think CSP is a good solution for this case.
;; Once one becomes accustomed to it, the result is a very elegant solution.
;;; END CONVENTIONS

;;; DEFINE-RECORD is used for defining a product type with functional accessors to it.
;; Matching is nice but it isn't particularly composable.
;; Thankfully it's easy to generate functions if the type is a single-constructor product type.
;; Accessors are:
;;   getters of the form record-name.field-name with type (:record -> :field)
;;   modifiers of the form record-name.field-name% with type ((:field -> :field) -> :record -> :record)

;; define-record-accessors only defines the accessor functions.
(cl:defmacro define-record-accessors (name constructor-name cl:&body field-names)
  (cl:let* (;; names used in definitions for accessors
	    (record-var (cl:gensym "RECORD"))
	    (update-var (cl:gensym "UPDATE"))
	    (value-var (cl:gensym "VALUE"))

	    ;; Field getters are RECORD-NAME.FIELD-NAME
	    (field-getters (cl:mapcar (cl:lambda (field-name)
					(cl:intern (cl:format nil "~A.~A" name field-name)))
				      field-names))
	    ;; Field modifiers are RECORD-NAME.FIELD-NAME%
	    (field-modifiers (cl:mapcar (cl:lambda (field-name)
					  (cl:intern (cl:format nil "~A.~A%" name field-name)))
					field-names)))
    `(coalton-toplevel
       ,@(cl:loop for i from 0
	    for field-name in field-names
	    for field-getter in field-getters
	    for field-modifier in field-modifiers
	    appending
	    `((define (,field-getter ,record-var)
		(match ,record-var
		  ;; Perform a match of ((_CONSTRUCTOR _ _ ... value-var _ _) value-var)
		  ((,constructor-name ,@(cl:make-list i :initial-element '_)
				      ,value-var
				      ,@(cl:make-list (cl:- (cl:length field-names) i 1) :initial-element '_))
		   ,value-var)))
	      (define (,field-modifier ,update-var ,record-var)
		(,constructor-name
		 ;; Copy the fields from the given record-var
		 ,@(cl:mapcar (cl:lambda (getter) `(,getter ,record-var)) (cl:subseq field-getters 0 i))
		 ;; update the field from the given record-var
		 (,update-var (,field-getter ,record-var))
		 ;; Copy the remaining fields from the given record-var
		 ,@(cl:mapcar (cl:lambda (getter) `(,getter ,record-var)) (cl:subseq field-getters (cl:1+ i))))))))))

;; define-record defines the type and the accessors.
(cl:defmacro define-record (name-and-type-parameters cl:&body fields)
  (cl:let* ((name (cl:if (cl:listp name-and-type-parameters)
			 (cl:first name-and-type-parameters)
			 name-and-type-parameters))

	    ;; Name of the constructor is _RECORD-NAME
	    (constructor-name (cl:intern (cl:format nil "_~A" name)))
	    (field-names (cl:mapcar #'cl:first fields))
	    (field-types (cl:mapcar #'cl:second fields)))
    `(cl:progn
       (coalton-toplevel
	 (define-type ,name-and-type-parameters
	   (,constructor-name ,@field-types)))
       (define-record-accessors ,name ,constructor-name ,@field-names))))

(cl:defmacro fmt ((cl:&rest coalton-references) fmt-string cl:&rest fmt-args)
  `(lisp string ,coalton-references
     (cl:format () ,fmt-string ,@fmt-args)))

;; Example usage of define-record
#+nil
(define-record (example :color)
  (name string)
  (age Integer)
  (favorite-color :color))

#+nil
(COMMON-LISP:PROGN
  (COALTON-TOPLEVEL
    (DEFINE-TYPE (EXAMPLE :COLOR)
      (_EXAMPLE STRING INTEGER :COLOR)))
  (COALTON-TOPLEVEL
    (DEFINE (EXAMPLE.NAME #:RECORD684)
      (MATCH #:RECORD684
	((_EXAMPLE #:VALUE686 _ _) #:VALUE686)))
    (DEFINE (EXAMPLE.NAME% #:UPDATE685 #:RECORD684)
      (_EXAMPLE (#:UPDATE685 (EXAMPLE.NAME #:RECORD684))
		(EXAMPLE.AGE #:RECORD684) (EXAMPLE.FAVORITE-COLOR #:RECORD684)))
    (DEFINE (EXAMPLE.AGE #:RECORD684)
      (MATCH #:RECORD684
	((_EXAMPLE _ #:VALUE686 _) #:VALUE686)))
    (DEFINE (EXAMPLE.AGE% #:UPDATE685 #:RECORD684)
      (_EXAMPLE (EXAMPLE.NAME #:RECORD684)
		(#:UPDATE685 (EXAMPLE.AGE #:RECORD684))
		(EXAMPLE.FAVORITE-COLOR #:RECORD684)))
    (DEFINE (EXAMPLE.FAVORITE-COLOR #:RECORD684)
      (MATCH #:RECORD684
	((_EXAMPLE _ _ #:VALUE686) #:VALUE686)))
    (DEFINE (EXAMPLE.FAVORITE-COLOR% #:UPDATE685 #:RECORD684)
      (_EXAMPLE (EXAMPLE.NAME #:RECORD684) (EXAMPLE.AGE #:RECORD684)
		(#:UPDATE685 (EXAMPLE.FAVORITE-COLOR #:RECORD684))))))

#+nil
(coalton
 (let ((example (_example "George" 31 "Blue")))
   (tuple (example.favorite-color example)
	  (example.age% (+ 1) example))))
;; #.(TUPLE "Blue" #.(_EXAMPLE "George" 32 "Blue"))

;; END DEFINE-RECORD


;; An implementation for stateful-computations that relies on a continuation instead of a tuple.
(coalton-toplevel
  (define-type (stateful-computation :continue :state :value)
    (_stateful-computation (:state -> (:state -> :value -> :continue) -> :continue)))

  (define (run s)
    (match s ((_stateful-computation fstate) fstate)))
  (define (run-tuple s initial-state)
    (run s initial-state tuple))
  (define (run-state s initial-state)
    (run s initial-state (fn (state _) state)))
  (define (run-value s initial-state)
    (run s initial-state (fn (_ value) value)))
  (define (run-unit s initial-state)
    (run s initial-state (fn (_ _) unit)))

  (define get
    "Return a stateful computation that returns the state."
    (_stateful-computation (fn (state continue) (continue state state))))
  (define (put state)
    "Return a stateful computation that sets state and returns Unit"
    (_stateful-computation (fn (_ continue) (continue state Unit))))
  (define (modify state->state)
    "Return a stateful computation that updates state and returns Unit."
    (>>= get (compose put state->state)))
  (define (thread state->value)
    "Return a stateful computation that threads the state through state->value"
    (_stateful-computation (fn (state continue) (continue state (state->value state)))))
  (define (const-stateful-computation state value)
    "Return a stateful computation that returns the state and the value"
    (>> (put state)
	(pure value)))
  (define (modify-return state->state value)
    "Return a stateful computation that updates state and returns value."
    (>> (modify state->state)
	(pure value)))
  (define (get-value state->value)
    "A stateful-computation that returns a value given the current state."
    (>>= get (compose pure state->value)))


  (define-instance (Functor (stateful-computation :continue :state))
    (define (map a->b sa)
      (_stateful-computation
       (fn (state1 continue)
	 (run sa state1
	      (fn (state2 a)
		(continue state2 (a->b a))))))))

  (define-instance (Applicative (stateful-computation :continue :state))
    (define (pure value)
      (_stateful-computation
       (fn (state continue)
	 (continue state value))))

    (define (liftA2 ab->c sa sb)
      (_stateful-computation
       (fn (state1 continue)
	 (run sa state1
	      (fn (state2 a)
		(run sb state2
		     (fn (state3 b)
		       (continue state3 (ab->c a b))))))))))

  (define-instance (Monad (stateful-computation :continue :state))
    (define (>>= sa a->sb)
      (_stateful-computation
       (fn (state1 continue)
	 (run sa state1
	      (fn (state2 a)
		(run (a->sb a) state2 continue))))))))

(coalton-toplevel
  (define (wrap-state unwrap wrap computation)
    "A stateful-computation that runs computation on a field of state.
Uses (unwrap state) to get the field, runs the given computation on the field to produce the result
and an updated field, and (wrap field state) to get the updated state."
    (>>= get
	 (fn (state)
	   (run computation (unwrap state)
		(fn (inner-state2 result)
		  (modify-return (wrap inner-state2) result)))))))

(coalton-toplevel
  (declare put-field (((:a -> :a) -> :record -> :record) -> :a -> :record -> :record))
  (define (put-field field-modifier value record)
    "Given a field modifier, a field value, and a record return the record with the field updated."
    (field-modifier (const value) record)))

;;; INFINITE STREAM
;; To efficiently implement a stream we need to memoize the tail (so it is only computed once).
(coalton-toplevel
  (declare memoized ((unit -> :a) -> (unit -> :a)))
  (define (memoized f)
    "Return a memoized function that wraps f."
    (lisp (unit -> :a) (f)
      (cl:let ((value cl:nil)
	       (run? cl:nil))
	(fn (_)
	  (cl:declare (cl:ignore _))
	  (cl:if run?
		 value
		 (cl:progn
		   (cl:setq value (cl:funcall f unit))
		   (cl:setq run? cl:t)
		   value)))))))

;; Infinite streams are guaranteed to never be empty
(define-record (infinite-stream :value)
  (head :value)
  (delayed-tail (unit -> (infinite-stream :value))))

(coalton-toplevel
  (define (infinite-stream head delayed-tail)
    (_infinite-stream head (memoized delayed-tail))))

(coalton-toplevel
  (define (infinite-stream-tail stream)
    ((infinite-stream.delayed-tail stream))))

(coalton-toplevel
  (define-instance (functor infinite-stream)
    (define (map a->b sa)
      (match sa
	((_infinite-stream a dsa)
	 (infinite-stream (a->b a) (fn (_) (map a->b (dsa)))))))))

(coalton-toplevel
  (define-instance (applicative infinite-stream)
    (define (pure a)
      (infinite-stream a (fn (_) (pure a))))
    (define (lifta2 ab->c sa sb)
      (infinite-stream (ab->c (infinite-stream.head sa)
			      (infinite-stream.head sb))
		       (fn (_) (lifta2
				ab->c
				(infinite-stream-tail sa)
				(infinite-stream-tail sb)))))))

(coalton-toplevel
  (define infinite-stream-computation
    (_stateful-computation
     (fn (stream continue)
       (continue (infinite-stream-tail stream) (infinite-stream.head stream))))))
;; END INFINITE-STREAM

;; RANDOM STREAM
(define-record random-state
  ;; A random-state is a choice of functions which return a random number s.t. 0 <= number < limit
  (integer (integer -> integer))
  (float (single-float -> single-float))
  (double (double-float -> double-float)))

(coalton-toplevel
  ;; Return an infinite stream of random-states.
  ;; Each random-state is unique, but when applied with the same limit will result in the same value.
  (define random-stream
    (lisp (infinite-stream random-state) ()
      (cl:labels ((make-stream ()
		    (cl:let ((random-state (cl:make-random-state)))
		      (infinite-stream
		       (_random-state
			;; Applies random to a copy of the random state.
			(fn (limit) (cl:random limit (cl:make-random-state random-state)))
			(fn (limit) (cl:random limit (cl:make-random-state random-state)))
			(fn (limit) (cl:random limit (cl:make-random-state random-state))))
		       (fn (_) (cl:declare (cl:ignore _)) (make-stream))))))
	(make-stream)))))

(coalton-toplevel
  (define (next-random accessor limit random-states)
    (tuple (infinite-stream-tail random-states)
	   ((accessor (infinite-stream.head random-states)) limit)))

  (define (next-random-integer limit random-states)
    (next-random random-state.integer limit random-states))
  (define (next-random-float limit random-states)
    (next-random random-state.float limit random-states))
  (define (next-random-double limit random-states)
    (next-random random-state.double limit random-states)))
;; END RANDOM STREAM

;;; UID
;; A UId is represented as an integer.
;; NOTEs: It would be helpful to be able to hide the constructor of a UId,
;; to limit the construction of UIds to a central location.
;; It might also be helpful to distinguish between an Entity's own UId,
;; and the UIds provided to them, so that they couldn't accidentally
;; change their own UId.
(define-record uid
  (value Integer))
(coalton-toplevel
  (declare same-uid? (uid -> uid -> boolean))
  (define (same-uid? a b)
    "True if a and b are the same uid"
    (== (uid.value a) (uid.value b))))

(coalton-toplevel
  (define (stream-integers initial)
    (_infinite-stream initial (fn (_) (stream-integers (+ 1 initial))))))
(coalton-toplevel
  (define (stream-uids initial-index)
    (map _uid (stream-integers initial-index))))
(coalton-toplevel
  (define initial-uids (stream-uids 0)))
;;; END UID

;;; TABLE
(define-record (table-entry :key :value)
  (key :key)
  (value :value))

(define-record (table :key :value)
  (entries (list (table-entry :key :value)))
  (equal (:key -> :key -> boolean)))

(coalton-toplevel
  (declare test-key ((:key -> boolean) -> (:object -> :key) -> :object -> boolean))
  (define (test-key test extract-key object)
    (test (extract-key object))))

(coalton-toplevel
  (declare table-remove (:key -> (table :key :value) -> (table :key :value)))
  (define (table-remove key table)
    "Remove value associated with key in table."
    (let ((equal (table.equal table))
	  (test (fn (entry-key) (not (equal key entry-key)))))
      (table.entries% (filter (test-key test table-entry.key)) table))))


(coalton-toplevel
  (declare table-store (:key -> :value -> (table :key :value) -> (table :key :value)))
  (define (table-store key value table)
    "Uniquely associate key and value in table. Removes old association if present."
    (table.entries%
     (fn (entries) (cons (_table-entry key value) entries))
     (table-remove key table))))

(coalton-toplevel
  (declare table-lookup (:key -> (table :key :value) -> (Optional :value)))
  (define (table-lookup key table)
    "Lookup the value associated with key in key."
    (let ((test ((table.equal table) key)))
      (match (filter (test-key test table-entry.key) (table.entries table))
	((cons entry _) (some (table-entry.value entry)))
	((nil) none)))))

(coalton-toplevel
  (declare table-keys ((table :key :value) -> (list :key)))
  (define (table-keys table)
    "Return all keys in the table."
    (map table-entry.key (table.entries table))))
(coalton-toplevel
  (declare table-values ((table :key :value) -> (list :value)))
  (define (table-values table)
    "Return all values in the table."
    (map table-entry.value (table.entries table))))
;;; END TABLE


;; The sender may be the system itself, or it could be another entity.
(coalton-toplevel
  (define-type sender-id
    ;; Entity sender is a uid
    (_entity-sender-id uid)
    ;; The delivery service is returning the envelope. (UID is the undeliverable address)
    (_return-sender-id uid)
    ;; Otherwise it may be sent from the system.
    (_system-sender-id)))

;; An envelope has a "sender address" (the author of the entity-message)
;; a "delivery addresse", and the actual message.
;; An can come from one sender and can be delivered to any entity (including oneself).
(define-record (envelope :message)
  (sender-id sender-id)
  (destination-id uid)
  ;; message payload
  (message :message))

;; The entity system is parameterized by a two types of messages:
;;  entity-message: the specific messages that entities should be able to respond to
;;    each entity has a entity-message handler, which takes an entity-message and performs an update
;;  system-requests: the IO requests that the system should be able to handle
(coalton-toplevel
  ;; An entity is defined by its interface:
  ;; The entity-interface the public entity data associated with the uid.
  ;; It is comprised of a single method for responding to entity-messages.

  ;; TODO: Type alias this if that is a thing
  #+nil
  (define-type (entity-interface :entity-message :system-request)
    (_entity-interface
     ;; A way for the entity to respond to entity messages.
     ((envelope :entity-message) -> (entity-environment :entity-message :system-request) -> (entity-environment :entity-message :system-request))))
  
  ;; System requests are requests to the entity system itself.
  ;; These requests are handled by the system, and not delivered to entities.
  (define-type (entity-system-request :entity-message :system-request)
    ;; Forward a request to the system (I/O)
    (_sys-request :system-request)
    ;; Request to terminate the entity system.
    (_sys-quit)
    ;; Tell the system that an envelope has been returned to the system.
    (_sys-returned-envelope (envelope :entity-message))
    ;; Tell the system that an envelope could not bee returned to the original sender.
    (_sys-unreturnable-envelope (envelope :entity-message))
    ;; Add the new entity to the entity-system
    (_sys-create-entity uid ((envelope :entity-message) -> (entity-environment :entity-message :system-request) -> (entity-environment :entity-message :system-request)))
    ;; Remove the entity from the entity-system (if present)
    (_sys-destroy-entity uid))

  ;; The entity-environment includes all of the outgoing messages/requests.
  ;; This way, an entity-environment can accumulate sent messages/requests.
  ;; Additionally the entity-environment references global resources like the uid stream,
  ;; so that entities can easily create new uids.
  (define-type (entity-environment :entity-message :system-request)
    (_entity-environment
     ;; List of outgoing messages to other entities
     (list (envelope :entity-message))
     ;; List of system requests.
     (list (entity-system-request :entity-message :system-request))
     ;; Stream of UIDs
     (infinite-stream uid)
     ;; Infinite stream of random states
     (infinite-stream random-state)
     ;; UID of the entity being updated
     uid
     ;; Interface of the entity being updated
     ((envelope :entity-message) -> (entity-environment :entity-message :system-request) -> (entity-environment :entity-message :system-request))))

  ;; During an update, an entity depends on the presence of persistent state to provide resources like
  ;; unique ids, random numbers, and the interfaces of other entities that it can communicate with.
  ;; This state must persist between entity updates to preserve unique ids and randomness.
  (define-type (entity-system-state :entity-message :system-request)
    (_entity-system-state
     ;; Infinite stream of unique ids
     (infinite-stream uid)
     ;; Table of all entities: uid -> entity-interface
     (table uid ((envelope :entity-message) -> (entity-environment :entity-message :system-request) -> (entity-environment :entity-message :system-request)))
     ;; Infinite stream of random states
     (infinite-stream random-state))))

;; NOTE: The above types need to be evaluated together since they are interdependent, which means
;; I can't just use define-record. I've separated out define-record-accessors to patch this.
(define-record-accessors entity-environment _entity-environment
  messages
  requests
  uid-stream
  random-state-stream
  entity-uid
  interface)
(define-record-accessors entity-system-state _entity-system-state
  uid-stream
  table
  random-state-stream)

;;; ENTITY-SYSTEM-STATE Functions
;; The system state provides operations to: 
;;   store/remove an entity

(coalton-toplevel
  (define (store-entity uid interface)
    "Store/replace the entity-interface in the entity-system state"
    (entity-system-state.table% (table-store uid interface))))

(coalton-toplevel
  (declare remove-entity (uid -> (entity-system-state :em :sr) -> (entity-system-state :em :sr)))
  (define (remove-entity uid)
    "Remove the entity from the entity-system state"
    (entity-system-state.table% (table-remove uid))))

;; END ENTITY-SYSTEM-STATE

;;; ENTITY-ENVIRONMENT Functions
;; An entity environment provides operations to:
;;   get the next uid
;;   append new messages to send
;;   append new requests to send

(coalton-toplevel
  (declare next-uid (stateful-computation :c (entity-environment :em :sr) uid))
  (define next-uid
    "Return a new uid in the updated entity-environment."
    (wrap-state
     ;; wrap/unwrap uid-stream
     entity-environment.uid-stream
     (put-field entity-environment.uid-stream%)
     ;; computation on uid-stream
     infinite-stream-computation)))

(coalton-toplevel
  (define my-uid
    (get-value entity-environment.entity-uid)))

(coalton-toplevel
  (define (put-interface interface env)
    "Updates the interface of entity-environment."
    (put-field entity-environment.interface% interface env)))

(coalton-toplevel
  (declare entity-envelope (uid -> :em -> (entity-environment :em :sr) -> (envelope :em)))
  (define (entity-envelope destination-uid entity-message env)
    "Creates an envelope with my-uid as the sender."
    (_envelope (_entity-sender-id (entity-environment.entity-uid env))
	       destination-uid
	       entity-message)))
(coalton-toplevel
  (declare send-envelope ((envelope :em) -> (entity-environment :em :sr) -> (entity-environment :em :sr)))
  (define (send-envelope envelope env)
    "Send an outgoing message."
    (entity-environment.messages%
     (fn (old-messages)
       (append old-messages (make-list envelope)))
     env)))
(coalton-toplevel
  (declare send (uid -> :em -> (entity-environment :em :sr) -> (entity-environment :em :sr)))
  (define (send destination-id message env)
    "Send an outgoing message."
    (send-envelope (entity-envelope destination-id message env) env)))

(coalton-toplevel
  (declare request ((entity-system-request :em :sr) -> (entity-environment :em :sr) -> (entity-environment :em :sr)))
  (define (request r env)
    "Append new outgoing requests."
    (entity-environment.requests% (fn (old-requests) (append old-requests (make-list r))) env)))
;;; END ENTITY-ENVIRONMENT

;;; ENTITY SYSTEM

;; The interface to the entity system is a function to deliver an envelope off the front of a queue of envelopes:
;;   deliver-next-envelope

;; deliver-next-envelope is applied to initial entity-system-state, as well as a queue of envelopes

;;; DELIVER-NEXT-ENVELOPE ALGORITHM
;; During the delivery process:
;; Enveloped messages are put into a queue: envelope-queue

;; one envelope is removed from the envelope-queue
;;  the delivery address on the envelope is used to look up the entity interface in the entity table in the entity-system-state
;;  if found:
;;    the envelope is applied to the entity's message handler
;;    the return values are:
;;      the updated entity-system-state
;;      the queue of envelopes with the new outgoing envelopes appended to the end
;;      the list of system requests
;;  if not found:
;;    the sender's address is used:
;;      if the sender is the system:
;;         return entity-system-state, the queue of envelopes, a list of a single system request notifying the system that the entity does not exist
;;      if the sender is an entity:
;;         look up the entity-interface associated with the uid of the sender
;;           if found:
;;             deliver a return-envelope to the sender's message handler
;;             the return values are:
;;               the updated entity-system-state
;;               the queue of envelopes with the new outgoing envelopes appended to the end
;;               the list of system requests
;;           if not found:
;;             return entity-system-state, the queue of envelopes, a list of a single system request notifying the system that neither the sender nor the recipient exist
;; END DELIVER-NEXT-ENVELOPE

(coalton-toplevel
  ;; Lookup-recipient finds the recipient for the envelope in the entity-system-state.
  (define (lookup-recipient entity-system-state envelope)
    ;; Lookup the entitiy given the delivery-address uid
    ;; Lookup the entity given the envelope's destination id
    (table-lookup (envelope.destination-id envelope)
		  (entity-system-state.table entity-system-state))))


(coalton-toplevel
  ;; Return a fresh entity-environment with no outgoing messages/requests,
  ;; and the global state from the entity-system-state
  (define (fresh-entity-environment entity-system-state entity-uid entity-interface)
    (_entity-environment (make-list)
			 (make-list)
			 ;; The uid-stream and random-state-stream come from the system state.
			 (entity-system-state.uid-stream entity-system-state)
			 (entity-system-state.random-state-stream entity-system-state)
			 entity-uid
			 entity-interface)))

(coalton-toplevel
  ;; Return an updated entity-system-state, with the results of entity-environment
  (define (entity-system-state-updated entity-system-state entity-environment)
    ;; Store the updated the uid-stream and random stream
    (_entity-system-state (entity-environment.uid-stream entity-environment)
			  (entity-system-state.table entity-system-state)
			  (entity-environment.random-state-stream entity-environment))))

(coalton-toplevel
  ;; Runs the entity update in an entity-environment with the provided entity-system-state.
  ;; Returns (continue new-entity-system-state new-envelopes new-system-reuqests new-interface)
  (define (run-entity-update entity-update entity-system-state entity-uid entity-interface continue)
    ;; Apply the state function (:entity-environment -> (state-result :entity-environment :entity-interface))
    ;; to a fresh entity-environment to get the final state-result
    (let ((entity-environment (entity-update (fresh-entity-environment entity-system-state entity-uid entity-interface)))) 
      ;; Parse/return the results to the continuation:
      (continue
       (entity-system-state-updated entity-system-state entity-environment)
       (entity-environment.messages entity-environment)
       (entity-environment.requests entity-environment)
       (entity-environment.interface entity-environment)))))

(coalton-toplevel
  ;; Handle message applies a message to an entities handler in the context of entity-system-state.
  ;; Returns by calling (continue new-entity-system-state updated-envelope-queue new-system-requests new-interface)
  (define (handle-message entity-system-state entity-interface envelope continue)
    ;; Give the message to the entity's message handle, and run the computation.
    ;; Pass the results to continue.
    (run-entity-update (entity-interface envelope)
		       entity-system-state
		       (envelope.destination-id envelope)
		       entity-interface
		       continue)))

(coalton-toplevel
  ;; delivers an opened message to the entity's handler before
  ;; returning (continue new-entity-system-state new-envelope-queue new-system-request-queue)
  (define (deliver-envelope-to-entity entity-system-state envelope-queue entity-interface envelope continue)
    ;; Allow the entity to handle the message and update its interface, in
    ;; the context of the entity-system-state.
    (handle-message
     entity-system-state entity-interface envelope
     ;; Continuation after the entity has handled the message:
     (fn (entity-system-state new-envelopes system-requests new-interface)
       ;; After handling the message:
       (continue
	;; Store the updated interface in the updated entity-system-state
	(store-entity (envelope.destination-id envelope) new-interface entity-system-state)
	;; Append the new envelopes to the queue
	(append envelope-queue new-envelopes)
	;; Return the system-requests
	system-requests)))))

(coalton-toplevel
  ;; A return envelope inverts the destination-id and the sender-id,
  ;; and marks the sender-id as being a return-sender-id.
  (define (return-to-sender-envelope envelope sender-uid)
    (_envelope (_return-sender-id (envelope.destination-id envelope))
	       sender-uid
	       (envelope.message envelope))))

(coalton-toplevel
  ;; delivers an enveloped message before calling (continue new-entity-system-state envelope-queue system-request-queue)
  ;; if delivery fails, attempt to return the message to the sender.
  (define (deliver-envelope entity-system-state envelope envelope-queue continue)
    ;; To deliver a message (inside of envelope), we first lookup the recipient of the message in the current entity-system-state.
    (match (lookup-recipient entity-system-state envelope)
      ((some entity-interface)
       ;; Now we deliver the envelope to the entity's handler, before continuing.
       (deliver-envelope-to-entity entity-system-state
				   envelope-queue
				   entity-interface
				   envelope
				   ;; return the result of deliver-message to whoever called me (deliver-envelope)
				   continue))      
      ((none)
       ;; Recipient not found:
       (handle-undeliverable-envelope entity-system-state envelope envelope-queue continue))))

  ;; Handle the case when an envelope's destination entity no longer exists
  (define (handle-undeliverable-envelope entity-system-state envelope envelope-queue continue)
    (match (envelope.sender-id envelope)
      ;; This was a message from one entity to another
      ((_entity-sender-id uid)
       ;; Try delivering a return envelope to the entity that sent this envelope.
       ;; This may fail if the sender no longer exists either.
       (deliver-envelope entity-system-state
			 (return-to-sender-envelope envelope uid)
			 envelope-queue
			 continue))

      ;; This was a message from the system
      ((_system-sender-id)
       (continue entity-system-state
		 envelope-queue
		 ;; Return the message to the system
		 (make-list (_sys-returned-envelope envelope))))
      
      ;; This was a message that we tried to return to the sender, but the sender doesn't exist anymore.
      ((_return-sender-id _)
       (continue entity-system-state
		 envelope-queue
		 ;; return the message to the system as an unreturnable message
		 (make-list (_sys-unreturnable-envelope envelope)))))))


(coalton-toplevel
  ;; delivers an enveloped message before calling (continue new-entity-system-state envelope-queue system-request-queue)
  (define (deliver-next-envelope entity-system-state envelope-queue continue terminate)
    (match envelope-queue
      ((cons envelope envelope-queue)
       ;; Pull the envelope out of the front of the queue
       (deliver-envelope entity-system-state envelope envelope-queue continue))
      ((nil)
       ;; No envelopes: call the termination continuation.
       (terminate entity-system-state)))))
;;; END ENTITY SYSTEM


;; Each time an envelope is delivered a list of system requests are generated.
;; These can only be handled at the top-level. A function 'process-request is applied to each system request
;; Process-request may generate a list of envelopes, which are appended to the end of the envelope queue

(coalton-toplevel
  ;; Process-request handles creation/removal of entities.
  ;; It handles envelopes that could not be delivered to any entities by logging it to standard-out.
  ;; It returns by calling continue with the new entity-system-state and new envelopes,
  ;; or, if a _sys-quit request is processed, it calls terminate with the entity-system-state.
  
  ;; All _sys-requests are forwarded to 'process-system-request, which may do IO.
  ;; A system request may update the entity-system-state, and may create new envelopes
  ;; which will be appended to the end of the envelope-queue.
  (define (process-request process-system-request entity-system-state request continue terminate)
    (match request
      ;; Unreturnable envelope means the destination entity AND the original sending entity no longer exist
      ((_sys-unreturnable-envelope (_envelope (_return-sender-id original-destination-id) original-sender-id _))
       ((fn (_) (continue entity-system-state (make-list)))
	(lisp unit (original-sender-id original-destination-id)
	  (cl:prog1 unit
	    (cl:format cl:t "~&SYSTEM: Unreturnable envelope addressed to ~A from ~A. Neither entity exists."
		       (uid.value original-destination-id) (uid.value original-sender-id))))))
      
      ;; Returned envelopes means the system sent a message to an entity that doesn't exist.
      ((_sys-returned-envelope (_envelope _ uid _))
       ((fn (_) (continue entity-system-state (make-list)))
	(lisp unit (uid)
	  (cl:prog1 unit
	    (cl:format cl:t "~&SYSTEM: Returned envelope addressed to ~A from system. Entity does not exist."
		       (uid.value uid))))))

      ;; create/destroy entities
      ((_sys-create-entity uid entity-interface)
       (continue (store-entity uid entity-interface entity-system-state)
		 (make-list)))
      ((_sys-destroy-entity uid)
       (continue (remove-entity uid entity-system-state)
		 (make-list)))

      ;; Terminate if we recieve a quit message
      ((_sys-quit)
       (terminate entity-system-state))

      ;; Forward the system-request to process-system-request
      ((_sys-request system-request)
       (process-system-request entity-system-state system-request continue))
      
      ;; Unhandled system requests are likely a bug in the entity system.
      (_
       (continue entity-system-state (make-list))))))

;; All system requests are processed before delivering the next envelope
(coalton-toplevel
  (define (process-requests-loop process-system-request entity-system-state envelope-queue system-request-queue continue terminate)
    (match system-request-queue
      ;; Get the next system-request to process
      ((cons system-request system-request-queue)
       ;; Process the next request
       (process-request
	process-system-request
	entity-system-state
	system-request
	(fn (entity-system-state new-envelopes)
	  ;; continue processing requests, with the new entity-system-state
	  ;; and the new envelopes appended to the end of the envelope-queue
	  (process-requests-loop process-system-request
				 entity-system-state
				 (append envelope-queue new-envelopes)
				 system-request-queue
				 continue
				 terminate))
	terminate))
      ;; Finished processing: return the entity-system-state and the envelope-queue
      ((nil)
       (continue entity-system-state envelope-queue))))

  (define (process-requests process-system-request entity-system-state system-request-queue continue terminate)
    (process-requests-loop process-system-request entity-system-state (make-list) system-request-queue continue terminate)))

(coalton-toplevel
  ;; Run-entity-system delivers envelopes and processes system-requests
  ;; until one of the entities sends a termination-request OR
  ;; there are no more envelopes or requests to process.
  ;; The result is the final entity-system-state
  (define (run-entity-system process-system-request entity-system-state envelope-queue)
    (let ((terminate
	    ;; Termination continuation. Just return the entity-system-state.
	    (fn (entity-system-state) entity-system-state)))
      ;; Deliver the next envelope to an entity
      (deliver-next-envelope
       entity-system-state
       envelope-queue
       (fn (entity-system-state envelope-queue system-requests)
	 ;; Immediately process the system requests
	 (process-requests
	  process-system-request
	  entity-system-state
	  system-requests
	  (fn (entity-system-state envelopes)
	    ;; Finished processing the requests
	    ;; Keep running the system
	    (run-entity-system process-system-request entity-system-state (append envelope-queue envelopes)))
	  ;; Processed a quit event.
	  terminate))
       ;; No more envelopes to deliver.
       terminate))))

;;; Concrete Implementation

;; A simple system-request will just provide logging.
(coalton-toplevel
  (define-type system-request
    (_sr-log uid string)))

(coalton-toplevel
  (define (process-system-request entity-system-state system-request continue)
    "Processes a system-request at the top-level. The I/O layer of the program. Used to parameterize run-entity-system."
    (match system-request
      ((_sr-log (_uid uid) string)
       ((fn (_) (continue entity-system-state (make-list)))
	(lisp unit (uid string)
	  (cl:prog1 unit
	    (cl:format cl:t "~&Entity ~A: ~S" uid string))))))))

(coalton-toplevel
  (define (log string env)
    "sends a request to the system to log string with my id."
    (run-state (do (uid <- my-uid)
		   (modify (request (_sys-request (_sr-log uid string)))))
	       env)))

(cl:defmacro log-fmt ((cl:&rest coalton-references) fmt-string cl:&rest fmt-args)
  "Use fmt arguments to (log string)."
  `(log (fmt (,@coalton-references) ,fmt-string ,@fmt-args)))

;; A signal on a wire is a value (either true/false representing 1/0) and the time unit
;; the value was last changed.
(define-record signal
  (time integer)
  (value boolean))

(coalton-toplevel
  ;; Entity-message provides all of the messages that entities can potentially handle.
  (define-type entity-message
    ;; The value on the signal was changed from true<->false.
    ;; Message handled by objects like gates and wires.
    (_em-new-value signal)

    ;; A message to the scheduler to send envelope at the given time unit.
    (_em-schedule
     ;; Time for delivery
     integer
     ;; Envelope to deliver
     (envelope entity-message))
    ;; A message to the scheduler to start sending out scheduled envelopes.
    (_em-propagate)
    ;; A message to the scheduler to stop sending out scheduled envelopes.
    (_em-stop-propagating)
    
    ;; A message to objects like gates to initialize/connect their input wires.
    (_em-connect-inputs)
    
    ;; A message to a wire to send _em-new-value messages to UID.
    (_em-wire-add-output uid)

    ;; A message to the system-interface object to run the system.
    (_em-system-begin)))

(coalton-toplevel
  (define (addressed-envelope destination-id message)
    "Return a pre-addressed envelope which only needs a sender-id. See send-addressed."
    (fn (sender-id)
      (_envelope (_entity-sender-id sender-id)
		 destination-id
		 message))))

;; Interfaces
;; Interfaces provide means of safely creating messages that can be sent with send-addressed.

;; An input wire is a wire that can be used as an input to e.g. a gate or a probe.
(define-record i-input-wire
  ;; True if uid is talking about the i-input-wire.
  (self? (uid -> boolean))
  ;; A message to the wire to add uid as an output. 
  (connect-output (uid -> (envelope entity-message))))

;; An output wire is a wire that can be used as an output to a e.g. a gate or a probe.
(define-record i-output-wire
  ;; Message to change the signal on the wire. Returns an addressed-envelope
  (set-signal (signal -> uid -> (envelope entity-message))))

;; A wire is both an input wire and an output wire.
(define-record i-wire
  (input i-input-wire)
  (output i-output-wire))

;; An object which holds a schedule of events.
(define-record i-scheduler
  ;; Schedule a new signal change to output-wire.
  (schedule (i-output-wire ; the wire to change
	     -> integer ; the time unit of the change
	     -> boolean ; the new value
	     ;; The addressed-envelope
	     -> uid -> (envelope entity-message)))
  ;; An addressed-envelope which tells the scheduler to start processing the events. 
  (propagate (uid -> (envelope entity-message))))

(coalton-toplevel
  (define (schedule scheduler output time new-value)
    (fn (sender-id)
      (addressed-envelope scheduler
			  (_em-schedule time (i-output-wire.set-signal output (_signal time new-value) sender-id))
			  sender-id))))
(coalton-toplevel
  (define (i-scheduler scheduler-uid)
    "Constructs the scheduler interface given a uid to the scheduler object."
    (_i-scheduler
     (schedule scheduler-uid)
     (addressed-envelope scheduler-uid _em-propagate))))

(coalton-toplevel
  (define (i-wire wire-id)
    "constructs a wire interface given a uid to a wire."
    (_i-wire
     (_i-input-wire
      (fn (uid) (same-uid? wire-id uid))
      (fn (uid) (addressed-envelope wire-id (_em-wire-add-output uid) uid)))
     (_i-output-wire (fn (signal) (addressed-envelope wire-id (_em-new-value signal)))))))

(coalton-toplevel
  (define (send-addressed addressed-envelope)
    "Sends an addressed envelope using my-uid as the sender-id."
    (do (self <- my-uid)
	(modify (send-envelope (addressed-envelope self))))))

(coalton-toplevel
  (define (mapm a->mb as)
    "Apply a->mb to each a in as."
    (match as
      ((cons a as)
       (>> (a->mb a)
	   (mapm a->mb as)))
      ((nil) (pure unit)))))

(coalton-toplevel
  (define (%wire name signal outputs envelope)
    (match envelope
      ;; Request to add an output (someone listening for new signals)
      ((_envelope _ _ (_em-wire-add-output uid))
       (run-state (do
		   ;;(modify (log-fmt (sender-id name) "wire:~A Adding ~A to wire outputs" name sender-id))
		   ;; Send the current signal value
		   (modify (send uid (_em-new-value signal)))
		   ;; Add the entity as an output
		   (modify (put-interface (%wire name signal (cons uid outputs)))))))
      ((_envelope _ _ (_em-new-value new-signal))
       ;; Forward the message to all outputs, if the signal value has changed.
       (if (xor (signal.value new-signal)
		(signal.value signal))
	   (run-state (do
		       ;;(modify (log-fmt (name new-signal) "wire:~A got new signal ~A" name new-signal))
		       (mapm (fn (output) (modify (send output (_em-new-value new-signal))))
			     outputs)
		       ;; update my signal
		       (modify (put-interface (%wire name new-signal outputs)))))
	   id))
      (_ id)))

  (define (wire name envelope env)
    "Construct a wire entity with the given name."
    (%wire name (_signal 0 false) (make-list) envelope env)))

(coalton-toplevel
  (define (create-wire name)
    "Create a wire entity and return an i-wire interface to it."
    (map i-wire (create-entity (wire name)))))

(coalton-toplevel
  (define inverter-delay 2)
  (define (inverter scheduler name input output envelope)
    "Creates a gate entity. When input changes, inverts the input after inverter-delay time-units and sends the signal to output."
    (match envelope
      ((_envelope _ _ (_em-connect-inputs))
       ;; Connect to the input.
       (run-state
	(do ;;(modify (log-fmt (name input) "inverter:~A connecting to ~A" name input))
	 (send-addressed (i-input-wire.connect-output input)))))
      ((_envelope (_entity-sender-id sender-id) _ (_em-new-value signal))
       (if (i-input-wire.self? input sender-id)
	   ;; input changed, send the output after a delay.
	   (run-state (do ;;(modify (log-fmt (name input signal) "inverter:~A input:~A changed to ~A" name input signal))
		       (send-addressed (i-scheduler.schedule scheduler output (+ (signal.time signal) inverter-delay) (not (signal.value signal))))))
	   ;; Don't recgonize input, ignore.
	   (log-fmt (name) "inverter:~A unrecognized input." name)))
      ;; Don't recognize message. Ignore.
      (_ (log-fmt (name) "inverter:~A unrecognized message." name)))))

(coalton-toplevel
  (define-type (binary-logic-gate-params :sr)
    (_binary-logic-gate-params
     ;; Binary-op
     (boolean -> boolean -> boolean)
     ;; delay
     Integer
     ;; input1
     i-input-wire
     ;; input2
     i-input-wire
     ;; output
     i-output-wire
     ;; name
     string))

  (define (%binary-logic-gate scheduler binary-logic-gate-params input1-signal input2-signal envelope)
    (match binary-logic-gate-params
      ((_binary-logic-gate-params binary-op delay input1 input2 output name)
       (match envelope
	 ;; Connect inputs:
	 ((_envelope _ _ (_em-connect-inputs))
	  (run-state (do
		      ;;(modify (log-fmt (name input1 input2) "binary-gate:~A connecting to ~A and ~A" name input1 input2))
		      (self <- my-uid)
		      (send-addressed (i-input-wire.connect-output input1))
		       (send-addressed (i-input-wire.connect-output input2)))))

	 ;; New signal
	 ((_envelope (_entity-sender-id sender-id) _ (_em-new-value signal))
	  (cond
	    ((i-input-wire.self? input1 sender-id)
	     ;; Signal came from input1
	     (let ((input1-signal signal))
	       (run-state (do ;;(modify (log-fmt (name input1 input1-signal) "binary-gate:~A input1:~A changed to ~A" name input1 input1-signal))
			   ;; Schedule a (binary-op input1 input2) to output
			   (send-addressed (i-scheduler.schedule scheduler
								 output
								 (+ (signal.time signal) delay)
								 (binary-op (signal.value input1-signal)
									    (signal.value input2-signal))))
			   ;; Update input1-signal
			   (modify (put-interface (%binary-logic-gate scheduler binary-logic-gate-params input1-signal input2-signal)))))))
	    ((i-input-wire.self? input2 sender-id)
	     ;; Signal came from input 2
	     (let ((input2-signal signal))
	       (run-state (do ;;(modify (log-fmt (name input2 input2-signal) "binary-gate:~A input2:~A changed to ~A" name input2 input2-signal))
			   ;; Schedule a (binary-op input1 input2) to output
			   (send-addressed (i-scheduler.schedule scheduler
								 output
								 (+ (signal.time signal) delay)
								 (binary-op (signal.value input1-signal)
									    (signal.value input2-signal))))
			   ;; Update input2-signal
			   (modify (put-interface (%binary-logic-gate scheduler binary-logic-gate-params input1-signal input2-signal)))))))

	    (true (log-fmt (name) "binary-gate:~A new-value from unrecognized input" name))))
	 (_ (log-fmt (name) "binary-gate:~A urecognized message" name))))))

  (define (binary-logic-gate scheduler binary-logic-gate-params)
    "Creates a gate entity. If input1 or input2 changes, sends (binary-op input1 input2) to the output after delay time units."
    (%binary-logic-gate scheduler binary-logic-gate-params (_signal 0 false) (_signal 0 false))))

(coalton-toplevel
  (define and-gate-delay 3)
  (define (and-gate scheduler name input1 input2 output envelope env)
    "Create an and-gate entity. Sets output to (and input1 input2) after and-gate-delay."
    (binary-logic-gate scheduler
		       (_binary-logic-gate-params (fn (a b) (and a b)) and-gate-delay input1 input2 output name)
		       envelope env)))

(coalton-toplevel
  (define or-gate-delay 5)
  (define (or-gate scheduler name input1 input2 output envelope env)
    "Create an or-gate entity. Sets output to (or input1 input2) after or-gate-delay."
    (binary-logic-gate scheduler
		       (_binary-logic-gate-params (fn (a b) (or a b)) or-gate-delay input1 input2 output name)
		       envelope env)))

(coalton-toplevel
  (define (create-entity interface)
    "Create a new entity. Return its id."
    (do (id <- next-uid)
	(modify (request (_sys-create-entity id interface)))
      (pure id))))

(coalton-toplevel
  (define (create-and-connect interface)
    "Create the entity and send _em-connect-inputs message. For e.g. gates/probes."
    (do (e <- (create-entity interface))
	(modify (send e _em-connect-inputs))
      (pure e))))

(coalton-toplevel
  (define (half-adder scheduler input1 input2 sum carry)
    "Construct and connect the gates/wires for a half adder.
Input1 and input2 are the two bits of input, and sum/carry are the two outputs."
    (do
     (input1-or-input2 <- (create-wire "half-adder:input1-or-input2"))
     (input1-nand-input2 <- (create-wire "half-adder:input1-nand-input2"))

      (create-and-connect (or-gate scheduler "half-adder:input1-or-input2" input1 input2 (i-wire.output input1-or-input2)))
      ;; Carry value is 1 if input1 and input2 are both 1
      (create-and-connect (and-gate scheduler "half-adder:carry" input1 input2 (i-wire.output carry)))
      (create-and-connect (inverter scheduler "half-adder:input1-nand-input2" (i-wire.input carry) (i-wire.output input1-nand-input2)))
      ;; The sum is 1 if input1+input2 is 1, otherwise 0.
      (create-and-connect (and-gate scheduler "half-adder:sum" (i-wire.input input1-or-input2) (i-wire.input input1-nand-input2) sum)))))

(coalton-toplevel
  (define (full-adder scheduler input1 input2 carry-input sum carry-output envelope)
    "Construct and connect the gates/wires for a full-adder.
Input1, input2, and carry-input are the 3 bits of input, and sum/carry-output are the two outputs."
    (do
     (intermediate-sum <- (create-wire "full-adder:intermediate-sum"))
     (carry1 <- (create-wire "full-adder:carry1"))
      (carry2 <- (create-wire "full-adder:carry2"))

      ;; Add input1 + input2 + carry-input:

      ;; Add input2+carry-input to produce intermediate-sum and carry1
      (half-adder scheduler input2 carry-input (i-wire.output intermediate-sum) carry1)
      
      ;; Add input1+intermediate-sum to produce the final sum and carry2
      (half-adder scheduler input1 (i-wire.input intermediate-sum) (i-wire.output sum) carry2)

      ;; There is a carry if carry1 or carry 2 are set.
      (create-and-connect (or-gate scheduler "full-adder:carry-output" (i-wire.input carry1) (i-wire.input carry2) carry-output)))))

;; A time segment is a queue of envelopes that have been scheduled for a time unit.
(define-record time-segment
  (time Integer)
  (queue (list (envelope entity-message))))
;; An agenda is a list of time-segments.
(define-record agenda
  (current-time Integer)
  (segments (list time-segment)))

(coalton-toplevel
  (define empty-agenda
    "Return an empty agenda at time 0."
    (_agenda 0 (make-list)))

  (define (empty-agenda? agenda)
    "True if there are no more agenda items."
    (null (agenda.segments agenda)))

  (define (first-agenda-item agenda)
    "Return the first agenda item or None."
    (match (agenda.segments agenda)
      ((cons segment _)
       (match (time-segment.queue segment)
	 ((cons envelope _) (some (tuple (time-segment.time segment) envelope)))
	 ((nil) (error "shouldn't happen."))))
      ((nil) none)))

  (define (remove-first-agenda-item agenda)
    "Returns agenda with the first item removed."
    (match (agenda.segments agenda)
      ((cons segment segments)
       (match (time-segment.queue segment)
	 ((cons _ (nil))
	  ;; Remove the whole segment if its the last element.
	  (put-field agenda.segments% segments agenda))
	 ((cons _ es)
	  ;; Remove the first envelope from the queue.
	  (put-field agenda.segments%
		     (cons (put-field time-segment.queue% es segment) segments)
		     agenda))
	 ((nil) (error "shouldn't happen"))))
      ((nil) agenda)))

  (define (add-to-segments time envelope segments)
    "Add agenda-item envelope at the given time to segments."
    (match segments
      ((cons segment rest-segments)
       (cond
	 ((== (time-segment.time segment) time)
	  ;; Add to this segment
	  (cons (time-segment.queue% (fn (queue) (append queue (make-list envelope))) segment)
		rest-segments))
	 ((< (time-segment.time segment) time)
	  ;; Add to a later segment
	  (cons segment (add-to-segments time envelope rest-segments)))
	 (true
	  ;; Add to a new time segment
	  (cons (_time-segment time (make-list envelope)) segments))))
      ((nil)
       ;; Add to the end.
       (make-list (_time-segment time (make-list envelope))))))

  (define (add-to-agenda time envelope agenda)
    "Schedule the envelope to be delivered at time. Returns an agenda."
    (agenda.segments% (add-to-segments time envelope) agenda)))

(coalton-toplevel
  ;; Scheduler that is currently propagating
  (define (%active-scheduler agenda time-listeners envelope)
    (match envelope
      ((_envelope _ _ (_em-schedule time envelope))
       ;; Schedule a new event by adding it to the agenda.
       (run-state
	(do
	 ;;(modify (log-fmt (time) "active-scheduler: scheduling agenda item with scheduled time=~A" time))
	 (self <- my-uid)
	 (modify (send self _em-propagate))
	  (modify (put-interface (%active-scheduler (add-to-agenda time envelope agenda) time-listeners))))))
      
      ((_envelope _ _ (_em-propagate))
       ;; Take the next envelope off of the agenda and deliver it. Update the current time.
       (let ((current-time (agenda.current-time agenda)))
	 (match (first-agenda-item agenda)
	   ((some (tuple time envelope))
	    (run-state
	     (do
	      ;;(modify (log-fmt (time current-time) "scheduler: current-time=~A, handling agenda item for time=~A" current-time time))
	      ;; Send the first envelope.
	      (modify (send-envelope envelope))
	      (self <- my-uid)
	       (modify (send self _em-propagate))
	       ;; Remove the agenda item and update the current-time.
	       (modify (put-interface (%active-scheduler (remove-first-agenda-item (put-field agenda.current-time% time agenda)) time-listeners))))))
	   ((none)
	    ;;(log-fmt (current-time) "scheduler: attempt to propagate empty agenda at current-time=~A" current-time)
	    id))))
      
      ((_envelope _ _ (_em-stop-propagating))
       (put-interface (%inactive-scheduler agenda time-listeners)))
      (_ id)))

  ;; Scheduler that is not currently propagating
  (define (%inactive-scheduler agenda time-listeners envelope)
    (match envelope
      ((_envelope _ _ (_em-schedule time envelope))
       (run-state
	(do
	 ;;(modify (log-fmt (time) "inactive-scheduler: scheduling agenda item with scheduled time=~A" time))
	 (modify (put-interface (%inactive-scheduler (add-to-agenda time envelope agenda) time-listeners))))))

      ((_envelope _ _ (_em-propagate))
       (run-state
	(do
	 (modify (put-interface (%active-scheduler agenda time-listeners)))
	 (self <- my-uid)
	  (modify (send self _em-propagate)))))
      (_ id)))

  (define scheduler
    (%inactive-scheduler empty-agenda (make-list))))

(coalton-toplevel
  (define (%probe name input envelope)
    (match envelope
      ;; Connect to input
      ((_envelope _ _ (_em-connect-inputs))
       (run-state (do ;; (modify (log-fmt (name input) "probe:~A connecting to ~A" name input))
		   (send-addressed (i-input-wire.connect-output input)))))

      ;; Log the new value.
      ((_envelope _ _ (_em-new-value signal))
       (match signal
	 ((_signal time value)
	  (let ((num (if value 1 0)))
	    (log-fmt (name num time) "probe:~A got new value=~A at time=~A" name num time)))))
      (_ id)))
  (define (probe name input envelope env)
    "Create a probe entity that logs new signals from input."
    (%probe name input envelope env)))

(coalton-toplevel
  (define create-scheduler
    "Create a scheduler entity and return an i-scheduler interface to it."
    (map i-scheduler (create-entity scheduler))))

(coalton-toplevel
  (define (system-interface envelope)
    "return a system-interface entity which will set up the simulation and run it."
    (match envelope
      ((_envelope _ _ (_em-system-begin))
       (run-state (do
		   (scheduler <- create-scheduler)
		   (input1 <- (create-wire "input1"))
		    (input2 <- (create-wire "input2"))
		    (sum <- (create-wire "sum"))
		    (carry <- (create-wire "carry"))

		    (half-adder scheduler (i-wire.input input1) (i-wire.input input2) (i-wire.output sum) carry)
		    (send-addressed (i-output-wire.set-signal (i-wire.output input1) (_signal 0 true)))
		    
		    (create-and-connect (probe "sum" (i-wire.input sum)))
		    (create-and-connect (probe "carry" (i-wire.input carry)))

		    (send-addressed (i-scheduler.schedule scheduler (i-wire.output input2) 8 true))
		    (send-addressed (i-scheduler.propagate scheduler)))))
      (_ id))))

;; To run the system, we need an initial entity-system-state
(coalton-toplevel
  (define system-interface-id (_uid -1))
  (define (initial-entity-system-state _)
    (_entity-system-state
     (stream-uids 0)
     (_table (make-list (_table-entry system-interface-id system-interface)) same-uid?)
     random-stream)))

(coalton-toplevel
  (define (run-system-with-message message)
    "Sends message to the system-interface from system."
    (modify
     (fn (entity-system-state)
       (run-entity-system process-system-request entity-system-state (make-list (_envelope _system-sender-id system-interface-id message)))))))

;; With a function to process-system-requests, an initial entity-system-state, and a list of messages,
;; we can run the system.
#+nil
(coalton
 (run-unit
  (do (run-system-with-message _em-system-begin))
  (initial-entity-system-state)))
#||
Output:
Entity 11: "probe:sum got new value=0 at time=0"
Entity 12: "probe:carry got new value=0 at time=0"
Entity 12: "probe:carry got new value=1 at time=11"
Entity 11: "probe:sum got new value=1 at time=8"
Entity 11: "probe:sum got new value=0 at time=16"
||#
;; => #.UNIT