Fixed a bug in LoopRegionMerging.clp

Fixed a bug in LoopRegionMerging.clp

I found that I was not retracting finished facts correctly because the match
was looking for the word 'for' instead of '=>'. I also reformatted the code to
be far cleaner and took advantage of modify and delete where appropriate.

;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.
;------------------------------------------------------------------------------
; LoopRegionMerging.clp - Contains rules that merge loops and regions together
; Written by Joshua Scoggins (6/26/2012)
;
; Major Rewrite started on 10/22/2012 to reflect changes made to
; LibExpertSystem
;------------------------------------------------------------------------------
; The first thing to understand is that LibExpertSystem will no longer be
; lifting a finger to assist us in merging loops and regions. I did a thought
; experiment and I realized that it will be easier this way to ensure proper
; merging and (by proxy) ordering.
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-build::ConstructFlatListForRegion
         "Creates a flat representation of the contents of the given region"
         (object (is-a Region)
                 (id ?id)
                 (contents $?z))
         (not (exists (object (is-a FlatList)
                              (parent ?id))))
         =>
         (make-instance of FlatList (parent ?id))
         (assert (message (to loop-region-merging)
                          (action populate-flatlist)
                          (arguments ?id => $?z))))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-build::PopulateFlatList-BasicBlock
         ?f <- (message (to loop-region-merging)
                        (action populate-flatlist)
                        (arguments ?id => ?first $?rest))
         ?o <- (object (is-a FlatList)
                       (parent ?id))
         (object (is-a BasicBlock)
                 (id ?first))
         =>
         (slot-insert$ ?o values 1 ?first)
         (modify ?f (arguments ?id => $?rest)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-build::PopulateFlatList-Region
         ?f <- (message (to loop-region-merging)
                        (action populate-flatlist)
                        (arguments ?id => ?first $?rest))
         ?o <- (object (is-a FlatList)
                       (parent ?id))
         (object (is-a Region)
                 (id ?first))
         (object (is-a FlatList)
                 (parent ?first)
                 (id ?name))
         =>
         ;Add the reference to FlatList for the time being until we have
         ;finished constructing an entire flat list
         (slot-insert$ ?o values 1 ?name)
         (modify ?f (arguments ?id => $?rest)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-build::RetractFlatListConstruction
         ?f <- (message (to loop-region-merging)
                        (action populate-flatlist)
                        (arguments ?id =>))
         =>
         (retract ?f))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-expand::ExpandFlatListEntry
         "Takes a flat list and expands one of the elements of the contents if
         it turns out that element is another flat list"
         ?id <- (object (is-a FlatList)
                        (values $?a ?b $?c))
         (object (is-a FlatList)
                 (id ?b)
                 (values $?j))
         =>
         (modify-instance ?id (values $?a $?j $?c)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-claim::ClaimOwnership
         "Asserts that a region owns another through a subset check. The first
         flat list is checked to see if it is a _proper_ subset of the second"
         ?f0 <- (object (is-a FlatList)
                        (id ?i0)
                        (values $?c0)
                        (parent ?p0))
         ?f1 <- (object (is-a FlatList)
                        (id ?i1&~?i0)
                        (values $?c1)
                        (parent ?p1))
         (test (and (subsetp ?c0 ?c1)
                    (> (length$ ?c1)
                       (length$ ?c0))))
         =>
         (assert (message (to loop-region-merging)
                          (action claim-owns)
                          (arguments ?p1 => ?p0))))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-claim::ClaimOwnershipOfBlocks
         "This rule is used to assert ownership claims on basic blocks"
         ?f0 <- (object (is-a FlatList)
                        (parent ?p)
                        (values $? ?b $?))
         (object (is-a BasicBlock)
                 (id ?b))
         =>
         (assert (message (to loop-region-merging)
                          (action claim-owns)
                          (arguments ?p => ?b))))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-claim::ClaimEquivalence
         "Asserts that two regions are equivalent if one flat list contains the
         same elements as a second one."
         ?f0 <- (object (is-a FlatList)
                        (id ?i0)
                        (values $?c0)
                        (parent ?p0))
         ?f1 <- (object (is-a FlatList)
                        (id ?i1&~?i0)
                        (values $?c1)
                        (parent ?p1))
         (test (and (subsetp ?c0 ?c1)
                    (= (length$ ?c1)
                       (length$ ?c0))))
         =>
         (assert (message (to loop-region-merging)
                          (action claim-equivalent)
                          (arguments ?p1 => ?p0))))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-claim::MergeClaimsOfEquivalence
         "It is possible for two facts of equivalence to actually be the same
         fact"
         (declare (salience -1))
         ?f0 <- (message (to loop-region-merging)
                         (action claim-equivalent)
                         (arguments ?a => ?b))
         ?f1 <- (message (to loop-region-merging)
                         (action claim-equivalent)
                         (arguments ?b => ?a))
         =>
         (retract ?f1)
         (modify ?f0 (arguments ?a => ?b)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-arbitrate::EliminateEquivalences-LoopFirst
         "If we find an equivalence then it means that a loop and a region
         contain the same elements. Therefore the loop persists and the region
         dies. The loop is the first entry."
         (declare (salience 1))
         ?f0 <- (message (to loop-region-merging)
                         (action claim-equivalent)
                         (arguments ?a => ?b))
         (object (is-a Loop)
                 (id ?a))
         (object (is-a Region&~Loop)
                 (id ?b))
         =>
         (duplicate ?f0 (action delete-region)
                    (arguments ?b))
         (modify ?f0 (action replace)
                 (arguments ?b => ?a)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-arbitrate::EliminateEquivalences-LoopSecond
         "If we find an equivalence then it means that a loop and a region
         contain the same elements. Therefore the loop persists and the region
         dies. The loop is the second entry."
         (declare (salience 1))
         ?f0 <- (message (to loop-region-merging)
                         (action claim-equivalent)
                         (arguments ?b => ?a))
         (object (is-a Loop)
                 (id ?a))
         (object (is-a Region&~Loop)
                 (id ?b))
         =>
         (duplicate ?f0 (action delete-region)
                    (arguments ?b))
         (modify ?f0 (action replace)))
;------------------------------------------------------------------------------
; Now that we have asserted delete and replacement claims it's necessary to
; carry those claims out. First, we need to do the replacement actions
; We need to apply these changes to the flat lists associated with these
; objects to ensure that we do the proper replacement thing.
; What we do is we use those replacement facts to retract the ownership claims
;
; Then we go through and perform partial replacement on the flat lists
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-resolve::RemoveStaleClaims-DeletionTargetClaimsAnother
         "We target claims of ownership that deal with a given region that has
         to be replaced by another due to equivalence"
         (declare (salience 1))
         ?f0 <- (message (to loop-region-merging)
                         (action replace)
                         (arguments ?old => ?new))
         ?f1 <- (message (to loop-region-merging)
                         (action claim-owns)
                         (arguments ?old => ?other))
         =>
         (modify ?f0)
         (modify ?f1 (arguments ?new => ?other)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-resolve::RemoveStaleClaims-AnotherClaimsDeletionTarget
         (declare (salience 1))
         ?f0 <- (message (to loop-region-merging)
                         (action replace)
                         (arguments ?old => ?new))
         ?f1 <- (message (to loop-region-merging)
                         (action claim-owns)
                         (arguments ?other => ?old))
         =>
         (modify ?f0)
         (modify ?f1 (arguments ?other => ?new)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-resolve::RemoveStaleClaims-NoMoreConvergence
         "Retract replacement facts because there are no more claims to worry
         about"
         ?f0 <- (message (to loop-region-merging)
                         (action replace)
                         (arguments ? => ?))
         =>
         (retract ?f0))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-resolve::DeleteTargetRegion
         "Deletes the target region slated for deletion"
         ?f0 <- (message (to loop-region-merging)
                         (action delete-region)
                         (arguments ?r0))
         ?region <- (object (is-a Region)
                            (id ?r0))
         =>
         (retract ?f0)
         (unmake-instance ?region))
;------------------------------------------------------------------------------
(defrule loop-region-merging-cleanup-merger::initiate-deletion
         "Retracts the initial fact for this module and asserts local facts for
         deleting flat lists and ownership determinants"
         ?f <- (message (from pipeline)
                        (to loop-region-merging-cleanup-merger)
                        (action initial-fact))
         =>
         (retract ?f)
         (assert (delete ownership-determinants)
                 (delete flat-lists)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-cleanup-merger::DeleteFlatLists
         "Deletes all of the flat lists in a single rule fire"
         ?f0 <- (delete flat-lists)
         =>
         (retract ?f0)
         (progn$ (?fl (find-all-instances ((?list FlatList)) TRUE))
                 (unmake-instance ?fl)))
;------------------------------------------------------------------------------

;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.
;------------------------------------------------------------------------------
; LoopRegionMerging.clp - Contains rules that merge loops and regions together
; Written by Joshua Scoggins (6/26/2012)
;
; Major Rewrite started on 10/22/2012 to reflect changes made to
; LibExpertSystem
;------------------------------------------------------------------------------
; The first thing to understand is that LibExpertSystem will no longer be
; lifting a finger to assist us in merging loops and regions. I did a thought
; experiment and I realized that it will be easier this way to ensure proper
; merging and (by proxy) ordering.
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-build::ConstructFlatListForRegion
			"Creates a flat representation of the contents of the given region"
			(object (is-a Region) (id ?id) (contents $?z))
			(not (exists (object (is-a FlatList) (parent ?id))))
			=>
			(make-instance of FlatList (parent ?id))
			(assert (Populate FlatList of ?id with $?z)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-build::PopulateFlatList-BasicBlock
			?f <- (Populate FlatList of ?id with ?first $?rest)
			?o <- (object (is-a FlatList) (parent ?id))
			(object (is-a BasicBlock) (id ?first))
			=>
			(slot-insert$ ?o values 1 ?first)
			(retract ?f)
			(assert (Populate FlatList of ?id with $?rest)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-build::PopulateFlatList-Region
			?f <- (Populate FlatList of ?id with ?first $?rest)
			?o <- (object (is-a FlatList) (parent ?id))
			(object (is-a Region) (id ?first))
			(object (is-a FlatList) (parent ?first) (id ?name))
			=>
			;Add the reference to FlatList for the time being until we have
			;finished constructing an entire flat list
			(slot-insert$ ?o values 1 ?name)
			(retract ?f)
			(assert (Populate FlatList of ?id with $?rest)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-build::RetractFlatListConstruction
			?f <- (Populate FlatList of ? with)
			=>
			(retract ?f))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-expand::ExpandFlatListEntry
			"Takes a flat list and expands one of the elements of the contents if
			it turns out that element is another flat list"
			?id <- (object (is-a FlatList) (values $?a ?b $?c))
			(object (is-a FlatList) (id ?b) (values $?j))
			=>
			(modify-instance ?id (values $?a $?j $?c)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-claim::ClaimOwnership
			"Asserts that a region owns another through a subset check. The first
			flat list is checked to see if it is a _proper_ subset of the second"
			?f0 <- (object (is-a FlatList) (id ?i0) (values $?c0) (parent ?p0))
			?f1 <- (object (is-a FlatList) (id ?i1&~?i0) (values $?c1)
								(parent ?p1))
			(test (and (subsetp ?c0 ?c1) (> (length$ ?c1) (length$ ?c0))))
			=>
			(assert (message (to loop-region-merging)
								  (action claim-owns)
								  (arguments ?p1 => ?p0))))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-claim::ClaimOwnershipOfBlocks
			"This rule is used to assert ownership claims on basic blocks"
			?f0 <- (object (is-a FlatList) (parent ?p) (values $? ?b $?))
			(object (is-a BasicBlock) (id ?b))
			=>
			(assert (message (to loop-region-merging)
								  (action claim-owns)
								  (arguments ?p => ?b))))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-claim::ClaimEquivalence
			"Asserts that two regions are equivalent if one flat list contains the
			same elements as a second one."
			?f0 <- (object (is-a FlatList) (id ?i0) (values $?c0) (parent ?p0))
			?f1 <- (object (is-a FlatList) (id ?i1&~?i0) (values $?c1)
								(parent ?p1))
			(test (and (subsetp ?c0 ?c1) (= (length$ ?c1) (length$ ?c0))))
			=>
			(assert (message (to loop-region-merging)
								  (action claim-equivalent)
								  (arguments ?p1 => ?p0))))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-claim::MergeClaimsOfEquivalence
			"It is possible for two facts of equivalence to actually be the same
			fact"
			(declare (salience -1))
			?f0 <- (message (to loop-region-merging)
								 (action claim-equivalent)
								 (arguments ?a => ?b))
			?f1 <- (message (to loop-region-merging)
								 (action claim-equivalent)
								 (arguments ?b => ?a))
			=>
			(retract ?f0 ?f1)
			(assert (message (to loop-region-merging)
								  (action claim-equivalent)
								  (arguments ?a => ?b))))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-arbitrate::EliminateEquivalences-LoopFirst
			"If we find an equivalence then it means that a loop and a region
			contain the same elements. Therefore the loop persists and the region
			dies. The loop is the first entry."
			(declare (salience 1))
			?f0 <- (message (to loop-region-merging)
								 (action claim-equivalent)
								 (arguments ?a => ?b))
			(object (is-a Loop) (id ?a))
			(object (is-a Region&~Loop) (id ?b))
			=>
			(retract ?f0)
			(assert (message (to loop-region-merging)
								  (action delete-region)
								  (arguments ?b))
					  (message (to loop-region-merging)
								  (action replace)
								  (arguments ?b => ?a))))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-arbitrate::EliminateEquivalences-LoopSecond
			"If we find an equivalence then it means that a loop and a region
			contain the same elements. Therefore the loop persists and the region
			dies. The loop is the second entry."
			(declare (salience 1))
			?f0 <- (message (to loop-region-merging)
				(action claim-equivalent)
				(arguments ?b => ?a))
			(object (is-a Loop) (id ?a))
			(object (is-a Region&~Loop) (id ?b))
			=>
			(retract ?f0)
			(assert (message (to loop-region-merging)
								  (action delete-region)
								  (arguments ?b))
					  (message (to loop-region-merging)
								  (action replace)
								  (arguments ?b => ?a))))
;------------------------------------------------------------------------------
; Now that we have asserted delete and replacement claims it's necessary to
; carry those claims out. First, we need to do the replacement actions
; We need to apply these changes to the flat lists associated with these
; objects to ensure that we do the proper replacement thing.
; What we do is we use those replacement facts to retract the ownership claims
;
; Then we go through and perform partial replacement on the flat lists
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-resolve::RemoveStaleClaims-DeletionTargetClaimsAnother
			"We target claims of ownership that deal with a given region that has
			to be replaced by another due to equivalence"
			(declare (salience 1))
			?f0 <- (message (to loop-region-merging)
				(action replace)
				(arguments ?old => ?new))
			?f1 <- (message (to loop-region-merging)
				(action claim-owns)
				(arguments ?old => ?other))
			=>
			(retract ?f0 ?f1)
			(assert (message (to loop-region-merging)
						        (action claim-owns)
								  (arguments ?new => ?other))
			        (message (to loop-region-merging)
						        (action replace)
								  (arguments ?old => ?new))))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-resolve::RemoveStaleClaims-AnotherClaimsDeletionTarget
			(declare (salience 1))
			?f0 <- (message (to loop-region-merging)
				             (action replace)
								 (arguments ?old => ?new))
			?f1 <- (message (to loop-region-merging)
				             (action claim-owns)
								 (arguments ?other => ?old))
			=>
			(retract ?f0 ?f1)
			(assert (message (to loop-region-merging)
						        (action claim-owns)
								  (arguments ?other => ?new))
			        (message (to loop-region-merging)
						        (action replace)
								  (arguments ?old => ?new))))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-resolve::RemoveStaleClaims-NoMoreConvergence
			"Retract replacement facts because there are no more claims to worry
			about"
			?f0 <- (message (to loop-region-merging)
				  (action replace)
				  (arguments ?old with ?new))
			=>
			(retract ?f0))
;------------------------------------------------------------------------------
(defrule loop-region-merging-flatlist-resolve::DeleteTargetRegion
			"Deletes the target region slated for deletion"
			?f0 <- (message (to loop-region-merging)
				             (action delete-region)
								 (arguments ?r0))
			?region <- (object (is-a Region) (id ?r0))
			=>
			(retract ?f0)
			(unmake-instance ?region))
;------------------------------------------------------------------------------
(defrule loop-region-merging-cleanup-merger::initiate-deletion
 "Retracts the initial fact for this module and asserts local facts for
 deleting flat lists and ownership determinants"
	?f <- (message (from pipeline)
		            (to loop-region-merging-cleanup-merger)
						(action initial-fact))
	=>
	(retract ?f)
	(assert (delete ownership-determinants)
	        (delete flat-lists)))
;------------------------------------------------------------------------------
(defrule loop-region-merging-cleanup-merger::DeleteFlatLists
			"Deletes all of the flat lists in a single rule fire"
			?f0 <- (delete flat-lists)
			=>
			(retract ?f0)
			(progn$ (?fl (find-all-instances ((?list FlatList)) TRUE))
					  (unmake-instance ?fl)))
;------------------------------------------------------------------------------


Fixed a bug in merge-three-line-headers

Fixed a bug in merge-three-line-headers

I had put UNKNONW instead of UNKNOWN for one of the templates to match

;------------------------------------------------------------------------------
;Copyright (c) 2013, 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.
;------------------------------------------------------------------------------
; GLConstantConversion.clp - an expert system that reads a define and generates
; conversion code for it.
;------------------------------------------------------------------------------
(defclass opened-file
  (is-a USER)
  (slot id)
  (slot index (type INTEGER) (range 0 ?VARIABLE))
  (message-handler next-index)
  (message-handler read-line)
  (message-handler close-file))
;------------------------------------------------------------------------------
(defmessage-handler opened-file next-index ()
                    (bind ?old ?self:index)
                    (bind ?self:index (+ ?old 1))
                    (return ?old))
;------------------------------------------------------------------------------
(defmessage-handler opened-file read-line ()
                    (readline ?self:id))
;------------------------------------------------------------------------------
(defmessage-handler opened-file close-file ()
                    (close ?self:id))
;------------------------------------------------------------------------------
(deftemplate file-line
             (slot index)
             (slot parent)
             (slot type)
             (multifield contents))
;------------------------------------------------------------------------------
; INPUT FACT FORM: (parse constant file ?path)
;------------------------------------------------------------------------------
(deffunction get-input-form-factor ()
             (printout t "(parse constant file ?path)" crlf))
;------------------------------------------------------------------------------
(defrule open-target-file
         "This rule takes a fact of the above INPUT FORM and attempts to open the file"
         ?fct <- (parse constant file ?path)
         =>
         (bind ?name (gensym*))
         (retract ?fct)
         (if (open ?path ?name "r") then
           (make-instance of opened-file (id ?name) (index 0))
           (assert (read file ?name))
           else
           (printout t "ERROR: target file at " ?path " does not exist!" crlf
                     "Halting!" crlf)
           (halt)))
;------------------------------------------------------------------------------
(defrule build-file-line
         ?fct <- (read file ?fid)
         ?obj <- (object (is-a opened-file)
                         (id ?fid))
         =>
         (retract ?fct)
         (bind ?result (send ?obj read-line))
         (if (neq ?result EOF) then
           (assert (read file ?fid)
                   (file-line (index (send ?obj next-index))
                              (type UNKNOWN)
                              (parent ?fid)
                              (contents (explode$ ?result))))
           else
           (send ?obj close-file)
           (unmake-instance ?obj)))
;------------------------------------------------------------------------------
;(defrule retract-unknowns
; (declare (salience -10))
; ?f <- (file-line (type UNKNOWN))
; =>
; (retract ?f))
;------------------------------------------------------------------------------
(defrule mark-heading-groups
         "Tags lines that consist of /* $? */ as group headings"
         ?f <- (file-line (type UNKNOWN)
                          (contents /* $? */))
         =>
         (modify ?f (type heading)))
;------------------------------------------------------------------------------
(defrule mark-entry-line
         "Tags lines that are defines and modifies the associated contents"
         ?f <- (file-line (type UNKNOWN)
                          (contents #define ?name ?))
         =>
         (modify ?f (type #define) (contents ?name)))
;------------------------------------------------------------------------------
(defrule merge-three-line-headers
         "Merges simple three line headings into one rule"
         ?f0 <- (file-line (index ?i)
                           (type UNKNOWN)
                           (contents /*))
         ?f1 <- (file-line (index ?i2&:(= ?i2 (+ ?i 1)))
                           (type UNKNOWN)
                           (contents $?c))
         ?f2 <- (file-line (index ?i3&:(= ?i3 (+ ?i 2)))
                           (type UNKNOWN)
                           (contents */))
         =>
         (retract ?f1 ?f2)
         (modify ?f0 (contents /* $?contents */)))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;Copyright (c) 2013, 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.
;------------------------------------------------------------------------------
; GLConstantConversion.clp - an expert system that reads a define and generates
; conversion code for it.
;------------------------------------------------------------------------------
(defclass opened-file
 (is-a USER)
 (slot id)
 (slot index (type INTEGER) (range 0 ?VARIABLE))
 (message-handler next-index)
 (message-handler read-line)
 (message-handler close-file))
;------------------------------------------------------------------------------
(defmessage-handler opened-file next-index ()
 (bind ?old ?self:index)
 (bind ?self:index (+ ?old 1))
 (return ?old))
;------------------------------------------------------------------------------
(defmessage-handler opened-file read-line ()
 (readline ?self:id))
;------------------------------------------------------------------------------
(defmessage-handler opened-file close-file ()
 (close ?self:id))
;------------------------------------------------------------------------------
(deftemplate file-line
 (slot index)
 (slot parent)
 (slot type)
 (multifield contents))
;------------------------------------------------------------------------------
; INPUT FACT FORM: (parse constant file ?path)
;------------------------------------------------------------------------------
(deffunction get-input-form-factor ()
 (printout t "(parse constant file ?path)" crlf))
;------------------------------------------------------------------------------
(defrule open-target-file
 "This rule takes a fact of the above INPUT FORM and attempts to open the file"
 ?fct <- (parse constant file ?path)
 =>
 (bind ?name (gensym*))
 (retract ?fct)
 (if (open ?path ?name "r") then
  (make-instance of opened-file (id ?name) (index 0))
  (assert (read file ?name))
 else
 (printout t "ERROR: target file at " ?path " does not exist!" crlf
  "Halting!" crlf)
 (halt)))
;------------------------------------------------------------------------------
(defrule build-file-line
 ?fct <- (read file ?fid)
 ?obj <- (object (is-a opened-file)
                 (id ?fid))
 =>
 (retract ?fct)
 (bind ?result (send ?obj read-line))
 (if (neq ?result EOF) then
  (assert (read file ?fid)
          (file-line (index (send ?obj next-index))
           (type UNKNOWN)
           (parent ?fid)
           (contents (explode$ ?result))))
  else
  (send ?obj close-file)
  (unmake-instance ?obj)))
;------------------------------------------------------------------------------
(defrule retract-unknowns
 (declare (salience -10))
 ?f <- (file-line (type UNKNOWN))
 =>
 (retract ?f))
;------------------------------------------------------------------------------
(defrule mark-heading-groups
 "Tags lines that consist of /* $? */ as group headings"
 ?f <- (file-line (contents /* $? */) (type UNKNOWN))
 =>
 (modify ?f (type heading)))
;------------------------------------------------------------------------------
(defrule mark-entry-line
 "Tags lines that are defines and modifies the associated contents"
 ?f <- (file-line (contents #define ?name ?) (type UNKNOWN))
 =>
 (modify ?f (type #define) (contents ?name)))
;------------------------------------------------------------------------------


Cambiar las reglas y las funciones.

Cambiar las reglas y las funciones.

Hemos quitado las reglas de avanzar lo días para poner una función que
lo hace automáticamente. También hemos añadido una función para avanzar
el los cursos.

(defrule asignar
    (cursoActual ?cursoActual)
    ?as<-(asignatura
		(nombre ?nombre)
		(horasSemanales ?horasSemanales)
		(horasRestantes ?horasRestantes)
		(profesor ?profe)
		(curso ?cursoActual)
	)
	(test (> ?horasRestantes 0))
    (diaActual ?dia)
	?h<- (horaActual ?horaInicio)
	(test (< ?horaInicio 14))

	(not (exists (clase (curso ?) (nombre ?) (diaSemana ?dia) (profe ?profe) (horaInicio ?horaInicio) (horaFin ?))))

	=>

    (assert
        (clase
            (curso ?cursoActual)
            (nombre ?nombre)
            (diaSemana ?dia)
            (profe ?profe)
            (horaInicio ?horaInicio)
            (horaFin (+ ?horaInicio 1))
        )
    )
	(retract ?h)
	(assert (horaActual (+ ?horaInicio 1)))
	(modify ?as (horasRestantes (- ?horasRestantes 1)))

)

(deffunction avanzardia (?dia)
	(bind ?var ?dia)
	(switch ?var
	(case LUNES then (bind ?var MARTES))
	(case MARTES then (bind ?var MIERCOLES))
	(case MIERCOLES then (bind ?var JUEVES))
	(case JUEVES then (bind ?var VIERNES))
	(case VIERNES then (bind ?var LUNES)))
)

(deffunction avanzarannio (?dia)
	(bind ?var ?dia)
	(switch ?var
	(case LUNES then (bind ?var 0))
	(case MARTES then (bind ?var 0))
	(case MIERCOLES then (bind ?var 0))
	(case JUEVES then (bind ?var 0))
	(case VIERNES then (bind ?var 1)))
)

(defrule avanzar
	?d<-(diaActual ?dia)
	?h <-(horaActual 14)
	?c<-(cursoActual ?cursoActual)
	=>
	(retract ?d)
	(retract ?h)
	(retract ?c)
	(assert (cursoActual (+ ?cursoActual (avanzarannio ?dia))))
	(assert (diaActual (avanzardia ?dia)))
	(assert (horaActual 8))
)

(defrule asignar
    (cursoActual ?cursoActual)
    ?as<-(asignatura
		(nombre ?nombre)
		(horasSemanales ?horasSemanales)
		(horasRestantes ?horasRestantes)
		(profesor ?profe)
		(curso ?cursoActual)
	)
	(test (> ?horasRestantes 0))
    (diaActual ?dia)
	?h<- (horaActual ?horaInicio)
	(test (< ?horaInicio 14))

	(not (exists (clase (curso ?) (nombre ?) (diaSemana ?dia) (profe ?profe) (horaInicio ?horaInicio) (horaFin ?))))

	=>

    (assert
        (clase
            (curso ?cursoActual)
            (nombre ?nombre)
            (diaSemana ?dia)
            (profe ?profe)
            (horaInicio ?horaInicio)
            (horaFin (+ ?horaInicio 1))
        )
    )
	(retract ?h)
	(assert (horaActual (+ ?horaInicio 1)))
	(modify ?as (horasRestantes (- ?horasRestantes 1)))

)

(defrule avanzarDeLunesAMartes
	?d<-(diaActual LUNES)
	?h <-(horaActual 14)
	=>
	(retract ?d)
	(retract ?h)
	(assert (diaActual MARTES))
	(assert (horaActual 8))
)

(defrule avanzarDeMartesAMiercoles
	?d<-(diaActual MARTES)
	?h <-(horaActual 14)
	=>
	(retract ?d)
	(retract ?h)
	(assert (diaActual MIERCOLES))
	(assert (horaActual 8))
)

(defrule avanzarDeMiercolesAJueves
	?d<-(diaActual MIERCOLES)
	?h <-(horaActual 14)
	=>
	(retract ?d)
	(retract ?h)
	(assert (diaActual JUEVES))
	(assert (horaActual 8))
)

(defrule avanzarDeJuevesAViernes
	?d<-(diaActual JUEVES)
	?h <-(horaActual 14)
	=>
	(retract ?d)
	(retract ?h)
	(assert (diaActual VIERNES))
	(assert (horaActual 8))
)

(defrule avanzarDeViernesALunes
	?d<-(diaActual VIERNES)
	?h <-(horaActual 14)
	?c<-(cursoActual ?cursoActual)
	=>
	(retract ?d)
	(retract ?h)
	(retract ?c)
	(assert (diaActual LUNES))
	(assert (cursoActual (+ 1 ?cursoActual)))
	(assert (horaActual 8))
)

(defrule forzar-avanzar-de-curso
	?c<-(cursoActual ?cursoActual)
	?d<-(diaActual ?)
	?h <-(horaActual ?)
	(asignatura
		(nombre ?)
		(horasSemanales ?)
		(horasRestantes 0)
		(profesor ?)
		(curso ?cursoActual))
	=>
	(retract ?c)
	(assert (diaActual LUNES))
	(assert (cursoActual (+ 1 ?cursoActual)))
	(assert (horaActual 8))
)


Add task2 for chapter4

Add task2 for chapter4

(deffacts tovars
    (tovar TV 200 4 2015 Russia)
    (tovar Watch 199 5 2017 USA)
    (tovar Linkorn 1000 1 2010 Russia)
    (tovar IceCream 10 99 2017 Ukraine)
    (tovar Book 1 1 2001 Vanuatu)
)

(defrule ucenk
    (tovar ?name ?cost ?count ?year ?country)

    (test (or (?year < 2010)
              (?count < 4)
          )
    )
     =>
     (assert (ucenka ?name (* ?cost 0.15)))
)

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


Changed the paths in Header.clp

Changed the paths in Header.clp

; Header.clp Describes the header for the engine module
; See LICENSE for license details
; Written by Joshua Scoggins

(defmodule engine (export ?ALL))

(load* "src/clips/modules/engine/Object.clp")
(load* "src/clips/modules/engine/Screen.clp")
(load* "src/clips/modules/engine/Entity.clp")
(load* "src/clips/modules/engine/Resource.clp")
(load* "src/clips/modules/engine/ResourceEntry.clp")
(load* "src/clips/modules/engine/MusicResource.clp")
(load* "src/clips/modules/engine/SoundResource.clp")

; Header.clp Describes the header for the engine module
; See LICENSE for license details
; Written by Joshua Scoggins

(defmodule engine (export ?ALL))

(load* "src/engine/Object.clp")
(load* "src/engine/Screen.clp")
(load* "src/engine/Entity.clp")
(load* "src/engine/Resource.clp")
(load* "src/engine/ResourceEntry.clp")
(load* "src/engine/MusicResource.clp")
(load* "src/engine/SoundResource.clp")