fixed clips import

fixed clips import

;;;===============================================
;;; BeerEX: the Beer EXpert system
;;;
;;;   This expert system suggests a beer to drink.
;;;
;;;   CLIPS 6.30
;;;
;;;   Author: Donato Meoli
;;;===============================================

;;**************
;;* DEFGLOBALS *
;;**************

(defglobal
   ?*high-priority* = 1000
   ?*medium-high-priority* = 100
   ?*medium-low-priority* = -100
   ?*low-priority* = -1000)

;;****************
;;* DEFTEMPLATES *
;;****************

(deftemplate UI-state
   (slot id
      (default-dynamic (gensym*)))
   (slot display)
   (slot help)
   (slot why)
   (slot relation-asserted
      (default none))
   (multislot valid-answers)
   (slot response
      (default none))
   (slot state
      (default middle)))

(deftemplate state-list
   (slot current)
   (multislot sequence))

(deftemplate attribute
   (slot name)
   (slot value)
   (slot certainty
      (range -1.0 1.0)
      (default 1.0)))

(deftemplate beer
   (slot style
      (type STRING)
      (allowed-strings "Pale Ale" "Dark Lager" "Brown Ale" "India Pale Ale" "Wheat Beer" "Strong Ale"
                       "Belgian Style" "Hybrid Beer" "Porter" "Stout" "Bock" "Scottish-Style Ale"
                       "Wild/Sour" "Pilsener & Pale Lager" "Specialty Beer"))
   (slot name
      (type STRING))
   (multislot alcohol
      (type SYMBOL)
      (allowed-symbols not-detectable mild noticeable harsh))
   (multislot color
      (type SYMBOL)
      (allowed-symbols pale amber brown dark))
   (multislot flavor
      (type SYMBOL)
      (allowed-symbols crisp-clean malty-sweet dark-roasty hoppy-bitter fruity-spicy sour-tart-funky))
   (multislot fermentation
      (type SYMBOL)
      (allowed-symbols top bottom wild))
   (multislot carbonation
      (type SYMBOL)
      (allowed-symbols low medium high))
   (slot link
      (type STRING)))

;;************
;;* DEFFACTS *
;;************

(deffacts startup
   (state-list))

(defrule load-beer-styles-list
   =>
   (load-facts clipsrc/beer-styles.fct))

;;****************
;;* DEFFUNCTIONS *
;;****************

(deffunction sort-certainties (?attribute1 ?attribute2)
   (< (fact-slot-value ?attribute1 certainty) (fact-slot-value ?attribute2 certainty)))

(deffunction combine-CFs (?x ?y)
   (if (and (> ?x 0) (> ?y 0))
    then (bind ?c (- (+ ?x ?y) (* ?x ?y)))
    else (if (and (< ?x 0) (< ?y 0))
          then (bind ?c (+ (+ ?x ?y) (* ?x ?y)))
          else (bind ?c (/ (+ ?x ?y ) (- 1 (min (abs ?x) (abs ?y)))))))
   ?c)

(deffunction get-explanation ()
   (bind ?explanation (format nil "%s %n%n" "*... for the following reasons:*"))
   (do-for-all-facts ((?a attribute))
                     (eq ?a:name explanation-scenario)
                     (bind ?explanation (str-cat ?explanation ?a:value " ")))
   (do-for-all-facts ((?a attribute))
                     (eq ?a:name explanation-preference)
                     (bind ?explanation (str-cat ?explanation ?a:value " ")))
   (do-for-all-facts ((?a attribute)) (eq ?a:name explanation-main-meal)
                     (bind ?explanation (str-cat ?explanation ?a:value " ")))
   (do-for-all-facts ((?a attribute)) (eq ?a:name explanation-specific-meal)
                     (bind ?explanation (str-cat ?explanation ?a:value " ")))
   ?explanation)

;;*****************
;;* INITIAL STATE *
;;*****************

(defrule start
   =>
   (set-strategy random)
   (assert (UI-state (display (format nil "%n%s %n%n%s %n%n%s" "Welcome to the Beer EXpert system 🍻"
                                          (str-cat "⁉ All I need is that you answer simple questions by choosing "
                                                   "one of the responses that are offered to you.")
                                          "To start, please press the /new button 😄"))
                     (relation-asserted start)
                     (state initial))))

;;***********************
;;* BEER QUESTION RULES *
;;***********************

(defrule load-beer-question-rules
   =>
   (load clipsrc/beer-questions.clp))

;;************************
;;* BEER KNOWLEDGE RULES *
;;************************

(defrule load-beer-knowledge-rules
   =>
   (load clipsrc/beer-knowledge.clp))

;;********************************
;;* BEER SELECTION & PRINT RULES *
;;********************************

(defrule combine-certainties
   ?f1 <- (attribute (name ?name) (value ?value) (certainty ?certainty1))
   ?f2 <- (attribute (name ?name) (value ?value) (certainty ?certainty2))
   (test (neq ?f1 ?f2))
   =>
   (retract ?f1)
   (modify ?f2 (certainty (combine-CFs ?certainty1 ?certainty2))))

(defrule generate-beers
   (declare (salience ?*medium-low-priority*))
   (or (and (beer (style ?beer-style) (name ?beer-name) (link ?link))
            (attribute (name best-style) (value ?beer-style) (certainty ?certainty)))
       (and (beer (style ?beer-style) (name ?beer-name) (link ?link))
            (attribute (name best-name) (value ?beer-name) (certainty ?certainty)))
       (and (beer (style ?beer-style) (name ?beer-name) (alcohol $? ?alcohol $?) (link ?link))
            (attribute (name best-alcohol) (value ?alcohol) (certainty ?certainty)))
       (and (beer (style ?beer-style) (name ?beer-name) (color $? ?color $?) (link ?link))
            (attribute (name best-color) (value ?color) (certainty ?certainty)))
       (and (beer (style ?beer-style) (name ?beer-name) (flavor $? ?flavor $?) (link ?link))
            (attribute (name best-flavor) (value ?flavor) (certainty ?certainty)))
       (and (beer (style ?beer-style) (name ?beer-name) (fermentation $? ?fermentation $?) (link ?link))
            (attribute (name best-fermentation) (value ?fermentation) (certainty ?certainty)))
       (and (beer (style ?beer-style) (name ?beer-name) (carbonation $? ?carbonation $?) (link ?link))
            (attribute (name best-carbonation) (value ?carbonation) (certainty ?certainty))))
   =>
   (assert (attribute (name beer)
                      (value (format nil "🍺 [%s - %s](%s)" ?beer-style ?beer-name ?link))
                      (certainty ?certainty))))

(defrule clean-working-memory-and-print-results
   (declare (salience ?*low-priority*))
   (UI-state (id ?id))
   (state-list (current ?id))
   =>
   (bind ?beers "")
   (bind ?attributes (sort sort-certainties (find-all-facts ((?a attribute)) (eq ?a:name beer))))
   (progn$ (?a ?attributes)
           (if (< (member$ ?a ?attributes) 5)
            then (bind ?beers (str-cat ?beers (format nil "%s with certainty %2d%% %n" (fact-slot-value ?a value)
                                                          (* (fact-slot-value ?a certainty) 100)))))
           (retract ?a))
   (if (neq ?beers "")
    then (bind ?results (str-cat (format nil "%s %n%n%s %n%s" "*✅ Done. I have selected these beer styles for you...*"
                                             ?beers (get-explanation))))
    else (bind ?results (format nil "%s %n%n%s" "*🚫 Sorry! I could not select any beer style for you. 😞"
                                                "Please, try again! 💪🏻*")))
   (do-for-all-facts ((?a attribute)) TRUE (retract ?a))
   (assert (UI-state (display ?results)
                     (state final))))

;;*************************
;;* GUI INTERACTION RULES *
;;*************************

(defrule ask-question
   (declare (salience ?*medium-high-priority*))
   (UI-state (id ?id))
   ?f <- (state-list (sequence $?s&:(not (member$ ?id ?s))))
   =>
   (modify ?f (current ?id) (sequence ?id ?s))
   (halt))

(defrule handle-next-no-change-none-middle-of-chain
   (declare (salience ?*high-priority*))
   ?f1 <- (next ?id)
   ?f2 <- (state-list (current ?id) (sequence $? ?nid ?id $?))
   =>
   (retract ?f1)
   (modify ?f2 (current ?nid))
   (halt))

(defrule handle-next-response-none-end-of-chain
   (declare (salience ?*high-priority*))
   ?f <- (next ?id)
   (state-list (sequence ?id $?))
   (UI-state (id ?id) (relation-asserted ?relation))
   =>
   (retract ?f)
   (assert (add-response ?id)))

(defrule handle-next-no-change-middle-of-chain
   (declare (salience ?*high-priority*))
   ?f1 <- (next ?id ?response)
   ?f2 <- (state-list (current ?id) (sequence $? ?nid ?id $?))
   (UI-state (id ?id) (response ?response))
   =>
   (retract ?f1)
   (modify ?f2 (current ?nid))
   (halt))

(defrule handle-next-change-middle-of-chain
   (declare (salience ?*high-priority*))
   (next ?id ?response)
   ?f1 <- (state-list (current ?id) (sequence ?nid $?b ?id $?e))
   (UI-state (id ?id) (response ~?response))
   ?f2 <- (UI-state (id ?nid))
   =>
   (modify ?f1 (sequence ?b ?id ?e))
   (retract ?f2))

(defrule handle-next-response-end-of-chain
   (declare (salience ?*high-priority*))
   ?f1 <- (next ?id ?response)
   (state-list (sequence ?id $?))
   ?f2 <- (UI-state (id ?id) (response ?expected) (relation-asserted ?relation))
   =>
   (retract ?f1)
   (if (neq ?response ?expected)
    then (modify ?f2 (response ?response)))
   (assert (add-response ?id ?response)))

(defrule handle-add-response
   (declare (salience ?*high-priority*))
   (UI-state (id ?id) (relation-asserted ?relation))
   ?f <- (add-response ?id ?response)
   =>
   (if (eq (str-index " " ?response) FALSE)
    then (str-assert (str-cat "(" ?relation " " ?response ")"))
    else (str-assert (str-cat "(" ?relation " " "\"" ?response "\"" ")")))
   (retract ?f))

(defrule handle-add-response-none
   (declare (salience ?*high-priority*))
   (UI-state (id ?id) (relation-asserted ?relation))
   ?f <- (add-response ?id)
   =>
   (str-assert (str-cat "(" ?relation ")"))
   (retract ?f))

(defrule handle-prev
   (declare (salience ?*high-priority*))
   ?f1 <- (prev ?id)
   (UI-state (id ?id) (state ?state))
   ?f2 <- (state-list (sequence $?b ?id ?pid $?e))
   (UI-state (id ?pid) (relation-asserted ?relation))
   =>
   (retract ?f1)
   (modify ?f2 (current ?pid))
   (do-for-fact ((?r ?relation)) (neq ?relation start) (retract ?r))
   (if (eq (get-strategy) random)
    then (progn$ (?rule (get-defrule-list))
                 (if (neq (str-index "random-question" ?rule) FALSE)
                  then (refresh ?rule))))
   (if (eq ?state final)
    then (progn$ (?rule (get-defrule-list))
                 (if (neq (str-index "determine-best-beer-attributes" ?rule) FALSE)
                  then (refresh ?rule))))
   (halt))

;;;===============================================
;;; BeerEX: the Beer EXpert system
;;;
;;;   This expert system suggests a beer to drink.
;;;
;;;   CLIPS 6.30
;;;
;;;   Author: Donato Meoli
;;;===============================================

;;**************
;;* DEFGLOBALS *
;;**************

(defglobal
   ?*high-priority* = 1000
   ?*medium-high-priority* = 100
   ?*medium-low-priority* = -100
   ?*low-priority* = -1000)

;;****************
;;* DEFTEMPLATES *
;;****************

(deftemplate UI-state
   (slot id
      (default-dynamic (gensym*)))
   (slot display)
   (slot help)
   (slot why)
   (slot relation-asserted
      (default none))
   (multislot valid-answers)
   (slot response
      (default none))
   (slot state
      (default middle)))

(deftemplate state-list
   (slot current)
   (multislot sequence))

(deftemplate attribute
   (slot name)
   (slot value)
   (slot certainty
      (range -1.0 1.0)
      (default 1.0)))

(deftemplate beer
   (slot style
      (type STRING)
      (allowed-strings "Pale Ale" "Dark Lager" "Brown Ale" "India Pale Ale" "Wheat Beer" "Strong Ale"
                       "Belgian Style" "Hybrid Beer" "Porter" "Stout" "Bock" "Scottish-Style Ale"
                       "Wild/Sour" "Pilsener & Pale Lager" "Specialty Beer"))
   (slot name
      (type STRING))
   (multislot alcohol
      (type SYMBOL)
      (allowed-symbols not-detectable mild noticeable harsh))
   (multislot color
      (type SYMBOL)
      (allowed-symbols pale amber brown dark))
   (multislot flavor
      (type SYMBOL)
      (allowed-symbols crisp-clean malty-sweet dark-roasty hoppy-bitter fruity-spicy sour-tart-funky))
   (multislot fermentation
      (type SYMBOL)
      (allowed-symbols top bottom wild))
   (multislot carbonation
      (type SYMBOL)
      (allowed-symbols low medium high))
   (slot link
      (type STRING)))

;;************
;;* DEFFACTS *
;;************

(deffacts startup
   (state-list))

(defrule load-beer-styles-list
   =>
   (load-facts clips/beer-styles.fct))

;;****************
;;* DEFFUNCTIONS *
;;****************

(deffunction sort-certainties (?attribute1 ?attribute2)
   (< (fact-slot-value ?attribute1 certainty) (fact-slot-value ?attribute2 certainty)))

(deffunction combine-CFs (?x ?y)
   (if (and (> ?x 0) (> ?y 0))
    then (bind ?c (- (+ ?x ?y) (* ?x ?y)))
    else (if (and (< ?x 0) (< ?y 0))
          then (bind ?c (+ (+ ?x ?y) (* ?x ?y)))
          else (bind ?c (/ (+ ?x ?y ) (- 1 (min (abs ?x) (abs ?y)))))))
   ?c)

(deffunction get-explanation ()
   (bind ?explanation (format nil "%s %n%n" "*... for the following reasons:*"))
   (do-for-all-facts ((?a attribute))
                     (eq ?a:name explanation-scenario)
                     (bind ?explanation (str-cat ?explanation ?a:value " ")))
   (do-for-all-facts ((?a attribute))
                     (eq ?a:name explanation-preference)
                     (bind ?explanation (str-cat ?explanation ?a:value " ")))
   (do-for-all-facts ((?a attribute)) (eq ?a:name explanation-main-meal)
                     (bind ?explanation (str-cat ?explanation ?a:value " ")))
   (do-for-all-facts ((?a attribute)) (eq ?a:name explanation-specific-meal)
                     (bind ?explanation (str-cat ?explanation ?a:value " ")))
   ?explanation)

;;*****************
;;* INITIAL STATE *
;;*****************

(defrule start
   =>
   (set-strategy random)
   (assert (UI-state (display (format nil "%n%s %n%n%s %n%n%s" "Welcome to the Beer EXpert system 🍻"
                                          (str-cat "⁉ All I need is that you answer simple questions by choosing "
                                                   "one of the responses that are offered to you.")
                                          "To start, please press the /new button 😄"))
                     (relation-asserted start)
                     (state initial))))

;;***********************
;;* BEER QUESTION RULES *
;;***********************

(defrule load-beer-question-rules
   =>
   (load clipsrc/beer-questions.clp))

;;************************
;;* BEER KNOWLEDGE RULES *
;;************************

(defrule load-beer-knowledge-rules
   =>
   (load clipsrc/beer-knowledge.clp))

;;********************************
;;* BEER SELECTION & PRINT RULES *
;;********************************

(defrule combine-certainties
   ?f1 <- (attribute (name ?name) (value ?value) (certainty ?certainty1))
   ?f2 <- (attribute (name ?name) (value ?value) (certainty ?certainty2))
   (test (neq ?f1 ?f2))
   =>
   (retract ?f1)
   (modify ?f2 (certainty (combine-CFs ?certainty1 ?certainty2))))

(defrule generate-beers
   (declare (salience ?*medium-low-priority*))
   (or (and (beer (style ?beer-style) (name ?beer-name) (link ?link))
            (attribute (name best-style) (value ?beer-style) (certainty ?certainty)))
       (and (beer (style ?beer-style) (name ?beer-name) (link ?link))
            (attribute (name best-name) (value ?beer-name) (certainty ?certainty)))
       (and (beer (style ?beer-style) (name ?beer-name) (alcohol $? ?alcohol $?) (link ?link))
            (attribute (name best-alcohol) (value ?alcohol) (certainty ?certainty)))
       (and (beer (style ?beer-style) (name ?beer-name) (color $? ?color $?) (link ?link))
            (attribute (name best-color) (value ?color) (certainty ?certainty)))
       (and (beer (style ?beer-style) (name ?beer-name) (flavor $? ?flavor $?) (link ?link))
            (attribute (name best-flavor) (value ?flavor) (certainty ?certainty)))
       (and (beer (style ?beer-style) (name ?beer-name) (fermentation $? ?fermentation $?) (link ?link))
            (attribute (name best-fermentation) (value ?fermentation) (certainty ?certainty)))
       (and (beer (style ?beer-style) (name ?beer-name) (carbonation $? ?carbonation $?) (link ?link))
            (attribute (name best-carbonation) (value ?carbonation) (certainty ?certainty))))
   =>
   (assert (attribute (name beer)
                      (value (format nil "🍺 [%s - %s](%s)" ?beer-style ?beer-name ?link))
                      (certainty ?certainty))))

(defrule clean-working-memory-and-print-results
   (declare (salience ?*low-priority*))
   (UI-state (id ?id))
   (state-list (current ?id))
   =>
   (bind ?beers "")
   (bind ?attributes (sort sort-certainties (find-all-facts ((?a attribute)) (eq ?a:name beer))))
   (progn$ (?a ?attributes)
           (if (< (member$ ?a ?attributes) 5)
            then (bind ?beers (str-cat ?beers (format nil "%s with certainty %2d%% %n" (fact-slot-value ?a value)
                                                          (* (fact-slot-value ?a certainty) 100)))))
           (retract ?a))
   (if (neq ?beers "")
    then (bind ?results (str-cat (format nil "%s %n%n%s %n%s" "*✅ Done. I have selected these beer styles for you...*"
                                             ?beers (get-explanation))))
    else (bind ?results (format nil "%s %n%n%s" "*🚫 Sorry! I could not select any beer style for you. 😞"
                                                "Please, try again! 💪🏻*")))
   (do-for-all-facts ((?a attribute)) TRUE (retract ?a))
   (assert (UI-state (display ?results)
                     (state final))))

;;*************************
;;* GUI INTERACTION RULES *
;;*************************

(defrule ask-question
   (declare (salience ?*medium-high-priority*))
   (UI-state (id ?id))
   ?f <- (state-list (sequence $?s&:(not (member$ ?id ?s))))
   =>
   (modify ?f (current ?id) (sequence ?id ?s))
   (halt))

(defrule handle-next-no-change-none-middle-of-chain
   (declare (salience ?*high-priority*))
   ?f1 <- (next ?id)
   ?f2 <- (state-list (current ?id) (sequence $? ?nid ?id $?))
   =>
   (retract ?f1)
   (modify ?f2 (current ?nid))
   (halt))

(defrule handle-next-response-none-end-of-chain
   (declare (salience ?*high-priority*))
   ?f <- (next ?id)
   (state-list (sequence ?id $?))
   (UI-state (id ?id) (relation-asserted ?relation))
   =>
   (retract ?f)
   (assert (add-response ?id)))

(defrule handle-next-no-change-middle-of-chain
   (declare (salience ?*high-priority*))
   ?f1 <- (next ?id ?response)
   ?f2 <- (state-list (current ?id) (sequence $? ?nid ?id $?))
   (UI-state (id ?id) (response ?response))
   =>
   (retract ?f1)
   (modify ?f2 (current ?nid))
   (halt))

(defrule handle-next-change-middle-of-chain
   (declare (salience ?*high-priority*))
   (next ?id ?response)
   ?f1 <- (state-list (current ?id) (sequence ?nid $?b ?id $?e))
   (UI-state (id ?id) (response ~?response))
   ?f2 <- (UI-state (id ?nid))
   =>
   (modify ?f1 (sequence ?b ?id ?e))
   (retract ?f2))

(defrule handle-next-response-end-of-chain
   (declare (salience ?*high-priority*))
   ?f1 <- (next ?id ?response)
   (state-list (sequence ?id $?))
   ?f2 <- (UI-state (id ?id) (response ?expected) (relation-asserted ?relation))
   =>
   (retract ?f1)
   (if (neq ?response ?expected)
    then (modify ?f2 (response ?response)))
   (assert (add-response ?id ?response)))

(defrule handle-add-response
   (declare (salience ?*high-priority*))
   (UI-state (id ?id) (relation-asserted ?relation))
   ?f <- (add-response ?id ?response)
   =>
   (if (eq (str-index " " ?response) FALSE)
    then (str-assert (str-cat "(" ?relation " " ?response ")"))
    else (str-assert (str-cat "(" ?relation " " "\"" ?response "\"" ")")))
   (retract ?f))

(defrule handle-add-response-none
   (declare (salience ?*high-priority*))
   (UI-state (id ?id) (relation-asserted ?relation))
   ?f <- (add-response ?id)
   =>
   (str-assert (str-cat "(" ?relation ")"))
   (retract ?f))

(defrule handle-prev
   (declare (salience ?*high-priority*))
   ?f1 <- (prev ?id)
   (UI-state (id ?id) (state ?state))
   ?f2 <- (state-list (sequence $?b ?id ?pid $?e))
   (UI-state (id ?pid) (relation-asserted ?relation))
   =>
   (retract ?f1)
   (modify ?f2 (current ?pid))
   (do-for-fact ((?r ?relation)) (neq ?relation start) (retract ?r))
   (if (eq (get-strategy) random)
    then (progn$ (?rule (get-defrule-list))
                 (if (neq (str-index "random-question" ?rule) FALSE)
                  then (refresh ?rule))))
   (if (eq ?state final)
    then (progn$ (?rule (get-defrule-list))
                 (if (neq (str-index "determine-best-beer-attributes" ?rule) FALSE)
                  then (refresh ?rule))))
   (halt))


Updated pipeline logic to not pop the top focus element

This was causing a slow down to occur because we were entering the MAIN module
which was being saved to the focus stack when focus was called.

;------------------------------------------------------------------------------
;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; PassHandler.clp - Contains the logic necessary to handle pass execution
;------------------------------------------------------------------------------
(defrule pipeline::build-pass-descriptor
         ?fct <- (message (to pipeline)
                          (action pass-description)
                          (arguments $?passes))
         =>
         (retract ?fct)
         (make-instance of pass-description (passes $?passes)))
;------------------------------------------------------------------------------
(defrule pipeline::next-pass
         ?obj <- (object (is-a pass-description)
                         (passes ?first $?rest))
         =>
         (modify-instance ?obj (passes $?rest))
         ;remove what is currently on the focus stack
         ;			(pop-focus)
         (assert (message (from pipeline)
                          (to ?first)
                          (action initial-fact)))
         (focus ?first pipeline))
;------------------------------------------------------------------------------
(defrule pipeline::terminate-pass
         ?obj <- (object (is-a pass-description)
                         (passes))
         =>
         (unmake-instance ?obj))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; PassHandler.clp - Contains the logic necessary to handle pass execution
;------------------------------------------------------------------------------
(defrule pipeline::build-pass-descriptor
			?fct <- (message (to pipeline)
								  (action pass-description)
								  (arguments $?passes))
			=>
			(retract ?fct)
			(make-instance of pass-description (passes $?passes)))
;------------------------------------------------------------------------------
(defrule pipeline::next-pass
			?obj <- (object (is-a pass-description)
								 (passes ?first $?rest))
			=>
			(modify-instance ?obj (passes $?rest))
			;remove what is currently on the focus stack
			(pop-focus)
			(assert (message (from pipeline)
								  (to ?first)
								  (action initial-fact)))
			(focus ?first pipeline))
;------------------------------------------------------------------------------
(defrule pipeline::terminate-pass
			?obj <- (object (is-a pass-description)
								 (passes))
			=>
			(unmake-instance ?obj))
;------------------------------------------------------------------------------


Update task3.clp

Update task3.clp

(deffunction str-del (?substr ?str)
    (bind ?n1 (str-length ?substr))
    (bind ?n2 (str-length ?str))
    (bind ?k (str-index ?substr ?str))
    (while (> ?k 0) do
        (bind ?st1 (sub-string 1 (- ?k 1) ?str))
        (bind ?st2 (sub-string (+ ?k ?n1) ?n2 ?str))
        (bind ?str (str-cat ?st1 ?st2))
        (bind ?k (str-index ?substr ?str))
        (if (not ?k) then
            (bind ?k 0)
        )
    )
    ?str)

(defrule substr_delete
=>
(bind ?str (read))
(bind ?substr (read))
(bind ?str (str-del ?substr ?str))
(printout t "str=" ?str crlf))


add and sample

add and sample

; sample test

(clear)
(defclass DUCK (is-a USER)
    (slot age (default 1))
    (multislot sound (default quack quack))
)

(defrule find-sound
    ?duck <- (object
        (is-a DUCK)
        (sound $?find))
  =>
    (printout t "Duck " (instance-name ?duck) " says " ?find crlf)
)

(defrule find-dorky-sound
    (object
        (is-a DUCK)
        (sound $?find)
        (name [Dorky_Duck]))
    =>
    (printout t "[Dorky_Duck] sound" crlf)
)

(make-instance [Dorky_Duck] of DUCK)
(make-instance [Dinky_Duck] of DUCK)

(instances)

(agenda)
(run)

(defrule find-age-over-10
    ?duck <- (object
        (is-a DUCK)
        (age ?age &:(> ?age 10)))
  =>
    (printout t "Duck-1 " (instance-name ?duck) " age " ?age crlf)
)

(defrule find-age-over-20-or-below-10
    ?duck <- (object
        (is-a DUCK)
        (age ?age &:(> ?age 20)|:(< ?age 10)))
  =>
    (printout t "Duck-2 " (instance-name ?duck) " age " ?age crlf)
)

(defrule find-age-over-10-and-below-20
    ?duck <- (object
        (is-a DUCK)
        (age ?age &:(> ?age 10)&:(< ?age 20)))
  =>
    (printout t "Duck-3 " (instance-name ?duck) " age " ?age crlf)
)

(defrule find-name-is-unkown-or-name-is-dinky
    (or
        (object
            (is-a DUCK)
            (age 30)
        )

        (object
            (is-a DUCK)
            (name [Dinky_Duck])
        )
    )
    ?f <- (make-again 1)
  =>
    (retract ?f)
    (printout t "Duck-3 " crlf)
)

; (send [Dinky_Duck] put-age 30)
; (assert (make-again 1))
; (send [Dinky_Duck] print)
;
(instances)

(send [Dinky_Duck] print)
(send [Dorky_Duck] print)
(send [Dinky_Duck] put-age 25)
(send [Dinky_Duck] put-age 15)
(agenda)
(run)

; (agenda)
; (run)
; (agenda)
;
; (assert (make-again 1))
; (facts)
; (instances)
; (agenda)

(exit)

; sample test

(clear)
(defclass DUCK (is-a USER)
    (slot age (default 1))
    (multislot sound (default quack quack))
)

(defrule find-sound
    ?duck <- (object
        (is-a DUCK)
        (sound $?find))
  =>
    (printout t "Duck " (instance-name ?duck) " says " ?find crlf)
)

(defrule find-dorky-sound
    (object
        (is-a DUCK)
        (sound $?find)
        (name [Dorky_Duck]))
    =>
    (printout t "[Dorky_Duck] sound" crlf)
)

(make-instance [Dorky_Duck] of DUCK)
(make-instance [Dinky_Duck] of DUCK)

(instances)

(agenda)
(run)

(defrule find-age-over-10
    ?duck <- (object
        (is-a DUCK)
        (age ?age &:(> ?age 10)))
  =>
    (printout t "Duck-1 " (instance-name ?duck) " age " ?age crlf)
)

(defrule find-age-over-20-or-below-10
    ?duck <- (object
        (is-a DUCK)
        (age ?age &:(> ?age 20)|:(< ?age 10)))
  =>
    (printout t "Duck-2 " (instance-name ?duck) " age " ?age crlf)
)

(defrule find-name-is-unkown-or-name-is-dinky
    (or
        (object
            (is-a DUCK)
            (age 30)
        )

        (object
            (is-a DUCK)
            (name [Dinky_Duck])
        )
    )
    ?f <- (make-again 1)
  =>
    (retract ?f)
    (printout t "Duck-3 " crlf)
)

(send [Dinky_Duck] put-age 30)
(assert (make-again 1))
(send [Dinky_Duck] print)

(instances)

(agenda)
(run)
(agenda)

(assert (make-again 1))
(facts)
(instances)
(agenda)

(exit)


- fixed the view test.

- fixed the view test.

git-svn-id: 9643e93313b82f5e4da82d8413267a0daa4b5472@881 2cd91b7d-3b21-0410-a5f4-f42db4f24360

(printout t '

---J-A-M-O-C-H-A---B-Y---E-X-A-M-P-L-E---
* Defining two templates *
' crlf)

(printout t '
Defining a template T-1 with a slot S-1 of type STRING
and a slot S-2 of type INTEGER:

(deftemplate T-1
	(slot S-1 (type STRING))
	(slot S-2 (type INTEGER))
)'
 crlf)

(deftemplate T-1
	(slot S-1 (type STRING))
	(slot S-2 (type INTEGER))
)

(printout t '
Defining a template T-2 with a slot S-3 of type STRING
and a slot S-4 of type INTEGER:

(deftemplate T-2
	(slot S-3 (type STRING))
	(slot S-4 (type INTEGER))
)
'
 crlf)

(deftemplate T-2
	(slot S-3 (type STRING))
	(slot S-4 (type INTEGER))
)

(printout t '
Checking if the templates defined exist by typing

(templates)
-->'
crlf)

(templates)

(printout t '
and pretty print the definition of T-1 with

(ppdeftemplate T-1)
-->'
 crlf)

(ppdeftemplate T-1)

(printout t '

---J-A-M-O-C-H-A---B-Y---E-X-A-M-P-L-E---
* Defining two rules
' crlf)

(defrule R-1 "rule one"
	(T-1 (S-1 ?x)(S-2 42))
	=>
	(printout t ?x crlf)
)

(defrule R-2 "rule two"
	(T-2 (S-3 ?y)(S-4 28))
	=>
	(printout t ?y crlf)
)

(defrule R-3 "rule three"
	(T-1 (S-1 ?x)(S-2 2)) (T-2 (S-3 ?y)(S-4 2))
	=>
	(printout t ?x crlf)
)

(assert (T-1 (S-1 a)(S-2 1)))
(assert (T-2 (S-3 a)(S-4 1)))

(assert (T-1 (S-1 b)(S-2 2)))
(assert (T-2 (S-3 b)(S-4 2)))

(fire)

(printout t '

---J-A-M-O-C-H-A---B-Y---E-X-A-M-P-L-E---
* Defining two templates *
' crlf)

(printout t '
Defining a template T-1 with a slot S-1 of type STRING
and a slot S-2 of type INTEGER:

(deftemplate T-1
	(slot S-1 (type STRING))
	(slot S-2 (type INTEGER))
)'
 crlf)

(deftemplate T-1
	(slot S-1 (type STRING))
	(slot S-2 (type INTEGER))
)

(printout t '
Defining a template T-2 with a slot S-3 of type STRING
and a slot S-4 of type INTEGER:

(deftemplate T-2
	(slot S-3 (type STRING))
	(slot S-4 (type INTEGER))
)
'
 crlf)

(deftemplate T-2
	(slot S-3 (type STRING))
	(slot S-4 (type INTEGER))
)

(printout t '
Checking if the templates defined exist by typing

(templates)
-->'
crlf)

(templates)

(printout t '
and pretty print the definition of T-1 with

(ppdeftemplate T-1)
-->'
 crlf)

(ppdeftemplate T-1)

(printout t '

---J-A-M-O-C-H-A---B-Y---E-X-A-M-P-L-E---
* Defining two rules
' crlf)

(defrule R-1 "rule one"
	(T-1 (S-1 ?x)(S-2 42))
	=>
	(printout t ?x crlf)
)

(defrule R-2 "rule two"
	(T-2 (S-3 ?y)(S-4 28))
	=>
	(printout t ?y crlf)
)

(defrule R-3 "rule three"
	(T-1 (S-1 ?x)(S-2 a)) (T-2 (S-3 ?y)(S-4 a))
	=>
	(printout t ?x crlf)
)

(assert (T-1 (S-1 a)(S-2 b)))
(assert (T-2 (S-3 a)(S-4 b)))

(assert (T-1 (S-1 b)(S-2 a)))
(assert (T-2 (S-3 b)(S-4 a)))

(fire)


Added the Path class to the path module

Added the Path class to the path module


Modified Init.clp to load the standard module set

;------------------------------------------------------------------------------
;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; Init.clp - Default Entry Point for a expert system optimization
;------------------------------------------------------------------------------
; Usually this only contains elements necessary to start the load process
; With the modifications I made to CLIPS for LLVM this usually manifests
; itself as being a batch-load command which allows multiple loads to occur as
; a single command
;------------------------------------------------------------------------------
(batch-load
  (create$ "modules/core/ModuleHeader.clp"
	        "modules/llvm/ModuleHeader.clp"
        	  "modules/rampancy/ModuleHeader.clp"
			  "modules/indirect/ModuleHeader.clp"
			  "modules/types/ModuleHeader.clp"
			  "modules/pipeline/ModuleHeader.clp"
			  ; Add entries to other modules here
			  ))
;(defmodule MAIN (import core ?ALL) (import llvm ?ALL))

;------------------------------------------------------------------------------
;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; Init.clp - Default Entry Point for a expert system optimization
;------------------------------------------------------------------------------
; Usually this only contains elements necessary to start the load process
; With the modifications I made to CLIPS for LLVM this usually manifests
; itself as being a batch-load command which allows multiple loads to occur as
; a single command
;------------------------------------------------------------------------------
(batch-load
  (create$ "modules/core/ModuleHeader.clp"
	        "modules/llvm/ModuleHeader.clp"
			  "modules/scheduler/ModuleHeader.clp"
        "modules/rampancy/ModuleHeader.clp"
			  ; Add entries to other modules here
			  ))
;(defmodule MAIN (import core ?ALL) (import llvm ?ALL))


Fixed the CompensationPathVector class to work with the new module layout


Fixed a bug where there was a duplicate defmodule in Loader.clp


Fixed bugs in WavefrontDependencyUpdate.clp

;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; This stage is the actual act of scheduling the blocks on the wavefront.
; The first step is to reacquire all dependencies of the given blocks by
; running the same rules as before. The only difference is that we have to do
; it specially for the blocks on the wavefront.
;
; I'm thinking of just copying the rules from the analysis pass to here. It
; would be a duplication but I frankly don't care anymore.
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::CreateDependencyAnalysisTargets
         (declare (salience 10))
         (object (is-a Wavefront)
                 (parent ?r)
                 (values $? ?e $?))
         (object (is-a BasicBlock)
                 (id ?e))
         (object (is-a PathAggregate)
                 (parent ?e)
                 (OriginalStopIndex ?si))
         =>
         ;only look at instructions starting at the original stop index. This
         ;prevents unncessary recomputation
         (assert (Evaluate ?e for dependencies starting at ?si)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::IdentifyWAR
         "Identifies a WAR dependency between two instructions. It will not
         match if it turns out the values are constant integers or constant
         floating point values"
         (Evaluate ?p for dependencies starting at ?si)
         ;TODO: Rewrite this to be more efficient
         ?i0 <- (object (is-a Instruction)
                        (parent ?p)
                        (id ?t0)
                        (TimeIndex ?ti0)
                        (Operands $? ?c $?))
         (object (is-a Object&~ConstantInteger&~ConstantFloatingPoint)
                 (id ?c))
         ?i1 <- (object (is-a Instruction)
                        (parent ?p)
                        (id ?t1)
                        (TimeIndex ?ti1&:(and (>= ?ti1 ?si) (< ?ti0 ?ti1)))
                        (DestinationRegisters $? ?c $?))
         =>
         (assert (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?t1 => ?t0))
                 (message (to wavefront-scheduling)
                          (action instruction-produces)
                          (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::IdentifyRAW
         "Identifies a RAW dependency between two instructions in the same
         block. It will not match if it turns out that the values are constant
         integers or constant floating point values."
         (Evaluate ?p for dependencies starting at ?si)
         (object (is-a Instruction)
                 (parent ?p)
                 (id ?t0)
                 (TimeIndex ?ti0)
                 (DestinationRegisters $? ?c $?))
         (object (is-a Object&~ConstantInteger&~ConstantFloatingPoint)
                 (id ?c))
         (object (is-a Instruction)
                 (parent ?p)
                 (id ?t1)
                 (TimeIndex ?ti1&:(and (>= ?ti1 ?si) (< ?ti0 ?ti1)))
                 (Operands $? ?c $?))
         =>
         (assert (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?t1 => ?t0))
                 (message (to wavefront-scheduling)
                          (action instruction-produces)
                          (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::IdentifyWAW
         "Identifies a WAW dependency between two instructions in the same
         block. It will not match if it turns out that the values are constant
         integers or constant floating point values."
         (Evaluate ?p for dependencies starting at ?si)
         ?i0 <- (object (is-a Instruction)
                        (parent ?p)
                        (id ?t0)
                        (TimeIndex ?ti0)
                        (DestinationRegisters $? ?c $?))
         (object (is-a Object&~ConstantInteger&~ConstantFloatingPoint)
                 (id ?c))
         ?i1 <- (object (is-a Instruction)
                        (parent ?p)
                        (id ?t1)
                        (TimeIndex ?ti1&:(and (>= ?ti1 ?si) (< ?ti0 ?ti1)))
                        (DestinationRegisters $? ?c $?))
         =>
         (assert (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?t1 => ?t0))
                 (message (to wavefront-scheduling)
                          (action instruction-produces)
                          (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------
;these call instruction checks only work for new instructions or those that
; dont have a call dependency. As that was the only way they got into the
; block in the first place
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::MarkCallInstructionDependency-ModifiesMemory
         "Creates a series of dependencies for all instructions following a
         call instruction if it turns out that the call could modify memory."
         (Evaluate ?p for dependencies starting at ?si)
         (object (is-a CallInstruction)
                 (id ?name)
                 (parent ?p)
                 (DoesNotAccessMemory FALSE) (OnlyReadsMemory FALSE)
                 (MayWriteToMemory TRUE)
                 (TimeIndex ?t0))
         (object (is-a Instruction)
                 (parent ?p)
                 (TimeIndex ?ti1&:(and (>= ?ti1 ?si) (< ?t0 ?ti1)))
                 (HasCallDependency FALSE) (id ?following))
         =>
         (assert (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?following => ?name))
                 (message (to wavefront-scheduling)
                          (action instruction-produces)
                          (arguments ?name => ?following))
                 (message (to wavefront-scheduling)
                          (action instruction-has-a-call-dependency)
                          (arguments ?following))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::MarkCallInstructionDependency-InlineAsm
         "Creates a series of dependencies for all instructions following a
         call instruction if it turns out that the call is inline asm."
         (Evaluate ?p for dependencies starting at ?si)
         (object (is-a CallInstruction)
                 (id ?name)
                 (parent ?p)
                 (IsInlineAsm TRUE)
                 (TimeIndex ?t0))
         (object (is-a Instruction)
                 (parent ?p)
                 (id ?following)
                 (TimeIndex ?ti1&:(and (>= ?ti1 ?si) (< ?t0 ?ti1)))
                 (HasCallDependency FALSE))
         =>
         (assert (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?following => ?name))
                 (message (to wavefront-scheduling)
                          (action instruction-produces)
                          (arguments ?name => ?following))
                 (message (to wavefront-scheduling)
                          (action instruction-has-a-call-dependency)
                          (arguments ?following))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::MarkCallInstructionDependency-SideEffects
         "Creates a series of dependencies for all instructions following a
         call instruction if it turns out that the call is inline asm."
         (Evaluate ?p for dependencies starting at ?si)
         (object (is-a CallInstruction)
                 (id ?name)
                 (parent ?p)
                 (MayHaveSideEffects TRUE)
                 (MayWriteToMemory TRUE)
                 (TimeIndex ?t0))
         (object (is-a Instruction)
                 (parent ?p)
                 (TimeIndex ?ti1&:(and (>= ?ti1 ?si) (< ?t0 ?ti1)))
                 (HasCallDependency FALSE)
                 (id ?following))
         =>
         (assert (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?following => ?name))
                 (message (to wavefront-scheduling)
                          (action instruction-produces)
                          (arguments ?name => ?following))
                 (message (to wavefront-scheduling)
                          (action instruction-has-a-call-dependency)
                          (arguments ?following))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::MarkNonLocalDependencies
         (Evaluate ?p for dependencies starting at ?si)
         ?inst <- (object (is-a Instruction)
                          (parent ?p)
                          (TimeIndex ?t&:(>= ?t ?si))
                          (NonLocalDependencies $?nld)
                          (Operands $? ?o $?))
         (object (is-a Instruction)
                 (id ?o)
                 (parent ~?p))
         =>
         (modify-instance ?inst (NonLocalDependencies $?nld ?o)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::Wavefront-MarkHasCallDependency
         (declare (salience -2))
         ?fct <- (message (to wavefront-scheduling)
                          (action instruction-has-a-call-dependency)
                          (arguments ?f))

         ?obj <- (object (is-a Instruction)
                         (id ?f))
         =>
         (modify-instance ?obj (HasCallDependency TRUE))
         (retract ?fct))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::InjectConsumers
         "Adds a given consumer to the target instruction"
         (declare (salience -5))
         ?fct <- (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?target => ?id))
         ?inst <- (object (is-a Instruction)
                          (id ?id)
                          (Consumers $?consumers))
         =>
         (retract ?fct)
         (if (not (member$ ?target $?consumers)) then
           (modify-instance ?inst (Consumers $?consumers ?target))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::InjectProducers
         "Adds a given producer to the target instruction"
         (declare (salience -5))
         ?fct <- (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?target => ?id))
         ?inst <- (object (is-a Instruction)
                          (id ?id)
                          (LocalDependencies $?ld)
                          (Producers $?prod))
         =>
         (retract ?fct)
         (modify-instance ?inst
                          (LocalDependencies $?ld
                                             (if (not (member$ ?target $?ld))
                                               then ?target))
                          (Producers $?prod
                                     (if (not (member$ ?target $?prod))
                                       then ?target))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::StoreToLoadDependency
         (Evaluate ?p for dependencies starting at ?si)
         (object (is-a StoreInstruction)
                 (parent ?p)
                 (id ?t0)
                 (TimeIndex ?ti0)
                 (MemoryTarget ?sym0))
         (object (is-a LoadInstruction)
                 (parent ?p)
                 (id ?t1)
                 (TimeIndex ?ti1&:(and (>= ?ti1 ?si) (< ?ti0 ?ti1)))
                 (MemoryTarget ?sym1))
         (test (or (eq ?sym0 ?sym1)
                   (eq ?sym0 UNKNOWN)))
         =>
         (assert (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?t1 => ?t0))
                 (message (to wavefront-scheduling)
                          (action instruction-produces)
                          (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::StoreToStoreDependency
         (Evaluate ?p for dependencies starting at ?si)
         (object (is-a StoreInstruction)
                 (parent ?p)
                 (id ?t0)
                 (TimeIndex ?ti0)
                 (MemoryTarget ?sym0))
         (object (is-a StoreInstruction)
                 (parent ?p)
                 (id ?t1)
                 (TimeIndex ?ti1&:(and (>= ?ti1 ?si) (< ?ti0 ?ti1)))
                 (MemoryTarget ?sym1))
         (test (or (eq ?sym0 ?sym1)
                   (eq ?sym0 UNKNOWN)))
         =>
         (assert (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?t1 => ?t0))
                 (message (to wavefront-scheduling)
                          (action instruction-produces)
                          (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::LoadToStoreDependency
         (Evaluate ?p for dependencies starting at ?si)
         (object (is-a LoadInstruction)
                 (parent ?p)
                 (id ?t0)
                 (TimeIndex ?ti0)
                 (MemoryTarget ?sym0))
         (object (is-a StoreInstruction)
                 (parent ?p)
                 (id ?t1)
                 (TimeIndex ?ti1&:(and (>= ?ti1 ?si) (< ?ti0 ?ti1)))
                 (MemoryTarget ?sym1))
         (test (or (eq ?sym0 ?sym1)
                   (eq ?sym0 UNKNOWN)))
         =>
         (assert (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?t1 => ?t0))
                 (message (to wavefront-scheduling)
                          (action instruction-produces)
                          (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::FinishedDependencyAnalysis
         (declare (salience -800))
         ?fct <- (Evaluate ?p for dependencies starting at ?v)
         (object (is-a BasicBlock)
                 (id ?p)
                 (parent ?r))
         =>
         (retract ?fct))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge-update::RemoveInstructionsFromProducers
         (declare (salience 768))
         ?fct <- (message (to wavefront-scheduling)
                          (action remove-evidence)
                          (arguments ?tInst => ?inst $?insts))
         ?iObj <- (object (is-a Instruction)
                          (id ?inst)
                          (NonLocalDependencies $?nld)
                          (Producers $?pb ?tInst $?pa)
                          (LocalDependencies $?ldb ?tInst $?lda))
         =>
         (modify ?fct (arguments ?tInst => $?insts))
         (modify-instance ?iObj (Producers $?pb $?pa)
                          (LocalDependencies $?ldb $?lda)
                          (NonLocalDependencies $?nld ?tInst)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge-update::RetractRemoveInstructionsFromProducers
         (declare (salience 768))
         ?fct <- (message (to wavefront-scheduling)
                          (action remove-evidence)
                          (arguments ? =>))
         =>
         (retract ?fct))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge-update::StartRecomputeBlock
         (declare (salience 100))
         ?fct <- (message (to wavefront-scheduling)
                          (action recompute-block)
                          (arguments ?b))
         ?bb <- (object (is-a BasicBlock)
                        (id ?b)
                        (contents $?instructions ?last))
         (object (is-a TerminatorInstruction)
                 (id ?last))
         =>
         (modify-instance ?bb
                          (ReadsFrom)
                          (WritesTo)
                          (HasMemoryBarrier FALSE))
         (modify ?fct
                 (action recompute-block-with-instructions)
                 (arguments ?b => $?instructions)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge-update::RecomputeNonMemoryInstructionForBlock
         (declare (salience 99))
         ?fct <- (message (to wavefront-scheduling)
                          (action recompute-block-with-instructions)
                          (arguments ?b => ?inst $?rest))
         (object (is-a Instruction&~LoadInstruction&~StoreInstruction)
                 (id ?inst)
                 (parent ?b))
         =>
         (modify ?fct (arguments ?b => $?rest)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge-update::RecomputeLoadInstructionForBlock
         (declare (salience 99))
         ?fct <- (message (to wavefront-scheduling)
                          (action recompute-block-with-instructions)
                          (arguments ?b => ?inst $?rest))
         (object (is-a LoadInstruction)
                 (id ?inst)
                 (parent ?b)
                 (MemoryTarget ?mt))
         ?bb <- (object (is-a BasicBlock)
                        (id ?b)
                        (ReadsFrom $?rf))
         =>
         (if (not (member$ ?mt $?rf)) then
           (modify-instance ?bb (ReadsFrom $?rf ?mt)))
         (modify ?fct (arguments ?b => $?rest)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge-update::RecomputeStoreInstructionForBlock
         (declare (salience 99))
         ?fct <- (message (to wavefront-scheduling)
                          (action recompute-block-with-instructions)
                          (arguments ?b => ?inst $?rest))
         (object (is-a StoreInstruction)
                 (id ?inst)
                 (parent ?b)
                 (MemoryTarget ?mt))
         ?bb <- (object (is-a BasicBlock)
                        (id ?b)
                        (WritesTo $?wt))
         =>
         (if (not (member$ ?mt $?wt)) then
           (modify-instance ?bb (WritesTo $?wt ?mt)))
         (modify ?fct (arguments ?b => $?rest)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge-update::FinishRecomputationForBlock
         (declare (salience 98))
         ?fct <- (message (to wavefront-scheduling)
                          (action recompute-block-with-instructions)
                          (arguments ?b =>))
         ?bb <- (object (is-a BasicBlock)
                        (id ?b)
                        (ReadsFrom $?rf)
                        (WritesTo $?wt))
         =>
         (retract ?fct)
         (if (or (member$ UNKNOWN ?rf)
                 (member$ UNKNOWN ?wt)) then
           (modify-instance ?bb (HasMemoryBarrier TRUE))))
;------------------------------------------------------------------------------

;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; This stage is the actual act of scheduling the blocks on the wavefront.
; The first step is to reacquire all dependencies of the given blocks by
; running the same rules as before. The only difference is that we have to do
; it specially for the blocks on the wavefront.
;
; I'm thinking of just copying the rules from the analysis pass to here. It
; would be a duplication but I frankly don't care anymore.
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::CreateDependencyAnalysisTargets
         (declare (salience 10))
         (object (is-a Wavefront)
                 (parent ?r)
                 (contents $? ?e $?))
         (object (is-a BasicBlock)
                 (id ?e))
         (object (is-a PathAggregate)
                 (parent ?e)
                 (OriginalStopIndex ?si))
         =>
         ;only look at instructions starting at the original stop index. This
         ;prevents unncessary recomputation
         (assert (Evaluate ?e for dependencies starting at ?si)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::IdentifyWAR
         "Identifies a WAR dependency between two instructions. It will not
         match if it turns out the values are constant integers or constant
         floating point values"
         (Evaluate ?p for dependencies starting at ?si)
         ;TODO: Rewrite this to be more efficient
         ?i0 <- (object (is-a Instruction)
                        (parent ?p)
                        (id ?t0)
                        (TimeIndex ?ti0)
                        (Operands $? ?c $?))
         (object (is-a TaggedObject&~ConstantInteger&~ConstantFloatingPoint)
                 (id ?c))
         ?i1 <- (object (is-a Instruction)
                        (parent ?p)
                        (id ?t1)
                        (TimeIndex ?ti1&:(and (>= ?ti1 ?si) (< ?ti0 ?ti1)))
                        (DestinationRegisters $? ?c $?))
         =>
         (assert (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?t1 => ?t0))
                 (message (to wavefront-scheduling)
                          (action instruction-produces)
                          (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::IdentifyRAW
         "Identifies a RAW dependency between two instructions in the same
         block. It will not match if it turns out that the values are constant
         integers or constant floating point values."
         (Evaluate ?p for dependencies starting at ?si)
         (object (is-a Instruction)
                 (parent ?p)
                 (id ?t0)
                 (TimeIndex ?ti0)
                 (DestinationRegisters $? ?c $?))
         (object (is-a TaggedObject&~ConstantInteger&~ConstantFloatingPoint)
                 (id ?c))
         (object (is-a Instruction)
                 (parent ?p)
                 (id ?t1)
                 (TimeIndex ?ti1&:(and (>= ?ti1 ?si) (< ?ti0 ?ti1)))
                 (Operands $? ?c $?))
         =>
         (assert (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?t1 => ?t0))
                 (message (to wavefront-scheduling)
                          (action instruction-produces)
                          (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::IdentifyWAW
         "Identifies a WAW dependency between two instructions in the same
         block. It will not match if it turns out that the values are constant
         integers or constant floating point values."
         (Evaluate ?p for dependencies starting at ?si)
         ?i0 <- (object (is-a Instruction)
                        (parent ?p)
                        (id ?t0)
                        (TimeIndex ?ti0)
                        (DestinationRegisters $? ?c $?))
         (object (is-a TaggedObject&~ConstantInteger&~ConstantFloatingPoint)
                 (id ?c))
         ?i1 <- (object (is-a Instruction)
                        (parent ?p)
                        (id ?t1)
                        (TimeIndex ?ti1&:(and (>= ?ti1 ?si) (< ?ti0 ?ti1)))
                        (DestinationRegisters $? ?c $?))
         =>
         (assert (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?t1 => ?t0))
                 (message (to wavefront-scheduling)
                          (action instruction-produces)
                          (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------
;these call instruction checks only work for new instructions or those that
; dont have a call dependency. As that was the only way they got into the
; block in the first place
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::MarkCallInstructionDependency-ModifiesMemory
         "Creates a series of dependencies for all instructions following a
         call instruction if it turns out that the call could modify memory."
         (Evaluate ?p for dependencies starting at ?si)
         (object (is-a CallInstruction)
                 (id ?name)
                 (parent ?p)
                 (DoesNotAccessMemory FALSE) (OnlyReadsMemory FALSE)
                 (MayWriteToMemory TRUE)
                 (TimeIndex ?t0))
         (object (is-a Instruction)
                 (parent ?p)
                 (TimeIndex ?ti1&:(and (>= ?ti1 ?si) (< ?t0 ?ti1)))
                 (HasCallDependency FALSE) (id ?following))
         =>
         (assert (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?following => ?name))
                 (message (to wavefront-scheduling)
                          (action instruction-produces)
                          (arguments ?name => ?following))
                 (message (to wavefront-scheduling)
                          (action instruction-has-a-call-dependency)
                          (arguments ?following))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::MarkCallInstructionDependency-InlineAsm
         "Creates a series of dependencies for all instructions following a
         call instruction if it turns out that the call is inline asm."
         (Evaluate ?p for dependencies starting at ?si)
         (object (is-a CallInstruction)
                 (id ?name)
                 (parent ?p)
                 (IsInlineAsm TRUE)
                 (TimeIndex ?t0))
         (object (is-a Instruction)
                 (parent ?p)
                 (id ?following)
                 (TimeIndex ?ti1&:(and (>= ?ti1 ?si) (< ?t0 ?ti1)))
                 (HasCallDependency FALSE))
         =>
         (assert (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?following => ?name))
                 (message (to wavefront-scheduling)
                          (action instruction-produces)
                          (arguments ?name => ?following))
                 (message (to wavefront-scheduling)
                          (action instruction-has-a-call-dependency)
                          (arguments ?following))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::MarkCallInstructionDependency-SideEffects
         "Creates a series of dependencies for all instructions following a
         call instruction if it turns out that the call is inline asm."
         (Evaluate ?p for dependencies starting at ?si)
         (object (is-a CallInstruction)
                 (id ?name)
                 (parent ?p)
                 (MayHaveSideEffects TRUE)
                 (MayWriteToMemory TRUE)
                 (TimeIndex ?t0))
         (object (is-a Instruction)
                 (parent ?p)
                 (TimeIndex ?ti1&:(and (>= ?ti1 ?si) (< ?t0 ?ti1)))
                 (HasCallDependency FALSE)
                 (id ?following))
         =>
         (assert (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?following => ?name))
                 (message (to wavefront-scheduling)
                          (action instruction-produces)
                          (arguments ?name => ?following))
                 (message (to wavefront-scheduling)
                          (action instruction-has-a-call-dependency)
                          (arguments ?following))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::MarkNonLocalDependencies
         (Evaluate ?p for dependencies starting at ?si)
         ?inst <- (object (is-a Instruction)
                          (parent ?p)
                          (TimeIndex ?t&:(>= ?t ?si))
                          (NonLocalDependencies $?nld)
                          (Operands $? ?o $?))
         (object (is-a Instruction)
                 (id ?o)
                 (parent ~?p))
         =>
         (modify-instance ?inst (NonLocalDependencies $?nld ?o)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::Wavefront-MarkHasCallDependency
         (declare (salience -2))
         ?fct <- (message (to wavefront-scheduling)
                          (action instruction-has-a-call-dependency)
                          (arguments ?f))

         ?obj <- (object (is-a Instruction)
                         (id ?f))
         =>
         (modify-instance ?obj (HasCallDependency TRUE))
         (retract ?fct))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::InjectConsumers
         "Adds a given consumer to the target instruction"
         (declare (salience -5))
         ?fct <- (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?target => ?id))
         ?inst <- (object (is-a Instruction)
                          (id ?id)
                          (Consumers $?consumers))
         =>
         (retract ?fct)
         (if (not (member$ ?target $?consumers)) then
           (modify-instance ?inst (Consumers $?consumers ?target))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::InjectProducers
         "Adds a given producer to the target instruction"
         (declare (salience -5))
         ?fct <- (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?target => ?id))
         ?inst <- (object (is-a Instruction)
                          (id ?id)
                          (LocalDependencies $?ld)
                          (Producers $?prod))
         =>
         (retract ?fct)
         (modify-instance ?inst
                          (LocalDependencies $?ld
                                             (if (not (member$ ?target $?ld))
                                               then ?target))
                          (Producers $?prod
                                     (if (not (member$ ?target $?prod))
                                       then ?target))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::StoreToLoadDependency
         (Evaluate ?p for dependencies starting at ?si)
         (object (is-a StoreInstruction)
                 (parent ?p)
                 (id ?t0)
                 (TimeIndex ?ti0)
                 (MemoryTarget ?sym0))
         (object (is-a LoadInstruction)
                 (parent ?p)
                 (id ?t1)
                 (TimeIndex ?ti1&:(and (>= ?ti1 ?si) (< ?ti0 ?ti1)))
                 (MemoryTarget ?sym1))
         (test (or (eq ?sym0 ?sym1)
                   (eq ?sym0 UNKNOWN)))
         =>
         (assert (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?t1 => ?t0))
                 (message (to wavefront-scheduling)
                          (action instruction-produces)
                          (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::StoreToStoreDependency
         (Evaluate ?p for dependencies starting at ?si)
         (object (is-a StoreInstruction)
                 (parent ?p)
                 (id ?t0)
                 (TimeIndex ?ti0)
                 (MemoryTarget ?sym0))
         (object (is-a StoreInstruction)
                 (parent ?p)
                 (id ?t1)
                 (TimeIndex ?ti1&:(and (>= ?ti1 ?si) (< ?ti0 ?ti1)))
                 (MemoryTarget ?sym1))
         (test (or (eq ?sym0 ?sym1)
                   (eq ?sym0 UNKNOWN)))
         =>
         (assert (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?t1 => ?t0))
                 (message (to wavefront-scheduling)
                          (action instruction-produces)
                          (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::LoadToStoreDependency
         (Evaluate ?p for dependencies starting at ?si)
         (object (is-a LoadInstruction)
                 (parent ?p)
                 (id ?t0)
                 (TimeIndex ?ti0)
                 (MemoryTarget ?sym0))
         (object (is-a StoreInstruction)
                 (parent ?p)
                 (id ?t1)
                 (TimeIndex ?ti1&:(and (>= ?ti1 ?si) (< ?ti0 ?ti1)))
                 (MemoryTarget ?sym1))
         (test (or (eq ?sym0 ?sym1)
                   (eq ?sym0 UNKNOWN)))
         =>
         (assert (message (to wavefront-scheduling)
                          (action instruction-consumes)
                          (arguments ?t1 => ?t0))
                 (message (to wavefront-scheduling)
                          (action instruction-produces)
                          (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-analysis::FinishedDependencyAnalysis
         (declare (salience -800))
         ?fct <- (Evaluate ?p for dependencies starting at ?v)
         (object (is-a BasicBlock)
                 (id ?p)
                 (parent ?r))
         =>
         (retract ?fct))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-dependency-merge-update::RemoveInstructionsFromProducers
         (declare (salience 768))
         ?fct <- (message (to wavefront-scheduling)
                          (action remove-evidence)
                          (arguments ?tInst => ?inst $?insts))
         ?iObj <- (object (is-a Instruction)
                          (id ?inst)
                          (NonLocalDependencies $?nld)
                          (Producers $?pb ?tInst $?pa)
                          (LocalDependencies $?ldb ?tInst $?lda))
         =>
         (modify ?fct (arguments ?tInst => $?insts))
         (modify-instance ?iObj (Producers $?pb $?pa)
                          (LocalDependencies $?ldb $?lda)
                          (NonLocalDependencies $?nld ?tInst)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge-update::RetractRemoveInstructionsFromProducers
         (declare (salience 768))
         ?fct <- (message (to wavefront-scheduling)
                          (action remove-evidence)
                          (arguments ? =>))
         =>
         (retract ?fct))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge-update::StartRecomputeBlock
         (declare (salience 100))
         ?fct <- (message (to wavefront-scheduling)
                          (action recompute-block)
                          (arguments ?b))
         ?bb <- (object (is-a BasicBlock)
                        (id ?b)
                        (contents $?instructions ?last))
         (object (is-a TerminatorInstruction)
                 (id ?last))
         =>
         (modify-instance ?bb
                          (ReadsFrom)
                          (WritesTo)
                          (HasMemoryBarrier FALSE))
         (modify ?fct
                 (action recompute-block-with-instructions)
                 (arguments ?b => $?instructions)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge-update::RecomputeNonMemoryInstructionForBlock
         (declare (salience 99))
         ?fct <- (message (to wavefront-scheduling)
                          (action recompute-block-with-instructions)
                          (arguments ?b => ?inst $?rest))
         (object (is-a Instruction&~LoadInstruction&~StoreInstruction)
                 (id ?inst)
                 (parent ?b))
         =>
         (modify ?fct (arguments ?b => $?rest)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge-update::RecomputeLoadInstructionForBlock
         (declare (salience 99))
         ?fct <- (message (to wavefront-scheduling)
                          (action recompute-block-with-instructions)
                          (arguments ?b => ?inst $?rest))
         (object (is-a LoadInstruction)
                 (id ?inst)
                 (parent ?b)
                 (MemoryTarget ?mt))
         ?bb <- (object (is-a BasicBlock)
                        (id ?b)
                        (ReadsFrom $?rf))
         =>
         (if (not (member$ ?mt $?rf)) then
           (modify-instance ?bb (ReadsFrom $?rf ?mt)))
         (modify ?fct (arguments ?b => $?rest)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge-update::RecomputeStoreInstructionForBlock
         (declare (salience 99))
         ?fct <- (message (to wavefront-scheduling)
                          (action recompute-block-with-instructions)
                          (arguments ?b => ?inst $?rest))
         (object (is-a StoreInstruction)
                 (id ?inst)
                 (parent ?b)
                 (MemoryTarget ?mt))
         ?bb <- (object (is-a BasicBlock)
                        (id ?b)
                        (WritesTo $?wt))
         =>
         (if (not (member$ ?mt $?wt)) then
           (modify-instance ?bb (WritesTo $?wt ?mt)))
         (modify ?fct (arguments ?b => $?rest)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge-update::FinishRecomputationForBlock
         (declare (salience 98))
         ?fct <- (message (to wavefront-scheduling)
                          (action recompute-block-with-instructions)
                          (arguments ?b =>))
         ?bb <- (object (is-a BasicBlock)
                        (id ?b)
                        (ReadsFrom $?rf)
                        (WritesTo $?wt))
         =>
         (retract ?fct)
         (if (or (member$ UNKNOWN ?rf)
                 (member$ UNKNOWN ?wt)) then
           (modify-instance ?bb (HasMemoryBarrier TRUE))))
;------------------------------------------------------------------------------


Added the initial-fact to the error checking rule in paths-conditional

This made the rule actually fire and I found out that the pather is quite
broken. To this end, I am rewriting the path pass to fix this.

;------------------------------------------------------------------------------
;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; BlockUpdates.clp - Contains rules that add paths that a given block is a part
; of
; Written by Joshua Scoggins (6/7/2012)
;------------------------------------------------------------------------------
(defrule paths-conditional-update::FAIL-UNFINISHED-PATHS
 (message (to paths-conditional-update)
          (action initial-fact))
			(test (> (length$
						  (find-all-instances ((?path Path)) (not ?path:closed))) 0))
			=>
			(printout t "ERROR: Not all paths were closed!" crlf)
			(progn$ (?inst (find-all-instances ((?path Path))
									(not ?path:closed)))
						(send ?inst print))
			(printout t "Current facts!" crlf)
			(facts)
			(printout t "Halting Execution!!!" crlf)
			(halt))

(defrule paths-conditional::AddPathToDiplomat
			"Adds the given path name to the target diplomat"
			(declare (salience 1))
			(object (is-a Path) (closed TRUE) (id ?i) (values $? ?b $?))
			?d <- (object (is-a Diplomat) (id ?b))
			(test (not (member$ ?i (send ?d get-Paths))))
			=>
			(slot-insert$ ?d Paths 1 ?i))

(defrule paths-conditional-update::TraversePathForElementInjection
			(object (is-a Path) (closed TRUE) (id ?p) (values $? ?a ?b $?))
			?o0 <- (object (is-a Diplomat) (id ?a))
			?o1 <- (object (is-a Diplomat) (id ?b))
			=>
			(if (not (member$ ?a (send ?o1 get-PreviousPathElements))) then
			  (slot-insert$ ?o1 PreviousPathElements 1 ?a))
			(if (not (member$ ?b (send ?o0 get-NextPathElements))) then
			  (slot-insert$ ?o0 NextPathElements 1 ?b)))

;------------------------------------------------------------------------------
;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; BlockUpdates.clp - Contains rules that add paths that a given block is a part
; of
; Written by Joshua Scoggins (6/7/2012)
;------------------------------------------------------------------------------
(defrule paths-conditional-update::FAIL-UNFINISHED-PATHS
			(test (> (length$
						  (find-all-instances ((?path Path)) (not ?path:closed))) 0))
			=>
			(printout t "ERROR: Not all paths were closed!" crlf)
			(progn$ (?inst (find-all-instances ((?path Path))
									(not ?path:closed)))
						(send ?inst print))
			(printout t "Current facts!" crlf)
			(facts)
			(printout t "Halting Execution!!!" crlf)
			(halt))

(defrule paths-conditional::AddPathToDiplomat
			"Adds the given path name to the target diplomat"
			(declare (salience 1))
			(object (is-a Path) (closed TRUE) (id ?i) (values $? ?b $?))
			?d <- (object (is-a Diplomat) (id ?b))
			(test (not (member$ ?i (send ?d get-Paths))))
			=>
			(slot-insert$ ?d Paths 1 ?i))

(defrule paths-conditional-update::TraversePathForElementInjection
			(object (is-a Path) (closed TRUE) (id ?p) (values $? ?a ?b $?))
			?o0 <- (object (is-a Diplomat) (id ?a))
			?o1 <- (object (is-a Diplomat) (id ?b))
			=>
			(if (not (member$ ?a (send ?o1 get-PreviousPathElements))) then
			  (slot-insert$ ?o1 PreviousPathElements 1 ?a))
			(if (not (member$ ?b (send ?o0 get-NextPathElements))) then
			  (slot-insert$ ?o0 NextPathElements 1 ?b)))


this is the assignment for knowledge enineering2


Added first$ and rest$ messages to List

Added first$ and rest$ messages to List

;------------------------------------------------------------------------------
;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; List.clp - represents a wrapper over a multifield
;------------------------------------------------------------------------------
(defclass core::List (is-a core::Object)
 (multislot contents (visibility public)))
;------------------------------------------------------------------------------
(defmessage-handler core::List count primary
 "Returns the count of the given list." ()
 (length$ ?self:Contents))
;------------------------------------------------------------------------------
(defmessage-handler core::List add primary
 (?first $?rest)
 (slot-direct-insert$ contents (+ 2 (length$ ?self:contents)) ?first $?rest))
;------------------------------------------------------------------------------
(defmessage-handler core::List add-to-front primary
 (?first $?rest)
 (slot-direct-insert$ contents 1 ?first $?rest))
;------------------------------------------------------------------------------
(defmessage-handler core::List clear primary ()
 (bind ?self:contents (create$)))
;------------------------------------------------------------------------------
(defmessage-handler core::List remove primary
 (?element $?elements)
 (bind ?self:contents (delete-member$ ?self:contents ?element $?elements)))
;------------------------------------------------------------------------------
(defmessage-handler core::List remove-range primary
 (?start ?finish)
 (slot-direct-delete$ contents ?start ?finish))
;------------------------------------------------------------------------------
(defmessage-handler core::List remove-at primary
 (?index)
 (slot-direct-delete$ contents ?index ?index))
;------------------------------------------------------------------------------
(defmessage-handler core::List element-at primary
 (?index)
 (nth$ ?index ?self:Contents))
;------------------------------------------------------------------------------
(defmessage-handler core::List contains primary
 (?item)
 (member$ ?item ?self:Contents))
;------------------------------------------------------------------------------
(defmessage-handler core::List contains-subset primary
 ($?subset)
 (subsetp ?subset ?self:Contents))
;------------------------------------------------------------------------------
(defmessage-handler core::List reverse primary
 "Reverses the order of the values in contents" ()
 (bind ?copy (create$))
 (progn$ (?element ?self:contents)
  (bind ?copy (create$ ?element ?copy)))
 (bind ?self:contents ?copy))
;------------------------------------------------------------------------------
(defmessage-handler core::List implode$ primary
 "Calls implode$ on the contents of this object"
 (implode$ ?self:contents))
;------------------------------------------------------------------------------
(defmessage-handler core::List exists primary
 "Takes in the name of a function and applies the function to each element of
 the list until either the list is completed or a value is found. If TRUE is
 returned then it means that the query was successful and an element was found
 that satsified the given function. If FALSE is returned then none of the
 elements in this list satisfy the given function."
 (?fn)
 (progn$ (?element ?self:contents)
  (if (funcall ?fn ?element) then
	(return TRUE)))
 (return FALSE))
;------------------------------------------------------------------------------
(defmessage-handler core::List apply primary
 "Returns a new multifield with the results of the given function applied to
 each element of this list"
 (?fn)
 (bind ?list (create$))
 (progn$ (?e ?self:contents)
  (bind ?list (create$ ?list (funcall ?fn ?e))))
 (return ?list))
;------------------------------------------------------------------------------
(defmessage-handler core::List first$ primary
 "Returns the first element of this list as a list."
 ()
 (first$ ?self:contents))
;------------------------------------------------------------------------------
(defmessage-handler core::List rest$ primary
 "Returns a list missing the first element of the original list"
 ()
 (rest$ ?self:contents))
;------------------------------------------------------------------------------


Cambio en clases

Cambio en clases

Tenias mal el rango de las horas porque van desde las 8 a las 14 horas

(defclass ASIGNATURA
    (is-a USER)
    (role concrete)

    (slot curso
        (type INTEGER)
        (range 1 4)
        (create-accessor read-write)
    )

    (slot horasRestantes
        (type INTEGER)
        (range 1 4)
        (create-accessor read-write)
    )

    (slot profesor
        (type SYMBOL)
        (create-accessor read-write)
    )

)

(defclass DIA
    (is-a USER)
    (role concrete)

    (multislot clases
        (type INSTANCE)
        (allowed-classes CLASE)
        (create-accessor read-write)
    )
)

(defclass SEMANA
    (is-a USER)
    (role concrete)

    (slot deCurso
        (type INTEGER)
        (range 1 4)
        (create-accessor read-write)
    )

    (multislot dias
        (type INSTANCE)
        (allowed-classes DIA)
        (create-accessor read-write)
    )

    (slot diasUsados
        (type INTEGER)
        (range 1 5 DEFAULT 0)
        (create-accessor read-write)
    )
)

(defclass CLASE
    (is-a USER)
    (role concrete)

    (slot deAsignatura
        (type INSTANCE)
        (allowed-instances ASIGNATURA)
    )

    (slot diaSemana
        (type SYMBOL)
        (allowed-values LUNES MARTES MIERCOLES JUEVES VIERNES)
        (create-accessor read-write)
    )

    (slot horaInicio
        (type INTEGER)
        (range 8 14)
    )

    (slot horaFin
        (type INTEGER)
        (range 8 14)
    )
)

(defclass ASIGNATURA
    (is-a USER)
    (role concrete)

    (slot curso
        (type INTEGER)
        (range 1 4)
        (create-accessor read-write)
    )

    (slot horasRestantes
        (type INTEGER)
        (range 1 4)
        (create-accessor read-write)
    )

    (slot profesor
        (type SYMBOL)
        (create-accessor read-write)
    )

)

(defclass DIA
    (is-a USER)
    (role concrete)

    (multislot clases
        (type INSTANCE)
        (allowed-classes CLASE)
        (create-accessor read-write)
    )
)

(defclass SEMANA
    (is-a USER)
    (role concrete)

    (slot deCurso
        (type INTEGER)
        (range 1 4)
        (create-accessor read-write)
    )

    (multislot dias
        (type INSTANCE)
        (allowed-classes DIA)
        (create-accessor read-write)
    )

    (slot diasUsados
        (type INTEGER)
        (range 1 5 DEFAULT 0)
        (create-accessor read-write)
    )
)

(defclass CLASE
    (is-a USER)
    (role concrete)

    (slot deAsignatura
        (type INSTANCE)
        (allowed-instances ASIGNATURA)
    )

    (slot diaSemana
        (type SYMBOL)
        (allowed-values LUNES MARTES MIERCOLES JUEVES VIERNES)
        (create-accessor read-write)
    )

    (slot horaInicio
        (type INTEGER)
        (range 8 12)
    )

    (slot horaFin
        (type INTEGER)
        (range 8 12)
    )
)


Create task3.clp

Create task3.clp

(deffunction str-del (?substr ?str)
    (bind ?n1 (str-length ?substr))
    (bind ?n2 (str-length ?str))
    (bind ?k (str-index ?substr ?str))
    (while (> ?k 0) do
        (bind ?st1 (sub-string 1 (- ?k 1) ?str))
        (bind ?st2 (sub-string (+ ?k ?n1) ?n2 ?str))
        (bind ?str (str-cat ?st1 ?st2))
        (bind ?k (str-index ?substr ?str))
        (if (not ?k) then
            (bind ?k 0)
        )
    )
    ?str)

error: pathspec 'ssu-ai-level-2/chapter7/task3.clp' did not match any file(s) known to git


Create task6.clp

Create task6.clp

(deffunction summ-iter (?n)
  (if (= ?n 1) then (return 1))
  (+ (/ 1 ?n) (summ-iter (- ?n 1)))
)

error: pathspec 'ssu-ai-level-2/chapter6/task6.clp' did not match any file(s) known to git