src/lib/widget/Library.clp: Updated the started on date

;------------------------------------------------------------------------------
;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 widget module and loads all corresponding files.
;
; Written by Joshua Scoggins
; Started on 3/11/2013
;------------------------------------------------------------------------------
; Define the module
;------------------------------------------------------------------------------
(defmodule widget
			  (import cortex ?ALL)
			  (export ?ALL))
;------------------------------------------------------------------------------
; Load the corresponding types and functions
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;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 widget module and loads all corresponding files.
;
; Written by Joshua Scoggins
; Started on 3/6/2013
;------------------------------------------------------------------------------
; Define the module
;------------------------------------------------------------------------------
(defmodule widget
			  (import cortex ?ALL)
			  (export ?ALL))
;------------------------------------------------------------------------------
; Load the corresponding types and functions
;------------------------------------------------------------------------------


Added a third supertype to the llvm::Function class in clips

This third supertype is the List type so that we can store the blocks that make
up the target function.

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; LLVMFunction.clp - Represents the LLVM Function class
;------------------------------------------------------------------------------
(defclass llvm::Function
  (is-a GlobalValue Diplomat List)
  (slot ReturnType)
  (slot FunctionType)
  (slot IsVarArg (type SYMBOL) (allowed-values FALSE TRUE))
  (slot IntrinsicID)
  (slot IsIntrinsic (type SYMBOL) (allowed-values FALSE TRUE))
  (slot CallingConvention
        (type SYMBOL)
        (allowed-values Unknown intel-ocl-bi spir-kernel spir-func
                        HiPE mblaze-svol mblaze-intr ptx-device ptx-kernel x86-thiscall
                        msp430-intr arm-aapcs-vfp arm-aapcs arm-apcs x86-fastcall x86-stdcall
                        GHC Cold Fast C))
  (slot HasGC (type SYMBOL) (allowed-values FALSE TRUE))
  (slot GC)
  (slot DoesNotAccessMemory (type SYMBOL) (allowed-values FALSE TRUE))
  (slot OnlyReadsMemory (type SYMBOL) (allowed-values FALSE TRUE))
  (slot DoesNotReturn (type SYMBOL) (allowed-values FALSE TRUE))
  (slot HasUWTable (type SYMBOL) (allowed-values FALSE TRUE))
  (slot NeedsUnwindTableEntry (type SYMBOL) (allowed-values FALSE TRUE))
  (slot HasStructRetAttr (type SYMBOL) (allowed-values FALSE TRUE))
  (slot IsDefTriviallyDead (type SYMBOL) (allowed-values FALSE TRUE))
  (slot CallsFunctionThatReturnsTwice
        (type SYMBOL)
        (allowed-values FALSE TRUE))
  (slot EntryBlock)
  (multislot Arguments))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function put-GC after
                    (?str)
                    (llvm-function-set-gc ?self:pointer ?str))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function clear-GC primary
                    ()
                    (llvm-function-clear-gc ?self:pointer)
                    (bind ?self:GC ""))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function delete-body primary
                    ()
                    (llvm-function-delete-body ?self:pointer)
                    (bind ?self:contents (create$)))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function remove-from-parent primary
                    ()
                    (llvm-function-remove-from-parent ?self:pointer)
                    (bind ?self:parent nil))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function erase-from-parent primary
                    ()
                    (llvm-function-erase-from-parent ?self:pointer)
                    (delete-instance))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function put-DoesNotAccessMemory after
                    (?symbol)
                    (if ?symbol then
                      (llvm-function-set-does-not-access-memory
                        ?self:pointer)))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function set-does-not-alias primary
                    (?index)
                    (llvm-function-set-does-not-alias ?self:pointer ?index))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function set-does-not-capture primary
                    (?index)
                    (llvm-function-set-does-not-capture ?self:pointer ?index))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function put-DoesNotThrow after
                    (?symbol)
                    (if ?symbol then
                      (llvm-function-set-does-not-throw ?self:pointer)))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function put-HasUWTable after
                    (?symbol)
                    (if ?symbol then
                      (llvm-function-set-has-uw-table ?self:pointer)))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function put-DoesNotReturn after
                    (?symbol)
                    (if ?symbol then
                      (llvm-function-set-does-not-return ?self:pointer)))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function put-OnlyReadsMemory after
                    (?symbol)
                    (if ?symbol then
                      (llvm-function-set-only-reads-memory ?self:pointer)))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function drop-all-references primary
                    ()
                    (llvm-function-drop-all-references
                      ?self:pointer))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function does-not-alias primary
                    (?index)
                    (llvm-function-set-does-not-alias ?self:pointer ?index))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function does-not-capture primary
                    (?index)
                    (llvm-function-does-not-capture ?self:pointer ?index))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function get-param-alignment primary
                    (?index)
                    (llvm-function-get-param-alignment ?self:pointer ?index))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; LLVMFunction.clp - Represents the LLVM Function class
;------------------------------------------------------------------------------
(defclass llvm::Function
  (is-a GlobalValue Diplomat)
  (slot ReturnType)
  (slot FunctionType)
  (slot IsVarArg (type SYMBOL) (allowed-values FALSE TRUE))
  (slot IntrinsicID)
  (slot IsIntrinsic (type SYMBOL) (allowed-values FALSE TRUE))
  (slot CallingConvention
        (type SYMBOL)
        (allowed-values Unknown intel-ocl-bi spir-kernel spir-func
                        HiPE mblaze-svol mblaze-intr ptx-device ptx-kernel x86-thiscall
                        msp430-intr arm-aapcs-vfp arm-aapcs arm-apcs x86-fastcall x86-stdcall
                        GHC Cold Fast C))
  (slot HasGC (type SYMBOL) (allowed-values FALSE TRUE))
  (slot GC)
  (slot DoesNotAccessMemory (type SYMBOL) (allowed-values FALSE TRUE))
  (slot OnlyReadsMemory (type SYMBOL) (allowed-values FALSE TRUE))
  (slot DoesNotReturn (type SYMBOL) (allowed-values FALSE TRUE))
  (slot HasUWTable (type SYMBOL) (allowed-values FALSE TRUE))
  (slot NeedsUnwindTableEntry (type SYMBOL) (allowed-values FALSE TRUE))
  (slot HasStructRetAttr (type SYMBOL) (allowed-values FALSE TRUE))
  (slot IsDefTriviallyDead (type SYMBOL) (allowed-values FALSE TRUE))
  (slot CallsFunctionThatReturnsTwice
        (type SYMBOL)
        (allowed-values FALSE TRUE))
  (slot EntryBlock)
  (multislot Arguments))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function put-GC after
                    (?str)
                    (llvm-function-set-gc ?self:pointer ?str))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function clear-GC primary
                    ()
                    (llvm-function-clear-gc ?self:pointer)
                    (bind ?self:GC ""))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function delete-body primary
                    ()
                    (llvm-function-delete-body ?self:pointer)
                    (bind ?self:contents (create$)))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function remove-from-parent primary
                    ()
                    (llvm-function-remove-from-parent ?self:pointer)
                    (bind ?self:parent nil))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function erase-from-parent primary
                    ()
                    (llvm-function-erase-from-parent ?self:pointer)
                    (delete-instance))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function put-DoesNotAccessMemory after
                    (?symbol)
                    (if ?symbol then
                      (llvm-function-set-does-not-access-memory
                        ?self:pointer)))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function set-does-not-alias primary
                    (?index)
                    (llvm-function-set-does-not-alias ?self:pointer ?index))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function set-does-not-capture primary
                    (?index)
                    (llvm-function-set-does-not-capture ?self:pointer ?index))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function put-DoesNotThrow after
                    (?symbol)
                    (if ?symbol then
                      (llvm-function-set-does-not-throw ?self:pointer)))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function put-HasUWTable after
                    (?symbol)
                    (if ?symbol then
                      (llvm-function-set-has-uw-table ?self:pointer)))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function put-DoesNotReturn after
                    (?symbol)
                    (if ?symbol then
                      (llvm-function-set-does-not-return ?self:pointer)))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function put-OnlyReadsMemory after
                    (?symbol)
                    (if ?symbol then
                      (llvm-function-set-only-reads-memory ?self:pointer)))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function drop-all-references primary
                    ()
                    (llvm-function-drop-all-references
                      ?self:pointer))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function does-not-alias primary
                    (?index)
                    (llvm-function-set-does-not-alias ?self:pointer ?index))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function does-not-capture primary
                    (?index)
                    (llvm-function-does-not-capture ?self:pointer ?index))
;------------------------------------------------------------------------------
(defmessage-handler llvm::Function get-param-alignment primary
                    (?index)
                    (llvm-function-get-param-alignment ?self:pointer ?index))
;------------------------------------------------------------------------------


Finished a prototype GLAPIConversion expert system

I still need to generate the actual code but this is a start

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; GLAPIConversion.clp - an expert system that reads a define and generates
; corresponding CLIPS functions that convert the CLIPS values into
; corresponding opengl types. This gets a little goofy when dealing with
; multifields but the idea is sound.
;------------------------------------------------------------------------------
; We need to add functionality to diverge asterisks from a symbol
;------------------------------------------------------------------------------
(target-symbol-is-special "*"
								  identify-symbols-with-asterisks
								  "Splits asterisks (*) out of symbols if necessary")
;------------------------------------------------------------------------------
; Can't escape with double quotes with ] and [...strange
;------------------------------------------------------------------------------
(target-symbol-is-special "["
								  identify-symbols-with-open-square-bracket
								  "Splits an input string on [")
;------------------------------------------------------------------------------
(target-symbol-is-special "]"
								  identify-symbols-with-close-square-bracket
								  "Splits an input string on ]")
;------------------------------------------------------------------------------
; Unlike GLConstantConversion, I don't need to use the heading span objects.
; This is because each file-line has already been correctly merged.
;------------------------------------------------------------------------------
(defrule build-groups::delete-heading-span
			"We don't need heading spans in this expert system. So delete them"
			?obj <- (object (is-a heading-span))
			=>
			(unmake-instance ?obj))
;------------------------------------------------------------------------------
; We need to define a transformation function/rule f which is responsible for
; taking in a knowledge representation of the original code from the input
; language and translates it to a knowledge representation of the code in the
; output language. In this case it is C => C with the added "benefit" of
; needing to add CLIPS api calls to interact with the overall environment.
;
; This isn't really that hard as what we need to do is just parse the arguments
; and generate the corresponding C code.
;------------------------------------------------------------------------------
(defclass types::GLAPIFunction
  "Defines a given GLAPI function"
  (is-a Object)
  (slot return-type (type SYMBOL STRING))
  (slot function-name)
  (slot clips-function-name))
;------------------------------------------------------------------------------
(defclass types::GLAPIArgument
  "Defines a given GLAPI function argument"
  (is-a Object)
  (slot argument-type (visibility public))
  (slot argument-name)
  (slot index)
  (slot is-constant (type SYMBOL) (allowed-values FALSE TRUE))
  (slot is-pointer (type SYMBOL) (allowed-values FALSE TRUE))
  (message-handler reconstitute))
;------------------------------------------------------------------------------
(defmessage-handler types::GLAPIArgument reconstitute
						  ()
						  (return (format nil "%s %s %s %s"
												(if ?self:is-constant then "const" else "")
												?self:argument-type
												(if ?self:is-pointer then "*" else "")
												?self:argument-name)))
;------------------------------------------------------------------------------
(defclass types::GLAPIFixedArrayArgument
  "Refers to fixed size arrays"
  (is-a GLAPIArgument)
  (slot array-size)
  (message-handler reconstitute around))
;------------------------------------------------------------------------------
(defmessage-handler types::GLAPIFixedArrayArgument reconstitute around
						  ()
						  (return (format nil "%s[%s]"
												(call-next-handler)
												(str-cat ?self:array-size))))
;------------------------------------------------------------------------------
; build-groups module
;------------------------------------------------------------------------------
(defrule build-groups::build-glapi-function
			?msg <- (message (to build-groups)
								  (action add-to-span)
								  (arguments ?id))
			?obj <- (object (is-a file-line)
								 (id ?id)
								 (type GLAPI-DEF)
								 (contents GLAPI ?ret GLAPIENTRY ?name "(" $?args ")"))
			=>
			;we need to set this up to do conversion of the different arguments
			(bind ?objName (gensym*))
			(modify ?msg
					  (action parse-arguments)
					  (arguments ?objName => $?args))
			(make-instance ?objName of GLAPIFunction
								(return-type ?ret)
								(function-name ?name)
								(clips-function-name (sym-cat CLIPS_ ?name))))
;------------------------------------------------------------------------------
(defrule build-groups::build-glapi-function-void
			(declare (salience 1))
			?msg <- (message (to build-groups)
								  (action add-to-span)
								  (arguments ?id))
			?obj <- (object (is-a file-line)
								 (id ?id)
								 (type GLAPI-DEF)
								 (contents GLAPI ?ret GLAPIENTRY ?name "(" void ")"))
			=>
			;we need to set this up to do conversion of the different arguments
			(retract ?msg)
			(make-instance of GLAPIFunction
								(return-type ?ret)
								(function-name ?name)
								(clips-function-name (sym-cat CLIPS_ ?name))))
;------------------------------------------------------------------------------
(deffunction build-groups::count-commas
				 "Iterates through a multifield and counts the number of commas"
				 (?list)
				 (bind ?count 0)
				 (progn$ (?e ?list)
							(if (or (eq ?e ",")
									  (eq ?e ,)) then
							  (bind ?count (+ 1 ?count))))
				 (return ?count))
;------------------------------------------------------------------------------
(defrule build-groups::concatentate-length
			"Adds a range to the target argument set"
			?fct <- (message (to build-groups)
								  (action parse-arguments)
								  (arguments ?o => $?contents))
			=>
			(modify ?fct (action diverge-arguments)
					  (arguments ?o 0 (count-commas $?contents) =>
									 $?contents)))
;------------------------------------------------------------------------------
(defrule build-groups::diverge-arguments
			"Splits the set of arguments into two separate facts"
			(declare (salience 1))
			?fct <- (message (to build-groups)
								  (action diverge-arguments)
								  (arguments ?o ?start ?finish => $?a "," $?b))
			(test (neq ?start ?finish))
			=>
			(bind ?cca (+ ?start (count-commas $?a)))
			(bind ?startb (+ ?cca 1))
			(bind ?ccb (+ ?startb (count-commas $?b)))
			(modify ?fct (arguments ?o ?start ?cca => $?a))
			(duplicate ?fct (arguments ?o ?startb (+ ?startb ?ccb) => $?b)))
;------------------------------------------------------------------------------
(defrule build-groups::generate-build-argument-statement
			?fct <- (message (to build-groups)
								  (action diverge-arguments)
								  (arguments ?o ?pos ?pos => $?conditions))
			=>
			(modify ?fct (action build-argument)
					  (arguments ?o ?pos => $?conditions)))
;------------------------------------------------------------------------------
(defrule build-groups::argument-is-fixed-array
			(declare (salience 1))
			?fct <- (message (to build-groups)
								  (action build-argument)
								  (arguments ?o ?ind => $?field "[" ?size "]"))
			=>
			(bind ?name (gensym*))
			(modify ?fct (to grouping-update)
					  (action populate-argument)
					  (arguments ?name => $?field))
			(make-instance ?name of GLAPIFixedArrayArgument
								(parent ?o)
								(array-size ?size)
								(index ?ind)))
;------------------------------------------------------------------------------
(defrule build-groups::argument-is-generic
			?fct <- (message (to build-groups)
								  (action build-argument)
								  (arguments ?o ?ind => $?input))
			=>
			(bind ?name (gensym*))
			(modify ?fct (to grouping-update)
					  (action populate-argument)
					  (arguments ?name => $?input))
			(make-instance ?name of GLAPIArgument
								(parent ?o)
								(index ?ind)))
;------------------------------------------------------------------------------
; grouping-update module
;------------------------------------------------------------------------------
(defrule grouping-update::mark-argument-is-pointer
			(declare (salience 1))
			?fct <- (message (to grouping-update)
								  (action populate-argument)
								  (arguments ?o => $?before "*" $?after))
			?obj <- (object (is-a GLAPIArgument)
								 (id ?o))
			=>
			(modify ?fct (arguments ?o => $?before $?after))
			(modify-instance ?obj (is-pointer TRUE)))
;------------------------------------------------------------------------------
(defrule grouping-update::mark-argument-is-constant
			(declare (salience 1))
			?fct <- (message (to grouping-update)
								  (action populate-argument)
								  (arguments ?o => $?before const|"const" $?after))
			?obj <- (object (is-a GLAPIArgument)
								 (id ?o))
			=>
			(modify ?fct (arguments ?o => $?before $?after))
			(modify-instance ?obj (is-constant TRUE)))
;------------------------------------------------------------------------------
(defrule grouping-update::set-argument-core-info
			?fct <- (message (to grouping-update)
								  (action populate-argument)
								  (arguments ?o => ?type ?name))
			?obj <- (object (is-a GLAPIArgument)
								 (id ?o))
			=>
			(modify ?fct (arguments ?o =>))

			(modify-instance ?obj (argument-type ?type)
								  (argument-name ?name)))
;------------------------------------------------------------------------------
(defrule grouping-update::retract-arguments
			?fct <- (message (to grouping-update)
								  (action populate-argument)
								  (arguments ?o =>))
			(object (is-a GLAPIArgument)
					  (id ?o)
					  (parent ?p))
			=>
			(modify ?fct (action make-function-builder)
					  (arguments ?p)))
;------------------------------------------------------------------------------
(defrule types::FunctionBuilder
			"Builds C functions"
			(is-a Object)
			(multislot contents))
;------------------------------------------------------------------------------
(defrule grouping-update::make-function-builder
			?fct <- (message (to grouping-update)
								  (action make-function-builder)
								  (arguments ?p))
			=>
			(modify ?fct (action build-function)
					  (arguments ?p -1))
			(make-instance of FunctionBuilder (parent ?p)))
;------------------------------------------------------------------------------
(defrule grouping-update::build-function-header
			(declare (salience 1))
			?fct <- (message (to grouping-update)
								  (action build-function)
								  (arguments ?p -1))
			?obj <- (object (is-a FunctionBuilder)
								 (parent ?p))
			(object (is-a GLAPIFunction)
					  (id ?p)
					  (return-type ?ret)
					  (clips-function-name ?cfn))
			=>
			(modify ?fct (arguments ?p 0))
			(modify-contents ?obj (contents
											(format nil "extern %s %s(void* theEnv) {"
													  ?ret ?cfn))))
;------------------------------------------------------------------------------
(defrule grouping-update::build-function-add-argument
			?fct <- (message (to grouping-update)
								  (action build-function)
								  (arguments ?p ?index))
			?arg <- (object (is-a GLAPIArgument)
								 (parent ?p)
								 (index ?index))
			?obj <- (object (is-a FunctionBuilder)
								 (parent ?p)
								 (contents $?contents))
			=>
			(modify ?fct (arguments ?p (+ ?index 1)))
			(modify-instance ?obj
								  (contents $?contents
												(format nil "//code to handle %s"
														  (send ?arg reconstitute)))))
;------------------------------------------------------------------------------
(defrule grouping-update::close-function
         (declare (salience -1))
			?fct <- (message (to grouping-update)
				              (action build-function)
								  (arguments ?p ?index))
			(not (exists (object (is-a GLAPIArgument)
							  (parent ?p)
							  (index ?index))))
			?f <- (object (is-a FunctionBuilder)
				(parent ?p)
				(contents $?contents))
			=>
			(modify ?fct (action print-function)
			 (arguments ?p))
			(modify-instance ?f (contents $?contents "}")))
;------------------------------------------------------------------------------
(defrule grouping-update::print-built-function
         ?fct <- (message (to grouping-update)
				              (action build-function)
								  (arguments ?p))
			?f <- (object (is-a FunctionBuilder)
				           (parent ?p)
							  (contents $?c))
			=>
			(progn$ (?line ?c)
			        (printout t ?line crlf))
			(printout t crlf crlf)
			(retract ?fct)
			(unmake-instance ?f))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; GLAPIConversion.clp - an expert system that reads a define and generates
; corresponding CLIPS functions that convert the CLIPS values into
; corresponding opengl types. This gets a little goofy when dealing with
; multifields but the idea is sound.
;------------------------------------------------------------------------------
; We need to add functionality to diverge asterisks from a symbol
;------------------------------------------------------------------------------
(target-symbol-is-special "*"
								  identify-symbols-with-asterisks
								  "Splits asterisks (*) out of symbols if necessary")
;------------------------------------------------------------------------------
; Can't escape with double quotes with ] and [...strange
;------------------------------------------------------------------------------
(target-symbol-is-special "["
								  identify-symbols-with-open-square-bracket
								  "Splits an input string on [")
;------------------------------------------------------------------------------
(target-symbol-is-special "]"
								  identify-symbols-with-close-square-bracket
								  "Splits an input string on ]")
;------------------------------------------------------------------------------
; Unlike GLConstantConversion, I don't need to use the heading span objects.
; This is because each file-line has already been correctly merged.
;------------------------------------------------------------------------------
(defrule build-groups::delete-heading-span
			"We don't need heading spans in this expert system. So delete them"
			?obj <- (object (is-a heading-span))
			=>
			(unmake-instance ?obj))
;------------------------------------------------------------------------------
; We need to define a transformation function/rule f which is responsible for
; taking in a knowledge representation of the original code from the input
; language and translates it to a knowledge representation of the code in the
; output language. In this case it is C => C with the added "benefit" of
; needing to add CLIPS api calls to interact with the overall environment.
;
; This isn't really that hard as what we need to do is just parse the arguments
; and generate the corresponding C code.
;------------------------------------------------------------------------------
(defclass types::GLAPIFunction
  "Defines a given GLAPI function"
  (is-a Object)
  (slot return-type (type SYMBOL STRING))
  (slot function-name)
  (slot clips-function-name))
;------------------------------------------------------------------------------
(defclass types::GLAPIArgument
  "Defines a given GLAPI function argument"
  (is-a Object)
  (slot argument-type (visibility public))
  (slot argument-name)
  (slot index)
  (slot is-constant (type SYMBOL) (allowed-values FALSE TRUE))
  (slot is-pointer (type SYMBOL) (allowed-values FALSE TRUE))
  (message-handler reconstitute))
;------------------------------------------------------------------------------
(defmessage-handler types::GLAPIArgument reconstitute
						  ()
						  (return (format nil "%s %s %s %s"
												(if ?self:is-constant then "const" else "")
												?self:argument-type
												(if ?self:is-pointer then "*" else "")
												?self:argument-name)))
;------------------------------------------------------------------------------
(defclass types::GLAPIFixedArrayArgument
  "Refers to fixed size arrays"
  (is-a GLAPIArgument)
  (slot array-size)
  (message-handler reconstitute around))
;------------------------------------------------------------------------------
(defmessage-handler types::GLAPIFixedArrayArgument reconstitute around
						  ()
						  (return (format nil "%s[%s]"
												(call-next-handler)
												(str-cat ?self:array-size))))
;------------------------------------------------------------------------------
(defrule build-groups::build-glapi-function
			?msg <- (message (to build-groups)
								  (action add-to-span)
								  (arguments ?id))
			?obj <- (object (is-a file-line)
								 (id ?id)
								 (type GLAPI-DEF)
								 (contents GLAPI ?ret GLAPIENTRY ?name "(" $?args ")"))
			=>
			;we need to set this up to do conversion of the different arguments
			(bind ?objName (gensym*))
			(modify ?msg
					  (action parse-arguments)
					  (arguments ?objName => $?args))
			(make-instance ?objName of GLAPIFunction
								(return-type ?ret)
								(function-name ?name)
								(clips-function-name (sym-cat CLIPS_ ?name))))
;------------------------------------------------------------------------------
(defrule build-groups::build-glapi-function-void
			(declare (salience 1))
			?msg <- (message (to build-groups)
								  (action add-to-span)
								  (arguments ?id))
			?obj <- (object (is-a file-line)
								 (id ?id)
								 (type GLAPI-DEF)
								 (contents GLAPI ?ret GLAPIENTRY ?name "(" void ")"))
			=>
			;we need to set this up to do conversion of the different arguments
			(retract ?msg)
			(make-instance of GLAPIFunction
								(return-type ?ret)
								(function-name ?name)
								(clips-function-name (sym-cat CLIPS_ ?name))))
;------------------------------------------------------------------------------
(deffunction build-groups::count-commas
				 "Iterates through a multifield and counts the number of commas"
				 (?list)
				 (bind ?count 0)
				 (progn$ (?e ?list)
							(if (or (eq ?e ",")
									  (eq ?e ,)) then
							  (bind ?count (+ 1 ?count))))
				 (return ?count))
;------------------------------------------------------------------------------
(defrule build-groups::concatentate-length
			"Adds a range to the target argument set"
			?fct <- (message (to build-groups)
								  (action parse-arguments)
								  (arguments ?o => $?contents))
			=>
			(modify ?fct (action diverge-arguments)
					  (arguments ?o 0 (count-commas $?contents) =>
									 $?contents)))
;------------------------------------------------------------------------------
(defrule build-groups::diverge-arguments
			"Splits the set of arguments into two separate facts"
			(declare (salience 1))
			?fct <- (message (to build-groups)
								  (action diverge-arguments)
								  (arguments ?o ?start ?finish => $?a "," $?b))
			(test (neq ?start ?finish))
			=>
			(bind ?cca (+ ?start (count-commas $?a)))
			(bind ?startb (+ ?cca 1))
			(bind ?ccb (+ ?startb (count-commas $?b)))
			(modify ?fct (arguments ?o ?start ?cca => $?a))
			(duplicate ?fct (arguments ?o ?startb (+ ?startb ?ccb) => $?b)))
;------------------------------------------------------------------------------
(defrule build-groups::generate-build-argument-statement
			?fct <- (message (to build-groups)
								  (action diverge-arguments)
								  (arguments ?o ?pos ?pos => $?conditions))
			=>
			(modify ?fct (action build-argument)
					  (arguments ?o ?pos => $?conditions)))
;------------------------------------------------------------------------------
(defrule build-groups::argument-is-fixed-array
			(declare (salience 1))
			?fct <- (message (to build-groups)
								  (action build-argument)
								  (arguments ?o ?ind => $?field "[" ?size "]"))
			=>
			(bind ?name (gensym*))
			(modify ?fct (to grouping-update)
					  (action populate-argument)
					  (arguments ?name => $?field))
			(make-instance ?name of GLAPIFixedArrayArgument
								(parent ?o)
								(array-size ?size)
								(index ?ind)))
;------------------------------------------------------------------------------
(defrule build-groups::argument-is-generic
			?fct <- (message (to build-groups)
								  (action build-argument)
								  (arguments ?o ?ind => $?input))
			=>
			(bind ?name (gensym*))
			(modify ?fct (to grouping-update)
					  (action populate-argument)
					  (arguments ?name => $?input))
			(make-instance ?name of GLAPIArgument
								(parent ?o)
								(index ?ind)))
;------------------------------------------------------------------------------
; grouping-update module
;------------------------------------------------------------------------------
(defrule grouping-update::mark-argument-is-pointer
			(declare (salience 1))
			?fct <- (message (to grouping-update)
								  (action populate-argument)
								  (arguments ?o => $?before "*" $?after))
			?obj <- (object (is-a GLAPIArgument)
								 (id ?o))
			=>
			(modify ?fct (arguments ?o => $?before $?after))
			(modify-instance ?obj (is-pointer TRUE)))
;------------------------------------------------------------------------------
(defrule grouping-update::mark-argument-is-constant
			(declare (salience 1))
			?fct <- (message (to grouping-update)
								  (action populate-argument)
								  (arguments ?o => $?before const|"const" $?after))
			?obj <- (object (is-a GLAPIArgument)
								 (id ?o))
			=>
			(modify ?fct (arguments ?o => $?before $?after))
			(modify-instance ?obj (is-constant TRUE)))
;------------------------------------------------------------------------------
(defrule grouping-update::set-argument-core-info
			?fct <- (message (to grouping-update)
								  (action populate-argument)
								  (arguments ?o => ?type ?name))
			?obj <- (object (is-a GLAPIArgument)
								 (id ?o))
			=>
			(retract ?fct)
			(modify-instance ?obj (argument-type ?type)
								  (argument-name ?name)))
;------------------------------------------------------------------------------
(defrule grouping-update::retract-arguments
			?fct <- (message (to grouping-update)
								  (action populate-argument)
								  (arguments ? =>))
			=>
			(retract ?fct))
;------------------------------------------------------------------------------
(defrule grouping-update::printout-arguments
			(declare (salience -10))
			?obj <- (object (is-a GLAPIArgument))
			=>
			(printout t (send ?obj reconstitute) crlf))
;------------------------------------------------------------------------------


Added the rooms interactive game

Added the rooms interactive game

;------------------------------------------------------------------------------
;The Adventure Engine
;Copyright (c) 2012-2016, 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 The Adventure Engine 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.
;------------------------------------------------------------------------------
; Inspect.clp - a simple inspect the room game
;------------------------------------------------------------------------------
; Required module implementations
;------------------------------------------------------------------------------
(defmodule pre-prompt
           (import constants defglobal router-out))
(defrule pre-prompt::print-objectives
         =>
         (printout ?*router-out*
                   "This tools is meant to automate the construction of rooms" crlf))
(defmodule post-prompt
           (import constants
                   defglobal
                   router-out))
;(defrule post-prompt::say-thanks
;         =>
;         (printout ?*router-out*
;                   "Thanks for playing!" crlf))

;------------------------------------------------------------------------------

(defmodule game
           (import constants ?ALL)
           (import core ?ALL)
           (import world ?ALL)
           (import prompt defclass input-state))

(definstances game::room-and-items
              (self of player)
              (entry of room
                     (title "")
                     (description "A non descript room")))

(defrule game::handle-look-keyword:no-extra-input
         ?f <- (object (is-a input-state)
                       (should-prompt FALSE)
                       (processed-input FALSE)
                       (input look))
         (object (is-a player)
                 (name [self])
                 (current-room ?room))
         (object (is-a room)
                 (name ?room)
                 (description ?description))
         =>
         (modify-instance ?f
                          (processed-input TRUE))
         (printout ?*router-out*
                   "You are in a " ?description crlf))

(defrule game::handle-go-keyword
         ?f <- (object (is-a input-state)
                       (should-prompt FALSE)
                       (processed-input FALSE)
                       (input go ?direction))
         =>
         (modify-instance ?f (processed-input TRUE))
         (assert (go ?direction)))
(defrule game::go-north
         ?f <- (go north)
         ?p <- (object (is-a player)
                       (name [self])
                       (current-room ?room))
         (object (is-a room)
                 (name ?room)
                 (north ?north))
         =>
         (retract ?f)
         (assert (go to room north ?north)))

(defrule game::go-south
         ?f <- (go south)
         ?p <- (object (is-a player)
                       (name [self])
                       (current-room ?room))
         (object (is-a room)
                 (name ?room)
                 (south ?south))
         =>
         (retract ?f)
         (assert (go to room south ?south)))
(defrule game::go-west
         ?f <- (go west)
         ?p <- (object (is-a player)
                       (name [self])
                       (current-room ?room))
         (object (is-a room)
                 (name ?room)
                 (west ?west))
         =>
         (retract ?f)
         (assert (go to room west ?west)))
(defrule game::go-east
         ?f <- (go east)
         ?p <- (object (is-a player)
                       (name [self])
                       (current-room ?room))
         (object (is-a room)
                 (name ?room)
                 (east ?east))
         =>
         (retract ?f)
         (assert (go to room east ?east)))

(defrule game::go-to-room:nope
         ?f <- (go to room ?dir FALSE)
         =>
         (retract ?f)
         (printout ?*router-out*
                   "Can't go " ?dir " from this room!" crlf))

(defrule game::go-to-room
         ?f <- (go to room ? ?target&~FALSE)
         =>
         (retract ?f)
         (modify-instance [self]
                          (current-room ?target)))

(defrule game::list-inventory
         ?f <- (object (is-a input-state)
                       (should-prompt FALSE)
                       (processed-input FALSE)
                       (input inventory))
         (object (is-a player)
                 (name [self])
                 (items $?items))
         =>
         (printout ?*router-out*
                   tab "Currently have in inventory:" crlf)
         (progn$ (?item ?items)
                 (printout ?*router-out*
                           tab tab "- " (send ?item get-title) crlf))
         (modify-instance ?f
                          (processed-input TRUE)))

(defrule game::inspect-item
         ?f <- (object (is-a input-state)
                       (should-prompt FALSE)
                       (processed-input FALSE)
                       (input inspect ?item))
         (object (is-a item)
                 (title ?item)
                 (description ?desc)
                 (name ?n))
         (object (is-a player)
                 (name [self])
                 (items $? ?n $?))
         =>
         (modify-instance ?f
                          (processed-input TRUE))
         (printout ?*router-out* tab ?desc crlf))

(defrule game::inspect-item:not-in-inventory
         ?f <- (object (is-a input-state)
                       (should-prompt FALSE)
                       (processed-input FALSE)
                       (input inspect ?item))
         (object (is-a item)
                 (title ?item)
                 (name ?n))
         (object (is-a player)
                 (name [self])
                 (items $?elements&:(not (member$ ?n ?elements))))
         =>
         (modify-instance ?f
                          (processed-input TRUE))
         (printout ?*router-out*
                   tab "This is not an item in your inventory" crlf))

(defrule game::inspect-item:doesn't-exist
         ?f <- (object (is-a input-state)
                       (should-prompt FALSE)
                       (processed-input FALSE)
                       (input inspect ?item))
         (not (exists (object (is-a item)
                              (title ?item))))
         =>
         (modify-instance ?f
                          (processed-input TRUE))
         (printout ?*router-out*
                   tab "This is not an item in your inventory" crlf))

(defrule game::list-rooms
         ?f <- (object (is-a input-state)
                       (should-prompt FALSE)
                       (processed-input FALSE)
                       (input list rooms))
         =>
         (printout ?*router-out*
                   tab "Currently defined rooms" crlf)
         (do-for-all-instances ((?r room))
                               TRUE
                               (printout ?*router-out*
                                         tab tab (instance-name ?r) crlf)))
(defrule game::new-room::with-title
         ?f <- (object (is-a input-state)
                       (should-prompt FALSE)
                       (processed-input FALSE)
                       (input new-room ?room-name&:(symbolp ?room-name)))

         =>
         (modify-instance ?f
                          (processed-input TRUE))
         (printout ?*router-out*
                   "Made a new blank room named: "
                   (make-instance ?room-name of room) crlf))

(defrule game::new-room
         ?f <- (object (is-a input-state)
                       (should-prompt FALSE)
                       (processed-input FALSE)
                       (input new-room))

         =>
         (modify-instance ?f
                          (processed-input TRUE))
         (printout ?*router-out*
                   "Made a new blank room named: "
                   (make-instance of room) crlf))

(defrule game::set-title
         ?f <- (object (is-a input-state)
                       (should-prompt FALSE)
                       (processed-input FALSE)
                       (input set-title ?room ?title))
         (object (is-a room)
                 (name ?room))
         =>
         (modify-instance ?f
                          (processed-input TRUE))
         (modify-instance ?room
                          (title ?title))
         (printout ?*router-out*
                   "Set " ?room " to " ?title crlf))

error: pathspec 'games/dev/rooms.clp' did not match any file(s) known to git


Simplified the extended memory analysis rules by adding more of them

I realized that the rules checking load to store, store to store, and store to
load were a tad complex in that a bunch of data was generated but never
actually used until the third conditional element was evaluated in the network.
The problem with this layout is that it is possible to do partial evaluation
as we are matching. Thus, I created rules that generated unconditional
dependency for the following load and store instructions if the target Load
or Store had an unknown memory dependency. This reduces the total number of
matches for each rule. The flip side is that I have to introduce the parent
basic block and use a multifield match ($? ?t0 $? ?t1 $?) to find the elements
that come after ?t0 that are stores and loads.

For the cases when the memory target was not UNKNOWN I set it up so that it
used the same basic block acquisition method but just checked the MemoryTarget
of the second instruction to check to see if it is the same symbol. This change
seems to make the code significantly simpler (and by proxy somewhat faster).

;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.
;------------------------------------------------------------------------------
; BlockDependencyCreation.clp - Contains rules pertaining to the creation of
; data dependencies between different instructions inside of a basic block
; Written by Joshua Scoggins (7/1/2012)
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis::MarkLocalDependency-Call
			(declare (salience 1))
			(object (is-a CallInstruction) (parent ?p) (id ?t0)
					  (ArgumentOperands $? ?o $?))
			(object (is-a Instruction) (id ?o) (parent ?p))
			=>
			(assert (message (to dependency-analysis)
								  (action instruction-produces)
								  (arguments ?o => ?t0))
					  (message (to dependency-analysis)
								  (action instruction-consumes)
								  (arguments ?t0 => ?o))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis::MarkLocalDependency
			?i0 <- (object (is-a Instruction&~CallInstruction) (parent ?p) (id ?t0)
								(Operands $? ?o $?))
			(object (is-a Instruction) (id ?o) (parent ?p))
			=>
			(assert (message (to dependency-analysis)
								  (action instruction-produces)
								  (arguments ?o => ?t0))
					  (message (to dependency-analysis)
								  (action instruction-consumes)
								  (arguments ?t0 => ?o))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis::MarkInstructionsThatHappenBeforeCall-WritesToMemory
			(object (is-a BasicBlock) (id ?v) (contents $?before ?n0 $?))
			(object (is-a CallInstruction) (id ?n0) (parent ?v)
					  (MayWriteToMemory TRUE))
			=>
			(progn$ (?n1 ?before)
					  (assert (message (to dependency-analysis)
											 (action instruction-produces)
											 (arguments ?n1 => ?n0))
								 (message (to dependency-analysis)
											 (action instruction-consumes)
											 (arguments ?n0 => ?n1)))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis::MarkInstructionsThatHappenBeforeCall-HasSideEffects
			(Stage Analysis $?)
			(object (is-a BasicBlock) (id ?p) (contents $?a ?n0 $?))
			(object (is-a CallInstruction) (id ?n0) (parent ?p)
					  (MayHaveSideEffects TRUE))
			=>
			(progn$ (?n1 ?a)
					  (assert (message (to dependency-analysis)
											 (action instruction-produces)
											 (arguments ?n1 => ?n0))
								 (message (to dependency-analysis)
											 (action instruction-consumes)
											 (arguments ?n0 => ?n1)))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis::MarkCallInstructionDependency-ModifiesMemory
			"Creates a series of dependencies for all instructions following a
			call instruction if it turns out that the call could modify memory."
			(object (is-a BasicBlock) (id ?p) (contents $? ?name $?rest))
			(object (is-a CallInstruction) (id ?name) (parent ?p)
					  (MayWriteToMemory TRUE))
			=>
			(assert (message (to dependency-analysis)
								  (action element-has-a-call-barrier)
								  (arguments ?p)))
			(progn$ (?following ?rest)
					  (assert (message (to dependency-analysis)
											 (action instruction-has-a-call-barrier)
											 (arguments ?following))
								 ;(message (to dependency-analysis)
								 ;	      (action instruction-consumes)
								 ;		   (arguments ?following => ?name))
								 (message (to dependency-analysis)
											 (action instruction-produces)
											 (arguments ?name => ?following)))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis::MarkCallInstructionDependency-InlineAsm
			"Creates a series of dependencies for all instructions following a
			call instruction if it turns out that the call is inline asm."
			(object (is-a BasicBlock) (id ?p) (contents $? ?name $?rest))
			(object (is-a CallInstruction) (id ?name) (parent ?p)
					  (IsInlineAsm TRUE))
			=>
			(assert (message (to dependency-analysis)
								  (action element-has-a-call-barrier)
								  (arguments ?p)))
			(progn$ (?following ?rest)
					  (assert (message (to dependency-analysis)
											 (action instruction-has-a-call-barrier)
											 (arguments ?following))
								 ;(message (to dependency-analysis)
								 ;	      (action instruction-consumes)
								 ;		   (arguments ?following => ?name))
								 (message (to dependency-analysis)
											 (action instruction-produces)
											 (arguments ?name => ?following)))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis::MarkCallInstructionDependency-SideEffects
			"Creates a series of dependencies for all instructions following a
			call instruction if it turns out that the call has side effects."
			(object (is-a CallInstruction) (id ?name) (parent ?p)
					  (MayHaveSideEffects TRUE))
			(object (is-a BasicBlock) (id ?p) (contents $? ?name $?rest))
			=>
			(assert (message (to dependency-analysis)
								  (action element-has-a-call-barrier)
								  (arguments ?p)))
			(progn$ (?following ?rest)
					  (assert (message (to dependency-analysis)
											 (action instruction-has-a-call-barrier)
											 (arguments ?following))
								 ;(message (to dependency-analysis)
								 ;	      (action instruction-consumes)
								 ;		   (arguments ?following => ?name))
								 (message (to dependency-analysis)
											 (action instruction-produces)
											 (arguments ?name => ?following)))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis-update::FlagCallBarrierForDiplomat-HasParent
			;(declare (salience -10))
			?fct <- (message (to dependency-analysis)
								  (action element-has-a-call-barrier)
								  (arguments ?z))
			?d <- (object (is-a Diplomat) (id ?z) (parent ?p)
							  (HasCallBarrier FALSE))
			(exists (object (is-a Diplomat) (id ?p)))
			=>
			(retract ?fct)
			(assert (message (to dependency-analysis)
								  (action element-has-a-call-barrier)
								  (arguments ?p)))
			(modify-instance ?d (HasCallBarrier TRUE)))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis-update::PropagateCallBarrierForDiplomat-HasParent
			;(declare (salience -10))
			?fct <- (message (to dependency-analysis)
								  (action element-has-a-call-barrier)
								  (arguments ?z))
			?d <- (object (is-a Diplomat) (id ?z) (parent ?p)
							  (HasCallBarrier TRUE))
			(exists (object (is-a Diplomat) (id ?p)))
			=>
			(retract ?fct)
			(assert (message (to dependency-analysis)
								  (action element-has-a-call-barrier)
								  (arguments ?p))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis-update::FlagCallBarrierForDiplomat-NoParent
			;(declare (salience -10))
			?fct <- (message (to dependency-analysis)
								  (action element-has-a-call-barrier)
								  (arguments ?z))
			?d <- (object (is-a Diplomat) (id ?z) (parent ?p)
							  (HasCallBarrier FALSE))
			(not (exists (object (is-a Diplomat) (id ?p))))
			=>
			(retract ?fct)
			(modify-instance ?d (HasCallBarrier TRUE)))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis-update::PropagateCallBarrierForDiplomat-NoParent
			;(declare (salience -10))
			?fct <- (message (to dependency-analysis)
								  (action element-has-a-call-barrier)
								  (arguments ?z))
			?d <- (object (is-a Diplomat) (id ?z) (parent ?p)
							  (HasCallBarrier TRUE))
			(not (exists (object (is-a Diplomat) (id ?p))))
			=>
			(retract ?fct))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis-update::MarkHasACallDependency-Set
			?fct <- (message (to dependency-analysis)
								  (action instruction-has-a-call-barrier)
								  (arguments ?target))
			?inst <- (object (is-a Instruction) (id ?target)
								  (HasCallDependency FALSE))
			=>
			(retract ?fct)
			(modify-instance ?inst (HasCallDependency TRUE)))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis-update::MarkHasACallDependency-Ignore
			?fct <- (message (to dependency-analysis)
								  (action instruction-has-a-call-barrier)
								  (arguments ?target))
			?inst <- (object (is-a Instruction) (id ?target)
								  (HasCallDependency TRUE))
			=>
			(retract ?fct))
;------------------------------------------------------------------------------
(defrule dependency-analysis-extended-memory-analysis::StoreDependency-UNKNOWN
			(object (is-a StoreInstruction)
					  (MemoryTarget UNKNOWN)
					  (id ?t0)
					  (parent ?p))
			(object (is-a BasicBlock)
					  (id ?p)
					  (contents $? ?t0 $? ?t1 $?))
			(object (is-a StoreInstruction|LoadInstruction)
					  (id ?t1))
			=>
			(assert (message (to dependency-analysis)
								  (action instruction-consumes)
								  (arguments ?t1 => ?t0))
					  (message (to dependency-analysis)
								  (action instruction-produces)
								  (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-extended-memory-analysis::LoadDependency-UNKNOWN
			(object (is-a LoadInstruction)
					  (parent ?p)
					  (id ?t0)
					  (MemoryTarget UNKNOWN))
			(object (is-a BasicBlock)
					  (id ?p)
					  (contents $? ?t0 $? ?t1 $?))
			(object (is-a StoreInstruction)
					  (id ?t1))
			=>
			(assert (message (to dependency-analysis)
								  (action instruction-consumes)
								  (arguments ?t1 => ?t0))
					  (message (to dependency-analysis)
								  (action instruction-produces)
								  (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-extended-memory-analysis::Store=>LoadDependency
			(object (is-a StoreInstruction)
					  (parent ?p)
					  (id ?t0)
					  (MemoryTarget ?sym0&~UNKNOWN))
			(object (is-a BasicBlock)
					  (id ?p)
					  (contents $? ?t0 $? ?t1 $?))
			(object (is-a LoadInstruction)
					  (parent ?p)
					  (id ?t1)
					  (MemoryTarget ?sym0))
			=>
			(assert (message (to dependency-analysis)
								  (action instruction-consumes)
								  (arguments ?t1 => ?t0))
					  (message (to dependency-analysis)
								  (action instruction-produces)
								  (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-extended-memory-analysis::Store=>StoreDependency
			(object (is-a StoreInstruction)
					  (parent ?p)
					  (id ?t0)
					  (MemoryTarget ?sym0&~UNKNOWN))
			(object (is-a BasicBlock)
					  (id ?p)
					  (contents $? ?t0 $? ?t1 $?))
			(object (is-a StoreInstruction)
					  (id ?t1)
					  (MemoryTarget ?sym0))
			=>
			(assert (message (to dependency-analysis)
								  (action instruction-consumes)
								  (arguments ?t1 => ?t0))
					  (message (to dependency-analysis)
								  (action instruction-produces)
								  (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-extended-memory-analysis::Load=>StoreDependency
			(object (is-a LoadInstruction)
					  (parent ?p)
					  (id ?t0)
					  (MemoryTarget ?sym0&~UNKNOWN))
			(object (is-a BasicBlock)
					  (id ?p)
					  (contents $? ?t0 $? ?t1 $?))
			(object (is-a StoreInstruction)
					  (id ?t1)
					  (MemoryTarget ?sym0))
			=>
			(assert (message (to dependency-analysis)
								  (action instruction-consumes)
								  (arguments ?t1 => ?t0))
					  (message (to dependency-analysis)
								  (action instruction-produces)
								  (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------

;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.
;------------------------------------------------------------------------------
; BlockDependencyCreation.clp - Contains rules pertaining to the creation of
; data dependencies between different instructions inside of a basic block
; Written by Joshua Scoggins (7/1/2012)
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis::MarkLocalDependency-Call
			(declare (salience 1))
			(object (is-a CallInstruction) (parent ?p) (id ?t0)
					  (ArgumentOperands $? ?o $?))
			(object (is-a Instruction) (id ?o) (parent ?p))
			=>
			(assert (message (to dependency-analysis)
								  (action instruction-produces)
								  (arguments ?o => ?t0))
					  (message (to dependency-analysis)
								  (action instruction-consumes)
								  (arguments ?t0 => ?o))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis::MarkLocalDependency
			?i0 <- (object (is-a Instruction&~CallInstruction) (parent ?p) (id ?t0)
								(Operands $? ?o $?))
			(object (is-a Instruction) (id ?o) (parent ?p))
			=>
			(assert (message (to dependency-analysis)
								  (action instruction-produces)
								  (arguments ?o => ?t0))
					  (message (to dependency-analysis)
								  (action instruction-consumes)
								  (arguments ?t0 => ?o))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis::MarkInstructionsThatHappenBeforeCall-WritesToMemory
			(object (is-a BasicBlock) (id ?v) (contents $?before ?n0 $?))
			(object (is-a CallInstruction) (id ?n0) (parent ?v)
					  (MayWriteToMemory TRUE))
			=>
			(progn$ (?n1 ?before)
					  (assert (message (to dependency-analysis)
											 (action instruction-produces)
											 (arguments ?n1 => ?n0))
								 (message (to dependency-analysis)
											 (action instruction-consumes)
											 (arguments ?n0 => ?n1)))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis::MarkInstructionsThatHappenBeforeCall-HasSideEffects
			(Stage Analysis $?)
			(object (is-a BasicBlock) (id ?p) (contents $?a ?n0 $?))
			(object (is-a CallInstruction) (id ?n0) (parent ?p)
					  (MayHaveSideEffects TRUE))
			=>
			(progn$ (?n1 ?a)
					  (assert (message (to dependency-analysis)
											 (action instruction-produces)
											 (arguments ?n1 => ?n0))
								 (message (to dependency-analysis)
											 (action instruction-consumes)
											 (arguments ?n0 => ?n1)))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis::MarkCallInstructionDependency-ModifiesMemory
			"Creates a series of dependencies for all instructions following a
			call instruction if it turns out that the call could modify memory."
			(object (is-a BasicBlock) (id ?p) (contents $? ?name $?rest))
			(object (is-a CallInstruction) (id ?name) (parent ?p)
					  (MayWriteToMemory TRUE))
			=>
			(assert (message (to dependency-analysis)
								  (action element-has-a-call-barrier)
								  (arguments ?p)))
			(progn$ (?following ?rest)
					  (assert (message (to dependency-analysis)
											 (action instruction-has-a-call-barrier)
											 (arguments ?following))
								 ;(message (to dependency-analysis)
								 ;	      (action instruction-consumes)
								 ;		   (arguments ?following => ?name))
								 (message (to dependency-analysis)
											 (action instruction-produces)
											 (arguments ?name => ?following)))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis::MarkCallInstructionDependency-InlineAsm
			"Creates a series of dependencies for all instructions following a
			call instruction if it turns out that the call is inline asm."
			(object (is-a BasicBlock) (id ?p) (contents $? ?name $?rest))
			(object (is-a CallInstruction) (id ?name) (parent ?p)
					  (IsInlineAsm TRUE))
			=>
			(assert (message (to dependency-analysis)
								  (action element-has-a-call-barrier)
								  (arguments ?p)))
			(progn$ (?following ?rest)
					  (assert (message (to dependency-analysis)
											 (action instruction-has-a-call-barrier)
											 (arguments ?following))
								 ;(message (to dependency-analysis)
								 ;	      (action instruction-consumes)
								 ;		   (arguments ?following => ?name))
								 (message (to dependency-analysis)
											 (action instruction-produces)
											 (arguments ?name => ?following)))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis::MarkCallInstructionDependency-SideEffects
			"Creates a series of dependencies for all instructions following a
			call instruction if it turns out that the call has side effects."
			(object (is-a CallInstruction) (id ?name) (parent ?p)
					  (MayHaveSideEffects TRUE))
			(object (is-a BasicBlock) (id ?p) (contents $? ?name $?rest))
			=>
			(assert (message (to dependency-analysis)
								  (action element-has-a-call-barrier)
								  (arguments ?p)))
			(progn$ (?following ?rest)
					  (assert (message (to dependency-analysis)
											 (action instruction-has-a-call-barrier)
											 (arguments ?following))
								 ;(message (to dependency-analysis)
								 ;	      (action instruction-consumes)
								 ;		   (arguments ?following => ?name))
								 (message (to dependency-analysis)
											 (action instruction-produces)
											 (arguments ?name => ?following)))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis-update::FlagCallBarrierForDiplomat-HasParent
			;(declare (salience -10))
			?fct <- (message (to dependency-analysis)
								  (action element-has-a-call-barrier)
								  (arguments ?z))
			?d <- (object (is-a Diplomat) (id ?z) (parent ?p)
							  (HasCallBarrier FALSE))
			(exists (object (is-a Diplomat) (id ?p)))
			=>
			(retract ?fct)
			(assert (message (to dependency-analysis)
								  (action element-has-a-call-barrier)
								  (arguments ?p)))
			(modify-instance ?d (HasCallBarrier TRUE)))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis-update::PropagateCallBarrierForDiplomat-HasParent
			;(declare (salience -10))
			?fct <- (message (to dependency-analysis)
								  (action element-has-a-call-barrier)
								  (arguments ?z))
			?d <- (object (is-a Diplomat) (id ?z) (parent ?p)
							  (HasCallBarrier TRUE))
			(exists (object (is-a Diplomat) (id ?p)))
			=>
			(retract ?fct)
			(assert (message (to dependency-analysis)
								  (action element-has-a-call-barrier)
								  (arguments ?p))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis-update::FlagCallBarrierForDiplomat-NoParent
			;(declare (salience -10))
			?fct <- (message (to dependency-analysis)
								  (action element-has-a-call-barrier)
								  (arguments ?z))
			?d <- (object (is-a Diplomat) (id ?z) (parent ?p)
							  (HasCallBarrier FALSE))
			(not (exists (object (is-a Diplomat) (id ?p))))
			=>
			(retract ?fct)
			(modify-instance ?d (HasCallBarrier TRUE)))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis-update::PropagateCallBarrierForDiplomat-NoParent
			;(declare (salience -10))
			?fct <- (message (to dependency-analysis)
								  (action element-has-a-call-barrier)
								  (arguments ?z))
			?d <- (object (is-a Diplomat) (id ?z) (parent ?p)
							  (HasCallBarrier TRUE))
			(not (exists (object (is-a Diplomat) (id ?p))))
			=>
			(retract ?fct))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis-update::MarkHasACallDependency-Set
			?fct <- (message (to dependency-analysis)
								  (action instruction-has-a-call-barrier)
								  (arguments ?target))
			?inst <- (object (is-a Instruction) (id ?target)
								  (HasCallDependency FALSE))
			=>
			(retract ?fct)
			(modify-instance ?inst (HasCallDependency TRUE)))
;------------------------------------------------------------------------------
(defrule dependency-analysis-analysis-update::MarkHasACallDependency-Ignore
			?fct <- (message (to dependency-analysis)
								  (action instruction-has-a-call-barrier)
								  (arguments ?target))
			?inst <- (object (is-a Instruction) (id ?target)
								  (HasCallDependency TRUE))
			=>
			(retract ?fct))
;------------------------------------------------------------------------------
(defrule dependency-analysis-extended-memory-analysis::StoreToLoadDependency
			(object (is-a StoreInstruction) (parent ?p) (id ?t0)
					  (TimeIndex ?ti0) (MemoryTarget ?sym0))
			(object (is-a LoadInstruction) (parent ?p) (id ?t1)
					  (TimeIndex ?ti1&:(< ?ti0 ?ti1)) (MemoryTarget ?sym1))
			(test (or (eq ?sym0 ?sym1) (eq ?sym0 UNKNOWN)))
			=>
			(assert (message (to dependency-analysis)
								  (action instruction-consumes)
								  (arguments ?t1 => ?t0))
					  (message (to dependency-analysis)
								  (action instruction-produces)
								  (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-extended-memory-analysis::StoreToStoreDependency
			(object (is-a StoreInstruction) (parent ?p) (id ?t0)
					  (TimeIndex ?ti0) (MemoryTarget ?sym0))
			(object (is-a StoreInstruction) (parent ?p) (id ?t1)
					  (TimeIndex ?ti1&:(< ?ti0 ?ti1)) (MemoryTarget ?sym1))
			(test (or (eq ?sym0 ?sym1) (eq ?sym0 UNKNOWN)))
			=>
			(assert (message (to dependency-analysis)
								  (action instruction-consumes)
								  (arguments ?t1 => ?t0))
					  (message (to dependency-analysis)
								  (action instruction-produces)
								  (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------
(defrule dependency-analysis-extended-memory-analysis::LoadToStoreDependency
			(object (is-a LoadInstruction) (parent ?p) (id ?t0)
					  (TimeIndex ?ti0) (MemoryTarget ?sym0))
			(object (is-a StoreInstruction) (parent ?p) (id ?t1)
					  (TimeIndex ?ti1&:(< ?ti0 ?ti1)) (MemoryTarget ?sym1))
			(test (or (eq ?sym0 ?sym1) (eq ?sym0 UNKNOWN)))
			=>
			(assert (message (to dependency-analysis)
								  (action instruction-consumes)
								  (arguments ?t1 => ?t0))
					  (message (to dependency-analysis)
								  (action instruction-produces)
								  (arguments ?t0 => ?t1))))
;------------------------------------------------------------------------------


Removed the commented out code for Hint.clp as it's no longer necessary.

Using the doom sector trick I can get paths through a loop without needing to
figure out where the backedge is :D.

;------------------------------------------------------------------------------
; Hint.clp - Contains the basic hint type plus a few ease of access sub types
;            Hints are my way of quickly creating objects that map a single
;            object to a series of other objects. A hint also contains a type
;            field that allows hints to be further constrained by another type.
;            Suprisingly enough hints are quite useful as they allow facts to
;            be created with a minimal amount of effort yet are very expressive
;            in their contents.
;
;            They can also keep track of the number of references they have
; Written by Joshua Scoggins
;------------------------------------------------------------------------------
(defclass Hint (is-a List)
 (slot Type (visibility public) (default nil))
 (slot Point (default nil))
 (slot ReferenceCount (visibility public) (type NUMBER)))

(defmessage-handler Hint .IncrementReferenceCount ()
 (bind ?self:ReferenceCount (+ ?self:ReferenceCount 1)))

(defmessage-handler Hint .DecrementReferenceCount ()
 (bind ?self:ReferenceCount (- ?self:ReferenceCount 1)))
;------------------------------------------------------------------------------
(deffunction hints-of-type-with-point (?type ?point)
 "Gets all hints with the specified type and point"
 (find-all-instances ((?h Hint)) (and (eq ?type (send ?h get-Type))
											 (eq ?point (send ?h get-Point)))))
;------------------------------------------------------------------------------
(deffunction hints-of-type (?type)
 "Returns all hints of a given type"
 (find-all-instances ((?h Hint)) (eq ?type (send ?h get-Type))))
;------------------------------------------------------------------------------
(deffunction hintp (?instance)
 (if (or (instance-namep ?instance)
		(instance-addressp ?instance)) then
  (bind ?conv ?instance)
  else
  (bind ?conv (symbol-to-instance-name ?instance)))
 (return (eq (class ?conv) Hint)))
;------------------------------------------------------------------------------
(defclass Path (is-a Hint)
 (slot ExitBlock (type SYMBOL))
 (slot Closed (type SYMBOL) (allowed-values FALSE TRUE)))

(defmessage-handler Path init after ()
 (bind ?self:Type Path))

;------------------------------------------------------------------------------
(defclass Hierarchy (is-a Hint))

(defmessage-handler Hierarchy init after ()
 (bind ?self:Type Hierarchy))

;------------------------------------------------------------------------------
(defclass FrequencyAnalysis (is-a Hint)
 (slot Frequency (type NUMBER) (range 0 ?VARIABLE)))

(defmessage-handler FrequencyAnalysis init after ()
 (bind ?self:Type FrequencyAnalysis))

(defmessage-handler FrequencyAnalysis .IncrementFrequency ()
 (bind ?self:Frequency (+ 1 ?self:Frequency)))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
; Hint.clp - Contains the basic hint type plus a few ease of access sub types
;            Hints are my way of quickly creating objects that map a single
;            object to a series of other objects. A hint also contains a type
;            field that allows hints to be further constrained by another type.
;            Suprisingly enough hints are quite useful as they allow facts to
;            be created with a minimal amount of effort yet are very expressive
;            in their contents.
;
;            They can also keep track of the number of references they have
; Written by Joshua Scoggins
;------------------------------------------------------------------------------
(defclass Hint (is-a List)
 (slot Type (visibility public) (default nil))
 (slot Point (default nil))
 (slot ReferenceCount (visibility public) (type NUMBER)))

(defmessage-handler Hint .IncrementReferenceCount ()
 (bind ?self:ReferenceCount (+ ?self:ReferenceCount 1)))

(defmessage-handler Hint .DecrementReferenceCount ()
 (bind ?self:ReferenceCount (- ?self:ReferenceCount 1)))
;------------------------------------------------------------------------------
(deffunction hints-of-type-with-point (?type ?point)
 "Gets all hints with the specified type and point"
 (find-all-instances ((?h Hint)) (and (eq ?type (send ?h get-Type))
											 (eq ?point (send ?h get-Point)))))
;------------------------------------------------------------------------------
(deffunction hints-of-type (?type)
 "Returns all hints of a given type"
 (find-all-instances ((?h Hint)) (eq ?type (send ?h get-Type))))
;------------------------------------------------------------------------------
(deffunction hintp (?instance)
 (if (or (instance-namep ?instance)
		(instance-addressp ?instance)) then
  (bind ?conv ?instance)
  else
  (bind ?conv (symbol-to-instance-name ?instance)))
 (return (eq (class ?conv) Hint)))
;------------------------------------------------------------------------------
(defclass Path (is-a Hint)
 (slot ExitBlock (type SYMBOL))
 (slot Closed (type SYMBOL) (allowed-values FALSE TRUE)))
; (multislot BackEdgesVisited))

(defmessage-handler Path init after ()
 (bind ?self:Type Path))

;(defmessage-handler Path .AddBackEdge (?be)
; (bind ?self:BackEdgesVisited (create$ ?self:BackEdgesVisited ?be)))
;------------------------------------------------------------------------------
(defclass Hierarchy (is-a Hint))

(defmessage-handler Hierarchy init after ()
 (bind ?self:Type Hierarchy))

;------------------------------------------------------------------------------
(defclass FrequencyAnalysis (is-a Hint)
 (slot Frequency (type NUMBER) (range 0 ?VARIABLE)))

(defmessage-handler FrequencyAnalysis init after ()
 (bind ?self:Type FrequencyAnalysis))

(defmessage-handler FrequencyAnalysis .IncrementFrequency ()
 (bind ?self:Frequency (+ 1 ?self:Frequency)))
;------------------------------------------------------------------------------


Add chapter 2 tasks

Add chapter 2 tasks

// First task
// Students
(deffacts students
         (student LelyakinMA 4)
         (student ArutunyaAS 4)
         (student KefalicsAI 1)
         (student BelokobylskySA 2)
)

(facts)

(retract 2)
(retract 3)

(assert (student KefalicsAI 2))

(facts)

// Trains
(deffacts trains
          (train 11 Saratov 11)
          (train 22 Engels 21)
          (train 33 Kazan 22)
)

(assert (train 44 Samara 10))
(assert (train 55 Volgograd 08))

(retract 1 4)

(retract 2 3)

(assert (train 22 Moscow 01))
(assert (train 33 Kazan 00))

// Employees
(assert (sotrudnik LelyakinMA 1)
        (sotrudnik GerasimovVD 2)
        (sotrudnik VonnegutKG 3)
        (sotrudnik PushkinAS 3)
)

(retract 1)

(retract 3)
(assert (sotrudnik VasilevKD 3))

// Products
(assert (IceCream Russia 10 1)
		(ApelsineJuce Russia 20 2)
		(WaterMelone Russia 30 3)
		(Liberty USA 1000 99)
)

(facts)

(retract 2)
(ApelsineJuce Russia 19 2)

(retract 4)
(Liberty USA 0 99)

// First task
(deffacts students
         (student LelyakinMA 4)
         (student ArutunyaAS 4)
         (student KefalicsAI 1)
         (student BelokobylskySA 2)
)

(facts)

(retract 2)
(retract 3)

(assert (student KefalicsAI 2))

(facts)


Added a simple run script to make things easier to keep track of

(batch* constants.clp)
(batch* core.clp)
(batch* configuration.clp)
(batch* world.clp)
(batch* prompt.clp)
; code goes here
(batch* init.clp)
(reset)
(run)
;(exit)

error: pathspec 'run.clp' did not match any file(s) known to git