Fixed bugs in WavefrontInstructionMerging.clp

;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; Contains rules associated with the act of actually scheduling instructions
; into blocks on the wavefront
;
; Written by Joshua Scoggins
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::AssertScheduleCPVIntoTargetBlock
         (object (is-a Wavefront)
                 (values $? ?e $?))
         (object (is-a Diplomat)
                 (id ?e)
                 (IsOpen TRUE))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e)
                           (MovableCompensationPathVectors
                             $?cpvs&:(<> 0 (length$ $?cpvs))))
         =>
         (modify-instance ?agObj (MovableCompensationPathVectors))
         (progn$ (?cpv $?cpvs)
                 (assert (message (to wavefront-scheduling)
                                  (action determine-schedule-style)
                                  (arguments ?cpv => ?e)))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::ScheduleStyleForCPVIsMove
         "This rule attempts to determine if the CPV should be moved into the
         given block on the wavefront. If this is true then the fact to perform
         this action will be asserted"
         ?fct <- (message (to wavefront-scheduling)
                          (action determine-schedule-style)
                          (arguments ?cpv => ?e))
         (object (is-a BasicBlock)
                 (id ?e)
                 (Paths $?paths))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (Paths $?cpvPaths))
         ;the two sets are the same
         (test (equal$ ?paths ?cpvPaths))
         =>
         ;change the action...nothing more :D
         (modify ?fct (action move-instruction)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::ScheduleStyleForCPVIsCompensate
         "This rule attempts to determine if the CPV should be copied into the
         given block on the wavefront. If this is true then the fact to perform
         this action will be asserted."
         ?fct <- (message (to wavefront-scheduling)
                          (action determine-schedule-style)
                          (arguments ?cpv => ?e))
         (object (is-a BasicBlock)
                 (id ?e)
                 (Paths $?paths))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (Paths $?cpvPaths))
         ;there are more paths in the CPV than in the block
         (test (subsetp ?paths ?cpvPaths))
         =>
         (modify ?fct (action clone-instruction)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::RemoveScheduleStyleForCPV
         (declare (salience 1))
         ?fct <- (message (to wavefront-scheduling)
                          (action determine-schedule-style)
                          (arguments ?cpv => ?e))
         (object (is-a BasicBlock)
                 (id ?e)
                 (Paths $?paths))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (parent ?i)
                 (Paths $?cpvPaths))
         (test (not (subsetp ?paths ?cpvPaths)))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e)
                           (InstructionList $?il))
         =>
         ;TODO: Put code in here to delete a given instruction from the target
         ;      instruction list as well.
         ;
         ; Eventually, I will detect if we are in a loop. If we are then it is
         ; necessary to figure out which paths remain in the loop and those
         ; that exit.
         ;this should prevent a potential infinite loop
         ;(printout t "Preventing " ?i " from being scheduled into " ?e crlf)
         (retract ?fct)
         (bind ?ind (member$ ?i $?il))
         (if ?ind then (slot-delete$ ?agObj InstructionList ?ind ?ind)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::MoveInstructionIntoBlock
         "Moves the given object into bottom of the given block"
         ?fct <- (message (to wavefront-scheduling)
                          (action move-instruction)
                          (arguments ?cpv => ?e))
         ?newBlock <- (object (is-a BasicBlock)
                              (id ?e)
                              (contents $?blockBefore ?last)
                              (Produces $?nBProds))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e)
                           (InstructionPropagation $?agIP)
                           (ScheduledInstructions $?agSI)
                           (ReplacementActions $?agRA))
         ?terminator <- (object (is-a TerminatorInstruction)
                                (pointer ?tPtr)
                                (id ?last)
                                (TimeIndex ?ti)
                                (parent ?e))
         ?cpvObject <- (object (is-a CompensationPathVector)
                               (id ?cpv)
                               (parent ?inst)
                               (ScheduleTargets $?cpvST)
                               (Aliases $?cpvAliases))
         ?newInst <- (object (is-a Instruction)
                             (id ?inst)
                             (pointer ?nPtr)
                             (parent ?otherBlock)
                             (DestinationRegisters ?register)
                             (Consumers $?niConsumers)
                             (class ?class))
         ?oldBlock <- (object (is-a BasicBlock)
                              (id ?otherBlock)
                              (Produces $?pBefore ?inst $?pRest)
                              (contents $?before ?inst $?rest))
         ;TODO: add another rule where we have to update the consumers list as
         ;      well
         =>
         (object-pattern-match-delay
           ;(printout t "Scheduled " ?inst " into " ?e crlf)
           (modify-instance ?terminator (TimeIndex (+ ?ti 1)))
           ;(modify-instance ?newBlock (Produces ?nBProds ?register))
           (modify-instance ?oldBlock (contents $?before $?rest)
                            (Produces $?pBefore $?pRest))
           ;(modify-instance ?cpvObject (Paths))
           (modify ?fct (action remove-evidence)
                   (arguments ?inst => $?niConsumers))
           (assert (message (to wavefront-scheduling)
                            (action recompute-block)
                            (arguments ?otherBlock)))
           (if (eq StoreInstruction ?class) then
             (modify-instance ?agObj
                              (ScheduledInstructions $?agSI ?inst ?register)
                              (ReplacementActions $?agRA ?inst ?inst !))
             ;(slot-insert$ ?agObj ScheduledInstructions 1 ?inst ?register)
             (modify-instance ?newBlock
                              (Produces $?nBProds ?register)
                              (contents $?blockBefore ?inst ?last))
             (modify-instance ?cpvObject
                              (Paths)
                              (ScheduleTargets ?cpvST ?e ?inst)
                              (Aliases $?cpvAliases ?inst ?e))
             (llvm-unlink-and-move-instruction-before ?nPtr ?tPtr)
             ;(slot-insert$ ?cpvObject ScheduleTargets 1 ?e ?inst)
             ;(slot-insert$ ?cpvObject Aliases 1 ?inst ?e)
             ;(slot-insert$ ?agObj ReplacementActions 1 ?inst ?inst !)
             else
             (bind ?newName (sym-cat movedinstruction. (gensym*) . ?inst))
             (modify-instance ?cpvObject (Paths)
                              (ScheduleTargets ?cpvST ?e ?newName)
                              (Aliases ?cpvAliases ?newName ?e))
             ;(slot-insert$ ?cpvObject ScheduleTargets 1 ?e ?newName)
             ;(slot-insert$ ?cpvObject Aliases 1 ?newName ?e)
             ;(slot-insert$ ?agObj ReplacementActions 1 ?inst ?newName !)
             (modify-instance ?newBlock
                              (Produces $?nBProds ?register)
                              (contents $?blockBefore ?newName ?last))
             (bind ?newPtr (llvm-clone-instruction ?nPtr ?newName))
             ;purge the list of producers and consumers
             (duplicate-instance ?inst to ?newName
                                 (id ?newName)
                                 (Name ?newName)
                                 (pointer ?newPtr)
                                 (Producers)
                                 (Consumers)
                                 (NonLocalDependencies)
                                 (LocalDependencies)
                                 (TimeIndex ?ti)
                                 (parent ?e))
             (llvm-move-instruction-before ?newPtr ?tPtr)
             (slot-insert$ ?oldBlock UnlinkedInstructions 1 ?inst)
             (modify-instance ?agObj (ReplacementActions $?agRA ?inst ?newName !)
                              (InstructionPropagation $?agIP ?inst ?newName ?e !)
                              (ScheduledInstructions $?agSI ?inst)))))
;(slot-insert$ ?agObj InstructionPropagation 1 ?inst ?newName ?e !)
;(slot-insert$ ?agObj ScheduledInstructions 1 ?inst))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::CloneInstructionIntoBlock
         "Moves the given object into bottom of the given block"
         ?fct <- (message (to wavefront-scheduling)
                          (action clone-instruction)
                          (arguments ?cpv => ?e))
         ?newBlock <- (object (is-a BasicBlock)
                              (id ?e)
                              (contents $?blockBefore ?last))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e))
         ?terminator <- (object (is-a TerminatorInstruction)
                                (pointer ?tPtr)
                                (id ?last)
                                (TimeIndex ?ti)
                                (parent ?e))
         ?cpvObject <- (object (is-a CompensationPathVector)
                               (id ?cpv)
                               (parent ?inst)
                               (Paths $?cpvPaths))
         ?newInst <- (object (is-a Instruction)
                             (id ?inst)
                             (pointer ?nPtr)
                             (parent ?otherBlock)
                             (DestinationRegisters ?register)
                             (class ?class))
         =>
         ;we also need to update all CPVs within
         (object-pattern-match-delay
           (bind ?newName (sym-cat compensation.copy. (gensym*) . ?inst))
           ;(printout t "Scheduled " ?inst " into " ?e " from " ?otherBlock
           ;            " as " ?newName crlf)
           (bind ?newPtr (llvm-clone-instruction ?nPtr ?newName))
           ;purge the list of producers and consumers
           (duplicate-instance ?inst to ?newName
                               (id ?newName)
                               (Name ?newName)
                               (pointer ?newPtr)
                               (parent ?e)
                               (TimeIndex (+ ?ti 1)))
           (llvm-move-instruction-before ?newPtr ?tPtr)
           ;we add the original name so that we don't have to do
           ; an insane number of updates to the CPVs that follow
           ; this object
           (if (eq StoreInstruction ?class) then
             (slot-insert$ ?agObj ScheduledInstructions 1 ?inst ?register)
             else
             (slot-insert$ ?agObj InstructionPropagation 1 ?inst ?newName ?e !)
             (slot-insert$ ?agObj ScheduledInstructions 1 ?inst))
           (slot-insert$ ?newBlock Produces 1 ?register)
           (modify-instance ?newBlock (contents $?blockBefore ?newName ?last))
           (slot-insert$ ?cpvObject ScheduleTargets 1 ?e ?newName)
           (slot-insert$ ?cpvObject Aliases 1 ?newName ?e)
           (slot-insert$ ?agObj ReplacementActions 1 ?inst ?newName !)
           (modify ?fct (action recompute-block)
                   (arguments ?otherBlock))
           (assert (message (to wavefront-scheduling)
                            (action reopen-blocks)
                            (arguments ?cpv)))
           (bind ?leftOvers (create$))
           (progn$ (?z ?cpvPaths)
                   (bind ?cPath (symbol-to-instance-name ?z))
                   (if (not (member$ ?e (send ?cPath get-contents))) then
                     (bind ?leftOvers (insert$ ?leftOvers 1 ?z))))
           (modify-instance ?cpvObject (Paths ?leftOvers))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::FAILURE-CLONE
         (declare (salience -768))
         ?fct <- (message (to wavefront-scheduling)
                          (action clone-instruction)
                          (arguments ?cpv => ?e))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (parent ?p))
         =>
         (printout t "ERROR: Didn't clone " ?p " into " ?e crlf)
         (halt))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::FAILURE-MOVE
         (declare (salience -768))
         ?fct <- (message (to wavefront-scheduling)
                          (action move-instruction)
                          (arguments ?cpv => ?e))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (parent ?p))
         =>
         (printout t "ERROR: Didn't move " ?p " into " ?e crlf)
         (halt))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::FAILURE-SCHEDULE-STYLE
         (declare (salience -768))
         (message (to wavefront-scheduling)
                  (action determine-schedule-style)
                  (arguments ?cpv => ?e))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (parent ?p)
                 (Aliases $?aliases)
                 (Paths $?cpvPaths))
         ?pa <- (object (is-a PathAggregate)
                        (parent ?e))
         (object (is-a Instruction)
                 (id ?p)
                 (parent ?bb))
         (object (is-a BasicBlock)
                 (id ?e)
                 (parent ?r)
                 (Paths $?paths))
         (object (is-a Wavefront)
                 (parent ?r)
                 (values $?z)
                 (Closed $?y))
         (object (is-a Region)
                 (id ?r)
                 (Entrances ?x $?))
         (object (is-a BasicBlock)
                 (id ?x)
                 (Paths $?allPaths))
         =>
         (printout t "ERROR: Couldn't figure out scheduling stype for " ?p
                   " which is targeted for " ?e crlf
                   "Blocks on the wavefront = " ?z crlf
                   "Closed Blocks = " ?y crlf
                   "For reference ?cpvPaths = " ?cpvPaths crlf
                   "For reference aliases of ?cpv are = " $?aliases crlf
                   "For reference ?paths = " ?paths crlf
                   "Parent of " ?p " is " ?bb crlf
                   "Printing out the path aggregate for " ?p crlf )
         (send ?pa print)
         (progn$ (?apath ?allPaths)
                 (bind ?aObj (instance-name (symbol-to-instance-name ?apath)))
                 (printout t "  " ?apath " = " (send ?aObj get-contents) crlf))
         (facts)
         (halt))
;------------------------------------------------------------------------------

;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.
;------------------------------------------------------------------------------
; Contains rules associated with the act of actually scheduling instructions
; into blocks on the wavefront
;
; Written by Joshua Scoggins
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::AssertScheduleCPVIntoTargetBlock
         (object (is-a Wavefront)
                 (contents $? ?e $?))
         (object (is-a Diplomat)
                 (id ?e)
                 (IsOpen TRUE))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e)
                           (MovableCompensationPathVectors
                             $?cpvs&:(<> 0 (length$ $?cpvs))))
         =>
         (modify-instance ?agObj (MovableCompensationPathVectors))
         (progn$ (?cpv $?cpvs)
                 (assert (message (to wavefront-scheduling)
                                  (action determine-schedule-style)
                                  (arguments ?cpv => ?e)))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::ScheduleStyleForCPVIsMove
         "This rule attempts to determine if the CPV should be moved into the
         given block on the wavefront. If this is true then the fact to perform
         this action will be asserted"
         ?fct <- (message (to wavefront-scheduling)
                          (action determine-schedule-style)
                          (arguments ?cpv => ?e))
         (object (is-a BasicBlock)
                 (id ?e)
                 (Paths $?paths))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (Paths $?cpvPaths))
         ;the two sets are the same
         (test (equal$ ?paths ?cpvPaths))
         =>
         ;change the action...nothing more :D
         (modify ?fct (message (action move-instruction))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::ScheduleStyleForCPVIsCompensate
         "This rule attempts to determine if the CPV should be copied into the
         given block on the wavefront. If this is true then the fact to perform
         this action will be asserted."
         ?fct <- (message (to wavefront-scheduling)
                          (action determine-schedule-style)
                          (arguments ?cpv => ?e))
         (object (is-a BasicBlock)
                 (id ?e)
                 (Paths $?paths))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (Paths $?cpvPaths))
         ;there are more paths in the CPV than in the block
         (test (subsetp ?paths ?cpvPaths))
         =>
         (modify ?fct (action clone-instruction)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::RemoveScheduleStyleForCPV
         (declare (salience 1))
         ?fct <- (message (to wavefront-scheduling)
                          (action determine-schedule-style)
                          (arguments ?cpv => ?e))
         (object (is-a BasicBlock)
                 (id ?e)
                 (Paths $?paths))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (Paths $?cpvPaths))
         (test (not (subsetp ?paths ?cpvPaths)))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e)
                           (InstructionList $?il))
         =>
         ;TODO: Put code in here to delete a given instruction from the target
         ;      instruction list as well.
         ;
         ; Eventually, I will detect if we are in a loop. If we are then it is
         ; necessary to figure out which paths remain in the loop and those
         ; that exit.
         ;this should prevent a potential infinite loop
         ;(printout t "Preventing " ?i " from being scheduled into " ?e crlf)
         (retract ?fct)
         (bind ?ind (member$ ?i $?il))
         (if ?ind then (slot-delete$ ?agObj InstructionList ?ind ?ind)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::MoveInstructionIntoBlock
         "Moves the given object into bottom of the given block"
         ?fct <- (message (to wavefront-scheduling)
                          (action move-instruction)
                          (arguments ?cpv => ?e))
         ?newBlock <- (object (is-a BasicBlock)
                              (id ?e)
                              (contents $?blockBefore ?last)
                              (Produces $?nBProds))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e)
                           (InstructionPropagation $?agIP)
                           (ScheduledInstructions $?agSI)
                           (ReplacementActions $?agRA))
         ?terminator <- (object (is-a TerminatorInstruction)
                                (pointer ?tPtr)
                                (id ?last)
                                (TimeIndex ?ti)
                                (parent ?e))
         ?cpvObject <- (object (is-a CompensationPathVector)
                               (id ?cpv)
                               (parent ?inst)
                               (ScheduleTargets $?cpvST)
                               (Aliases $?cpvAliases))
         ?newInst <- (object (is-a Instruction)
                             (id ?inst)
                             (pointer ?nPtr)
                             (parent ?otherBlock)
                             (DestinationRegisters ?register)
                             (Consumers $?niConsumers)
                             (Class ?class))
         ?oldBlock <- (object (is-a BasicBlock)
                              (id ?otherBlock)
                              (Produces $?pBefore ?inst $?pRest)
                              (Contents $?before ?inst $?rest))
         ;TODO: add another rule where we have to update the consumers list as
         ;      well
         =>
         (object-pattern-match-delay
           ;(printout t "Scheduled " ?inst " into " ?e crlf)
           (modify-instance ?terminator (TimeIndex (+ ?ti 1)))
           ;(modify-instance ?newBlock (Produces ?nBProds ?register))
           (modify-instance ?oldBlock (Contents $?before $?rest)
                            (Produces $?pBefore $?pRest))
           ;(modify-instance ?cpvObject (Paths))
           (modify ?fct (action remove-evidence)
                   (arguments ?inst => $?niConsumers))
           (assert (message (to wavefront-scheduling)
                            (action recompute-block)
                            (arguments ?otherBlock)))
           (if (eq StoreInstruction ?class) then
             (modify-instance ?agObj
                              (ScheduledInstructions $?agSI ?inst ?register)
                              (ReplacementActions $?agRA ?inst ?inst !))
             ;(slot-insert$ ?agObj ScheduledInstructions 1 ?inst ?register)
             (modify-instance ?newBlock
                              (Produces $?nBProds ?register)
                              (Contents $?blockBefore ?inst ?last))
             (modify-instance ?cpvObject
                              (Paths)
                              (ScheduleTargets ?cpvST ?e ?inst)
                              (Aliases $?cpvAliases ?inst ?e))
             (llvm-unlink-and-move-instruction-before ?nPtr ?tPtr)
             ;(slot-insert$ ?cpvObject ScheduleTargets 1 ?e ?inst)
             ;(slot-insert$ ?cpvObject Aliases 1 ?inst ?e)
             ;(slot-insert$ ?agObj ReplacementActions 1 ?inst ?inst !)
             else
             (bind ?newName (sym-cat movedinstruction. (gensym*) . ?inst))
             (modify-instance ?cpvObject (Paths)
                              (ScheduleTargets ?cpvST ?e ?newName)
                              (Aliases ?cpvAliases ?newName ?e))
             ;(slot-insert$ ?cpvObject ScheduleTargets 1 ?e ?newName)
             ;(slot-insert$ ?cpvObject Aliases 1 ?newName ?e)
             ;(slot-insert$ ?agObj ReplacementActions 1 ?inst ?newName !)
             (modify-instance ?newBlock
                              (Produces $?nBProds ?register)
                              (Contents $?blockBefore ?newName ?last))
             (bind ?newPtr (llvm-clone-instruction ?nPtr ?newName))
             ;purge the list of producers and consumers
             (duplicate-instance ?inst to ?newName
                                 (id ?newName)
                                 (Name ?newName)
                                 (pointer ?newPtr)
                                 (Producers)
                                 (Consumers)
                                 (NonLocalDependencies)
                                 (LocalDependencies)
                                 (TimeIndex ?ti)
                                 (parent ?e))
             (llvm-move-instruction-before ?newPtr ?tPtr)
             (slot-insert$ ?oldBlock UnlinkedInstructions 1 ?inst)
             (modify-instance ?agObj (ReplacementActions $?agRA ?inst ?newName !)
                              (InstructionPropagation $?agIP ?inst ?newName ?e !)
                              (ScheduledInstructions $?agSI ?inst)))))
;(slot-insert$ ?agObj InstructionPropagation 1 ?inst ?newName ?e !)
;(slot-insert$ ?agObj ScheduledInstructions 1 ?inst))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::CloneInstructionIntoBlock
         "Moves the given object into bottom of the given block"
         ?fct <- (message (to wavefront-scheduling)
                          (action clone-instruction)
                          (arguments ?cpv => ?e))
         ?newBlock <- (object (is-a BasicBlock)
                              (id ?e)
                              (contents $?blockBefore ?last))
         ?agObj <- (object (is-a PathAggregate)
                           (parent ?e))
         ?terminator <- (object (is-a TerminatorInstruction)
                                (pointer ?tPtr)
                                (id ?last)
                                (TimeIndex ?ti)
                                (parent ?e))
         ?cpvObject <- (object (is-a CompensationPathVector)
                               (id ?cpv)
                               (parent ?inst)
                               (Paths $?cpvPaths))
         ?newInst <- (object (is-a Instruction)
                             (id ?inst)
                             (pointer ?nPtr)
                             (parent ?otherBlock)
                             (DestinationRegisters ?register)
                             (Class ?class))
         =>
         ;we also need to update all CPVs within
         (object-pattern-match-delay
           (bind ?newName (sym-cat compensation.copy. (gensym*) . ?inst))
           ;(printout t "Scheduled " ?inst " into " ?e " from " ?otherBlock
           ;            " as " ?newName crlf)
           (bind ?newPtr (llvm-clone-instruction ?nPtr ?newName))
           ;purge the list of producers and consumers
           (duplicate-instance ?inst to ?newName
                               (ID ?newName)
                               (Name ?newName)
                               (Pointer ?newPtr)
                               (Parent ?e)
                               (TimeIndex (+ ?ti 1)))
           (llvm-move-instruction-before ?newPtr ?tPtr)
           ;we add the original name so that we don't have to do
           ; an insane number of updates to the CPVs that follow
           ; this object
           (if (eq StoreInstruction ?class) then
             (slot-insert$ ?agObj ScheduledInstructions 1 ?inst ?register)
             else
             (slot-insert$ ?agObj InstructionPropagation 1 ?inst ?newName ?e !)
             (slot-insert$ ?agObj ScheduledInstructions 1 ?inst))
           (slot-insert$ ?newBlock Produces 1 ?register)
           (modify-instance ?newBlock (contents $?blockBefore ?newName ?last))
           (slot-insert$ ?cpvObject ScheduleTargets 1 ?e ?newName)
           (slot-insert$ ?cpvObject Aliases 1 ?newName ?e)
           (slot-insert$ ?agObj ReplacementActions 1 ?inst ?newName !)
           (modify ?fct (action recompute-block)
                   (arguments ?otherBlock))
           (assert (message (to wavefront-scheduling)
                            (action reopen-blocks)
                            (arguments ?cpv)))
           (bind ?leftOvers (create$))
           (progn$ (?z ?cpvPaths)
                   (bind ?cPath (symbol-to-instance-name ?z))
                   (if (not (member$ ?e (send ?cPath get-contents))) then
                     (bind ?leftOvers (insert$ ?leftOvers 1 ?z))))
           (modify-instance ?cpvObject (Paths ?leftOvers))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::FAILURE-CLONE
         (declare (salience -768))
         ?fct <- (message (to wavefront-scheduling)
                          (action clone-instruction)
                          (arguments ?cpv => ?e))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (parent ?p))
         =>
         (printout t "ERROR: Didn't clone " ?p " into " ?e crlf)
         (halt))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::FAILURE-MOVE
         (declare (salience -768))
         ?fct <- (message (to wavefront-scheduling)
                          (action move-instruction)
                          (arguments ?cpv => ?e))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (parent ?p))
         =>
         (printout t "ERROR: Didn't move " ?p " into " ?e crlf)
         (halt))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-merge::FAILURE-SCHEDULE-STYLE
         (declare (salience -768))
         (message (to wavefront-scheduling)
                  (action determine-schedule-style)
                  (arguments ?cpv => ?e))
         (object (is-a CompensationPathVector)
                 (id ?cpv)
                 (Parent ?p)
                 (Aliases $?aliases)
                 (Paths $?cpvPaths))
         ?pa <- (object (is-a PathAggregate)
                        (parent ?e))
         (object (is-a Instruction)
                 (id ?p)
                 (Parent ?bb))
         (object (is-a BasicBlock)
                 (id ?e)
                 (parent ?r)
                 (Paths $?paths))
         (object (is-a Wavefront)
                 (parent ?r)
                 (contents $?z)
                 (Closed $?y))
         (object (is-a Region)
                 (id ?r)
                 (Entrances ?x $?))
         (object (is-a BasicBlock)
                 (id ?x)
                 (Paths $?allPaths))
         =>
         (printout t "ERROR: Couldn't figure out scheduling stype for " ?p
                   " which is targeted for " ?e crlf
                   "Blocks on the wavefront = " ?z crlf
                   "Closed Blocks = " ?y crlf
                   "For reference ?cpvPaths = " ?cpvPaths crlf
                   "For reference aliases of ?cpv are = " $?aliases crlf
                   "For reference ?paths = " ?paths crlf
                   "Parent of " ?p " is " ?bb crlf
                   "Printing out the path aggregate for " ?p crlf )
         (send ?pa print)
         (progn$ (?apath ?allPaths)
                 (bind ?aObj (instance-name (symbol-to-instance-name ?apath)))
                 (printout t "  " ?apath " = " (send ?aObj get-contents) crlf))
         (facts)
         (halt))
;------------------------------------------------------------------------------


Defined splitting of * in GLAPI calls.

Defined splitting of * in GLAPI calls.

;------------------------------------------------------------------------------
;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")
;------------------------------------------------------------------------------
; 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::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))
;------------------------------------------------------------------------------
; Alright, we now need to build a corresponding procedure from each heading
; There are several ways to do this. The easiest would be to just do it
; procedurally in a single rule fire.
;------------------------------------------------------------------------------
(deffunction grouping-update::retrieve-element (?s)
             (nth 1 (send (instance-address * (symbol-to-instance-name ?s))
                          get-contents)))
;------------------------------------------------------------------------------
(deffunction grouping-update::to-conditional-field (?symbol ?if)
             (bind ?str (str-cat (retrieve-element ?symbol)))
             (create$ (format nil "%s(strcmp(input, \"%s\") == 0) {"
                              (if ?if then "if" else "} else if")
                              (sub-string (+ (str-index "_" ?str) 1)
                                          (str-length ?str) ?str))
                      (format nil "return %s" ?str)))
;------------------------------------------------------------------------------
(defrule grouping-update::build-constant-conversion-procedure
         ?obj <- (object (is-a heading-span)
                         (header-name ?group)
                         (contents $?entries))
         (test (> (length$ $?entries) 0))
         =>
         (unmake-instance ?obj)
         (bind ?target (format nil "//%s" ?group))
         (bind ?header (format nil "extern GLenum To%s(char* input) {" ?group))
         (bind ?first (to-conditional-field (nth$ 1 (first$ ?entries)) TRUE))
         (bind ?result (create$ ?target ?header ?first))
         (progn$ (?e (rest$ ?entries))
                 (bind ?result
                       (create$ ?result (to-conditional-field ?e FALSE))))
         (bind ?result (create$ ?result "} else {" "return 0;" "}" "}"))
         (progn$ (?r ?result) (printout t ?r crlf))
         (printout t crlf crlf))
;------------------------------------------------------------------------------
(defrule grouping-update::skip-constant-conversion
         ?obj <- (object (is-a heading-span)
                         (header-name ?group)
                         (contents $?entries))
         (test (= (length$ $?entries) 0))
         =>
         (unmake-instance ?obj))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;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
; conversion code for it.
;------------------------------------------------------------------------------
(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))
;------------------------------------------------------------------------------
; Alright, we now need to build a corresponding procedure from each heading
; There are several ways to do this. The easiest would be to just do it
; procedurally in a single rule fire.
;------------------------------------------------------------------------------
(deffunction grouping-update::retrieve-element (?s)
             (nth 1 (send (instance-address * (symbol-to-instance-name ?s))
                          get-contents)))
;------------------------------------------------------------------------------
(deffunction grouping-update::to-conditional-field (?symbol ?if)
             (bind ?str (str-cat (retrieve-element ?symbol)))
             (create$ (format nil "%s(strcmp(input, \"%s\") == 0) {"
                              (if ?if then "if" else "} else if")
                              (sub-string (+ (str-index "_" ?str) 1)
                                          (str-length ?str) ?str))
                      (format nil "return %s" ?str)))
;------------------------------------------------------------------------------
(defrule grouping-update::build-constant-conversion-procedure
         ?obj <- (object (is-a heading-span)
                         (header-name ?group)
                         (contents $?entries))
         (test (> (length$ $?entries) 0))
         =>
         (unmake-instance ?obj)
         (bind ?target (format nil "//%s" ?group))
         (bind ?header (format nil "extern GLenum To%s(char* input) {" ?group))
         (bind ?first (to-conditional-field (nth$ 1 (first$ ?entries)) TRUE))
         (bind ?result (create$ ?target ?header ?first))
         (progn$ (?e (rest$ ?entries))
                 (bind ?result
                       (create$ ?result (to-conditional-field ?e FALSE))))
         (bind ?result (create$ ?result "} else {" "return 0;" "}" "}"))
         (progn$ (?r ?result) (printout t ?r crlf))
         (printout t crlf crlf))
;------------------------------------------------------------------------------
(defrule grouping-update::skip-constant-conversion
         ?obj <- (object (is-a heading-span)
                         (header-name ?group)
                         (contents $?entries))
         (test (= (length$ $?entries) 0))
         =>
         (unmake-instance ?obj))
;------------------------------------------------------------------------------


Added the concepts of the player and item

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; The concept of a world for a player to explore
;------------------------------------------------------------------------------
(defmodule world
           (import constants defglobal ?ALL)
           (import core defclass thing)
           (export defclass
                   item
                   room
                   player))

(defclass world::player
  "The inventory container that the player uses / self"
  (is-a thing)
  (multislot items
             (type INSTANCE)
             (allowed-classes item)
             (visibility public)))

(defclass world::item
  "An thing that can be moved around"
  (is-a thing))

(defclass world::room
  "A place that contains items and can be exited from one of the four cardinal directions"
  (is-a thing)
  (multislot contents)
  ; TODO: eventually implement a description of the door
  (slot north
        (type INSTANCE
              SYMBOL)
        (visibility public)
        (allowed-classes room)
        (allowed-symbols FALSE))
  (slot south
        (type INSTANCE
              SYMBOL)
        (visibility public)
        (allowed-classes room)
        (allowed-symbols FALSE))
  (slot east
        (type INSTANCE
              SYMBOL)
        (visibility public)
        (allowed-classes room)
        (allowed-symbols FALSE))
  (slot west
        (type INSTANCE
              SYMBOL)
        (visibility public)
        (allowed-classes room)
        (allowed-symbols FALSE)))

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; The concept of a world for a player to explore
;------------------------------------------------------------------------------
(defmodule world
           (import constants defglobal ?ALL)
           (import core defclass thing))

(defclass world::room
          "A place that contains items and can be exited from one of the four cardinal directions"
          (is-a thing)
          (multislot contents)
          ; TODO: eventually implement a description of the door
          (slot north
                (type INSTANCE
                      SYMBOL)
                (visibility public)
                (allowed-classes room)
                (allowed-symbols FALSE))
          (slot south
                (type INSTANCE
                      SYMBOL)
                (visibility public)
                (allowed-classes room)
                (allowed-symbols FALSE))
          (slot east
                (type INSTANCE
                      SYMBOL)
                (visibility public)
                (allowed-classes room)
                (allowed-symbols FALSE))
          (slot west
                (type INSTANCE
                      SYMBOL)
                (visibility public)
                (allowed-classes room)
                (allowed-symbols FALSE)))


update BeerEX.clp

update BeerEX.clp

(load clips/beerex.clp)

(undefrule load-beer-question-rules)
(load clips/beer-questions.clp)

(undefrule load-beer-knowledge-rules)
(load clips/beer-knowledge.clp)

(deffunction ask-question (?display ?allowed-values)
   (bind ?answer "")
   (if (or (not (member$ prev ?allowed-values))
           (member$ restart ?allowed-values))
    then (printout t crlf))
   (while (not (member$ ?answer ?allowed-values))
      (printout t ?display " ")
      (bind ?i 1)
      (progn$ (?value ?allowed-values)
              (printout t ?i "." ?value " ")
              (bind ?i (+ ?i 1)))
      (printout t "-> ")
      (if (neq (bind ?number (read-number)) "*** READ ERROR ***")
       then (bind ?answer (nth$ ?number ?allowed-values)))
      (if (member$ restart ?allowed-values)
       then (printout t crlf)))
   ?answer)

(deffunction next-UI-state ()
   (do-for-fact ((?s state-list)) TRUE (and (bind ?current-id ?s:current)
                                            (bind ?sequence ?s:sequence)))
   (do-for-fact ((?u UI-state)) (eq ?u:id ?current-id) (and (bind ?display ?u:display)
                                                            (bind ?help ?u:help)
                                                            (bind ?why ?u:why)
                                                            (bind ?state ?u:state)
                                                            (bind ?valid-answers ?u:valid-answers)))
   (if (eq ?state middle)
    then (bind ?allowed-values ?valid-answers)
         (if (neq ?help nil)
          then (bind ?allowed-values (insert$ ?allowed-values (+ (length$ ?allowed-values) 1) help)))
         (if (neq ?why nil)
          then (bind ?allowed-values (insert$ ?allowed-values (+ (length$ ?allowed-values) 1) why)))
         (bind ?allowed-values (insert$ ?allowed-values (+ (length$ ?allowed-values) 1) cancel))
         (if (> (length$ ?sequence) 2)
          then (bind ?allowed-values (insert$ ?allowed-values (length$ ?allowed-values) prev)))
         (bind ?answer (ask-question ?display ?allowed-values))
    else (if (eq ?state final)
          then (bind ?answer (ask-question ?display (create$ prev restart cancel)))
          else (assert (next ?current-id))
               (run)
               (next-UI-state)))
   (if (member$ ?answer ?valid-answers)
    then (assert (next ?current-id ?answer))
         (run)
         (next-UI-state)
    else (if (eq ?answer help)
          then (printout t crlf)
               (printout t ?help crlf)
               (printout t crlf)
               (next-UI-state))
         (if (eq ?answer why)
          then (printout t crlf)
               (printout t ?why crlf)
               (printout t crlf)
               (next-UI-state))
         (if (eq ?answer prev)
          then (assert (prev ?current-id))
               (run)
               (next-UI-state))
         (if (eq ?answer restart)
          then (reset)
               (run)
               (next-UI-state))
         (if (eq ?answer cancel)
          then (exit))))

(reset)
(run)

(next-UI-state)

(load clips/beerex.clp)

(undefrule load-beer-knowledge-rules)
(undefrule load-beer-question-rules)

(load clips/beer-questions.clp)
(load clips/beer-knowledge.clp)

(deffunction ask-question (?display ?allowed-values)
   (bind ?answer "")
   (if (or (not (member$ prev ?allowed-values))
           (member$ restart ?allowed-values))
    then (printout t crlf))
   (while (not (member ?answer ?allowed-values))
      (printout t ?display " " ?allowed-values " ")
      (bind ?answer (readline))
      (if (member$ restart ?allowed-values)
       then (printout t crlf))
      (if (eq (str-index " " ?answer) FALSE)
       then (bind ?answer (nth$ 1 (explode$ ?answer)))))
   ?answer)

(deffunction next-UI-state ()
   (do-for-fact ((?s state-list)) TRUE (and (bind ?current-id ?s:current)
                                            (bind ?sequence ?s:sequence)))
   (do-for-fact ((?u UI-state)) (eq ?u:id ?current-id) (and (bind ?display ?u:display)
                                                            (bind ?help ?u:help)
                                                            (bind ?why ?u:why)
                                                            (bind ?state ?u:state)
                                                            (bind ?valid-answers ?u:valid-answers)))
   (if (eq ?state middle)
    then (bind ?allowed-values ?valid-answers)
         (if (neq ?help nil)
          then (bind ?allowed-values (insert$ ?allowed-values (+ (length$ ?allowed-values) 1) help)))
         (if (neq ?why nil)
          then (bind ?allowed-values (insert$ ?allowed-values (+ (length$ ?allowed-values) 1) why)))
         (bind ?allowed-values (insert$ ?allowed-values (+ (length$ ?allowed-values) 1) cancel))
         (if (> (length$ ?sequence) 2)
          then (bind ?allowed-values (insert$ ?allowed-values (length$ ?allowed-values) prev)))
         (bind ?answer (ask-question ?display ?allowed-values))
    else (if (eq ?state final)
          then (bind ?answer (ask-question ?display (create$ prev restart cancel)))
          else (assert (next ?current-id))
               (run)
               (next-UI-state)))
   (if (member$ ?answer ?valid-answers)
    then (assert (next ?current-id ?answer))
         (run)
         (next-UI-state)
    else (if (eq ?answer help)
          then (printout t crlf)
               (printout t ?help crlf)
               (printout t crlf)
               (next-UI-state))
         (if (eq ?answer why)
          then (printout t crlf)
               (printout t ?why crlf)
               (printout t crlf)
               (next-UI-state))
         (if (eq ?answer prev)
          then (assert (prev ?current-id))
               (run)
               (next-UI-state))
         (if (eq ?answer restart)
          then (reset)
               (run)
               (next-UI-state))
         (if (eq ?answer cancel)
          then (exit))))

(reset)
(run)

(next-UI-state)


Rewrote the argument parsing to not use a linear search

I split the target fact at a given , which creates a range. This range is then
used to determine the positions of the arguments in each section. When the
begin and end positions are the same then we only have a single value and the
correct index.

;------------------------------------------------------------------------------
;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))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;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::parse-arguments
			(declare (salience 1))
			?fct <- (message (to build-groups)
								  (action parse-arguments)
								  ; this is going backwards, we defer the index field
								  ; by setting it as an offset of the length, which we
								  ; don't know until we actually generate these
								  ; arguments.
								  (arguments ?o => $?sentry "," $?rest))
			?obj <- (object (is-a GLAPIFunction)
								 (id ?o))
			=>
			(modify ?fct (arguments ?o => $?sentry))
			;we use the number of commas before plus 1 to determine index
			(bind ?index (+ (count-commas ?sentry) 1))
			;the problem is determining the direction to spit out an argument in
			;I don't want to assume backwards or forwards to tell the truth. So
			;that means that we just mark $?rest with the target index and move on
			;
			;This method is technically out of order due to the use of the , as a
			;fix point
			(duplicate ?fct (action build-argument)
			                (arguments ?o ?index => $?rest)))
;------------------------------------------------------------------------------
(defrule build-groups::create-last-argument
			?fct <- (message (to build-groups)
								  (action parse-arguments)
								  (arguments ?o => $?all))
			(test (and (not (member$ , $?all))
						  (not (member$ "," $?all))))
			=>
			;The last element doesn't contain any commas and thus must be zero
			(modify ?fct (action build-argument)
			             (arguments ?o 0 => $?all)))
;------------------------------------------------------------------------------
(defrule build-groups::retract-empty-parse-message
			?fct <- (message (to build-groups)
								  (action parse-arguments)
								  (arguments ? =>))
			=>
			(retract ?fct))
;------------------------------------------------------------------------------
;(defrule build-groups::argument-is-fixed-array
;			(declare (salience 1))
;			?fct <- (message (to build-groups)
;								  (action build-argument)
;								  (arguments ?o ?name ?ind => $?field "[" ?size "]"))
;			=>
;			(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 ?name ?ind => $?input))
;			=>
;			(modify ?fct (to grouping-update)
;					  (action populate-argument)
;					  (arguments ?name => $?input))
;			(make-instance ?name of GLAPIArgument
;								(parent ?o)
;								(index ?ind)))
;------------------------------------------------------------------------------
(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))
;------------------------------------------------------------------------------


changed sfp-test.clp

changed sfp-test.clp

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

(deftemplate wurst
	(slot name (type STRING))
	(multislot zutaten (default "Fleisch" "Salz" "Wasser"))
	(slot gewicht (type INTEGER))
	(slot laenge (type INTEGER) (default 25))
	(slot hersteller (type STRING))
)

(deftemplate bier
	(slot name (type STRING))
	(slot gewicht (type INTEGER))
	(slot hersteller (type STRING))
)

(assert (wurst
		(name "Fischwurst")
		(gewicht 200)
		(laenge 100)
		(hersteller "Nordmann")
	)
)

(assert (wurst
		(name "Fischwurst")
		(gewicht 100)
		(laenge 100)
		(hersteller "Nordmann")
	)
)

(assert (bier
		(name "Birburger")
		(gewicht 100)
		)
)

(defrule wurst-meter-langsam "Regel zur Ausgabe der Wurst-Lnge"
	(wurst (laenge 100) (gewicht 200))
	(bier (gewicht 100))

;;	y <- (wurst (laenge ?x)
	=>
	(printout t "Eine Wurst gefunden.")
)

(defrule wurst-meter "Regel zur Ausgabe der Wurst-Lnge"
	(declare (rule-version "performance version") (salience 101) (auto-focus TRUE))
	(wurst (gewicht ?x))
	(wurst (laenge 100))
	(bier (gewicht ?x))
;;	y <- (wurst (laenge ?x)
	=>
	(printout t "Lebensmittel die zusammenpassen.")
)

;modify test:
(deftemplate modifywurst
	(slot name)
	(slot laenge)
	(multislot zutaten)
)

(assert (modifywurst
		(name "zukurz")
		(laenge 25)
		(zutaten "wasser" "salz" "pferd")
	)
)

(defrule bessereWurst
	 ?wurstFact <-(modifywurst (laenge 25)(zutaten $?zutatenlist))
	=>
	(modify ?wurstFact (laenge 35) )
	;(printout t $?zutatenlist )
	(printout t "laengere wurst" )
	(foreach ?i $?zutatenlist (printout t ?i))
 )

(deftemplate wurst
	(slot name (type STRING))
	(multislot zutaten (default "Fleisch" "Salz" "Wasser"))
	(slot gewicht (type INTEGER))
	(slot laenge (type INTEGER) (default 25))
	(slot hersteller (type STRING))
)

(deftemplate bier
	(slot name (type STRING))
	(slot gewicht (type INTEGER))
	(slot hersteller (type STRING))
)

(assert (wurst
		(name "Fischwurst")
		(gewicht 200)
		(laenge 100)
		(hersteller "Nordmann")
	)
)

(assert (wurst
		(name "Fischwurst")
		(gewicht 100)
		(laenge 100)
		(hersteller "Nordmann")
	)
)

(assert (bier
		(name "Birburger")
		(gewicht 100)
		)
)

(defrule wurst-meter "Regel zur Ausgabe der Wurst-Lnge"
	(declare (rule-version "performance version") (salience 101) (auto-focus TRUE))
	(wurst (gewicht ?x))
	(bier (gewicht ?x))
;;	y <- (wurst (laenge ?x)
	=>
	(printout t "Lebensmittel die zusammenpassen.")
)

(defrule wurst-meter-langsam "Regel zur Ausgabe der Wurst-Lnge"
	(wurst (laenge 100) (gewicht 200))
	(bier (gewicht 100))

;;	y <- (wurst (laenge ?x)
	=>
	(printout t "Eine Wurst gefunden.")
)

;modify test:
(deftemplate modifywurst
	(slot name)
	(slot laenge)
	(multislot zutaten)
)

(assert (modifywurst
		(name "zukurz")
		(laenge 25)
		(zutaten "wasser" "salz" "pferd")
	)
)

(defrule bessereWurst
	 ?wurstFact <-(modifywurst (laenge 25)(zutaten $?zutatenlist))
	=>
	(modify ?wurstFact (laenge 35) )
	;(printout t $?zutatenlist )
	(printout t "laengere wurst" )
	(foreach ?i $?zutatenlist (printout t ?i))
 )


Cleaned up painter.clp

Cleaned up painter.clp

(load* /lib/chicanery/input.clp)
(load* /lib/chicanery/menu.clp)

(defglobal MAIN
	   ?*system-initialized* = FALSE)

(deffacts query-operation
	  (query input)
	  (defmenu menu1 cut copy paste)
	  (defmenu menu2 eat sleep drink))

(defrule initialize
	 (declare (salience 10000))
	 (initial-fact)
	 =>
	 (if (not ?*system-initialized*) then
	   (eresized 0)
	   (bind ?*system-initialized* TRUE)))

(defrule build-menus
	 (declare (salience 9999))
	 ?f <- (defmenu ?a $?b)
	 =>
	 (retract ?f)
	 (defmenu ?a ?b))

(defrule on-resized
	 (declare (salience 1000))
	 ?f <- (event resized new ?value)
	 =>
	 (if (and ?value (< (getwindow) 0)) then
	   (printout werror "ERROR: couldn't reattach to window" crlf)
	   (exit)
	   else
	   (retract ?f)))

(defrule query-input
	 ?f <- (query input)
	 =>
	 (retract ?f)
	 (mouse/query)
	 (assert (input mouse
			buttons: (translate/mouse/buttons)
			position: (mouse/position)
			time-stamp: (mouse/timestamp))
		 (input keyboard
			button: (translate/kbd/query))))

(defrule process-mouse-inputs
	 (declare (salience -1))
	 ?f <- (input mouse
		      buttons: $?
		      position: ? ?
		      time-stamp: ?)
	 =>
	 (retract ?f)
	 (assert (query mouse)))

(defrule process-mouse-inputs:menu1
	 ?f <- (input mouse
		      buttons: button3
		      position: ? ?
		      time-stamp: ?)
	 =>
	 (retract ?f)
	 ; Display a menu
	 (printout t (send [menu1] show-menu 3) crlf)
	 (assert (query mouse)))

(defrule process-mouse-inputs:menu2
	 ?f <- (input mouse
		      buttons: button2
		      position: ? ?
		      time-stamp: ?)
	 =>
	 (retract ?f)
	 ; Display a menu
	 (printout t (send [menu2] show-menu 2) crlf)
	 (assert (query mouse)))

(defrule process-keyboard-inputs:quit
	 (declare (salience 1))
	 ?f <- (input keyboard
		      button: ESC)
	 =>
	 (retract ?f)
	 (exit))

(defrule process-keyboard-inputs:nil
	 (declare (salience 1))
	 ?f <- (input keyboard button: NIL)
	 =>
	 (retract ?f)
	 (assert (query keyboard)))

(defrule process-keyboard-inputs
	 ?f <- (input keyboard
		      button: ?b)
	 =>
	 (retract ?f)
	 (printout t "Pressed " ?b crlf)
	 (assert (query keyboard)))

(defrule ready-to-query-input-again
	 ?f <- (query keyboard)
	 ?f2 <- (query mouse)
	 =>
	 (retract ?f ?f2)
	 (assert (query input)))

(load* /lib/chicanery/input.clp)
(load* /lib/chicanery/menu.clp)

(defglobal MAIN
           ?*system-initialized* = FALSE)

(deffacts query-operation
          (query input)
          (defmenu menu1 cut copy paste)
          (defmenu menu2 eat sleep drink))

(defrule initialize
         (declare (salience 10000))
         (initial-fact)
         =>
         (if (not ?*system-initialized*) then
           (eresized 0)
           (bind ?*system-initialized* TRUE)))

(defrule build-menus
         (declare (salience 9999))
         ?f <- (defmenu ?a $?b)
         =>
         (retract ?f)
         (defmenu ?a ?b))

(defrule on-resized
         ?f <- (event resized new ?value)
         =>
         (if (and ?value (< (getwindow) 0)) then
           (printout werror "ERROR: couldn't reattach to window" crlf)
           (exit)
           else
           (retract ?f)))

(defrule query-input
         ?f <- (query input)
         =>
         (retract ?f)
         (mouse/query)
         (assert (input mouse
                        buttons: (translate/mouse/buttons)
                        position: (mouse/position)
                        time-stamp: (mouse/timestamp))
                 (input keyboard
                        button: (translate/kbd/query))))

(defrule process-mouse-inputs
         (declare (salience -1))
         ?f <- (input mouse
                      buttons: $?
                      position: ? ?
                      time-stamp: ?)
         =>
         (retract ?f)
         (assert (query mouse)))

(defrule process-mouse-inputs:menu1
         ?f <- (input mouse
                      buttons: button3
                      position: ? ?
                      time-stamp: ?)
         =>
         (retract ?f)
         ; Display a menu
         (printout t (send [menu1] show-menu 3) crlf)
         (assert (query mouse)))

(defrule process-mouse-inputs:menu2
         ?f <- (input mouse
                      buttons: button2
                      position: ? ?
                      time-stamp: ?)
         =>
         (retract ?f)
         ; Display a menu
         (printout t (send [menu2] show-menu 2) crlf)
         (assert (query mouse)))

(defrule process-keyboard-inputs:quit
         (declare (salience 1))
         ?f <- (input keyboard button: ESC)
         =>
         (retract ?f)
         (exit))

(defrule process-keyboard-inputs:passthrough
         (declare (salience 1))
         ?f <- (input keyboard button: NIL)
         =>
         (retract ?f)
         (assert (query keyboard)))

(defrule process-keyboard-inputs
         ?f <- (input keyboard
                      button: ?b)
         =>
         (retract ?f)
         (printout t "Pressed " ?b crlf)
         (assert (query keyboard)))

(defrule ready-to-query-input-again
         ?f <- (query keyboard)
         ?f2 <- (query mouse)
         =>
         (retract ?f ?f2)
         (assert (query input)))