basic implementation of action selection (needs more tests)

core/core.lisp

@@ -2,7 +2,8 @@
 
 (defpackage :scopes/core
   (:use :common-lisp)
-  (:local-nicknames (:config :scopes/config))
+  (:local-nicknames (:config :scopes/config)
+                    (:message :scopes/core/message))
   (:export #:config #:service-config
            #:context #:name #:actions #:send
            #:action-spec
@@ -21,11 +22,13 @@
 ;;;; actions
 
 (defclass action-spec ()
-  ((pattern :initarg :pattern :initform nil)
+  ((pattern :reader pattern :initarg :pattern :initform nil)
    (handlers :reader handlers :initarg :handlers)))
 
 ;;;; context
 
+(defvar *context* nil)
+
 (defclass context () 
   ((name :reader name :initarg :name)
    (actions :accessor actions :initform nil)))
@@ -33,11 +36,24 @@
 (defgeneric send (rcvr msg)
   (:method ((rcvr context) msg)
     (let* ((acts (actions rcvr))
-           (selected (car acts)))
+           (hdlrs (select msg acts)))
-      (dolist (hdlr (handlers selected))
+      (dolist (hdlr hdlrs)
         (funcall hdlr rcvr msg)))))
 
-(defvar *context* nil)
+(defun select (msg acts)
+  (let ((h (message:head-as-list msg))
+        (hdlrs nil))
+    (dolist (a acts)
+      (if (match (pattern a) h)
+        (dolist (hdlr (handlers a))
+          (push hdlr hdlrs))))
+    hdlrs))
+
+(defun match (pat h)
+  (dolist (item pat)
+    (if (and item (not (eq item (pop h))))
+      (return-from match nil)))
+  t)
 
 ;;;; simple printer service
 

core/message.lisp

@@ -2,14 +2,11 @@
 
 (defpackage :scopes/core/message
   (:use :common-lisp)
-  (:local-nicknames (:core :scopes/core))
   (:export #:message #:simple-message
            #:head #:data #:head-as-list))
 
 (in-package :scopes/core/message)
 
-(defgeneric as-list (obj))
-
 ;;;; message-head
 
 (defclass message-head ()
@@ -32,12 +29,12 @@
       (setf (slot-value h sl) (pop head-vals)))
     (make-instance 'message :head h :data data)))
 
-(defmethod head-as-list ((msg message))
-  (with-slots (domain action class item) (head msg)
-    (list domain action class item)))
-
 (defmethod print-object ((msg message) stream)
   (with-slots (domain action class item) (head msg)
     (format stream 
             "<message (~a ~a ~a ~a) <data ~s>>" 
             domain action class item (data msg))))
+
+(defun head-as-list (msg)
+  (with-slots (domain action class item) (head msg)
+    (list domain action class item)))

scopes-core.asd

@@ -6,10 +6,13 @@
   :version "0.0.1"
   :homepage "https://www.cyberconcepts.org"
   :description "Core packages of the scopes project."
-  :depends-on (:alexandria :cl-dotenv :com.inuoe.jzon :local-time :log4cl :str)
+  :depends-on (:alexandria :cl-dotenv :com.inuoe.jzon 
+               :local-time :log4cl :str)
   :components ((:file "config" :depends-on ("util"))
-               (:file "core/core" :depends-on ("config" "forge/forge" "util"))
+               (:file "core/core" 
-               (:file "core/message" :depends-on ("core/core"))
+                      :depends-on ("core/message" "config" 
+                                   "forge/forge" "util"))
+               (:file "core/message")
                (:file "forge/forge")
                (:file "util")
                (:file "testing" :depends-on ("util"))

scopes.asd

@@ -9,8 +9,10 @@
   :depends-on (:alexandria :chanl :cl-dotenv :com.inuoe.jzon :dbi 
                :local-time :log4cl :str :sxql)
   :components ((:file "config" :depends-on ("util"))
-               (:file "core/core" :depends-on ("config" "forge/forge" "util"))
+               (:file "core/core" 
-               (:file "core/message" :depends-on ("core/core"))
+                      :depends-on ("core/message" "config" 
+                                   "forge/forge" "util"))
+               (:file "core/message")
                (:file "forge/forge")
                (:file "storage/storage")
                (:file "storage/tracking" :depends-on ("storage/storage"))
@@ -20,7 +22,8 @@
                (:file "test/test-core" :depends-on ("testing" "core/core"))
                (:file "test/test-forge" :depends-on ("testing" "forge/forge"))
                (:file "test/test-storage" 
-                      :depends-on ("testing" "storage/storage" "storage/tracking")))
+                      :depends-on ("testing" 
+                                   "storage/storage" "storage/tracking")))
   :long-description "scopes: generic data processing facilities."
   ;;#.(uiop:read-file-string
   ;;   (uiop:subpathname *load-pathname* "README.md")))

test/test-core.lisp

@@ -15,9 +15,9 @@
 
 (defvar *config* nil)
 
-;;;; core/testing
+;;;; core/testing: test-receiver
 
-(defclass test-rcvr (core:context)
+(defclass test-receiver (core:context)
   ((core:name :initform :test-rcvr)
    (core:actions 
      :initform (list 
@@ -49,8 +49,7 @@
 
 (defclass test-suite (t:test-suite)
   ((receiver :reader receiver 
-             ;:initform (core:printer :test-rcvr))))
+             :initform (make-instance 'test-receiver))))
-             :initform (make-instance 'test-rcvr))))
 
 (defun run ()
   (let ((*config* nil)