Modified the type fields in assert-build-groups and build-grouping

I reverted the type field in assert-build-groups back to ~UNKNOWN and added
(type #define) to build-grouping instead. This change makes it possible to
clean out the GLAPI-DEF instances along with the other objects

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; INPUT FACT FORM: (parse constant file ?path)
;------------------------------------------------------------------------------
(deffunction types::get-input-form-factor ()
             (printout t "(parse constant file ?path)" crlf))
;------------------------------------------------------------------------------
(defrule MAIN::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
                          (file-id ?name)
                          (index 0))
           (assert (message (to identify-lines)
                            (action read-file)
                            (arguments ?name)))
           (focus read-input
                  modify-input
                  identify-lines
                  convert-templates
                  build-groups
                  grouping-update)
           else
           (printout t "ERROR: target file at " ?path " does not exist!" crlf
                     "Halting!" crlf)
           (halt)))
;------------------------------------------------------------------------------
(defrule read-input::build-file-line
         ?fct <- (message (to identify-lines)
                          (action read-file)
                          (arguments ?name))
         ?obj <- (object (is-a opened-file)
                         (file-id ?fid))
         =>
         (retract ?fct)
         (bind ?result (send ?obj read-line))
         (if (neq ?result EOF) then
           (duplicate ?fct)
           (if (neq ?result "") then
             (make-instance of file-line (index (send ?obj next-index))
                            (type UNKNOWN)
                            (parent ?fid)
                            (contents (explode$ ?result))))
           else
           (send ?obj close-file)
           (unmake-instance ?obj)))
;------------------------------------------------------------------------------
(deffunction modify-input::blank-on-empty-string (?str)
             (if (> (str-length ?str) 0) then ?str else (create$)))
;------------------------------------------------------------------------------
(deffunction modify-input::break-apart (?sp ?i)
             (bind ?str (if (stringp ?i) then ?i else (str-cat ?i)))
             (bind ?ind (str-index ?sp ?str))
             (bind ?p0 (sub-string 1 (- ?ind 1) ?str))
             (bind ?p1 (sub-string (+ ?ind 1) (str-length ?str) ?str))
             (create$ (blank-on-empty-string ?p0) ?sp
                      (blank-on-empty-string ?p1)))
;------------------------------------------------------------------------------
(deffunction modify-input::input-is-not-split-symbol (?sp ?input)
             (bind ?str (str-cat ?input))
             (and (neq 0 (str-compare ?str ?sp))
                  (str-index ?sp ?str)))
;------------------------------------------------------------------------------
(defrule modify-input::identify-symbols-with-commas
         ?fct <- (object (is-a file-line)
                         (contents $?before ?symbol $?after))
         (test (input-is-not-split-symbol "," ?symbol))
         =>
         (modify-instance ?fct (contents $?before (break-apart "," ?symbol)
                                         $?after)))
;------------------------------------------------------------------------------
(defrule modify-input::identify-symbols-with-open-parens
         ?fct <- (object (is-a file-line)
                         (contents $?b ?s $?a))
         (test (input-is-not-split-symbol "(" ?s))
         =>
         (modify-instance ?fct (contents $?b (break-apart "(" ?s) $?a)))
;------------------------------------------------------------------------------
(defrule modify-input::identify-symbols-with-close-parens
         ?fct <- (object (is-a file-line)
                         (contents $?before ?symbol $?after))
         (test (input-is-not-split-symbol ")" ?symbol))
         =>
         (modify-instance ?fct (contents $?before (break-apart ")" ?symbol)
                                         $?after)))
;------------------------------------------------------------------------------
(defrule identify-lines::mark-heading-groups
         "Tags lines that consist of /* $? */ as group headings"
         ?f <- (object (is-a file-line)
                       (type UNKNOWN)
                       (contents /* $? */))
         =>
         (modify-instance ?f (type heading)))
;------------------------------------------------------------------------------
(defrule identify-lines::mark-entry-line
         "Tags lines that are defines and modifies the associated contents"
         ?f <- (object (is-a file-line)
                       (type UNKNOWN)
                       (contents #define ?name ?))
         =>
         (modify-instance ?f (type #define)
                          (contents ?name)))
;------------------------------------------------------------------------------
(defrule identify-lines::merge-three-line-headers
         "Merges simple three line headings into one rule"
         ?f0 <- (object (is-a file-line)
                        (index ?i)
                        (type UNKNOWN)
                        (contents /*))
         ?f1 <- (object (is-a file-line)
                        (index ?i2&:(= ?i2 (+ ?i 1)))
                        (type UNKNOWN)
                        (contents * $?c))
         ?f2 <- (object (is-a file-line)
                        (index ?i3&:(= ?i3 (+ ?i 2)))
                        (type UNKNOWN)
                        (contents */))
         =>
         (unmake-instance ?f1 ?f2)
         (modify-instance ?f0 (contents /* $?c */)))
;------------------------------------------------------------------------------
(defrule identify-lines::mark-glapi-calls
         "marks glapi calls"
         ?f <- (object (is-a file-line)
                       (type UNKNOWN)
                       (contents GLAPI $? "(" $? ")"))
         =>
         (modify-instance ?f (type GLAPI-DEF)))
;------------------------------------------------------------------------------
(defrule identify-lines::merge-potential-glapi-calls
         "Merges the next line of a GLAPI call if the line doesn't end with )"
         (declare (salience -1))
         ?f <- (object (is-a file-line)
                       (type UNKNOWN)
                       (contents GLAPI $?vals "(" $?c)
                       (index ?i))
         (test (not (member$ ")" $?c)))
         ?f0 <- (object (is-a file-line)
                        (index ?i0&:(= ?i0 (+ ?i 1)))
                        (type UNKNOWN)
                        (contents $?contents))
         =>
         (unmake-instance ?f)
         (modify-instance ?f0 (contents GLAPI $?vals "(" $?c $?contents)))
;------------------------------------------------------------------------------
(defrule identify-lines::define-header-spans-initial
         "Defines spans between headers"
         (declare (salience -3))
         (object (is-a file-line)
                 (type heading)
                 (parent ?parent)
                 (index ?i)
                 (contents /* $?name */))
         (not (exists (object (is-a heading-span)
                              (from ?i)
                              (parent ?parent))))
         (object (is-a file-line)
                 (type heading)
                 (parent ?parent)
                 (index ?i2&:(> ?i2 ?i)))
         =>
         (if (> (- ?i2 ?i) 0) then
           (make-instance of heading-span
                          (header-name (implode$ $?name))
                          (from ?i)
                          (to ?i2)
                          (parent ?parent))))
;------------------------------------------------------------------------------
(defrule identify-lines::modify-header-spans-for-smaller-size
         "Retracts the heading-span in response to finding an earlier heading"
         ?f <- (object (is-a heading-span)
                       (from ?i)
                       (to ?j)
                       (parent ?parent))
         (object (is-a file-line)
                 (type heading)
                 (parent ?parent)
                 (index ?i2&:(> ?j ?i2 ?i)))
         =>
         (modify-instance ?f (to ?i2)))
;------------------------------------------------------------------------------
(defrule convert-templates::retract-unknowns
         ?f <- (object (is-a file-line)
                       (type UNKNOWN))
         =>
         (unmake-instance ?f))
;------------------------------------------------------------------------------
(defrule convert-templates::assert-build-groups
         ?f <- (object (is-a file-line)
                       (type ~UNKNOWN)
                       (id ?id))
         =>
         (assert (message (to build-groups)
                          (action add-to-span)
                          (arguments ?id))))
;------------------------------------------------------------------------------
(defrule build-groups::build-grouping
         ?f <- (object (is-a heading-span)
                       (from ?i)
                       (to ?i2)
                       (parent ?parent)
                       (contents $?c))
         (object (is-a file-line)
                 (parent ?parent)
                 (index ?loc&:(> ?i2 ?loc ?i))
                 (type #define)
                 (id ?id))
         ?msg <- (message (to build-groups)
                          (action add-to-span)
                          (arguments ?id))
         =>
         (retract ?msg)
         (modify-instance ?f (contents $?c ?id)))
;------------------------------------------------------------------------------
(defrule build-groups::delete-still-existing-elements
         (declare (salience -100))
         ?msg <- (message (to build-groups)
                          (action add-to-span)
                          (arguments ?id))
         ?obj <- (object (is-a file-line)
                         (id ?id))
         =>
         (unmake-instance ?obj)
         (retract ?msg))
;------------------------------------------------------------------------------
(defrule grouping-update::generate-constant-if-statement
         (object (is-a heading-span)
                 (header-name ?group)
                 (contents $? ?name $?))
         ?obj <- (object (is-a file-line)
                         (id ?name)
                         (type #define)
                         (contents ?element))
         =>
         (bind ?str (str-cat ?element))
         (printout t (format nil "//%s" ?group) crlf
                   (format nil "if(strcmp(input,\"%s\")) { return %s; }"
                           (sub-string (+ (str-index "_" ?str) 1)
                                       (str-length ?str) ?str)
                           ?element) crlf crlf))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; INPUT FACT FORM: (parse constant file ?path)
;------------------------------------------------------------------------------
(deffunction types::get-input-form-factor ()
             (printout t "(parse constant file ?path)" crlf))
;------------------------------------------------------------------------------
(defrule MAIN::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
                          (file-id ?name)
                          (index 0))
           (assert (message (to identify-lines)
                            (action read-file)
                            (arguments ?name)))
           (focus read-input
                  modify-input
                  identify-lines
                  convert-templates
                  build-groups
                  grouping-update)
           else
           (printout t "ERROR: target file at " ?path " does not exist!" crlf
                     "Halting!" crlf)
           (halt)))
;------------------------------------------------------------------------------
(defrule read-input::build-file-line
         ?fct <- (message (to identify-lines)
                          (action read-file)
                          (arguments ?name))
         ?obj <- (object (is-a opened-file)
                         (file-id ?fid))
         =>
         (retract ?fct)
         (bind ?result (send ?obj read-line))
         (if (neq ?result EOF) then
           (duplicate ?fct)
           (if (neq ?result "") then
             (make-instance of file-line (index (send ?obj next-index))
                            (type UNKNOWN)
                            (parent ?fid)
                            (contents (explode$ ?result))))
           else
           (send ?obj close-file)
           (unmake-instance ?obj)))
;------------------------------------------------------------------------------
(deffunction modify-input::blank-on-empty-string (?str)
             (if (> (str-length ?str) 0) then ?str else (create$)))
;------------------------------------------------------------------------------
(deffunction modify-input::break-apart (?sp ?i)
             (bind ?str (if (stringp ?i) then ?i else (str-cat ?i)))
             (bind ?ind (str-index ?sp ?str))
             (bind ?p0 (sub-string 1 (- ?ind 1) ?str))
             (bind ?p1 (sub-string (+ ?ind 1) (str-length ?str) ?str))
             (create$ (blank-on-empty-string ?p0) ?sp
                      (blank-on-empty-string ?p1)))
;------------------------------------------------------------------------------
(deffunction modify-input::input-is-not-split-symbol (?sp ?input)
             (bind ?str (str-cat ?input))
             (and (neq 0 (str-compare ?str ?sp))
                  (str-index ?sp ?str)))
;------------------------------------------------------------------------------
(defrule modify-input::identify-symbols-with-commas
         ?fct <- (object (is-a file-line)
                         (contents $?before ?symbol $?after))
         (test (input-is-not-split-symbol "," ?symbol))
         =>
         (modify-instance ?fct (contents $?before (break-apart "," ?symbol)
                                         $?after)))
;------------------------------------------------------------------------------
(defrule modify-input::identify-symbols-with-open-parens
         ?fct <- (object (is-a file-line)
                         (contents $?b ?s $?a))
         (test (input-is-not-split-symbol "(" ?s))
         =>
         (modify-instance ?fct (contents $?b (break-apart "(" ?s) $?a)))
;------------------------------------------------------------------------------
(defrule modify-input::identify-symbols-with-close-parens
         ?fct <- (object (is-a file-line)
                         (contents $?before ?symbol $?after))
         (test (input-is-not-split-symbol ")" ?symbol))
         =>
         (modify-instance ?fct (contents $?before (break-apart ")" ?symbol)
                                         $?after)))
;------------------------------------------------------------------------------
(defrule identify-lines::mark-heading-groups
         "Tags lines that consist of /* $? */ as group headings"
         ?f <- (object (is-a file-line)
                       (type UNKNOWN)
                       (contents /* $? */))
         =>
         (modify-instance ?f (type heading)))
;------------------------------------------------------------------------------
(defrule identify-lines::mark-entry-line
         "Tags lines that are defines and modifies the associated contents"
         ?f <- (object (is-a file-line)
                       (type UNKNOWN)
                       (contents #define ?name ?))
         =>
         (modify-instance ?f (type #define)
                          (contents ?name)))
;------------------------------------------------------------------------------
(defrule identify-lines::merge-three-line-headers
         "Merges simple three line headings into one rule"
         ?f0 <- (object (is-a file-line)
                        (index ?i)
                        (type UNKNOWN)
                        (contents /*))
         ?f1 <- (object (is-a file-line)
                        (index ?i2&:(= ?i2 (+ ?i 1)))
                        (type UNKNOWN)
                        (contents * $?c))
         ?f2 <- (object (is-a file-line)
                        (index ?i3&:(= ?i3 (+ ?i 2)))
                        (type UNKNOWN)
                        (contents */))
         =>
         (unmake-instance ?f1 ?f2)
         (modify-instance ?f0 (contents /* $?c */)))
;------------------------------------------------------------------------------
(defrule identify-lines::mark-glapi-calls
         "marks glapi calls"
         ?f <- (object (is-a file-line)
                       (type UNKNOWN)
                       (contents GLAPI $? "(" $? ")"))
         =>
         (modify-instance ?f (type GLAPI-DEF)))
;------------------------------------------------------------------------------
(defrule identify-lines::merge-potential-glapi-calls
         "Merges the next line of a GLAPI call if the line doesn't end with )"
         (declare (salience -1))
         ?f <- (object (is-a file-line)
                       (type UNKNOWN)
                       (contents GLAPI $?vals "(" $?c)
                       (index ?i))
         (test (not (member$ ")" $?c)))
         ?f0 <- (object (is-a file-line)
                        (index ?i0&:(= ?i0 (+ ?i 1)))
                        (type UNKNOWN)
                        (contents $?contents))
         =>
         (unmake-instance ?f)
         (modify-instance ?f0 (contents GLAPI $?vals "(" $?c $?contents)))
;------------------------------------------------------------------------------
(defrule identify-lines::define-header-spans-initial
         "Defines spans between headers"
         (declare (salience -3))
         (object (is-a file-line)
                 (type heading)
                 (parent ?parent)
                 (index ?i)
                 (contents /* $?name */))
         (not (exists (object (is-a heading-span)
                              (from ?i)
                              (parent ?parent))))
         (object (is-a file-line)
                 (type heading)
                 (parent ?parent)
                 (index ?i2&:(> ?i2 ?i)))
         =>
         (if (> (- ?i2 ?i) 0) then
           (make-instance of heading-span
                          (header-name (implode$ $?name))
                          (from ?i)
                          (to ?i2)
                          (parent ?parent))))
;------------------------------------------------------------------------------
(defrule identify-lines::modify-header-spans-for-smaller-size
         "Retracts the heading-span in response to finding an earlier heading"
         ?f <- (object (is-a heading-span)
                       (from ?i)
                       (to ?j)
                       (parent ?parent))
         (object (is-a file-line)
                 (type heading)
                 (parent ?parent)
                 (index ?i2&:(> ?j ?i2 ?i)))
         =>
         (modify-instance ?f (to ?i2)))
;------------------------------------------------------------------------------
(defrule convert-templates::retract-unknowns
         ?f <- (object (is-a file-line)
                       (type UNKNOWN))
         =>
         (unmake-instance ?f))
;------------------------------------------------------------------------------
(defrule convert-templates::assert-build-groups
         ?f <- (object (is-a file-line)
                       (type #define)
                       (id ?id))
         =>
         (assert (message (to build-groups)
                          (action add-to-span)
                          (arguments ?id))))
;------------------------------------------------------------------------------
(defrule build-groups::build-grouping
         ?f <- (object (is-a heading-span)
                       (from ?i)
                       (to ?i2)
                       (parent ?parent)
                       (contents $?c))
         (object (is-a file-line)
                 (parent ?parent)
                 (index ?loc&:(> ?i2 ?loc ?i))
                 (id ?id))
         ?msg <- (message (to build-groups)
                          (action add-to-span)
                          (arguments ?id))
         =>
         (retract ?msg)
         (modify-instance ?f (contents $?c ?id)))
;------------------------------------------------------------------------------
(defrule build-groups::delete-still-existing-elements
         (declare (salience -100))
         ?msg <- (message (to build-groups)
                          (action add-to-span)
                          (arguments ?id))
         ?obj <- (object (is-a file-line)
                         (id ?id))
         =>
         (unmake-instance ?obj)
         (retract ?msg))
;------------------------------------------------------------------------------
(defrule grouping-update::generate-constant-if-statement
         (object (is-a heading-span)
                 (header-name ?group)
                 (contents $? ?name $?))
         ?obj <- (object (is-a file-line)
                         (id ?name)
                         (type #define)
                         (contents ?element))
         =>
         (bind ?str (str-cat ?element))
         (printout t (format nil "//%s" ?group) crlf
                   (format nil "if(strcmp(input,\"%s\")) { return %s; }"
                           (sub-string (+ (str-index "_" ?str) 1)
                                       (str-length ?str) ?str)
                           ?element) crlf crlf))
;------------------------------------------------------------------------------


overwrote the pointer fact in Environment

The only number allowed is zero which makes it easier to figure out if this is
a copy or not.

A message handler was added (init around) so that we can automatically
initialize an environment when a new environment object is created. It is up to
the end user to make the newly created environment aware of the creating
environment if they want.

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; Environment.clp - A wrapper over a CLIPS environment
;------------------------------------------------------------------------------
(defclass core::Environment
 "A wrapper over a clips environment"
 (is-a Object InteropObject)
 (slot pointer (type INTEGER EXTERNAL_ADDRESS) (source composite) (access initialize-only)
  (range 0 0) (dynamic-default 0))

(defmessage-handler core::Environment init around ()
 (call-next-handler)
 (if (eq ?self:pointer 0) then
  (bind ?self:pointer (env-create))))

(defmessage-handler core::Environment destroy primary ()
                    (if (not (is-executing-environment ?self:pointer)) then
                      (env-destroy ?self:pointer)
                      (return (delete-instance))
                      else
                      (printout
                        werror
                        "ERROR: attempted to destroy the executing environment."
                        crlf)
                      (return FALSE)))

(defmessage-handler core::Environment is-executing-environment primary ()
                    (return (is-executing-environment ?self:pointer)))

(defmessage-handler core::Environment run ($?count)
                    (bind ?size (length$ $?count))
                    (if (= 0 ?size) then
                      (if (is-executing-environment ?self:pointer) then
                        (run)
                        else
                        (env-run ?self:pointer))
                      else
                      (bind ?num (nth$ 1 ?count))
                      (if (and (> ?num 0) (integerp ?num)) then
                        (if (is-executing-environment ?self:pointer) then
                          (run ?num)
                          else
                          (env-run ?self:pointer ?num))
                        else
                        (printout werror "ERROR: invalid count provided." crlf))))

(defmessage-handler core::Environment eval (?string)
                    (if (stringp ?string) then
                      (if (is-executing-environment ?self:pointer) then
                        (eval ?string)
                        else
                        (env-eval ?self:pointer ?string))
                      else
                      (printout werror "ERROR: string expected" crlf)))

(defmessage-handler core::Environment build (?string)
                    (if (stringp ?string) then
                      (if (is-executing-environment ?self:pointer) then
                        (build ?string)
                        else
                        (env-build ?self:pointer ?string))
                      else
                      (printout werror "ERROR: string expected" crlf)))

(defmessage-handler core::Environment facts ()
                    (if (is-executing-environment ?self:pointer) then
                      (facts)
                      else
                      (env-facts ?self:pointer)))
(defmessage-handler core::Environment instances ()
                    (if (is-executing-environment ?self:pointer) then
                      (instances)
                      else
                      (env-instances ?self:pointer)))

(defmessage-handler core::Environment rules ()
                    (if (is-executing-environment ?self:pointer) then
                      (rules)
                      else
                      (env-rules ?self:pointer)))

(defmessage-handler core::Environment assert ($?elements)
                    (bind ?length (length$ ?elements))
                    (if (= 0 ?length) then
                      (printout werror "ERROR: No arguments provided" crlf)
                      else
                      (env-assert-string ?self:pointer
							  (implode$ $?elements))))

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; Environment.clp - A wrapper over a CLIPS environment
;------------------------------------------------------------------------------
(defclass core::Environment (is-a Object InteropObject))

(defmessage-handler core::Environment destroy primary ()
                    (if (not (is-executing-environment ?self:pointer)) then
                      (env-destroy ?self:pointer)
                      (return (delete-instance))
                      else
                      (printout
                        werror
                        "ERROR: attempted to destroy the executing environment."
                        crlf)
                      (return FALSE)))

(defmessage-handler core::Environment is-executing-environment primary ()
                    (return (is-executing-environment ?self:pointer)))

(defmessage-handler core::Environment run ($?count)
                    (bind ?size (length$ $?count))
                    (if (= 0 ?size) then
                      (if (is-executing-environment ?self:pointer) then
                        (run)
                        else
                        (env-run ?self:pointer))
                      else
                      (bind ?num (nth$ 1 ?count))
                      (if (and (> ?num 0) (integerp ?num)) then
                        (if (is-executing-environment ?self:pointer) then
                          (run ?num)
                          else
                          (env-run ?self:pointer ?num))
                        else
                        (printout werror "ERROR: invalid count provided." crlf))))

(defmessage-handler core::Environment eval (?string)
                    (if (stringp ?string) then
                      (if (is-executing-environment ?self:pointer) then
                        (eval ?string)
                        else
                        (env-eval ?self:pointer ?string))
                      else
                      (printout werror "ERROR: string expected" crlf)))

(defmessage-handler core::Environment build (?string)
                    (if (stringp ?string) then
                      (if (is-executing-environment ?self:pointer) then
                        (build ?string)
                        else
                        (env-build ?self:pointer ?string))
                      else
                      (printout werror "ERROR: string expected" crlf)))

(defmessage-handler core::Environment facts ()
                    (if (is-executing-environment ?self:pointer) then
                      (facts)
                      else
                      (env-facts ?self:pointer)))
(defmessage-handler core::Environment instances ()
                    (if (is-executing-environment ?self:pointer) then
                      (instances)
                      else
                      (env-instances ?self:pointer)))

(defmessage-handler core::Environment rules ()
                    (if (is-executing-environment ?self:pointer) then
                      (rules)
                      else
                      (env-rules ?self:pointer)))

(defmessage-handler core::Environment assert ($?elements)
                    (bind ?length (length$ ?elements))
                    (if (= 0 ?length) then
                      (printout werror "ERROR: No arguments provided" crlf)
                      else
                      (env-assert-string ?self:pointer
							  (implode$ $?elements))))


Rearranged several test conditions in LoopRegionMerging.clp

This should improve performance of equivalence and ownership claims due to the
fact that if the length checks fail then there is no need to evaluate the
subsetp commands which are far more expensive.

;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"
			(object (is-a FlatList)
					  (id ?i0)
					  (values $?c0)
					  (parent ?p0))
			(object (is-a FlatList)
					  (id ?i1&~?i0)
					  (values $?c1)
					  (parent ?p1))
			(test (and (> (length$ ?c1)
							  (length$ ?c0))
						  (subsetp ?c0 ?c1)))
			=>
			(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 (= (length$ ?c1)
							  (length$ ?c0))
						  (subsetp ?c0 ?c1)))
			=>
			(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 (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)))
;------------------------------------------------------------------------------


Rewrote ValidBlockIdentification to be simpler and use modules

I found several areas where I was taking a fact with a multifield and
converting each element into it's own fact through the use of individual rule
fires. I believe at the time I was trying to be more "expert system" like but I
realized that it would be faster to use a progn$ in a single rule to do the
same thing. This increases the amount of work the rule does but reduces the
overall number of rules that need to be fired.

;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.
;------------------------------------------------------------------------------
;defmodule is wavefront-scheduling-identify
(defrule wavefront-scheduling-identify::AssertIdentifySpansInitial
         (declare (salience 5))
         (object (is-a Wavefront) (parent ?r) (contents $? ?e $?))
         ;select only BasicBlocks
         (object (is-a BasicBlock) (ID ?e))
         =>
         (assert (Picked ?e for ?r)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-identify::IdentifySpanSkips-InvalidBlock
         (declare (salience 4))
         ?fct <- (Picked ?e for ?r)
         ?bb <- (object (is-a BasicBlock)
                        (id ?e)
                        (Successors $?a&:(not (eq (length$ $?a) 1))))
         =>
         ;we don't need to assert anything since the block isn't going to get
         ;scheduled
         (retract ?fct))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-identify::IdentifySpans
         (declare (salience 4))
         ?fct <- (Picked ?block for ?)
         ?bb <- (object (is-a BasicBlock)
                        (id ?block)
                        (Successors ?) ; we only have one successor
                        (Paths $?paths))
         =>
         (retract ?fct)
         (modify-instance ?bb (IsOpen TRUE))
         ; originally I had a rule here that took a fact asserted in the form
         ; ?e => $?paths which would be inverted individually by separate rule
         ; fires. While this is more like an expert system, it is extremely
         ; inefficient because the agenda has to be updated after each rule
         ; fire. Using this technique allows me to minimize the number of rule
         ; fires to one yet do the same amount of work.
         (progn$ (?path $?paths)
                 (assert (message (to wavefront-scheduling)
                                  (action check-path)
                                  (arguments ?path for block ?block)))))
;------------------------------------------------------------------------------
; defmodule is wavefront-scheduling-pathing
(defrule wavefront-scheduling-pathing::GetFactsBeforePathing
         (declare (salience 10000))
         (message (action Debug))
         (message (action Facts))
         =>
         (printout t "BEFORE: Wavefront Pathing " crlf crlf)
         (facts)
         (printout t crlf crlf))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pathing::DispatchDivideBlock
         (declare (salience 200))
         ?fct <- (message (to wavefront-scheduling)
                          (action check-path)
                          (arguments ?path for block ?block))
         (object (is-a Path) (id ?path) (contents $? ?block $?rest))
         ;we don't need to explicitly match for ?block
         =>
         (retract ?fct)
         (assert (message (to wavefront-scheduling-pathing)
                          (action scan-path)
                          (arguments ?p ?e => $?rest))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pathing::AnalyzePathElements
         ?fct <- (message (to wavefront-scheduling-pathing)
                          (action scan-path)
                          (arguments ?p ?e => ?curr $?rest))
         ?bb <- (object (is-a BasicBlock)
                        (id ?curr)
                        (Successors $?succ)
                        (HasCallBarrier ?hcb)
                        (HasMemoryBarrier ?hmb))
         =>
         (bind ?sLen (length$ $?succ))
         (if (= 0 ?sLen) then
           (assert (message (to wavefront-scheduling)
                            (action completely-invalid-blocks)
                            (arguments ?e => ?curr)))
           (retract ?fct)
           else
           (if (or (> ?sLen 1) ?hcb) then
             (assert (message (to wavefront-scheduling)
                              (action completely-invalid-blocks)
                              (arguments ?e => $?rest))
                     (message (to wavefront-scheduling)
                              (action potentially-valid-blocks)
                              (arguments ?e => ?curr)))
             (retract ?fct)
             else
             (if ?hmb then
               (assert (message (to wavefront-scheduling)
                                (action element-has-memory-barrier)
                                (arguments ?curr => ?e))))
             (modify ?fct (arguments ?p ?e => $?rest))
             (assert (message (to wavefront-scheduling)
                              (action potentially-valid-blocks)
                              (arguments ?e => ?curr))))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pathing::AnalyzePathElements-Region
         ?fct <- (message (to wavefront-scheduling-pathing)
                          (action scan-path)
                          (arguments ?p ?e => ?curr $?rest))
         ?bb <- (object (is-a Region)
                        (id ?curr)
                        (HasCallBarier ?hcb)
                        (HasMemoryBarrier ?hmb))
         =>
         (if ?hcb then
           (assert (message (to wavefront-scheduling)
                            (action completely-invalid-blocks)
                            (arguments ?e => $?rest))
                   (message (to wavefront-scheduling)
                            (action potentially-valid-blocks)
                            (arguments ?e => ?curr)))
           (retract ?fct)
           else
           (if ?hmb then
             (assert (message (to wavefront-scheduling)
                              (action element-has-memory-barrier)
                              (arguments ?curr => ?e))))
           (modify ?fct (arguments ?p ?e => $?rest))
           (assert (message (to wavefront-scheduling)
                            (action potentially-valid-blocks)
                            (arguments ?e => ?curr)))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pathing::RetractCompletedFact
         ?fct <- (message (to wavefront-scheduling)
                          (action scan-path)
                          (arguments ? ? =>))
         =>
         (retract ?fct))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pathing::PrintoutCompletedFacts
         (declare (salience -999))
         (message (action Debug))
         (message (action Facts))
         =>
         (printout t "AFTER: Wavefront Pathing" crlf crlf)
         (facts)
         (printout t crlf crlf))
;------------------------------------------------------------------------------

;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.
;------------------------------------------------------------------------------
(defrule AssertIdentifySpansInitial
			(declare (salience 100))
			(Stage WavefrontSchedule $?)
			(Substage Identify $?)
			(object (is-a Hint) (Type Wavefront) (Parent ?r) (Contents $? ?e $?))
			;select only BasicBlocks
			(object (is-a BasicBlock) (ID ?e))
			=>
			(assert (Picked ?e for ?r)))
;------------------------------------------------------------------------------
(defrule IdentifySpanSkips-SplitBlock
			(declare (salience 50))
			(Stage WavefrontSchedule $?)
			(Substage Identify $?)
			?fct <- (Picked ?e for ?r)
			?bb <- (object (is-a BasicBlock) (ID ?e))
			(test (send ?bb .IsSplitBlock))
			=>
			(retract ?fct)
			(assert (Schedule ?e for ?r)))
;------------------------------------------------------------------------------
(defrule IdentifySpans
			(declare (salience 50))
			(Stage WavefrontSchedule $?)
			(Substage Identify $?)
			?fct <- (Picked ?e for ?r)
			?bb <- (object (is-a BasicBlock) (ID ?e) (Paths $?paths))
			(test (not (send ?bb .IsSplitBlock)))
			=>
			(retract ?fct)
			(modify-instance ?bb (IsOpen TRUE))
			(assert (Build paths for ?e from $?paths)))
;------------------------------------------------------------------------------
(defrule BuildUpPaths
			(declare (salience 25))
			(Stage WavefrontSchedule $?)
			(Substage Identify $?)
			?fct <- (Build paths for ?e from ?path $?paths)
			=>
			(retract ?fct)
			(assert (Build paths for ?e from $?paths)
					  (Check path ?path for block ?e)))
;------------------------------------------------------------------------------
(defrule RetractPathBuildUp
			(Stage WavefrontSchedule $?)
			(Substage Identify $?)
			?fct <- (Build paths for ? from)
			=>
			(retract ?fct))
;------------------------------------------------------------------------------
(defrule GetFactsBeforePathing
			(declare (salience 10000))
			(Debug)
			(Facts)
			(Stage WavefrontSchedule $?)
			(Substage Pathing $?)
			=>
			(printout t "BEFORE: Wavefront Pathing " crlf crlf)
			(facts)
			(printout t crlf crlf))
;------------------------------------------------------------------------------
(defrule DispatchDivideBlock
			(declare (salience 200))
			(Stage WavefrontSchedule $?)
			(Substage Pathing $?)
			?fct <- (Check path ?p for block ?e)
			(object (is-a Path) (ID ?p) (Contents $? ?e $?rest))
			(object (is-a BasicBlock) (ID ?e))
			=>
			(retract ?fct)
			(assert (Scan path ?p for block ?e with contents $?rest)))
;------------------------------------------------------------------------------
(defrule AnalyzePathElements
			(Stage WavefrontSchedule $?)
			(Substage Pathing $?)
			?fct <- (Scan path ?p for block ?e with contents ?curr $?rest)
			?bb <- (object (is-a BasicBlock) (ID ?curr))
			=>
			(retract ?fct)
			(if (= 0 (length$ (send ?bb get-Successors))) then
			  (assert (CompletelyInvalid blocks for ?e are ?curr))
			  (return))
			(if (send ?bb .IsSplitBlock) then
			  (assert (CompletelyInvalid blocks for ?e are $?rest)
						 (PotentiallyValid blocks for ?e are ?curr))
			  (return))
			(if (send ?bb get-HasCallBarrier) then
			  (assert (CompletelyInvalid blocks for ?e are $?rest)
						 (PotentiallyValid blocks for ?e are ?curr))
			  (return))
			(if (send ?bb get-HasMemoryBarrier) then
			  (assert (Element ?curr has a MemoryBarrier for ?e)))
			(assert (PotentiallyValid blocks for ?e are ?curr)
					  (Scan path ?p for block ?e with contents $?rest)))
;------------------------------------------------------------------------------
(defrule AnalyzePathElements-Region
			(Stage WavefrontSchedule $?)
			(Substage Pathing $?)
			?fct <- (Scan path ?p for block ?e with contents ?curr $?rest)
			?bb <- (object (is-a Region) (ID ?curr))
			=>
			(retract ?fct)
			(if (send ?bb get-HasCallBarrier) then
			  (assert (CompletelyInvalid blocks for ?e are $?rest)
						 (PotentiallyValid blocks for ?e are ?curr))
			  (return))
			(if (send ?bb get-HasMemoryBarrier) then
			  (assert (Element ?curr has a MemoryBarrier for ?e)))
			(assert (PotentiallyValid blocks for ?e are ?curr)
					  (Scan path ?p for block ?e with contents $?rest)))
;------------------------------------------------------------------------------
(defrule RetractCompletedFact
			(Stage WavefrontSchedule $?)
			(Substage Strip $?)
			?fct <- (Scan path ? for block ? with contents)
			=>
			(retract ?fct))
;------------------------------------------------------------------------------
(defrule PrintoutCompletedFacts
			(declare (salience -999))
			(Debug)
			(Facts)
			(Stage WavefrontSchedule $?)
			(Substage Pathing $?)
			=>
			(printout t "AFTER: Wavefront Pathing" crlf crlf)
			(facts)
			(printout t crlf crlf))
;------------------------------------------------------------------------------
(defrule FAIL-PATHS-EXIST
			(declare (salience -2500))
			(Stage WavefrontSchedule $?)
			(Substage Strip $?)
			(Check path ?p for block ?e)
			=>
			(printout t "ERROR: DIDN'T RETRACT COMPLETED FACT: (Check path " ?p
						 " for block " ?e ")" crlf)
			(facts)
			(exit))
;------------------------------------------------------------------------------


Modified the surface class to require a height and width on initialization

;------------------------------------------------------------------------------
;Catharsis
;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.
;------------------------------------------------------------------------------
; Surface.clp - Defines a block of tiles to draw to the screen. Surfaces can't
; draw directly to the screen. That is up to the screen class.
;
; Written by Joshua Scoggins
; Started on 3/30/2013
;------------------------------------------------------------------------------
; Modify these global values to change tile size.
; Only do this if you know what you're doing
;------------------------------------------------------------------------------
(defclass Runtime::Surface
  "Defines the screen to draw to. A screen is made up of one or more surfaces
  which contain tiles."
  (is-a DrawableObject)
  (role concrete)
  (pattern-match reactive)
  (slot width
        (source composite)
        (create-accessor read-write)
        (range 0 ?VARIABLE)
        (default ?NONE))
  (slot height
        (source composite)
        (create-accessor read-write)
        (range 0 ?VARIABLE)
        (default ?NONE))
  (slot position-x
        (type INTEGER)
        (visibility public)
        (range 0 ?VARIABLE))
  (slot position-y
        (type INTEGER)
        (visibility public)
        (range 0 ?VARIABLE))
  (slot visible
        (type SYMBOL)
        (allowed-symbols FALSE TRUE)
        (visibility public))
  (multislot children
             (type INSTANCE)))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;Catharsis
;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.
;------------------------------------------------------------------------------
; Surface.clp - Defines a block of tiles to draw to the screen. Surfaces can't
; draw directly to the screen. That is up to the screen class.
;
; Written by Joshua Scoggins
; Started on 3/30/2013
;------------------------------------------------------------------------------
; Modify these global values to change tile size.
; Only do this if you know what you're doing
;------------------------------------------------------------------------------
(defclass Runtime::Surface
  "Defines the screen to draw to. A screen is made up of one or more surfaces
  which contain tiles."
  (is-a DrawableObject)
  (role concrete)
  (pattern-match reactive)
  (slot width
        (source composite)
        (create-accessor read-write)
        (range 0 ?VARIABLE))
  (slot height
        (source composite)
        (create-accessor read-write)
        (range 0 ?VARIABLE))
  (slot position-x
        (type INTEGER)
        (visibility public)
        (range 0 ?VARIABLE))
  (slot position-y
        (type INTEGER)
        (visibility public)
        (range 0 ?VARIABLE))
  (slot visible
        (type SYMBOL)
        (allowed-symbols FALSE TRUE)
        (visibility public))
  (multislot children
             (type INSTANCE)))
;------------------------------------------------------------------------------


Fixed a major logic bug in Hint.clp

Fixed a major logic bug in Hint.clp

I realized that the biggest issue I'm having with path traversal has to do
with the decrement-reference-count message-handler. The issue stems from an
incorrect ordering on the subtraction. I was doing 1 - ?self:reference-count
instead of ?self:reference-count - 1. Obviously, this is wrong and has been
fixed.

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; Hint.clp - An object used to signify something is a hint. It also has the
; ability to be reference counted if necessary
;------------------------------------------------------------------------------
(defclass core::Hint
  "An object that makes it easy to create temporary entities."
  (is-a Object)
  (multislot values (visibility public))
  (slot reference-count (type NUMBER) (visibility public))
  (slot type (visibility public) (type SYMBOL))
  (slot point (visibility public) (type SYMBOL)))
;------------------------------------------------------------------------------
(defmessage-handler core::Hint increment-reference-count primary
"Incrementes the reference count of the given hint.  If no parameters are given
then the default is one. If a parameter is given then that is the value
incremented by. If more than one parameter is given then those numbers are
added together and then added to the current reference count"
                    ($?by)
                    (bind ?len (length$ ?by))
                    (switch (length$ ?by)
                            (case 0 then
                              (bind ?self:reference-count
                                    (+ 1 ?self:reference-count)))
                            (case 1 then
                              (bind ?self:reference-count
                                    (eval (format nil "(+ %i %i)", (first$ ?by)
                                                  ?self:reference-count))))
                            (default
                              (bind ?v (eval (format nil "(+ %s)"
                                                     (implode$ ?by))))
                              (bind ?self:reference-count
                                    (+ ?self:reference-count ?v)))))
;------------------------------------------------------------------------------
(defmessage-handler core::Hint decrement-reference-count primary
"Decrements the reference count of the given hint.  If no parameters are given
then the default is one. If a parameter is given then that is the value
decremented by. If more than one parameter is given then those numbers are
added together and then subtracted from the current reference count"
                    ($?by)
                    (bind ?len (length$ ?by))
                    (switch (length$ ?by)
                            (case 0 then
                              (bind ?self:reference-count
                                    (- ?self:reference-count 1)))
                            (case 1 then
                              (bind ?self:reference-count
                                    (eval (format nil "(- %i %i)"
                                           ?self:reference-count
                                                  (first$ ?by)))))
                            (default
                              ;add all of the element together so that the
                              ;subtraction is correct
                              (bind ?v (eval (format nil "(+ %s)"
                                                     (implode$ ?by))))
                              (bind ?self:reference-count
                                    (- ?self:reference-count ?v)))))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; Hint.clp - An object used to signify something is a hint. It also has the
; ability to be reference counted if necessary
;------------------------------------------------------------------------------
(defclass core::Hint
  "An object that makes it easy to create temporary entities."
  (is-a Object)
  (multislot values (visibility public))
  (slot reference-count (type NUMBER) (visibility public))
  (slot type (visibility public) (type SYMBOL))
  (slot point (visibility public) (type SYMBOL)))
;------------------------------------------------------------------------------
(defmessage-handler core::Hint increment-reference-count primary ($?by)
"Incrementes the reference count of the given hint.  If no parameters are given
then the default is one. If a parameter is given then that is the value
incremented by. If more than one parameter is given then those numbers are
added together and then added to the current reference count"
						  (bind ?len (length$ ?by))
						  (switch (length$ ?by)
									 (case 0 then
										(bind ?self:reference-count
												(+ 1 ?self:reference-count)))
									 (case 1 then
										(bind ?self:reference-count
										      (eval (format nil "(+ %i %i)", (first$ ?by)
														 ?self:reference-count))))
									 (default
										(bind ?v (eval (format nil "(+ %s)"
																	  (implode$ ?by))))
										(bind ?self:reference-count
												(+ ?self:reference-count ?v)))))
;------------------------------------------------------------------------------
(defmessage-handler core::Hint decrement-reference-count
"Decrements the reference count of the given hint.  If no parameters are given
then the default is one. If a parameter is given then that is the value
decremented by. If more than one parameter is given then those numbers are
added together and then subtracted from the current reference count"
						  ($?by)
						  (bind ?len (length$ ?by))
						  (switch (length$ ?by)
									 (case 0 then
										(bind ?self:reference-count
												(- 1 ?self:reference-count)))
									 (case 1 then
										(bind ?self:reference-count
										      (eval (format nil "(- %i %i)" (first$ ?by)
														 ?self:reference-count))))
									 (default
										;add all of the element together so that the
										;subtraction is correct
										(bind ?v (eval (format nil "(+ %s)"
																	  (implode$ ?by))))
										(bind ?self:reference-count
												(- ?self:reference-count ?v)))))
;------------------------------------------------------------------------------


Deleted io from being loaded in Library.clp

;------------------------------------------------------------------------------
;The Adventure Engine
;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.
;------------------------------------------------------------------------------
; Library.clp - Defines the init module and loads all other corresponding
; files.
;
; Written by Joshua Scoggins
; Started on 3/11/2013
;------------------------------------------------------------------------------
; Define the module
;------------------------------------------------------------------------------
(defmodule Runtime (export ?ALL))
;------------------------------------------------------------------------------
; Load the corresponding types and functions
;------------------------------------------------------------------------------
(load* "System/Runtime/GenericDeclareFunctions.clp")
(batch* "System/Runtime/DeclareLibraryFunctions.clp")
(batch* "System/Runtime/DeclareApplicationFunctions.clp")
(batch* "System/Runtime/DeclareLogicFunctions.clp")
(batch* "System/Runtime/core/Loader.clp")
(batch* "System/Runtime/parsing/Loader.clp")
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;The Adventure Engine
;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.
;------------------------------------------------------------------------------
; Library.clp - Defines the init module and loads all other corresponding
; files.
;
; Written by Joshua Scoggins
; Started on 3/11/2013
;------------------------------------------------------------------------------
; Define the module
;------------------------------------------------------------------------------
(defmodule Runtime (export ?ALL))
;------------------------------------------------------------------------------
; Load the corresponding types and functions
;------------------------------------------------------------------------------
(load* "System/Runtime/GenericDeclareFunctions.clp")
(batch* "System/Runtime/DeclareLibraryFunctions.clp")
(batch* "System/Runtime/DeclareApplicationFunctions.clp")
(batch* "System/Runtime/DeclareLogicFunctions.clp")
(batch* "System/Runtime/core/Loader.clp")
(batch* "System/Runtime/io/Loader.clp")
(batch* "System/Runtime/parsing/Loader.clp")
;------------------------------------------------------------------------------