- Implemented Agent-Oriented Programming.

1 files changed, 150 insertions, 0 deletions

diff --git a/stdlib/source/lux/concurrency/space.lux b/stdlib/source/lux/concurrency/space.lux
new file mode 100644
index 000000000..7092e2395
--- /dev/null
+++ b/stdlib/source/lux/concurrency/space.lux
@@ -0,0 +1,150 @@
+(;module:
+  lux
+  (lux (control [monad #+ do]
+                ["ex" exception #+ exception:]
+                ["p" parser])
+       (concurrency ["P" promise]
+                    ["T" task]
+                    ["A" actor #+ actor:])
+       (data [product]
+             (coll [list "L/" Functor<List>]))
+       [io #- run]
+       [macro #+ with-gensyms]
+       (macro [code]
+              ["s" syntax #+ syntax:]
+              (syntax ["cs" common]
+                      (common ["csr" reader]
+                              ["csw" writer])))))
+
+(with-expansions
+  [<Event> [e (A;Actor Top) (Space e)]
+   <Action> (as-is (-> <Event> (A;Actor s) (T;Task Unit)))]
+  (type: #export (Space e)
+    (A;Actor (List (Ex [s] [(A;Actor s) <Action>]))))
+
+  (type: #export (Event e)
+    <Event>)
+
+  (type: #export (Action e)
+    (All [s] <Action>)))
+
+(exception: #export Closed-Space)
+
+(def: (send-space message space)
+  (All [s] (-> (A;Message s) (A;Actor s) (T;Task Unit)))
+  (P;future (do Monad<IO>
+              [success? (A;send message space)]
+              (wrap (if success?
+                      (ex;return [])
+                      (ex;throw Closed-Space ""))))))
+
+(def: #export (subscribe actor action space)
+  (All [e s] (-> (A;Actor s) (Action e s) (Space e) (T;Task Unit)))
+  (send-space (function [subscriptions _]
+                (T;return (|> subscriptions
+                              (list;filter (|>. product;left (:! []) (is (:! [] actor)) not))
+                              (#;Cons [actor action]))))
+              space))
+
+(def: #export (un-subscribe actor space)
+  (All [e s] (-> (A;Actor s) (Space e) (T;Task Unit)))
+  (send-space (function [subscriptions _]
+                (T;return (|> subscriptions
+                              (list;filter (|>. product;left (:! []) (is (:! [] actor)) not)))))
+              space))
+
+(def: #export (emit event space sender)
+  (All [e s] (-> e (Space e) (A;Actor s) (T;Task Unit)))
+  (send-space (function [subscriptions _]
+                (exec (monad;map T;Monad<Task>
+                                 (function [[receiver action]]
+                                   (if (is (:! [] receiver) (:! [] sender))
+                                     (T;return [])
+                                     (action [event sender space] receiver)))
+                                 subscriptions)
+                  (T;return subscriptions)))
+              space))
+
+(def: #export space
+  (All [e] (IO (Space e)))
+  (A;spawn A;default-behavior (list)))
+
+(type: ActionS
+  {#action-name Text
+   #sender-name Text
+   #space-name Text
+   #event Code
+   #state Code
+   #receiver-name Text})
+
+(def: reference^
+  (s;Syntax [Ident (List Code)])
+  (p;either (s;form (p;seq s;symbol (p;some s;any)))
+            (p;seq s;symbol (:: p;Monad<Parser> wrap (list)))))
+
+(def: action^
+  (s;Syntax ActionS)
+  (s;form ($_ p;seq
+              s;local-symbol
+              s;local-symbol
+              s;local-symbol
+              s;any
+              s;any
+              s;local-symbol)))
+
+(def: type-vars^
+  (s;Syntax (List Text))
+  (p;either (s;tuple (p;some s;local-symbol))
+            (:: p;Monad<Parser> wrap (list))))
+
+(def: #hidden _future P;future)
+
+(syntax: #export (on: [export csr;export]
+                   [t-vars type-vars^]
+                   [[actor-name actor-params] reference^]
+                   eventT
+                   [declaration action^]
+                   [annotations (p;default cs;empty-annotations csr;annotations)]
+                   body)
+  {#;doc (doc (type: Move
+                #Ping
+                #Pong)
+
+              (actor: #export Player {}
+                {#hits Nat})
+
+              (on: #export Move (counter move space hits self)
+                (do @
+                  [_ (emit (case move
+                             #;Ping #;Pong 
+                             #;Pong #;Ping)
+                           space
+                           self)]
+                  (wrap (n.inc hits)))))}
+  (with-gensyms [g!_]
+    (do @
+      [actor-name (A;resolve-actor actor-name)
+       #let [stateT (` ((~ (code;symbol (product;both id A;state-name actor-name)))
+                        (~@ actor-params)))
+             g!actionL (code;local-symbol (get@ #action-name declaration))
+             g!senderL (code;local-symbol (get@ #sender-name declaration))
+             g!spaceL (code;local-symbol (get@ #space-name declaration))
+             g!receiverL (code;local-symbol (get@ #receiver-name declaration))
+             g!event (get@ #event declaration)
+             g!state (get@ #state declaration)]]
+      (wrap (list (` (def: (~@ (csw;export export)) ((~ g!actionL) [(~ g!event) (~ g!senderL) (~ g!spaceL)] (~ g!receiverL))
+                       (~ (csw;annotations annotations))
+                       (All [(~@ (L/map code;local-symbol t-vars))]
+                         (;;Action (~ eventT) (~ stateT)))
+                       (monad;do T;Monad<Task>
+                         [(~ g!_) (T;from-promise
+                                   (_future
+                                    (A;send (function [(~ g!state) (~ g!receiverL)]
+                                              (: (T;Task (~ stateT))
+                                                 (do T;Monad<Task>
+                                                   []
+                                                   (~ body))))
+                                            (~ g!receiverL))))]
+                         ((~' wrap) []))
+                       ))))
+      )))