- checked in the missing init.clp

- checked in the missing init.clp

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

; ===================================================
; Initial data that is essential to run the JamochaAgent.
; ===================================================

; ===================================================
; Definition of the templates that are needed.
; ===================================================

(deftemplate agent-description
	"A template defining an agent."
    (slot name (type STRING))
    (slot local (type BOOLEAN))
)

(deftemplate agent-ontology
	"Definition of ontologies. (not needed at the moment)"
    (slot name (type STRING))
    (slot definition (type STRING))
)

(deftemplate agent-message
	"Definition of an (incoming) agent-message."
	(slot sender (type STRING))
	(multislot receivers)
	(multislot reply-to)
	(slot performative (type STRING))
	(slot content (type STRING))
	(slot language (type STRING))
	(slot encoding (type STRING))
	(slot ontology (type STRING))
	(slot protocol (type STRING))
	(slot conversation-id (type STRING))
	(slot in-reply-to (type STRING))
	(slot reply-with (type STRING))
	(slot reply-by (type LONG))
	(multislot user-properties)
	(silent slot content-clips (type STRING))
	(slot processed (type BOOLEAN)(default FALSE))
)

(deftemplate agent-message-initiator
	"Deftemplate for a message initiator."
	(slot receiver)
	(slot refering-message)
	(slot protocol (type STRING))
	(slot previous-performative (type STRING))
	(slot content (type STRING))
	(slot content-clips (type STRING))
	(slot processed (type BOOLEAN)(default FALSE))
	(slot error (type STRING)(default NIL))
)

; ===================================================
; definition of functions that are needed
; ===================================================

(deffunction process-incoming-message
	"Processes incoming messages with any protocol and performative."
	(functiongroup AgentFunctions)
	(?message ?protocol)

	; Assert the agent that sent the message if he is unknown.
	(bind ?agent (fact-id
		(assert (agent-description (name (fact-slot-value ?message "sender"))(local FALSE)))
	))

	; Translate the Code according to the given performative.
	(bind ?clipsCode
	    (sl2clips
	    	(fact-slot-value ?message "performative")
	    	(fact-slot-value ?message "content")
	    )
	)

	; Add the translated code to the initial message.
	(modify ?message (content-clips ?clipsCode))

	; Set the message to processed.
	(modify ?message (processed TRUE))

	; Evaluate the code in the rete engine.
	(bind ?error "")
	(bind ?result (eval ?clipsCode ?error))

	; Assert a new agent message initiator that will initiate a new message according
	; to the used performative and protocol.
	(assert (agent-message-initiator
		(receiver ?agent)
		(refering-message ?message)
		(protocol ?protocol)
		(previous-performative (fact-slot-value ?message "performative"))
		(content (clips2sl ?result))
		(content-clips ?result)
		(error ?error)
	))
)

; ===================================================
; Definition of rules that are needed
; ===================================================

(defrule incoming-message
	"Fires when a message in FIPA-SL arrives, that is addressed to a local Agent."
	; Only look for messages addressed to a local agent. There might be more than one
	; agent running locally using this rete engine.
	(agent-description
		(name ?receiver)
		(local TRUE)
	)
	; Only extract messages that have not been answered yet.
	?message <- (agent-message
		(receivers ?receivers)
		(language "fipa-sl")
		(protocol ?protocol)
		(processed FALSE)
	)
	; The receiver of the message must be local.
	(test (> (member$ ?receiver ?receivers) 0))

	=>

	; Process the message.
	(process-incoming-message ?message ?protocol)

	(fire)
)

error: pathspec 'src/main/org/jamocha/apps/jamochaagent/init.clp' did not match any file(s) known to git


snapshot

snapshot

(deftemplate rocky
  (slot name))

(deftemplate boris
  (slot name))

(deftemplate natasha
  (slot name)
  (slot nemesis))

(load-package jess.ViewFunctions)
(set-node-index-hash 1)

; (defrule rocky-boris-natasha
;   ?f-1 <- (rocky (name ?n&:(= (str-compare "bullwinkle" ?n) 0)))
;   (boris (name ?boris-name&:(= (str-compare ?boris-name "boris") 0)))
;   (natasha (name ?name&:(= (str-compare ?name "natasha") 0))
;            (nemesis ?z&:(= (str-compare ?z ?boris-name) 0)))
;   =>
;   (printout t "rocky-boris-natasha fired (?boris-name = " ?boris-name ")" crlf)
;   (retract ?f-1))

; (defrule not-rocky
;   (not (rocky (name "rocky")))
;   =>
;   (printout t "not-rocky fired." crlf))

; (defrule duplicate-vars
;   (natasha (name ?name) (nemesis ?name))
;   =>
;   (printout t "duplicate-vars fired!" crlf))

;  (defrule schtum
;    ?rocky <- (rocky (name "rocky"))
;    (boris (name "boris"))
;    ?natasha <- (natasha (name "natasha"))
;    =>
;    (retract ?rocky)
;    (retract ?natasha)
;    (printout t "schtum!" crlf))

; (defrule schtum-shared
;   (boris (name "boris"))
;   =>
;   (printout t "schtum-shared!" crlf))

; (defrule schtum-simple
;   (rocky (name ?name&:(stringp ?name)))
;   (boris (name ?name&:(stringp ?name)))
;   (natasha (name "natasha"))
;   =>
;   (printout t "schtum-simple!" crlf))

; (defrule no-patterns
;   =>
;   (printout t "no-patterns!" crlf))

;(reset)
;(assert (rocky (name "boris")))
;(assert (boris (name "boris")))
;(assert (natasha (name "natasha")))

(defrule rocky-1
  (rocky (name ?name&:(eq ?name "rocky")))
  (boris (name ?boris&:(eq ?boris ?name)))
  =>
  (format t "rocky-1 fired: ?name = ~S~%" ?name))

(defrule rocky-2
  (rocky (name ?name&:(eq ?name "rocky")))
  (natasha)
  (boris (name ?schtum&:(eq ?schtum ?name)))
  =>
  (format t "rocky-2 fired: ?name = ~S~%" ?name))

(deftemplate rocky
  (slot name))

(deftemplate boris
  (slot name))

(deftemplate natasha
  (slot name)
  (slot nemesis))

(load-package jess.ViewFunctions)
(set-node-index-hash 1)

(defrule rocky-1
  (rocky (name ?name&:(eq ?name "rocky")))
  (boris (name ?boris&:(eq ?boris ?name)))
  =>
  (format t "rocky-1 fired: ?name = ~S~%" ?name))

(defrule rocky-2
  (rocky (name ?name&:(eq ?name "rocky")))
  (natasha)
  (boris (name ?schtum&:(eq ?schtum ?name)))
  =>
  (format t "rocky-2 fired: ?name = ~S~%" ?name))


New file

New file

;;;======================================================
;;;   Monkees and Bananas Sample Problem
;;;
;;;     This is an extended version of a
;;;     rather common AI planning problem.
;;;     The point is for the monkee to find
;;;     and eat some bananas.
;;;
;;;     CLIPS Version 6.0 Example
;;;
;;;     To execute, merely load, reset and run.
;;;======================================================
;;;
;;; modified EJFH 4/11/96 for JES Java Expert System
;;; produces identical output under CLIPS

;;;*************
;;;* TEMPLATES *
;;;*************

(deftemplate monkey
   (slot location
      (default green-couch))
   (slot on-top-of
      (default floor))
   (slot holding
      (default nothing)))

(deftemplate thing
   (slot name)
   (slot location)
   (slot on-top-of
      (default floor))
   (slot weight
      (default light)))

(deftemplate chest
   (slot name)
   (slot contents)
   (slot unlocked-by))

(deftemplate goal-is-to
   (slot action)
   (slot argument-1)
   (slot argument-2))

;;;*************************
;;;* CHEST UNLOCKING RULES *
;;;*************************

(defrule hold-chest-to-put-on-floor ""
  (goal-is-to (action unlock) (argument-1 ?chest))
  (thing (name ?a&:(eq ?a ?chest)) (on-top-of ~floor) (weight light))
  (monkey (holding ?b&:(neq ?b ?chest)))
  (not (goal-is-to (action hold) (argument-1 ?c&:(eq ?c ?chest))))
  =>
  (assert (goal-is-to (action hold) (argument-1 ?chest))))

(defrule put-chest-on-floor ""
  (goal-is-to (action unlock) (argument-1 ?chest))
  ?monkey <- (monkey (location ?place)
                     (on-top-of ?on)
                     (holding ?c&:(eq ?c ?chest)))
  ?thing <- (thing (name ?d&:(eq ?d ?chest)))
  =>
  (printout t "Monkey throws the " ?chest " off the "
              ?on " onto the floor." crlf)
  (modify ?monkey (holding blank))
  (modify ?thing (location ?place) (on-top-of floor)))

(defrule get-key-to-unlock ""
  (goal-is-to (action unlock) (argument-1 ?obj))
  (thing (name ?a&:(eq ?a ?obj)) (on-top-of floor))
  (chest (name ?b&:(eq ?b ?obj)) (unlocked-by ?key))
  (monkey (holding ?c&:(neq ?c ?key)))
  (not (goal-is-to (action hold) (argument-1 ?d&:(eq ?d ?key))))
  =>
  (assert (goal-is-to (action hold) (argument-1 ?key))))

;; one conjunction removed here just by reordering patterns.

(defrule move-to-chest-with-key ""
  (goal-is-to (action unlock) (argument-1 ?chest))
  (thing (name ?a&:(eq ?a ?chest)) (location ?cplace) (on-top-of floor))
  (monkey (location ?b&:(neq ?b ?cplace)) (holding ?key))
  (chest (name ?c&:(eq ?c ?chest)) (unlocked-by ?d&:(eq ?d ?key)))
  (not (goal-is-to (action walk-to) (argument-1 ?e&:(eq ?e ?cplace))))
  =>
  (assert (goal-is-to (action walk-to) (argument-1 ?cplace))))

(defrule unlock-chest-with-key ""
  ?goal <- (goal-is-to (action unlock) (argument-1 ?name))
  ?chest <- (chest (name ?a&:(eq ?a ?name)) (contents ?contents)
                   (unlocked-by ?key))
  (thing (name ?b&:(eq ?b ?name)) (location ?place) (on-top-of ?on))
  (monkey (location ?c&:(eq ?c ?place)) (on-top-of ?d&:(eq ?d ?on))
          (holding ?e&:(eq ?e ?key)))
  =>
  (printout t "Monkey opens the " ?name " with the " ?key
              " revealing the " ?contents "." crlf)
  (modify ?chest (contents nothing))
  (assert (thing (name ?contents) (location ?place) (on-top-of ?name)))
  (retract ?goal))

;;;*********************
;;;* HOLD OBJECT RULES *
;;;*********************

(defrule unlock-chest-to-hold-object ""
  (goal-is-to (action hold) (argument-1 ?obj))
  (chest (name ?chest) (contents ?a&:(eq ?a ?obj)))
  (not (goal-is-to (action unlock) (argument-1 ?b&:(eq ?b ?chest))))
  =>
  (assert (goal-is-to (action unlock) (argument-1 ?chest))))

(defrule use-ladder-to-hold ""
  (goal-is-to (action hold) (argument-1 ?obj))
  (thing (name ?a&:(eq ?a ?obj)) (location ?place) (on-top-of ceiling)
         (weight light))
  (not (thing (name ladder) (location ?b&:(eq ?b ?place))))
  (not (goal-is-to (action move) (argument-1 ladder)
                   (argument-2 ?c&:(eq ?c ?place))))
  =>
  (assert (goal-is-to (action move) (argument-1 ladder) (argument-2 ?place))))

(defrule climb-ladder-to-hold ""
  (goal-is-to (action hold) (argument-1 ?obj))
  (thing (name ?a&:(eq ?a ?obj)) (location ?place)
         (on-top-of ceiling) (weight light))
  (thing (name ladder) (location ?b&:(eq ?b ?place)) (on-top-of floor))
  (monkey (on-top-of ~ladder))
  (not (goal-is-to (action on) (argument-1 ladder)))
  =>
  (assert (goal-is-to (action on) (argument-1 ladder))))

(defrule grab-object-from-ladder ""
  ?goal <- (goal-is-to (action hold) (argument-1 ?name))
  ?thing <- (thing (name ?a&:(eq ?a ?name)) (location ?place)
                   (on-top-of ceiling) (weight light))
  (thing (name ladder) (location ?b&:(eq ?b ?place)))
  ?monkey <- (monkey (location ?c&:(eq ?c ?place)) (on-top-of ladder)
                     (holding blank))
  =>
  (printout t "Monkey grabs the " ?name "." crlf)
  (modify ?thing (location held) (on-top-of held))
  (modify ?monkey (holding ?name))
  (retract ?goal))

(defrule climb-to-hold ""
  (goal-is-to (action hold) (argument-1 ?obj))
  (thing (name ?a&:(eq ?a ?obj)) (location ?place&~ceiling)
         (on-top-of ?on) (weight light))
  (monkey (location ?b&:(eq ?b ?place)) (on-top-of ?c&:(neq ?c ?on)))
  (not (goal-is-to (action on) (argument-1 ?d&:(eq ?d ?on))))
  =>
  (assert (goal-is-to (action on) (argument-1 ?on))))

(defrule walk-to-hold ""
  (goal-is-to (action hold) (argument-1 ?obj))
  (thing (name ?a&:(eq ?a ?obj)) (location ?place)
         (on-top-of ~ceiling) (weight light))
  (monkey (location ?b&:(neq ?b ?place)))
  (not (goal-is-to (action walk-to) (argument-1 ?c&:(eq ?c ?place))))
  =>
  (assert (goal-is-to (action walk-to) (argument-1 ?place))))

(defrule drop-to-hold ""
  (goal-is-to (action hold) (argument-1 ?obj))
  (thing (name ?a&:(eq ?a ?obj)) (location ?place) (on-top-of ?on)
         (weight light))
  (monkey (location ?b&:(eq ?b ?place)) (on-top-of ?c&:(eq ?c ?on))
          (holding ~blank))
  (not (goal-is-to (action hold) (argument-1 blank)))
  =>
  (assert (goal-is-to (action hold) (argument-1 blank))))

(defrule grab-object ""
  ?goal <- (goal-is-to (action hold) (argument-1 ?name))
  ?thing <- (thing (name ?a&:(eq ?a ?name)) (location ?place)
                   (on-top-of ?on) (weight light))
  ?monkey <- (monkey (location ?b&:(eq ?b ?place))
                     (on-top-of ?c&:(eq ?c ?on)) (holding blank))
  =>
  (printout t "Monkey grabs the " ?name "." crlf)
  (modify ?thing (location held) (on-top-of held))
  (modify ?monkey (holding ?name))
  (retract ?goal))

(defrule drop-object ""
  ?goal <- (goal-is-to (action hold) (argument-1 blank))
  ?monkey <- (monkey (location ?place)
                     (on-top-of ?on)
                     (holding ?name&~blank))
  ?thing <- (thing (name ?a&:(eq ?a ?name)))
  =>
  (printout t "Monkey drops the " ?name "." crlf)
  (modify ?monkey (holding blank))
  (modify ?thing (location ?place) (on-top-of ?on))
  (retract ?goal))

;;;*********************
;;;* MOVE OBJECT RULES *
;;;*********************

(defrule unlock-chest-to-move-object ""
  (goal-is-to (action move) (argument-1 ?obj))
  (chest (name ?chest) (contents ?a&:(eq ?a ?obj)))
  (not (goal-is-to (action unlock) (argument-1 ?b&:(eq ?b ?chest))))
  =>
  (assert (goal-is-to (action unlock) (argument-1 ?chest))))

(defrule hold-object-to-move ""
  (goal-is-to (action move) (argument-1 ?obj) (argument-2 ?place))
  (thing (name ?a&:(eq ?a ?obj)) (location ?b&:(neq ?b ?place))
         (weight light))
  (monkey (holding ?c&:(neq ?c ?obj)))
  (not (goal-is-to (action hold) (argument-1 ?d&:(eq ?d ?obj))))
  =>
  (assert (goal-is-to (action hold) (argument-1 ?obj))))

(defrule move-object-to-place ""
  (goal-is-to (action move) (argument-1 ?obj) (argument-2 ?place))
  (monkey (location ?a&:(neq ?a ?place)) (holding ?b&:(eq ?b ?obj)))
  (not (goal-is-to (action walk-to) (argument-1 ?c&:(eq ?c ?place))))
  =>
  (assert (goal-is-to (action walk-to) (argument-1 ?place))))

(defrule drop-object-once-moved ""
  ?goal <- (goal-is-to (action move) (argument-1 ?name) (argument-2 ?place))
  ?monkey <- (monkey (location ?a&:(eq ?a ?place)) (holding ?obj))
  ?thing <- (thing (name ?b&:(eq ?b ?name)) (weight light))
  =>
  (printout t "Monkey drops the " ?name "." crlf)
  (modify ?monkey (holding blank))
  (modify ?thing (location ?place) (on-top-of floor))
  (retract ?goal))

(defrule already-moved-object ""
  ?goal <- (goal-is-to (action move) (argument-1 ?obj) (argument-2 ?place))
  (thing (name ?a&:(eq ?a ?obj)) (location ?b&:(eq ?b ?place)))
  =>
  (retract ?goal))

;;;***********************
;;;* WALK TO PLACE RULES *
;;;***********************

(defrule already-at-place ""
  ?goal <- (goal-is-to (action walk-to) (argument-1 ?place))
  (monkey (location ?a&:(eq ?a ?place)))
  =>
  (retract ?goal))

(defrule get-on-floor-to-walk ""
  (goal-is-to (action walk-to) (argument-1 ?place))
  (monkey (location ?a&:(neq ?a ?place)) (on-top-of ~floor))
  (not (goal-is-to (action on) (argument-1 floor)))
  =>
  (assert (goal-is-to (action on) (argument-1 floor))))

(defrule walk-holding-nothing ""
  ?goal <- (goal-is-to (action walk-to) (argument-1 ?place))
  ?monkey <- (monkey (location ?a&:(neq ?a ?place)) (on-top-of floor)
                     (holding blank))
  =>
  (printout t "Monkey walks to " ?place "." crlf)
  (modify ?monkey (location ?place))
  (retract ?goal))

(defrule walk-holding-object ""
  ?goal <- (goal-is-to (action walk-to) (argument-1 ?place))
  ?monkey <- (monkey (location ?a&:(neq ?a ?place)) (on-top-of floor)
                     (holding ?obj))
  (thing (name ?b&:(eq ?b ?obj)))
  =>
  (printout t "Monkey walks to " ?place " holding the " ?obj "." crlf)
  (modify ?monkey (location ?place))
  (retract ?goal))

;;;***********************
;;;* GET ON OBJECT RULES *
;;;***********************

(defrule jump-onto-floor ""
  ?goal <- (goal-is-to (action on) (argument-1 floor))
  ?monkey <- (monkey (on-top-of ?on&~floor))
  =>
  (printout t "Monkey jumps off the " ?on " onto the floor." crlf)
  (modify ?monkey (on-top-of floor))
  (retract ?goal))

(defrule walk-to-place-to-climb ""
  (goal-is-to (action on) (argument-1 ?obj))
  (thing (name ?a&:(eq ?a ?obj)) (location ?place))
  (monkey (location ?b&:(neq ?b ?place)))
  (not (goal-is-to (action walk-to) (argument-1 ?c&:(eq ?c ?place))))
  =>
  (assert (goal-is-to (action walk-to) (argument-1 ?place))))

(defrule drop-to-climb ""
  (goal-is-to (action on) (argument-1 ?obj))
  (thing (name ?a&:(eq ?a ?obj)) (location ?place))
  (monkey (location ?b&:(eq ?b ?place)) (holding ~blank))
  (not (goal-is-to (action hold) (argument-1 blank)))
  =>
  (assert (goal-is-to (action hold) (argument-1 blank))))

(defrule climb-indirectly ""
  (goal-is-to (action on) (argument-1 ?obj))
  (thing (name ?a&:(eq ?a ?obj)) (location ?place) (on-top-of ?on))
  (monkey (location ?b&:(eq ?b ?place)) (on-top-of ~?on&~obj)
          (holding blank))
  (not (goal-is-to (action on) (argument-1 ?c&:(eq ?c ?on))))
  =>
  (assert (goal-is-to (action on) (argument-1 ?on))))

(defrule climb-directly ""
  ?goal <- (goal-is-to (action on) (argument-1 ?obj))
  (thing (name ?a&:(eq ?a ?obj)) (location ?place) (on-top-of ?on))
  ?monkey <- (monkey (location ?b&:(eq ?b ?place))
                     (on-top-of ?c&:(eq ?c ?on)) (holding blank))
  =>
  (printout t "Monkey climbs onto the " ?obj "." crlf)
  (modify ?monkey (on-top-of ?obj))
  (retract ?goal))

(defrule already-on-object ""
  ?goal <- (goal-is-to (action on) (argument-1 ?obj))
  (monkey (on-top-of ?a&:(eq ?a ?obj)))
  =>
  (retract ?goal))

;;;********************
;;;* EAT OBJECT RULES *
;;;********************
(defrule hold-to-eat ""
  (goal-is-to (action eat) (argument-1 ?obj))
  (monkey (holding ?a&:(neq ?a ?obj)))
  (not (goal-is-to (action hold) (argument-1 ?b&:(eq ?b ?obj))))
  =>
  (assert (goal-is-to (action hold) (argument-1 ?obj))))

(defrule satisfy-hunger ""
  ?goal <- (goal-is-to (action eat) (argument-1 ?name))
  ?monkey <- (monkey (holding ?a&:(eq ?a ?name)))
  ?thing <- (thing (name ?b&:(eq ?b ?name)))
  =>
  (printout t "Monkey eats the " ?name "." crlf)
  (modify ?monkey (holding blank))
  (retract ?goal ?thing))

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

(defrule startup ""
  =>
  (assert (monkey (location t5-7) (on-top-of green-couch) (holding blank)))
  (assert (thing (name green-couch) (location t5-7) (weight heavy)))
  (assert (thing (name red-couch) (location t2-2) (weight heavy)))
  (assert (thing (name big-pillow) (location t2-2) (on-top-of red-couch)))
  (assert (thing (name red-chest) (location t2-2) (on-top-of big-pillow)))
  (assert (chest (name red-chest) (contents ladder) (unlocked-by red-key)))
  (assert (thing (name blue-chest) (location t7-7) (on-top-of ceiling)))
  (assert (thing (name grapes) (location t7-8) (on-top-of ceiling)))
  (assert (chest (name blue-chest) (contents bananas) (unlocked-by blue-key)))
  (assert (thing (name blue-couch) (location t8-8) (weight heavy)))
  (assert (thing (name green-chest) (location t8-8) (on-top-of ceiling)))
  (assert (chest (name green-chest) (contents blue-key) (unlocked-by red-key)))
  (assert (thing (name red-key) (location t1-3)))
  (assert (goal-is-to (action eat) (argument-1 bananas)))
  )

(defglobal ?*time* = (time))
(set-reset-globals FALSE)

(deffunction run-mab (?n)
  (bind ?start (time))
  (while (> ?n 0) do
         (reset)
         (run)
         (bind ?n (- ?n 1)))
  (printout t "Elapsed time: "
            (- (time) ?start) crlf))

;;(run-n-times 256)
;;(run-n-times 1)
;;(printout t "Elapsed time: " (integer (- (time) ?*time*)) crlf)

error: pathspec 'misc/mab-slow.clp' did not match any file(s) known to git


Fixed an issue with the macro-expand rule in wavefront-scheduling

The to field was marked for wavefront (the old name of the pass) instead of
wavefront-scheduling. This was preventing the pass from firing correctly

;------------------------------------------------------------------------------
;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
;this module is used to determine which regions should be targeted for pathing
(defmodule wavefront-scheduling-determinant
			  (import core ?ALL)
			  (import llvm ?ALL)
			  (import types ?ALL)
			  (import pipeline ?ALL)
			  (import indirect ?ALL)
			  (import rampancy ?ALL)
			  (import MAIN ?ALL))
;------------------------------------------------------------------------------
(defmodule wavefront-scheduling-pre-init
			  (import core ?ALL)
			  (import llvm ?ALL)
			  (import types ?ALL)
			  (import pipeline ?ALL)
			  (import indirect ?ALL)
			  (import rampancy ?ALL)
			  (import MAIN ?ALL))
;------------------------------------------------------------------------------
(defmodule wavefront-scheduling-code
			  (import core ?ALL)
			  (import llvm ?ALL)
			  (import types ?ALL)
			  (import pipeline ?ALL)
			  (import indirect ?ALL)
			  (import rampancy ?ALL)
			  (import MAIN ?ALL))
;------------------------------------------------------------------------------
(defmodule wavefront-scheduling-final
			  (import core ?ALL)
			  (import llvm ?ALL)
			  (import types ?ALL)
			  (import pipeline ?ALL)
			  (import indirect ?ALL)
			  (import rampancy ?ALL)
			  (import MAIN ?ALL))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling::macro-expand-passes
			"Pushes the modules that make up this pass into the pass-description"
			?f <- (message (from pipeline)
								(to wavefront-scheduling)
								(action initial-fact))
			?p <- (object (is-a pass-description) (passes $?passes))
			=>
			(retract ?f)
			(modify-instance ?p (passes
										loop-region-merging
										dependency-analysis
										wavefront-determinant
										paths-conditional
                    wavefront-scheduling-pre-init
										wavefront-scheduling-code
                    wavefront-scheduling-final
										$?passes)))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
;this module is used to determine which regions should be targeted for pathing
(defmodule wavefront-scheduling-determinant
			  (import core ?ALL)
			  (import llvm ?ALL)
			  (import types ?ALL)
			  (import pipeline ?ALL)
			  (import indirect ?ALL)
			  (import rampancy ?ALL)
			  (import MAIN ?ALL))
;------------------------------------------------------------------------------
(defmodule wavefront-scheduling-pre-init
			  (import core ?ALL)
			  (import llvm ?ALL)
			  (import types ?ALL)
			  (import pipeline ?ALL)
			  (import indirect ?ALL)
			  (import rampancy ?ALL)
			  (import MAIN ?ALL))
;------------------------------------------------------------------------------
(defmodule wavefront-scheduling-code
			  (import core ?ALL)
			  (import llvm ?ALL)
			  (import types ?ALL)
			  (import pipeline ?ALL)
			  (import indirect ?ALL)
			  (import rampancy ?ALL)
			  (import MAIN ?ALL))
;------------------------------------------------------------------------------
(defmodule wavefront-scheduling-final
			  (import core ?ALL)
			  (import llvm ?ALL)
			  (import types ?ALL)
			  (import pipeline ?ALL)
			  (import indirect ?ALL)
			  (import rampancy ?ALL)
			  (import MAIN ?ALL))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling::macro-expand-passes
			"Pushes the modules that make up this pass into the pass-description"
			?f <- (message (from pipeline)
								(to wavefront)
								(action initial-fact))
			?p <- (object (is-a pass-description) (passes $?passes))
			=>
			(retract ?f)
			(modify-instance ?p (passes
										loop-region-merging
										dependency-analysis
										wavefront-determinant
										paths-conditional
                    wavefront-scheduling-pre-init
										wavefront-scheduling-code
                    wavefront-scheduling-final
										$?passes)))
;------------------------------------------------------------------------------


Fixed more bugs in GLConstantConversion.clp

;------------------------------------------------------------------------------
;Copyright (c) 2013, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; GLConstantConversion.clp - an expert system that reads a define and generates
; conversion code for it.
;------------------------------------------------------------------------------
(defmodule types
           (export ?ALL))
;------------------------------------------------------------------------------
(defmodule identify-lines
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule convert-templates
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule build-groups
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule MAIN
           (import types ?ALL)
           (export ?ALL))
;------------------------------------------------------------------------------
(defclass types::opened-file
  (is-a USER)
  (slot id)
  (slot index (type INTEGER) (range 0 ?VARIABLE))
  (message-handler next-index)
  (message-handler read-line)
  (message-handler close-file))
;------------------------------------------------------------------------------
(defmessage-handler types::opened-file next-index ()
                    (bind ?old ?self:index)
                    (bind ?self:index (+ ?old 1))
                    (return ?old))
;------------------------------------------------------------------------------
(defmessage-handler types::opened-file read-line ()
                    (readline ?self:id))
;------------------------------------------------------------------------------
(defmessage-handler types::opened-file close-file ()
                    (close ?self:id))
;------------------------------------------------------------------------------
(deftemplate types::file-line
             (slot index)
             (slot parent)
             (slot type)
             (multislot contents))
;------------------------------------------------------------------------------
(deftemplate types::heading-span
             "Defines a span between two different headings"
             (slot header-name)
             (multislot contents)
             (slot from)
             (slot to)
             (slot parent)
             (slot distance))
;------------------------------------------------------------------------------
(deftemplate types::message
             (slot from)
             (slot to)
             (slot action)
             (multislot arguments))
;------------------------------------------------------------------------------
(defclass types::line-entry
  (is-a USER)
  (slot id)
  (slot index)
  (slot parent)
  (slot type)
  (multislot contents))
;------------------------------------------------------------------------------
(defmessage-handler types::line-entry init after ()
                    (bind ?self:id (instance-name-to-symbol (instance-name ?self))))
;------------------------------------------------------------------------------
; INPUT FACT FORM: (parse constant file ?path)
;------------------------------------------------------------------------------
(deffunction types::get-input-form-factor ()
             (printout t "(parse constant file ?path)" crlf))
;------------------------------------------------------------------------------
(defrule MAIN::open-target-file
         "This rule takes a fact of the above INPUT FORM and attempts to open the file"
         ?fct <- (parse constant file ?path)
         =>
         (bind ?name (gensym*))
         (retract ?fct)
         (if (open ?path ?name "r") then
           (make-instance of opened-file (id ?name) (index 0))
           (assert (read file ?name))
           (focus identify-lines convert-templates build-groups)
           else
           (printout t "ERROR: target file at " ?path " does not exist!" crlf
                     "Halting!" crlf)
           (halt)))
;------------------------------------------------------------------------------
(defrule identify-lines::build-file-line
         ?fct <- (read file ?fid)
         ?obj <- (object (is-a opened-file)
                         (id ?fid))
         =>
         (retract ?fct)
         (bind ?result (send ?obj read-line))
         (if (neq ?result EOF) then
           (assert (read file ?fid)
                   (file-line (index (send ?obj next-index))
                              (type UNKNOWN)
                              (parent ?fid)
                              (contents (explode$ ?result))))
           else
           (send ?obj close-file)
           (unmake-instance ?obj)))
;------------------------------------------------------------------------------
(defrule identify-lines::retract-unknowns
         (declare (salience -10))
         ?f <- (file-line (type UNKNOWN))
         =>
         (retract ?f))
;------------------------------------------------------------------------------
(defrule identify-lines::mark-heading-groups
         "Tags lines that consist of /* $? */ as group headings"
         ?f <- (file-line (type UNKNOWN)
                          (contents /* $? */))
         =>
         (modify ?f (type heading)))
;------------------------------------------------------------------------------
(defrule identify-lines::mark-entry-line
         "Tags lines that are defines and modifies the associated contents"
         ?f <- (file-line (type UNKNOWN)
                          (contents #define ?name ?))
         =>
         (modify ?f (type #define) (contents ?name)))
;------------------------------------------------------------------------------
(defrule identify-lines::merge-three-line-headers
         "Merges simple three line headings into one rule"
         ?f0 <- (file-line (index ?i)
                           (type UNKNOWN)
                           (contents /*))
         ?f1 <- (file-line (index ?i2&:(= ?i2 (+ ?i 1)))
                           (type UNKNOWN)
                           (contents * $?c))
         ?f2 <- (file-line (index ?i3&:(= ?i3 (+ ?i 2)))
                           (type UNKNOWN)
                           (contents */))
         =>
         (retract ?f1 ?f2)
         (modify ?f0 (contents /* $?c */)))
;------------------------------------------------------------------------------
(defrule identify-lines::mark-glapi-calls
         "marks glapi calls"
         ?f <- (file-line (type UNKNOWN)
                          (contents GLAPI $? "(" $? ")"))
         =>
         (modify ?f (type GLAPI-DEF)))
;------------------------------------------------------------------------------
(defrule identify-lines::merge-potential-glapi-calls
         "Merges the next line of a GLAPI call if the line doesn't end with )"
         (declare (salience -1))
         ?f <- (file-line (type UNKNOWN)
                          (contents GLAPI $?vals "(" $?c)
                          (index ?i))
         (test (not (member$ ")" $?c)))
         ?f0 <- (file-line (index ?i0&:(= ?i0 (+ ?i 1)))
                           (type UNKNOWN)
                           (contents $?contents))
         =>
         (retract ?f)
         (modify ?f0 (contents GLAPI $?vals "(" $?c $?contents)))
;------------------------------------------------------------------------------
(defrule identify-lines::define-header-spans-initial
         "Defines spans between headers"
         (declare (salience -3))
         (file-line (type heading)
                    (parent ?parent)
                    (index ?i)
                    (contents /* $?name */))
         (not (exists (heading-span (from ?i)
                                    (parent ?parent))))
         (file-line (type heading)
                    (parent ?parent)
                    (index ?i2&:(> ?i2 ?i)))
         =>
         (bind ?difference (- ?i2 ?i))
         (if (> ?difference 0) then
           (assert (heading-span (header-name (implode$ $?name))
                                 (from ?i)
                                 (to ?i2)
                                 (parent ?parent)
                                 (distance ?difference)))))
;------------------------------------------------------------------------------
(defrule identify-lines::modify-header-spans-for-smaller-size
         "Retracts the heading-span in response to finding an earlier heading"
         ?f <- (heading-span (from ?i)
                             (to ?j)
                             (parent ?parent))
         (file-line (type heading)
                    (parent ?parent)
                    (index ?i2&:(> ?j ?i2 ?i)))
         =>
         (modify ?f (to ?i2)
                 (distance (- ?i2 ?i))))
;------------------------------------------------------------------------------
(defrule convert-templates::convert-line-objects
         ?f <- (file-line (type ?t) (parent ?p) (index ?i)
                          (contents $?c))
         =>
         (retract ?f)
         (bind ?name (gensym*))
         (assert (message (to build-groups)
                          (action add-to-span)
                          (arguments ?name)))
         (make-instance ?name of line-entry
                        (type ?t)
                        (parent ?p)
                        (index ?i)
                        (contents $?c)))
;------------------------------------------------------------------------------
(defrule build-groups::build-grouping
         ?f <- (heading-span (from ?i)
                             (to ?i2)
                             (parent ?parent)
                             (contents $?c))
         (object (is-a line-entry)
                 (parent ?parent)
                 (index ?loc&:(> ?i2 ?loc ?i))
                 (id ?id))
         ?msg <- (message (to build-groups)
                          (action add-to-span)
                          (arguments ?id))
         =>
         (retract ?msg)
         (modify ?f (contents $?c ?id)))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;Copyright (c) 2013, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; GLConstantConversion.clp - an expert system that reads a define and generates
; conversion code for it.
;------------------------------------------------------------------------------
(defmodule types
           (export ?ALL))
;------------------------------------------------------------------------------
(defmodule identify-lines
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule convert-templates
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule build-groups
           (import types ?ALL))
;------------------------------------------------------------------------------
(defclass types::opened-file
  (is-a USER)
  (slot id)
  (slot index (type INTEGER) (range 0 ?VARIABLE))
  (message-handler next-index)
  (message-handler read-line)
  (message-handler close-file))
;------------------------------------------------------------------------------
(defmessage-handler types::opened-file next-index ()
                    (bind ?old ?self:index)
                    (bind ?self:index (+ ?old 1))
                    (return ?old))
;------------------------------------------------------------------------------
(defmessage-handler types::opened-file read-line ()
                    (readline ?self:id))
;------------------------------------------------------------------------------
(defmessage-handler types::opened-file close-file ()
                    (close ?self:id))
;------------------------------------------------------------------------------
(deftemplate types::file-line
             (slot index)
             (slot parent)
             (slot type)
             (multislot contents))
;------------------------------------------------------------------------------
(deftemplate types::heading-span
             "Defines a span between two different headings"
             (slot header-name)
             (multislot contents)
             (slot from)
             (slot to)
             (slot parent)
             (slot distance))
;------------------------------------------------------------------------------
(deftemplate types::message
             (slot from)
             (slot to)
             (slot action)
             (multislot arguments))
;------------------------------------------------------------------------------
(defclass types::line-entry
  (is-a USER)
  (slot id)
  (slot index)
  (slot parent)
  (slot type)
  (multifield contents))
;------------------------------------------------------------------------------
(defmessage-handler types::line-entry init after ()
                    (bind ?self:id (instance-name-to-symbol (instance-name ?self))))
;------------------------------------------------------------------------------
; INPUT FACT FORM: (parse constant file ?path)
;------------------------------------------------------------------------------
(deffunction types::get-input-form-factor ()
             (printout t "(parse constant file ?path)" crlf))
;------------------------------------------------------------------------------
(defrule MAIN::open-target-file
         "This rule takes a fact of the above INPUT FORM and attempts to open the file"
         ?fct <- (parse constant file ?path)
         =>
         (bind ?name (gensym*))
         (retract ?fct)
         (if (open ?path ?name "r") then
           (make-instance of opened-file (id ?name) (index 0))
           (assert (read file ?name))
           (focus identify-lines convert-templates build-groups)
           else
           (printout t "ERROR: target file at " ?path " does not exist!" crlf
                     "Halting!" crlf)
           (halt)))
;------------------------------------------------------------------------------
(defrule identify-lines::build-file-line
         ?fct <- (read file ?fid)
         ?obj <- (object (is-a opened-file)
                         (id ?fid))
         =>
         (retract ?fct)
         (bind ?result (send ?obj read-line))
         (if (neq ?result EOF) then
           (assert (read file ?fid)
                   (file-line (index (send ?obj next-index))
                              (type UNKNOWN)
                              (parent ?fid)
                              (contents (explode$ ?result))))
           else
           (send ?obj close-file)
           (unmake-instance ?obj)))
;------------------------------------------------------------------------------
(defrule identify-lines::retract-unknowns
         (declare (salience -10))
         ?f <- (file-line (type UNKNOWN))
         =>
         (retract ?f))
;------------------------------------------------------------------------------
(defrule identify-lines::mark-heading-groups
         "Tags lines that consist of /* $? */ as group headings"
         ?f <- (file-line (type UNKNOWN)
                          (contents /* $? */))
         =>
         (modify ?f (type heading)))
;------------------------------------------------------------------------------
(defrule identify-lines::mark-entry-line
         "Tags lines that are defines and modifies the associated contents"
         ?f <- (file-line (type UNKNOWN)
                          (contents #define ?name ?))
         =>
         (modify ?f (type #define) (contents ?name)))
;------------------------------------------------------------------------------
(defrule identify-lines::merge-three-line-headers
         "Merges simple three line headings into one rule"
         ?f0 <- (file-line (index ?i)
                           (type UNKNOWN)
                           (contents /*))
         ?f1 <- (file-line (index ?i2&:(= ?i2 (+ ?i 1)))
                           (type UNKNOWN)
                           (contents * $?c))
         ?f2 <- (file-line (index ?i3&:(= ?i3 (+ ?i 2)))
                           (type UNKNOWN)
                           (contents */))
         =>
         (retract ?f1 ?f2)
         (modify ?f0 (contents /* $?c */)))
;------------------------------------------------------------------------------
(defrule identify-lines::mark-glapi-calls
         "marks glapi calls"
         ?f <- (file-line (type UNKNOWN)
                          (contents GLAPI $? "(" $? ")"))
         =>
         (modify ?f (type GLAPI-DEF)))
;------------------------------------------------------------------------------
(defrule identify-lines::merge-potential-glapi-calls
         "Merges the next line of a GLAPI call if the line doesn't end with )"
         (declare (salience -1))
         ?f <- (file-line (type UNKNOWN)
                          (contents GLAPI $?vals "(" $?c)
                          (index ?i))
         (test (not (member$ ")" $?c)))
         ?f0 <- (file-line (index ?i0&:(= ?i0 (+ ?i 1)))
                           (type UNKNOWN)
                           (contents $?contents))
         =>
         (retract ?f)
         (modify ?f0 (contents GLAPI $?vals "(" $?c $?contents)))
;------------------------------------------------------------------------------
(defrule identify-lines::define-header-spans-initial
         "Defines spans between headers"
         (declare (salience -3))
         (file-line (type heading)
                    (parent ?parent)
                    (index ?i)
                    (contents /* $?name */))
         (not (exists (heading-span (from ?i)
                                    (parent ?parent))))
         (file-line (type heading)
                    (parent ?parent)
                    (index ?i2&:(> ?i2 ?i)))
         =>
         (bind ?difference (- ?i2 ?i))
         (if (> ?difference 0) then
           (assert (heading-span (header-name (implode$ $?name))
                                 (from ?i)
                                 (to ?i2)
                                 (parent ?parent)
                                 (distance ?difference)))))
;------------------------------------------------------------------------------
(defrule identify-lines::modify-header-spans-for-smaller-size
         "Retracts the heading-span in response to finding an earlier heading"
         ?f <- (heading-span (from ?i)
                             (to ?j)
                             (parent ?parent))
         (file-line (type heading)
                    (parent ?parent)
                    (index ?i2&:(> ?j ?i2 ?i)))
         =>
         (modify ?f (to ?i2)
                 (distance (- ?i2 ?i))))
;------------------------------------------------------------------------------
(defrule convert-templates::convert-line-objects
         ?f <- (file-line (type ?t) (parent ?p) (index ?i)
                          (contents $?c))
         =>
         (retract ?f)
         (bind ?name (gensym*))
         (assert (message (to build-groups)
                          (action add-to-span)
                          (arguments ?name)))
         (make-instance ?name of line-entry
                        (type ?t)
                        (parent ?p)
                        (index ?i)
                        (contents $?c)))
;------------------------------------------------------------------------------
(defrule build-groups::build-grouping
         ?f <- (heading-span (from ?i)
                             (to ?i2)
                             (parent ?parent)
                             (contents $?c))
         (object (is-a line-entry)
                 (parent ?parent)
                 (index ?loc&:(> ?i2 ?loc ?i))
                 (id ?id))
         ?msg <- (message (to build-groups)
                          (action add-to-span)
                          (arguments ?id))
         =>
         (retract ?msg)
         (modify ?f (contents $?c ?id)))
;------------------------------------------------------------------------------


Fixed up fixed size array support

Fixed up fixed size array support

;------------------------------------------------------------------------------
;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")
;------------------------------------------------------------------------------
(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)
  (multislot arguments)
  (message-handler add-argument))
;------------------------------------------------------------------------------
(defmessage-handler types::GLAPIFunction add-argument
						  "Adds the arg name and returns the index"
						  (?name)
						  (bind ?index (length$ ?self:arguments))
						  (if (= 0 ?index) then
							 (slot-direct-insert$ arguments 1 ?name)
							 (return 1)
							 else
							 (slot-direct-insert$ arguments ?index ?name)
							 (return ?index)))
;------------------------------------------------------------------------------
(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[%d]"
												(call-next-handler)
												?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 (to grouping-update)
					  (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
			(bind ?objName (gensym*))
			(retract ?msg)
			(make-instance ?objName of GLAPIFunction
								(return-type ?ret)
								(function-name ?name)
								(clips-function-name (sym-cat CLIPS_ ?name))))
;------------------------------------------------------------------------------
(defrule grouping-update::parse-fixed-size-array-argument
			(declare (salience 2))
			?fct <- (message (to grouping-update)
								  (action parse-arguments)
								  (arguments ?o => $?sentry "[" ?size "]" ,|"," $?rest))
			?obj <- (object (is-a GLAPIFunction)
								 (id ?o))
			=>
			(modify ?fct (arguments ?o => $?rest))
			(bind ?name (gensym*))
			(duplicate ?fct (action populate-argument)
						  (arguments ?name => $?sentry))
			(make-instance ?name of GLAPIFixedArrayArgument
								(parent ?o)
								(index (send ?obj add-argument ?name))
								(array-size ?size)))
;------------------------------------------------------------------------------
(defrule grouping-update::parse-arguments-generic
			(declare (salience 1))
			?fct <- (message (to grouping-update)
								  (action parse-arguments)
								  (arguments ?o => $?sentry ,|"," $?rest))
			?obj <- (object (is-a GLAPIFunction)
								 (id ?o))
			=>
			(modify ?fct (arguments ?o => $?rest))
			(bind ?name (gensym*))
			(duplicate ?fct (action populate-argument)
						  (arguments ?name => $?sentry))
			(make-instance ?name of GLAPIArgument
								(parent ?o)
								(index (send ?obj add-argument ?name))))
;------------------------------------------------------------------------------
(defrule grouping-update::create-last-argument
			?fct <- (message (to grouping-update)
								  (action parse-arguments)
								  (arguments ?o => $?all))
			(test (and (not (member$ , $?all))
						  (not (member$ "," $?all))))
			?obj <- (object (is-a GLAPIFunction)
								 (id ?o))
			=>
			(bind ?name (gensym*))
			(modify ?fct (action populate-argument)
					  (arguments ?name => $?all))
			(make-instance ?name of GLAPIArgument
								(parent ?o)
								(index (send ?obj add-argument ?name))))
;------------------------------------------------------------------------------
(defrule grouping-update::retract-empty-parse-message
			?fct <- (message (to grouping-update)
								  (action parse-arguments)
								  (arguments ? =>))
			=>
			(retract ?fct))
;------------------------------------------------------------------------------
(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")
;------------------------------------------------------------------------------
; 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)
  (multislot arguments)
  (message-handler add-argument))
;------------------------------------------------------------------------------
(defmessage-handler types::GLAPIFunction add-argument
						  "Adds the arg name and returns the index"
						  (?name)
						  (bind ?index (length$ ?self:arguments))
						  (if (= 0 ?index) then
							 (slot-direct-insert$ arguments 1 ?name)
							 (return 1)
							 else
							 (slot-direct-insert$ arguments ?index ?name)
							 (return ?index)))
;------------------------------------------------------------------------------
(defclass types::GLAPIArgument
  "Defines a given GLAPI function argument"
  (is-a Object)
  (slot argument-type)
  (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
						  ()
						  (format t "%s %s %s %s"
									 (if ?self:is-constant then "const" else "")
									 ?self:argument-type
									 (if ?self:is-pointer then "*" else "")
									 ?self:argument-name))
;------------------------------------------------------------------------------
(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 (to grouping-update)
					  (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
			(bind ?objName (gensym*))
			(retract ?msg)
			(make-instance ?objName of GLAPIFunction
								(return-type ?ret)
								(function-name ?name)
								(clips-function-name (sym-cat CLIPS_ ?name))))
;------------------------------------------------------------------------------
(defrule grouping-update::parse-arguments
			(declare (salience 1))
			?fct <- (message (to grouping-update)
								  (action parse-arguments)
								  (arguments ?o => $?sentry ,|"," $?rest))
			?obj <- (object (is-a GLAPIFunction)
								 (id ?o))
			=>
			(modify ?fct (arguments ?o => $?rest))
			(bind ?name (gensym*))
			(duplicate ?fct (action populate-argument)
						  (arguments ?name => $?sentry))
			(make-instance ?name of GLAPIArgument
								(parent ?o)
								(index (send ?obj add-argument ?name))))
;------------------------------------------------------------------------------
(defrule grouping-update::create-last-argument
			?fct <- (message (to grouping-update)
								  (action parse-arguments)
								  (arguments ?o => $?all))
			(test (and (not (member$ , $?all))
						  (not (member$ "," $?all))))
			?obj <- (object (is-a GLAPIFunction)
								 (id ?o))
			=>
			(bind ?name (gensym*))
			(modify ?fct (action populate-argument)
					  (arguments ?name => $?all))
			(make-instance ?name of GLAPIArgument
								(parent ?o)
								(index (send ?obj add-argument ?name))))
;------------------------------------------------------------------------------
(defrule grouping-update::retract-empty-parse-message
			?fct <- (message (to grouping-update)
								  (action parse-arguments)
								  (arguments ? =>))
			=>
			(retract ?fct))
;------------------------------------------------------------------------------
(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))
			=>
			(send ?obj reconstitute)
			(printout t crlf))
;------------------------------------------------------------------------------