;;;
;;; Modeler for computing instantaneous system load 
;;;

;;
;; TEMPLATES
;;

(deftemplate point-signpost-config
    (slot config (type INTEGER))
    (slot type (type STRING))
    (slot name (type STRING))
    (slot code (type INTEGER))
    (slot class (type INTEGER))
    (slot subclass (type INTEGER))
)

(deftemplate level-signpost-config
    (slot config (type INTEGER))
    (slot type (type STRING))
    (slot name (type STRING))
    (slot code (type INTEGER))
    (slot class (type INTEGER))
    (slot subclass (type INTEGER))
    (slot arg (type STRING))
    (slot arg-type (type STRING))
)

(deftemplate interval-signpost-config
    (slot config (type INTEGER))
    (slot type (type STRING))
    (slot name (type STRING))
    (slot code-begin (type INTEGER))
    (slot code-end (type INTEGER))
    (slot class-begin (type INTEGER))
    (slot class-end (type INTEGER))
    (slot subclass-begin (type INTEGER))
    (slot subclass-end (type INTEGER))
)

(deftemplate match-by
    (slot config (type INTEGER) (default ?NONE))
    (slot match (type STRING) (default ?NONE))
)

(deftemplate open-interval
    (slot config (type INTEGER) (default ?NONE))
    (slot thread (type EXTERNAL-ADDRESS))
    (slot process (type EXTERNAL-ADDRESS))
    (slot start (type INTEGER))
    (multislot args)
)

(deftemplate open-level
    (slot config (type INTEGER) (default ?NONE))
    (slot time (type INTEGER))
    (slot level (type INTEGER))
)


;;
;; FACTS (initial conditions)
;;
(deffacts MODELER::defaults
    (level-arg-default "UInt32")
)

;;
;; RULES (modeler)
;;
(defrule MODELER::configure-generic-impulse
    (signpost-config (config ?config) (key "Type") (string-value "Impulse"))
    (signpost-config (config ?config) (key "Name") (string-value ?name))
    (signpost-config (config ?config) (key "Class") (int-value ?class))
    (signpost-config (config ?config) (key "Subclass") (int-value ?subclass))
    (signpost-config (config ?config) (key "Code") (int-value ?code))
    =>
    (assert (point-signpost-config (config ?config) (type "Impulse") (name ?name) (code ?code) (class ?class) (subclass ?subclass)))
)

(defrule MODELER::configure-generic-level
    (signpost-config (config ?config) (key "Type") (string-value ?type&"Level"|"DeltaLevel"))
    (signpost-config (config ?config) (key "Name") (string-value ?name))
    (signpost-config (config ?config) (key "Class") (int-value ?class))
    (signpost-config (config ?config) (key "Subclass") (int-value ?subclass))
    (signpost-config (config ?config) (key "Code") (int-value ?code))
    (signpost-config (config ?config) (key "LevelArg") (string-value ?arg))
    (or (signpost-config (config ?config) (key "LevelDataType") (string-value ?arg-type))
        (and (not (signpost-config (config ?config) (key "LevelDataType")))
             (level-arg-default ?arg-type)
        )
    )
    =>
    (assert (level-signpost-config (config ?config) (type ?type) (name ?name) (code ?code) (class ?class) (subclass ?subclass) (arg ?arg) (arg-type ?arg-type)))
) 

(defrule MODELER::configure-generic-interval
    (signpost-config (config ?config) (key "Type") (string-value "Interval"))
    (signpost-config (config ?config) (key "Name") (string-value ?name))
    (or (signpost-config (config ?config) (key "ClassBegin") (int-value ?class-begin))
        (signpost-config (config ?config) (key "Class") (int-value ?class-begin)))
    (or (signpost-config (config ?config) (key "ClassEnd") (int-value ?class-end))
        (signpost-config (config ?config) (key "Class") (int-value ?class-end)))
    (or (signpost-config (config ?config) (key "SubclassBegin") (int-value ?subclass-begin))
        (signpost-config (config ?config) (key "Subclass") (int-value ?subclass-begin)))
    (or (signpost-config (config ?config) (key "SubclassEnd") (int-value ?subclass-end))
        (signpost-config (config ?config) (key "Subclass") (int-value ?subclass-end)))
    (or (signpost-config (config ?config) (key "CodeBegin") (int-value ?code-begin))
        (signpost-config (config ?config) (key "Code") (int-value ?code-begin)))
    (or (signpost-config (config ?config) (key "CodeEnd") (int-value ?code-end))
        (signpost-config (config ?config) (key "Code") (int-value ?code-end)))
    =>
    (assert (interval-signpost-config (config ?config) (type "Interval") (name ?name) (class-begin ?class-begin) (subclass-begin ?subclass-begin) (code-begin ?code-begin)
                                                                                      (class-end ?class-end) (subclass-end ?subclass-end) (code-end ?code-end)))
)

(defrule MODELER::assert-match-bys
    (signpost-config (config ?config) (key "EventsMatchedBy") (string-value ?match-by))
    =>
    (bind ?matches (explode$ ?match-by))
    (loop-for-count (?cnt 1 (length$ ?matches)) do
        (assert (match-by (config ?config) (match (str-cat (nth$ ?cnt ?matches)))))
    )
)

(defrule MODELER::configure-aridne-interval
    (signpost-config (config ?config) (key "Type") (string-value "Interval"))
    (signpost-config (config ?config) (key "Name") (string-value ?name))
    (or (signpost-config (config ?config) (key "ComponentBegin") (int-value ?subclass-begin))
        (signpost-config (config ?config) (key "Component") (int-value ?subclass-begin)))
    (or (signpost-config (config ?config) (key "ComponentEnd") (int-value ?subclass-end))
        (signpost-config (config ?config) (key "Component") (int-value ?subclass-end)))
    (or (signpost-config (config ?config) (key "CodeBegin") (int-value ?code-begin))
        (signpost-config (config ?config) (key "Code") (int-value ?code-begin)))
    (or (signpost-config (config ?config) (key "CodeEnd") (int-value ?code-end))
        (signpost-config (config ?config) (key "Code") (int-value ?code-end)))
    =>
    (assert (interval-signpost-config (config ?config) (type "Interval") (name ?name) (class-begin 43) (subclass-begin ?subclass-begin) (code-begin ?code-begin)
                                                                                      (class-end 43) (subclass-end ?subclass-end) (code-end ?code-end)))
)

(defrule MODELER::detect-open-interval  ;; the RECORDER module will retract and clean these up
    (interval-signpost-config (config ?config) (class-begin ?cb) (subclass-begin ?scb) (code-begin ?cdb))
    (kdebug (time ?time) (class ?cb) (subclass ?scb) (code ?cdb) (thread ?thread) (arg1 ?arg1) (arg2 ?arg2) (arg3 ?arg3) (arg4 ?arg4))
    =>
    (assert (open-interval (thread ?thread) (process (process-from-thread ?thread)) (start ?time) (config ?config) (args ?arg1 ?arg2 ?arg3 ?arg4)))
)

(defrule MODELER::unneeded-interval-invariant
    (not (table-attribute (has schema thread-interval-signpost)))
    ?f <- (open-interval)
    =>
    (retract ?f)
)

(defrule MODELER::open-level-fact
    (table-attribute (table-id ?output) (has schema level-signpost))            
    (level-signpost-config (config ?config) (type ?type) (code ?code) (class ?class) (subclass ?subclass) (name ?name))
    (kdebug (time ?time) (code ?code) (class ?class) (subclass ?subclass))
    (or (and (level-signpost-config (config ?config) (arg "Arg1"))
             (kdebug (time ?time) (code ?code) (class ?class) (subclass ?subclass) (arg1 ?level)))
        (and (level-signpost-config (config ?config) (arg "Arg2"))
             (kdebug (time ?time) (code ?code) (class ?class) (subclass ?subclass) (arg2 ?level)))
        (and (level-signpost-config (config ?config) (arg "Arg3"))
             (kdebug (time ?time) (code ?code) (class ?class) (subclass ?subclass) (arg3 ?level)))
        (and (level-signpost-config (config ?config) (arg "Arg4"))
             (kdebug (time ?time) (code ?code) (class ?class) (subclass ?subclass) (arg4 ?level)))
    )  
    =>  
    (assert (open-level (config ?config) (level ?level) (time ?time)))
)



;;
;; RULES (recorder)
;;
(defrule RECORDER::emit-impulse-signpost
    (table-attribute (table-id ?output) (has schema kdebug-signpost))
    (point-signpost-config (type "Impulse") (code ?code) (class ?class) (subclass ?subclass) (name ?name))
    (kdebug (time ?time) (code ?code) (class ?class) (subclass ?subclass) (arg1 ?arg1) (arg2 ?arg2) (arg3 ?arg3) (arg4 ?arg4) (thread ?thread))
    =>
    (create-new-row ?output)
    
    (set-column time ?time)
    (set-column thread ?thread)
    (set-column process (process-from-thread ?thread))
    (set-column name ?name)
    (set-column arg1 ?arg1)
    (set-column arg2 ?arg2)
    (set-column arg3 ?arg3)
    (set-column arg4 ?arg4)
)

(defrule RECORDER::emit-level-signpost
    (table-attribute (table-id ?output) (has schema level-signpost))            
    ?f <- (open-level (config ?config) (time ?t1) (level ?level))
    (open-level (config ?config) (time ?t2&:(< ?t1 ?t2)))
    (level-signpost-config (config ?config) (name ?name) (type "Level") (arg-type ?arg-type))
    =>
    (create-new-row ?output)
    
    (set-column start ?t1)
    (set-column duration (- ?t2 ?t1))
    (set-column name ?name)
    (if (eq ?arg-type "Float") then 
        (set-column level (decode-ieee-float ?level))
        else 
        (set-column level ?level)
    )

    (retract ?f)
)

(defrule RECORDER::emit-delta-level-signpost
    (table-attribute (table-id ?output) (has schema level-signpost))            
    ?f <- (open-level (config ?config) (time ?t1) (level ?level))
    (open-level (config ?config) (time ?t2&:(< ?t1 ?t2)) (level ?new-level))
    (level-signpost-config (config ?config) (name ?name) (type "DeltaLevel") (arg-type ?arg-type))
    =>
    (create-new-row ?output)
    
    (set-column start ?t1)
    (set-column duration (- ?t2 ?t1))
    (set-column name ?name)
    (if (eq ?arg-type "Float") then     
        (set-column level (- (decode-ieee-float ?new-level) (decode-ieee-float ?level)))
        else 
        (set-column level (- ?new-level ?level))
    )

    (retract ?f)
)


(defrule RECORDER::emit-matched-thread-interval
    (table-attribute (table-id ?output) (has schema thread-interval-signpost))            
    (interval-signpost-config (class-end ?cls-end) (subclass-end ?subcls-end) (code-end ?code-end) (name ?name) (config ?config))
    (kdebug (time ?time) (class ?cls-end) (subclass ?subcls-end) (code ?code-end))     
    ?f <- (open-interval (thread ?thread) (start ?start&~?time) (config ?config) (args ?arg1 ?arg2 ?arg3 ?arg4))
    (or (and (match-by (config ?config) (match "Process"))
             (kdebug (time ?time) (class ?cls-end) (subclass ?subcls-end) (code ?code-end) (thread ?possible-thread))
             (thread-instance (instance ?possible-thread) (process ?process)))
        (not (match-by (config ?config) (match "Process"))))
    (or (and (match-by (config ?config) (match "Thread"))
             (kdebug (time ?time) (class ?cls-end) (subclass ?subcls-end) (code ?code-end) (thread ?thread)))
        (not (match-by (config ?config) (match "Thread"))))
    (or (and (match-by (config ?config) (match "Arg1"))
             (kdebug (time ?time) (class ?cls-end) (subclass ?subcls-end) (code ?code-end) (arg1 ?arg1)))
        (not (match-by (config ?config) (match "Arg1"))))
    (or (and (match-by (config ?config) (match "Arg2"))
             (kdebug (time ?time) (class ?cls-end) (subclass ?subcls-end) (code ?code-end) (arg1 ?arg2)))
        (not (match-by (config ?config) (match "Arg2"))))
    (or (and (match-by (config ?config) (match "Arg3"))
             (kdebug (time ?time) (class ?cls-end) (subclass ?subcls-end) (code ?code-end) (arg1 ?arg3)))
        (not (match-by (config ?config) (match "Arg3"))))
    (or (and (match-by (config ?config) (match "Arg4"))
             (kdebug (time ?time) (class ?cls-end) (subclass ?subcls-end) (code ?code-end) (arg1 ?arg4)))
        (not (match-by (config ?config) (match "Arg4"))))
    =>
    (create-new-row ?output)
    (bind ?duration (- ?time ?start))
    
    (set-column start ?start)
    (set-column duration ?duration)
    (set-column thread ?thread)
    (set-column process (process-from-thread ?thread))
    (set-column name ?name)
    (set-column arg1 ?arg1)
    (set-column arg2 ?arg2)
    (set-column arg3 ?arg3)
    (set-column arg4 ?arg4)

    (retract ?f)
)