waltz: commented out the deffunctions

waltz: commented out the deffunctions

;;; The Waltz Algorithm implemented using CLIPS
;;; The original source for the OPS5 benchmark suite is available
;;; at http://www.cs.utexas.edu/ftp/pub/ops5-benchmark-suite/

;;; The copyright notice from the original code:

;;; Copyright C 1991 Satoshi Nishiyama and the University of Texas at Austin
;;; anyone may copy and use this program the terms listed in the copyright
;;; notice in and covering the Communications of the ACM, the program is
;;; is not warranted to do anything

;;; Changes made for the CLIPS version
;;;
;;;   Reformatted code
;;;   Converted C code to deffunctions
;;;   Uses salience to obtain a number of rule firings consistent
;;;     with other rule engines running this benchmark

;;; ##########################################################################
;;; Deftemplates
;;;
;;; Lines have the lable line followed by the 2 points defining the line.
;;;
;;; Edges are like lines accept that they can be labeled, permanently labeled,
;;; and plotted.
;;;
;;; Junctions are defined by 4 points.  The basepoint is where the 3 (2) lines
;;; intersect.  The points p1, p2, p3 are the other endpoints of the lines at
;;; this junction
;;; ##########################################################################

(deftemplate stage
   (slot value))

(deftemplate line
   (slot p1 (type INTEGER))
   (slot p2 (type INTEGER)))

(deftemplate edge
   (slot p1 (type INTEGER))
   (slot p2 (type INTEGER))
   (slot joined (type BOOLEAN))
   (slot label)
   (slot plotted))

(deftemplate junction
   (slot p1 (type INTEGER))
   (slot p2 (type INTEGER))
   (slot p3 (type INTEGER))
   (slot base_point (type INTEGER))
   (slot jtype))

; ;;; #################################################################
; ;;; Deffunctions
; ;;;
; ;;; In the OPS5 version of this program, the following deffunctions
; ;;; were implemented in C code that needed to be linked with the OPS5
; ;;; interpreter. Using deffunctions allows the benchmark to be run
; ;;; without having to recompile and relink CLIPS with the C code used
; ;;; in the original benchmark. The performance impact of using
; ;;; deffunctions for this benchmark rather than C code is minimal.
; ;;; #################################################################

; (defglobal ?*MOD-NUM* = 100)

; ;;; *****
; ;;; atan2
; ;;; *****

; (deffunction atan2 (?y ?x)
;    (if (> ?x 0)
;       then
;       (return (atan (/ ?y ?x))))

;    (if (< ?x 0)
;       then
;       (return (- (atan (/ ?y ?x)) (pi))))

;    (if (> ?y 0) then
;       then
;       (return (pi)))

;    (if (< ?y 0)
;       then
;       (return (- 0 (pi))))

;    (return undefined))

; ;;; *****
; ;;; get-y
; ;;; *****

; (deffunction get-y (?val)
;    (mod ?val ?*MOD-NUM*))

; ;;; *****
; ;;; get-x
; ;;; *****

; (deffunction get-x (?val)
;    (integer (/ ?val ?*MOD-NUM*)))

; ;;; *********
; ;;; get-angle
; ;;; *********

; (deffunction get-angle (?p1 ?p2)
;    (bind ?delta-x (- (get-x ?p2) (get-x ?p1)))
;    (bind ?delta-y (- (get-y ?p2) (get-y ?p1)))
;    (if (= ?delta-x 0)
;       then
;        (if (> ?delta-y 0)
; 		  then (return (/ (pi) 2))
; 		  else (if (< ?delta-y 0) then (return (/ (pi) -2))))
;       else
;       (if (= ?delta-y 0)
;          then
;          (if (> ?delta-x 0)
;             then (return 0.0)
; 		    else (if (< ?delta-x 0) then return (pi)))
;          else
;          (return (atan2 ?delta-y ?delta-x)))))

; ;;; ***************
; ;;; inscribed-angle
; ;;; ***************

; (deffunction inscribed-angle (?basepoint ?p1 ?p2)

; 	;; Get the angle between line #1 and the origin and the angle
; 	;; between line #2 and the origin, and then subtract these values.

;    (bind ?angle1 (get-angle ?basepoint ?p1))
;    (bind ?angle2 (get-angle ?basepoint ?p2))
;    (bind ?temp (- ?angle1 ?angle2))

;    (if (< ?temp 0)
;       then (bind ?temp (- 0 ?temp)))

;    ;; We always want the smaller of the two angles inscribed, so
;    ;; if the answer is greater than 180 degrees, calculate the
;    ;; smaller angle and return it.

;    (if (> ?temp (pi))
;       then
;       (bind ?temp (- (* 2 (pi)) ?temp)))

;    (if (< ?temp 0)
;       then (return (- 0 ?temp)))

;    (return ?temp))

; ;;; ***************
; ;;; make-3-junction
; ;;; ***************

; (deffunction make-3-junction (?basepoint ?p1 ?p2 ?p3)
;    (bind ?angle12 (inscribed-angle ?basepoint ?p1 ?p2))
;    (bind ?angle13 (inscribed-angle ?basepoint ?p1 ?p3))
;    (bind ?angle23 (inscribed-angle ?basepoint ?p2 ?p3))

;    (bind ?sum1213 (+ ?angle12 ?angle13))
;    (bind ?sum1223 (+ ?angle12 ?angle23))
;    (bind ?sum1323 (+ ?angle13 ?angle23))

;    (if (< ?sum1213 ?sum1223)
;       then
;       (if (< ?sum1213 ?sum1323)
;          then
;          (bind ?sum ?sum1213)
;          (bind ?shaft ?p1)
;          (bind ?barb1 ?p2)
;          (bind ?barb2 ?p3)
;          else
;          (bind ?sum ?sum1323)
;          (bind ?shaft ?p3)
;          (bind ?barb1 ?p1)
;          (bind ?barb2 ?p2))
;       else
;       (if (< ?sum1223 ?sum1323)
;          then
;          (bind ?sum ?sum1223)
;          (bind ?shaft ?p2)
;          (bind ?barb1 ?p1)
;          (bind ?barb2 ?p3)
;          else
;          (bind ?sum ?sum1323)
;          (bind ?shaft ?p3)
;          (bind ?barb1 ?p1)
;          (bind ?barb2 ?p2)))

;    (bind ?delta (- ?sum (pi)))
;    (if (< ?delta 0)
;       then (bind ?delta (- 0 ?delta)))

;    (if (< ?delta 0.001)
;       then (bind ?jtype tee)
;       else
;       (if (> ?sum (pi))
;          then (bind ?jtype fork)
;          else (bind ?jtype arrow)))

;    (assert (junction (p1 (integer ?barb1))
;                      (p2 (integer ?shaft))
;                      (p3 (integer ?barb2))
;                      (base_point (integer ?basepoint))
;                      (jtype ?jtype))))

;;; ########
;;; Defrules
;;; ########

;;; *******************************************************
;;; begin: Our starting production. It checks to see if the
;;;   start flag is in WM, and if it is, it deletes it
;;; *******************************************************

(defrule begin
	?f1 <- (stage (value start))
	=>
	(assert (line (p1 0122) (p2 0107)))
	(assert (line (p1 0107) (p2 2207)))
	(assert (line (p1 2207) (p2 3204)))
	(assert (line (p1 3204) (p2 6404)))
	(assert (line (p1 2216) (p2 2207)))
	(assert (line (p1 3213) (p2 3204)))
	(assert (line (p1 2216) (p2 3213)))
	(assert (line (p1 0107) (p2 2601)))
	(assert (line (p1 2601) (p2 7401)))
	(assert (line (p1 6404) (p2 7401)))
	(assert (line (p1 3213) (p2 6413)))
	(assert (line (p1 6413) (p2 6404)))
	(assert (line (p1 7416) (p2 7401)))
	(assert (line (p1 5216) (p2 6413)))
	(assert (line (p1 2216) (p2 5216)))
	(assert (line (p1 0122) (p2 5222)))
	(assert (line (p1 5222) (p2 7416)))
	(assert (line (p1 5222) (p2 5216)))
	(modify ?f1 (value duplicateStage)))

;;; **********************************************************************
;;; reverse_edges: If the duplicate flag is set, and there is still a line
;;;   in WM, delete the line and add two edges. One edge runs from p1 to
;;;   p2 and the other runs from p2 to p1. We then plot the edge.
;;; **********************************************************************

(defrule reverse_edges
	(stage (value duplicateStage))
	?f2 <- (line (p1 ?p1) (p2 ?p2))
	=>
	(assert (edge (p1 ?p1) (p2 ?p2) (joined false)))
    (assert (edge (p1 ?p2) (p2 ?p1) (joined false)))
	(retract ?f2))

;;; **************************************************************************
;;; done_reversing: If the duplicating flag is set, and there are no more
;;;   lines, then remove the duplicating flag and set the make junctions flag.
;;; **************************************************************************

(defrule done_reversing
	(declare (salience -10))
	?f1 <- (stage (value duplicateStage))
	(not (line))
	=>
	(modify ?f1 (value detect_junctions)))

;;; *****************************************************************************
;;; make-3_junction: If three edges meet at a point and none of them have already
;;;   been joined in a junction, then make the corresponding jtype of junction and
;;;   label the edges joined.  This production calls make-3_junction to determine
;;;   what jtype of junction it is based on the angles inscribed by the
;;;   intersecting edges.
;;; *****************************************************************************

(defrule make-3_junction
	(declare (salience 10))
	(stage (value detect_junctions))
	?f2 <- (edge (p1 ?base_point) (p2 ?p1) (joined false))
	?f3 <- (edge (p1 ?base_point) (p2 ?p2&~?p1) (joined false))
	?f4 <- (edge (p1 ?base_point) (p2 ?p3&~?p1&~?p2) (joined false))
	=>
	(make-3-junction ?base_point ?p1 ?p2 ?p3)
	(modify ?f2 (joined true))
	(modify ?f3 (joined true))
	(modify ?f4 (joined true)))

;;; ******************************************************
;;; make_L: If two, and only two, edges meet that have not
;;;   already been joined, then the junction is an "L".
;;; ******************************************************

(defrule make_L
	(stage (value detect_junctions))
	?f2 <- (edge (p1 ?base_point) (p2 ?p2) (joined false))
	?f3 <- (edge (p1 ?base_point) (p2 ?p3&~?p2) (joined false))
	(not (edge (p1 ?base_point) (p2 ~?p2&~?p3)))
	=>
	(assert (junction (jtype L)
               		  (base_point ?base_point)
		              (p1 ?p2)
		              (p2 ?p3)))
	(modify ?f2 (joined true))
	(modify ?f3 (joined true)))

;;; ******************************************************************
;;; done_detecting: If the detect junctions flag is set, and there are
;;;   no more un_joined edges, set the find_initial_boundary flag.
;;; ******************************************************************

(defrule done_detecting
	(declare (salience -10))
	?f1 <- (stage (value detect_junctions))
	(not (edge (joined false)))
	=>
	(modify ?f1 (value find_initial_boundary)))

;;; ****************************************************
;;; initial_boundary_junction_L: If the initial boundary
;;;   junction is an L, then we know it's labelling
;;; ****************************************************

(defrule initial_boundary_junction_L
	?f1 <- (stage (value find_initial_boundary))
    (junction (jtype L)
              (base_point ?base_point)
              (p1 ?p1)
              (p2 ?p2))
	?f3 <- (edge (p1 ?base_point) (p2 ?p1))
	?f4 <- (edge (p1 ?base_point) (p2 ?p2))
    (not (junction (base_point ?bp&:(> ?bp ?base_point))))
	=>
    (modify ?f3 (label B))
	(modify ?f4 (label B))
	(modify ?f1 (value find_second_boundary)))

;;; ***************************************************
;;; initial_boundary_junction_arrow: Ditto for an arrow
;;; ***************************************************

(defrule initial_boundary_junction_arrow
	?f1 <- (stage (value find_initial_boundary))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	?f3 <- (edge (p1 ?bp) (p2 ?p1))
	?f4 <- (edge (p1 ?bp) (p2 ?p2))
	?f5 <- (edge (p1 ?bp) (p2 ?p3))
	(not (junction (base_point ?base_point&:(> ?base_point ?bp))))
	=>
    (modify ?f3 (label B))
	(modify ?f4 (label +))
	(modify ?f5 (label B))
	(modify ?f1 (value find_second_boundary)))

;;; ***********************************************************************
;;; second_boundary_junction_L: If we have already found the first boundary
;;;   point, then find the second boundary point, and label it.
;;; ***********************************************************************

(defrule second_boundary_junction_L
	?f1 <- (stage (value find_second_boundary))
    (junction (jtype L) (base_point ?base_point) (p1 ?p1) (p2 ?p2))
	?f3 <- (edge (p1 ?base_point) (p2 ?p1))
	?f4 <- (edge (p1 ?base_point) (p2 ?p2))
    (not (junction (base_point ?bp&:(< ?bp ?base_point))))
	=>
    (modify ?f3 (label B))
    (modify ?f4 (label B))
    (modify ?f1 (value labeling)))

;;; ******************************
;;; second_boundary_junction_arrow
;;; ******************************

(defrule second_boundary_junction_arrow
	?f1 <- (stage (value find_second_boundary))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	?f3 <- (edge (p1 ?bp) (p2 ?p1))
	?f4 <- (edge (p1 ?bp) (p2 ?p2))
	?f5 <- (edge (p1 ?bp) (p2 ?p3))
	(not (junction (base_point ?base_point&:(< ?base_point ?bp))))
	=>
    (modify ?f3 (label B))
	(modify ?f4 (label +))
	(modify ?f5 (label B))
	(modify ?f1 (value labeling)))

;;; **********************************************************************
;;; match_edge: If we have an edge whose label we already know definitely,
;;;   then label the corresponding edge in the other direction
;;; **********************************************************************

(defrule match_edge
	(stage (value labeling))
	?f2 <- (edge (p1 ?p1) (p2 ?p2) (label ?label& + | - | B))
	?f3 <- (edge (p1 ?p2) (p2 ?p1) (label nil))
	=>
	(modify ?f2 (plotted t))
	(modify ?f3 (label ?label) (plotted t)))

;;; The following productions propogate the possible labellings of the edges
;;; based on the labellings of edges incident on adjacent junctions.  Since
;;; from the initial boundary productions, we have determined the labellings of
;;; of atleast two junctions, this propogation will label all of the junctions
;;; with the possible labellings.  The search space is pruned due to filtering,
;;; i.e. - only label a junction in the ways physically possible based on the
;;; labellings of adjacent junctions.

;;; *******
;;; label_L
;;; *******

(defrule label_L
	(stage (value labeling))
	(junction (jtype L) (base_point ?p1))
	(edge (p1 ?p1) (p2 ?p2) (label + | -))
	?f4 <- (edge (p1 ?p1) (p2 ~?p2) (label nil))
	=>
	(modify ?f4 (label B)))

;;; ***********
;;; label_tee_A
;;; ***********

(defrule label_tee_A
	(declare (salience 5))
	(stage (value labeling))
	(junction (jtype tee) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	?f3 <- (edge (p1 ?bp) (p2 ?p1) (label nil))
	?f4 <- (edge (p1 ?bp) (p2 ?p3))
	=>
    (modify ?f3 (label B))
	(modify ?f4 (label B)))

;;; ***********
;;; label_tee_B
;;; ***********

(defrule label_tee_B
	(stage (value labeling))
	(junction (jtype tee) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	?f3 <- (edge (p1 ?bp) (p2 ?p1))
	?f4 <- (edge (p1 ?bp) (p2 ?p3) (label nil))
	=>
    (modify ?f3 (label B))
	(modify ?f4 (label B)))

;;; ************
;;; label_fork-1
;;; ************

(defrule label_fork-1
	(stage (value labeling))
	(junction (jtype fork) (base_point ?bp))
	(edge (p1 ?bp) (p2 ?p1) (label +))
	?f4 <- (edge (p1 ?bp) (p2 ?p2&~?p1) (label nil))
	?f5 <- (edge (p1 ?bp) (p2 ~?p2&~?p1))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label +)))

;;; ************
;;; label_fork-2
;;; ************

(defrule label_fork-2
	(stage (value labeling))
	(junction (jtype fork) (base_point ?bp))
	(edge (p1 ?bp) (p2 ?p1) (label B))
	(edge (p1 ?bp) (p2 ?p2&~?p1) (label -))
	?f5 <- (edge (p1 ?bp) (p2 ~?p2&~?p1) (label nil))
	=>
	(modify ?f5 (label B)))

;;; ************
;;; label_fork-3
;;; ************

(defrule label_fork-3
	(stage (value labeling))
	(junction (jtype fork) (base_point ?bp))
	(edge (p1 ?bp) (p2 ?p1) (label B))
	(edge (p1 ?bp) (p2 ?p2&~?p1) (label B))
	?f5 <- (edge (p1 ?bp) (p2 ~?p2&~?p1) (label nil))
	=>
	(modify ?f5 (label -)))

;;; ************
;;; label_fork-4
;;; ************

(defrule label_fork-4
	(stage (value labeling))
	(junction (jtype fork) (base_point ?bp))
	(edge (p1 ?bp) (p2 ?p1) (label -))
	(edge (p1 ?bp) (p2 ?p2&~?p1) (label -))
	?f5 <- (edge (p1 ?bp) (p2 ~?p2&~?p1) (label nil))
	=>
	(modify ?f5 (label -)))

;;; **************
;;; label_arrow-1A
;;; **************

(defrule label_arrow-1A
	(declare (salience 5))
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p1) (label ?label& B | - ))
	?f4 <- (edge (p1 ?bp) (p2 ?p2) (label nil))
	?f5 <- (edge (p1 ?bp) (p2 ?p3))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label ?label)))

;;; **************
;;; label_arrow-1B
;;; **************

(defrule label_arrow-1B
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p1) (label ?label& B | - ))
	?f4 <- (edge (p1 ?bp) (p2 ?p2))
	?f5 <- (edge (p1 ?bp) (p2 ?p3) (label nil))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label ?label)))

;;; **************
;;; label_arrow-2A
;;; **************

(defrule label_arrow-2A
	(declare (salience 5))
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p3) (label ?label& B | - ))
	?f4 <- (edge (p1 ?bp) (p2 ?p2) (label nil))
	?f5 <- (edge (p1 ?bp) (p2 ?p1))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label ?label)))

;;; **************
;;; label_arrow-2B
;;; **************

(defrule label_arrow-2B
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p3) (label ?label& B | - ))
	?f4 <- (edge (p1 ?bp) (p2 ?p2))
	?f5 <- (edge (p1 ?bp) (p2 ?p1) (label nil))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label ?label)))

;;; **************
;;; label_arrow-3A
;;; **************

(defrule label_arrow-3A
	(declare (salience 5))
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p1) (label +))
	?f4 <- (edge (p1 ?bp) (p2 ?p2) (label nil))
	?f5 <- (edge (p1 ?bp) (p2 ?p3))
	=>
	(modify ?f4 (label -))
	(modify ?f5 (label +)))

;;; **************
;;; label_arrow-3B
;;; **************

(defrule label_arrow-3B
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p1) (label +))
	?f4 <- (edge (p1 ?bp) (p2 ?p2))
	?f5 <- (edge (p1 ?bp) (p2 ?p3) (label nil))
	=>
	(modify ?f4 (label -))
	(modify ?f5 (label +)))

;;; **************
;;; label_arrow-4A
;;; **************

(defrule label_arrow-4A
	(declare (salience 5))
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p3) (label +))
	?f4 <- (edge (p1 ?bp) (p2 ?p2) (label nil))
	?f5 <- (edge (p1 ?bp) (p2 ?p1))
	=>
	(modify ?f4 (label -))
	(modify ?f5 (label +)))

;;; **************
;;; label_arrow-4B
;;; **************

(defrule label_arrow-4B
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p3) (label +))
	?f4 <- (edge (p1 ?bp) (p2 ?p2))
	?f5 <- (edge (p1 ?bp) (p2 ?p1) (label nil))
	=>
	(modify ?f4 (label -))
	(modify ?f5 (label +)))

;;; **************
;;; label_arrow-5A
;;; **************

(defrule label_arrow-5A
	(declare (salience 5))
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p2) (label -))
	?f4 <- (edge (p1 ?bp) (p2 ?p1))
	?f5 <- (edge (p1 ?bp) (p2 ?p3) (label nil))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label +)))

;;; **************
;;; label_arrow-5B
;;; **************

(defrule label_arrow-5B
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p2) (label -))
	?f4 <- (edge (p1 ?bp) (p2 ?p1) (label nil))
	?f5 <- (edge (p1 ?bp) (p2 ?p3))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label +)))

;;; *******************************************************************************
;;; done_labeling: The conflict resolution mechanism will only execute a production
;;;   if no productions that are more complicated are satisfied.  This production
;;;   is simple, so all of the above dictionary productions will fire before this
;;;   change of state production
;;; *******************************************************************************

(defrule done_labeling
	(declare (salience -10))
	?f1 <- (stage (value labeling))
	=>
	(modify ?f1 (value plot_remaining_edges)))

;;; **************************************************
;;; plot_remaining: At this point, some labellings may
;;;   have not been plotted, so plot them
;;; **************************************************

(defrule plot_remaining
	(stage (value plot_remaining_edges))
	?f2 <- (edge (plotted nil) (label ?label&~nil) (p1 ?p1) (p2 ?p2))
	=>
	(modify ?f2 (plotted t)))

;;; ********************************************************************************
;;; plot_boundaries: If we have been un able to label an edge, assume that it is a
;;;   boundary. This is a total Kludge, but what the hell. (if we assume only
;;;   valid drawings will be given for labeling, this assumption generally is true!)
;;; ********************************************************************************

(defrule plot_boundaries
	(stage (value plot_remaining_edges))
	?f2 <- (edge (plotted nil) (label nil) (p1 ?p1) (p2 ?p2))
	=>
	(modify ?f2 (plotted t)))

;;; ****************************************************************************
;;; done_plotting: If there is no more work to do, then we are done and flag it.
;;; ****************************************************************************

(defrule done_plotting
	(declare (salience -10))
	?f1 <- (stage (value plot_remaining_edges))
	(not (edge (plotted nil)))
	=>
	(modify ?f1 (value done)))

;;; The Waltz Algorithm implemented using CLIPS
;;; The original source for the OPS5 benchmark suite is available
;;; at http://www.cs.utexas.edu/ftp/pub/ops5-benchmark-suite/

;;; The copyright notice from the original code:

;;; Copyright C 1991 Satoshi Nishiyama and the University of Texas at Austin
;;; anyone may copy and use this program the terms listed in the copyright
;;; notice in and covering the Communications of the ACM, the program is
;;; is not warranted to do anything

;;; Changes made for the CLIPS version
;;;
;;;   Reformatted code
;;;   Converted C code to deffunctions
;;;   Uses salience to obtain a number of rule firings consistent
;;;     with other rule engines running this benchmark

;;; ##########################################################################
;;; Deftemplates
;;;
;;; Lines have the lable line followed by the 2 points defining the line.
;;;
;;; Edges are like lines accept that they can be labeled, permanently labeled,
;;; and plotted.
;;;
;;; Junctions are defined by 4 points.  The basepoint is where the 3 (2) lines
;;; intersect.  The points p1, p2, p3 are the other endpoints of the lines at
;;; this junction
;;; ##########################################################################

(deftemplate stage
   (slot value))

(deftemplate line
   (slot p1 (type INTEGER))
   (slot p2 (type INTEGER)))

(deftemplate edge
   (slot p1 (type INTEGER))
   (slot p2 (type INTEGER))
   (slot joined (type BOOLEAN))
   (slot label)
   (slot plotted))

(deftemplate junction
   (slot p1 (type INTEGER))
   (slot p2 (type INTEGER))
   (slot p3 (type INTEGER))
   (slot base_point (type INTEGER))
   (slot jtype))

;;; #################################################################
;;; Deffunctions
;;;
;;; In the OPS5 version of this program, the following deffunctions
;;; were implemented in C code that needed to be linked with the OPS5
;;; interpreter. Using deffunctions allows the benchmark to be run
;;; without having to recompile and relink CLIPS with the C code used
;;; in the original benchmark. The performance impact of using
;;; deffunctions for this benchmark rather than C code is minimal.
;;; #################################################################

(defglobal ?*MOD-NUM* = 100)

;;; *****
;;; atan2
;;; *****

(deffunction atan2 (?y ?x)
   (if (> ?x 0)
      then
      (return (atan (/ ?y ?x))))

   (if (< ?x 0)
      then
      (return (- (atan (/ ?y ?x)) (pi))))

   (if (> ?y 0) then
      then
      (return (pi)))

   (if (< ?y 0)
      then
      (return (- 0 (pi))))

   (return undefined))

;;; *****
;;; get-y
;;; *****

(deffunction get-y (?val)
   (mod ?val ?*MOD-NUM*))

;;; *****
;;; get-x
;;; *****

(deffunction get-x (?val)
   (integer (/ ?val ?*MOD-NUM*)))

;;; *********
;;; get-angle
;;; *********

(deffunction get-angle (?p1 ?p2)
   (bind ?delta-x (- (get-x ?p2) (get-x ?p1)))
   (bind ?delta-y (- (get-y ?p2) (get-y ?p1)))
   (if (= ?delta-x 0)
      then
       (if (> ?delta-y 0)
		  then (return (/ (pi) 2))
		  else (if (< ?delta-y 0) then (return (/ (pi) -2))))
      else
      (if (= ?delta-y 0)
         then
         (if (> ?delta-x 0)
            then (return 0.0)
		    else (if (< ?delta-x 0) then return (pi)))
         else
         (return (atan2 ?delta-y ?delta-x)))))

;;; ***************
;;; inscribed-angle
;;; ***************

(deffunction inscribed-angle (?basepoint ?p1 ?p2)

	;; Get the angle between line #1 and the origin and the angle
	;; between line #2 and the origin, and then subtract these values.

   (bind ?angle1 (get-angle ?basepoint ?p1))
   (bind ?angle2 (get-angle ?basepoint ?p2))
   (bind ?temp (- ?angle1 ?angle2))

   (if (< ?temp 0)
      then (bind ?temp (- 0 ?temp)))

   ;; We always want the smaller of the two angles inscribed, so
   ;; if the answer is greater than 180 degrees, calculate the
   ;; smaller angle and return it.

   (if (> ?temp (pi))
      then
      (bind ?temp (- (* 2 (pi)) ?temp)))

   (if (< ?temp 0)
      then (return (- 0 ?temp)))

   (return ?temp))

;;; ***************
;;; make-3-junction
;;; ***************

(deffunction make-3-junction (?basepoint ?p1 ?p2 ?p3)
   (bind ?angle12 (inscribed-angle ?basepoint ?p1 ?p2))
   (bind ?angle13 (inscribed-angle ?basepoint ?p1 ?p3))
   (bind ?angle23 (inscribed-angle ?basepoint ?p2 ?p3))

   (bind ?sum1213 (+ ?angle12 ?angle13))
   (bind ?sum1223 (+ ?angle12 ?angle23))
   (bind ?sum1323 (+ ?angle13 ?angle23))

   (if (< ?sum1213 ?sum1223)
      then
      (if (< ?sum1213 ?sum1323)
         then
         (bind ?sum ?sum1213)
         (bind ?shaft ?p1)
         (bind ?barb1 ?p2)
         (bind ?barb2 ?p3)
         else
         (bind ?sum ?sum1323)
         (bind ?shaft ?p3)
         (bind ?barb1 ?p1)
         (bind ?barb2 ?p2))
      else
      (if (< ?sum1223 ?sum1323)
         then
         (bind ?sum ?sum1223)
         (bind ?shaft ?p2)
         (bind ?barb1 ?p1)
         (bind ?barb2 ?p3)
         else
         (bind ?sum ?sum1323)
         (bind ?shaft ?p3)
         (bind ?barb1 ?p1)
         (bind ?barb2 ?p2)))

   (bind ?delta (- ?sum (pi)))
   (if (< ?delta 0)
      then (bind ?delta (- 0 ?delta)))

   (if (< ?delta 0.001)
      then (bind ?jtype tee)
      else
      (if (> ?sum (pi))
         then (bind ?jtype fork)
         else (bind ?jtype arrow)))

   (assert (junction (p1 (integer ?barb1))
                     (p2 (integer ?shaft))
                     (p3 (integer ?barb2))
                     (base_point (integer ?basepoint))
                     (jtype ?jtype))))

;;; ########
;;; Defrules
;;; ########

;;; *******************************************************
;;; begin: Our starting production. It checks to see if the
;;;   start flag is in WM, and if it is, it deletes it
;;; *******************************************************

(defrule begin
	?f1 <- (stage (value start))
	=>
	(assert (line (p1 0122) (p2 0107)))
	(assert (line (p1 0107) (p2 2207)))
	(assert (line (p1 2207) (p2 3204)))
	(assert (line (p1 3204) (p2 6404)))
	(assert (line (p1 2216) (p2 2207)))
	(assert (line (p1 3213) (p2 3204)))
	(assert (line (p1 2216) (p2 3213)))
	(assert (line (p1 0107) (p2 2601)))
	(assert (line (p1 2601) (p2 7401)))
	(assert (line (p1 6404) (p2 7401)))
	(assert (line (p1 3213) (p2 6413)))
	(assert (line (p1 6413) (p2 6404)))
	(assert (line (p1 7416) (p2 7401)))
	(assert (line (p1 5216) (p2 6413)))
	(assert (line (p1 2216) (p2 5216)))
	(assert (line (p1 0122) (p2 5222)))
	(assert (line (p1 5222) (p2 7416)))
	(assert (line (p1 5222) (p2 5216)))
	(modify ?f1 (value duplicateStage)))

;;; **********************************************************************
;;; reverse_edges: If the duplicate flag is set, and there is still a line
;;;   in WM, delete the line and add two edges. One edge runs from p1 to
;;;   p2 and the other runs from p2 to p1. We then plot the edge.
;;; **********************************************************************

(defrule reverse_edges
	(stage (value duplicateStage))
	?f2 <- (line (p1 ?p1) (p2 ?p2))
	=>
	(assert (edge (p1 ?p1) (p2 ?p2) (joined false)))
    (assert (edge (p1 ?p2) (p2 ?p1) (joined false)))
	(retract ?f2))

;;; **************************************************************************
;;; done_reversing: If the duplicating flag is set, and there are no more
;;;   lines, then remove the duplicating flag and set the make junctions flag.
;;; **************************************************************************

(defrule done_reversing
	(declare (salience -10))
	?f1 <- (stage (value duplicateStage))
	(not (line))
	=>
	(modify ?f1 (value detect_junctions)))

;;; *****************************************************************************
;;; make-3_junction: If three edges meet at a point and none of them have already
;;;   been joined in a junction, then make the corresponding jtype of junction and
;;;   label the edges joined.  This production calls make-3_junction to determine
;;;   what jtype of junction it is based on the angles inscribed by the
;;;   intersecting edges.
;;; *****************************************************************************

(defrule make-3_junction
	(declare (salience 10))
	(stage (value detect_junctions))
	?f2 <- (edge (p1 ?base_point) (p2 ?p1) (joined false))
	?f3 <- (edge (p1 ?base_point) (p2 ?p2&~?p1) (joined false))
	?f4 <- (edge (p1 ?base_point) (p2 ?p3&~?p1&~?p2) (joined false))
	=>
	(make-3-junction ?base_point ?p1 ?p2 ?p3)
	(modify ?f2 (joined true))
	(modify ?f3 (joined true))
	(modify ?f4 (joined true)))

;;; ******************************************************
;;; make_L: If two, and only two, edges meet that have not
;;;   already been joined, then the junction is an "L".
;;; ******************************************************

(defrule make_L
	(stage (value detect_junctions))
	?f2 <- (edge (p1 ?base_point) (p2 ?p2) (joined false))
	?f3 <- (edge (p1 ?base_point) (p2 ?p3&~?p2) (joined false))
	(not (edge (p1 ?base_point) (p2 ~?p2&~?p3)))
	=>
	(assert (junction (jtype L)
               		  (base_point ?base_point)
		              (p1 ?p2)
		              (p2 ?p3)))
	(modify ?f2 (joined true))
	(modify ?f3 (joined true)))

;;; ******************************************************************
;;; done_detecting: If the detect junctions flag is set, and there are
;;;   no more un_joined edges, set the find_initial_boundary flag.
;;; ******************************************************************

(defrule done_detecting
	(declare (salience -10))
	?f1 <- (stage (value detect_junctions))
	(not (edge (joined false)))
	=>
	(modify ?f1 (value find_initial_boundary)))

;;; ****************************************************
;;; initial_boundary_junction_L: If the initial boundary
;;;   junction is an L, then we know it's labelling
;;; ****************************************************

(defrule initial_boundary_junction_L
	?f1 <- (stage (value find_initial_boundary))
    (junction (jtype L)
              (base_point ?base_point)
              (p1 ?p1)
              (p2 ?p2))
	?f3 <- (edge (p1 ?base_point) (p2 ?p1))
	?f4 <- (edge (p1 ?base_point) (p2 ?p2))
    (not (junction (base_point ?bp&:(> ?bp ?base_point))))
	=>
    (modify ?f3 (label B))
	(modify ?f4 (label B))
	(modify ?f1 (value find_second_boundary)))

;;; ***************************************************
;;; initial_boundary_junction_arrow: Ditto for an arrow
;;; ***************************************************

(defrule initial_boundary_junction_arrow
	?f1 <- (stage (value find_initial_boundary))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	?f3 <- (edge (p1 ?bp) (p2 ?p1))
	?f4 <- (edge (p1 ?bp) (p2 ?p2))
	?f5 <- (edge (p1 ?bp) (p2 ?p3))
	(not (junction (base_point ?base_point&:(> ?base_point ?bp))))
	=>
    (modify ?f3 (label B))
	(modify ?f4 (label +))
	(modify ?f5 (label B))
	(modify ?f1 (value find_second_boundary)))

;;; ***********************************************************************
;;; second_boundary_junction_L: If we have already found the first boundary
;;;   point, then find the second boundary point, and label it.
;;; ***********************************************************************

(defrule second_boundary_junction_L
	?f1 <- (stage (value find_second_boundary))
    (junction (jtype L) (base_point ?base_point) (p1 ?p1) (p2 ?p2))
	?f3 <- (edge (p1 ?base_point) (p2 ?p1))
	?f4 <- (edge (p1 ?base_point) (p2 ?p2))
    (not (junction (base_point ?bp&:(< ?bp ?base_point))))
	=>
    (modify ?f3 (label B))
    (modify ?f4 (label B))
    (modify ?f1 (value labeling)))

;;; ******************************
;;; second_boundary_junction_arrow
;;; ******************************

(defrule second_boundary_junction_arrow
	?f1 <- (stage (value find_second_boundary))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	?f3 <- (edge (p1 ?bp) (p2 ?p1))
	?f4 <- (edge (p1 ?bp) (p2 ?p2))
	?f5 <- (edge (p1 ?bp) (p2 ?p3))
	(not (junction (base_point ?base_point&:(< ?base_point ?bp))))
	=>
    (modify ?f3 (label B))
	(modify ?f4 (label +))
	(modify ?f5 (label B))
	(modify ?f1 (value labeling)))

;;; **********************************************************************
;;; match_edge: If we have an edge whose label we already know definitely,
;;;   then label the corresponding edge in the other direction
;;; **********************************************************************

(defrule match_edge
	(stage (value labeling))
	?f2 <- (edge (p1 ?p1) (p2 ?p2) (label ?label& + | - | B))
	?f3 <- (edge (p1 ?p2) (p2 ?p1) (label nil))
	=>
	(modify ?f2 (plotted t))
	(modify ?f3 (label ?label) (plotted t)))

;;; The following productions propogate the possible labellings of the edges
;;; based on the labellings of edges incident on adjacent junctions.  Since
;;; from the initial boundary productions, we have determined the labellings of
;;; of atleast two junctions, this propogation will label all of the junctions
;;; with the possible labellings.  The search space is pruned due to filtering,
;;; i.e. - only label a junction in the ways physically possible based on the
;;; labellings of adjacent junctions.

;;; *******
;;; label_L
;;; *******

(defrule label_L
	(stage (value labeling))
	(junction (jtype L) (base_point ?p1))
	(edge (p1 ?p1) (p2 ?p2) (label + | -))
	?f4 <- (edge (p1 ?p1) (p2 ~?p2) (label nil))
	=>
	(modify ?f4 (label B)))

;;; ***********
;;; label_tee_A
;;; ***********

(defrule label_tee_A
	(declare (salience 5))
	(stage (value labeling))
	(junction (jtype tee) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	?f3 <- (edge (p1 ?bp) (p2 ?p1) (label nil))
	?f4 <- (edge (p1 ?bp) (p2 ?p3))
	=>
    (modify ?f3 (label B))
	(modify ?f4 (label B)))

;;; ***********
;;; label_tee_B
;;; ***********

(defrule label_tee_B
	(stage (value labeling))
	(junction (jtype tee) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	?f3 <- (edge (p1 ?bp) (p2 ?p1))
	?f4 <- (edge (p1 ?bp) (p2 ?p3) (label nil))
	=>
    (modify ?f3 (label B))
	(modify ?f4 (label B)))

;;; ************
;;; label_fork-1
;;; ************

(defrule label_fork-1
	(stage (value labeling))
	(junction (jtype fork) (base_point ?bp))
	(edge (p1 ?bp) (p2 ?p1) (label +))
	?f4 <- (edge (p1 ?bp) (p2 ?p2&~?p1) (label nil))
	?f5 <- (edge (p1 ?bp) (p2 ~?p2&~?p1))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label +)))

;;; ************
;;; label_fork-2
;;; ************

(defrule label_fork-2
	(stage (value labeling))
	(junction (jtype fork) (base_point ?bp))
	(edge (p1 ?bp) (p2 ?p1) (label B))
	(edge (p1 ?bp) (p2 ?p2&~?p1) (label -))
	?f5 <- (edge (p1 ?bp) (p2 ~?p2&~?p1) (label nil))
	=>
	(modify ?f5 (label B)))

;;; ************
;;; label_fork-3
;;; ************

(defrule label_fork-3
	(stage (value labeling))
	(junction (jtype fork) (base_point ?bp))
	(edge (p1 ?bp) (p2 ?p1) (label B))
	(edge (p1 ?bp) (p2 ?p2&~?p1) (label B))
	?f5 <- (edge (p1 ?bp) (p2 ~?p2&~?p1) (label nil))
	=>
	(modify ?f5 (label -)))

;;; ************
;;; label_fork-4
;;; ************

(defrule label_fork-4
	(stage (value labeling))
	(junction (jtype fork) (base_point ?bp))
	(edge (p1 ?bp) (p2 ?p1) (label -))
	(edge (p1 ?bp) (p2 ?p2&~?p1) (label -))
	?f5 <- (edge (p1 ?bp) (p2 ~?p2&~?p1) (label nil))
	=>
	(modify ?f5 (label -)))

;;; **************
;;; label_arrow-1A
;;; **************

(defrule label_arrow-1A
	(declare (salience 5))
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p1) (label ?label& B | - ))
	?f4 <- (edge (p1 ?bp) (p2 ?p2) (label nil))
	?f5 <- (edge (p1 ?bp) (p2 ?p3))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label ?label)))

;;; **************
;;; label_arrow-1B
;;; **************

(defrule label_arrow-1B
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p1) (label ?label& B | - ))
	?f4 <- (edge (p1 ?bp) (p2 ?p2))
	?f5 <- (edge (p1 ?bp) (p2 ?p3) (label nil))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label ?label)))

;;; **************
;;; label_arrow-2A
;;; **************

(defrule label_arrow-2A
	(declare (salience 5))
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p3) (label ?label& B | - ))
	?f4 <- (edge (p1 ?bp) (p2 ?p2) (label nil))
	?f5 <- (edge (p1 ?bp) (p2 ?p1))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label ?label)))

;;; **************
;;; label_arrow-2B
;;; **************

(defrule label_arrow-2B
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p3) (label ?label& B | - ))
	?f4 <- (edge (p1 ?bp) (p2 ?p2))
	?f5 <- (edge (p1 ?bp) (p2 ?p1) (label nil))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label ?label)))

;;; **************
;;; label_arrow-3A
;;; **************

(defrule label_arrow-3A
	(declare (salience 5))
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p1) (label +))
	?f4 <- (edge (p1 ?bp) (p2 ?p2) (label nil))
	?f5 <- (edge (p1 ?bp) (p2 ?p3))
	=>
	(modify ?f4 (label -))
	(modify ?f5 (label +)))

;;; **************
;;; label_arrow-3B
;;; **************

(defrule label_arrow-3B
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p1) (label +))
	?f4 <- (edge (p1 ?bp) (p2 ?p2))
	?f5 <- (edge (p1 ?bp) (p2 ?p3) (label nil))
	=>
	(modify ?f4 (label -))
	(modify ?f5 (label +)))

;;; **************
;;; label_arrow-4A
;;; **************

(defrule label_arrow-4A
	(declare (salience 5))
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p3) (label +))
	?f4 <- (edge (p1 ?bp) (p2 ?p2) (label nil))
	?f5 <- (edge (p1 ?bp) (p2 ?p1))
	=>
	(modify ?f4 (label -))
	(modify ?f5 (label +)))

;;; **************
;;; label_arrow-4B
;;; **************

(defrule label_arrow-4B
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p3) (label +))
	?f4 <- (edge (p1 ?bp) (p2 ?p2))
	?f5 <- (edge (p1 ?bp) (p2 ?p1) (label nil))
	=>
	(modify ?f4 (label -))
	(modify ?f5 (label +)))

;;; **************
;;; label_arrow-5A
;;; **************

(defrule label_arrow-5A
	(declare (salience 5))
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p2) (label -))
	?f4 <- (edge (p1 ?bp) (p2 ?p1))
	?f5 <- (edge (p1 ?bp) (p2 ?p3) (label nil))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label +)))

;;; **************
;;; label_arrow-5B
;;; **************

(defrule label_arrow-5B
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p2) (label -))
	?f4 <- (edge (p1 ?bp) (p2 ?p1) (label nil))
	?f5 <- (edge (p1 ?bp) (p2 ?p3))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label +)))

;;; *******************************************************************************
;;; done_labeling: The conflict resolution mechanism will only execute a production
;;;   if no productions that are more complicated are satisfied.  This production
;;;   is simple, so all of the above dictionary productions will fire before this
;;;   change of state production
;;; *******************************************************************************

(defrule done_labeling
	(declare (salience -10))
	?f1 <- (stage (value labeling))
	=>
	(modify ?f1 (value plot_remaining_edges)))

;;; **************************************************
;;; plot_remaining: At this point, some labellings may
;;;   have not been plotted, so plot them
;;; **************************************************

(defrule plot_remaining
	(stage (value plot_remaining_edges))
	?f2 <- (edge (plotted nil) (label ?label&~nil) (p1 ?p1) (p2 ?p2))
	=>
	(modify ?f2 (plotted t)))

;;; ********************************************************************************
;;; plot_boundaries: If we have been un able to label an edge, assume that it is a
;;;   boundary. This is a total Kludge, but what the hell. (if we assume only
;;;   valid drawings will be given for labeling, this assumption generally is true!)
;;; ********************************************************************************

(defrule plot_boundaries
	(stage (value plot_remaining_edges))
	?f2 <- (edge (plotted nil) (label nil) (p1 ?p1) (p2 ?p2))
	=>
	(modify ?f2 (plotted t)))

;;; ****************************************************************************
;;; done_plotting: If there is no more work to do, then we are done and flag it.
;;; ****************************************************************************

(defrule done_plotting
	(declare (salience -10))
	?f1 <- (stage (value plot_remaining_edges))
	(not (edge (plotted nil)))
	=>
	(modify ?f1 (value done)))


Replaced a call to (not (eq with (<> in ValidBlockIdentification.clp

This was done to make the code slightly more efficient by having one native
call instead of two for each match attempt when dealing with successor checks

;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
;defmodule is wavefront-scheduling-identify
(defrule wavefront-scheduling-identify::AssertIdentifySpansInitial
         (declare (salience 5))
         (object (is-a Wavefront)
          (parent ?r)
          (values $? ?e $?))
         ;select only BasicBlocks
         (object (is-a BasicBlock)
          (id ?e))
         =>
         (assert (Picked ?e for ?r)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-identify::IdentifySpanSkips-InvalidBlock
         (declare (salience 4))
         ?fct <- (Picked ?e for ?r)
         ?bb <- (object (is-a BasicBlock)
                        (id ?e)
								(Successors $?a&:(<> (length$ $?a) 1)))
         =>
         ;we don't need to assert anything since the block isn't going to get
         ;scheduled
         (retract ?fct))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-identify::IdentifySpans
         (declare (salience 4))
         ?fct <- (Picked ?block for ?)
         ?bb <- (object (is-a BasicBlock)
                        (id ?block)
                        (Successors ?) ; we only have one successor
                        (Paths $?paths))
         =>
         (retract ?fct)
         (modify-instance ?bb (IsOpen TRUE))
         ; originally I had a rule here that took a fact asserted in the form
         ; ?e => $?paths which would be inverted individually by separate rule
         ; fires. While this is more like an expert system, it is extremely
         ; inefficient because the agenda has to be updated after each rule
         ; fire. Using this technique allows me to minimize the number of rule
         ; fires to one yet do the same amount of work.
         (progn$ (?path $?paths)
                 (assert (message (to wavefront-scheduling)
                                  (action check-path)
                                  (arguments ?path for block ?block)))))
;------------------------------------------------------------------------------
; defmodule is wavefront-scheduling-pathing
(defrule wavefront-scheduling-pathing::GetFactsBeforePathing
         (declare (salience 10000))
         (message (action Debug))
         (message (action Facts))
         =>
         (printout t "BEFORE: Wavefront Pathing " crlf crlf)
         (facts)
         (printout t crlf crlf))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pathing::DispatchDivideBlock
         (declare (salience 200))
         ?fct <- (message (to wavefront-scheduling)
                          (action check-path)
                          (arguments ?path for block ?block))
         (object (is-a Path)
                 (id ?path)
                 (values $? ?block $?rest))
         ;we don't need to explicitly match for ?block
         =>
         (retract ?fct)
         (assert (message (to wavefront-scheduling-pathing)
                          (action scan-path)
                          (arguments ?path ?block => $?rest))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pathing::AnalyzePathElements
         ?fct <- (message (to wavefront-scheduling-pathing)
                          (action scan-path)
                          (arguments ?p ?e => ?curr $?rest))
         ?bb <- (object (is-a BasicBlock)
                        (id ?curr)
                        (Successors $?succ)
                        (HasCallBarrier ?hcb)
                        (HasMemoryBarrier ?hmb))
         =>
         (bind ?sLen (length$ $?succ))
         (if (= 0 ?sLen) then
           (assert (message (to wavefront-scheduling)
                            (action completely-invalid-blocks)
                            (arguments ?e => ?curr)))
           (retract ?fct)
           else
           (if (or (> ?sLen 1) ?hcb) then
             (assert (message (to wavefront-scheduling)
                              (action completely-invalid-blocks)
                              (arguments ?e => $?rest))
                     (message (to wavefront-scheduling)
                              (action potentially-valid-blocks)
                              (arguments ?e => ?curr)))
             (retract ?fct)
             else
             (if ?hmb then
               (assert (message (to wavefront-scheduling)
                                (action element-has-memory-barrier)
                                (arguments ?curr => ?e))))
             (modify ?fct (arguments ?p ?e => $?rest))
             (assert (message (to wavefront-scheduling)
                              (action potentially-valid-blocks)
                              (arguments ?e => ?curr))))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pathing::AnalyzePathElements-Region
         ?fct <- (message (to wavefront-scheduling-pathing)
                          (action scan-path)
                          (arguments ?p ?e => ?curr $?rest))
         ?bb <- (object (is-a Region)
                        (id ?curr)
                        (HasCallBarrier ?hcb)
                        (HasMemoryBarrier ?hmb))
         =>
         (if ?hcb then
           (assert (message (to wavefront-scheduling)
                            (action completely-invalid-blocks)
                            (arguments ?e => $?rest))
                   (message (to wavefront-scheduling)
                            (action potentially-valid-blocks)
                            (arguments ?e => ?curr)))
           (retract ?fct)
           else
           (if ?hmb then
             (assert (message (to wavefront-scheduling)
                              (action element-has-memory-barrier)
                              (arguments ?curr => ?e))))
           (modify ?fct (arguments ?p ?e => $?rest))
           (assert (message (to wavefront-scheduling)
                            (action potentially-valid-blocks)
                            (arguments ?e => ?curr)))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pathing::RetractCompletedFact
         ?fct <- (message (to wavefront-scheduling-pathing)
                          (action scan-path)
                          (arguments ? ? =>))
         =>
         (retract ?fct))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pathing::PrintoutCompletedFacts
         (declare (salience -999))
         (message (action Debug))
         (message (action Facts))
         =>
         (printout t "AFTER: Wavefront Pathing" crlf crlf)
         (facts)
         (printout t crlf crlf))
;------------------------------------------------------------------------------

;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
;defmodule is wavefront-scheduling-identify
(defrule wavefront-scheduling-identify::AssertIdentifySpansInitial
         (declare (salience 5))
         (object (is-a Wavefront)
          (parent ?r)
          (values $? ?e $?))
         ;select only BasicBlocks
         (object (is-a BasicBlock)
          (id ?e))
         =>
         (assert (Picked ?e for ?r)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-identify::IdentifySpanSkips-InvalidBlock
         (declare (salience 4))
         ?fct <- (Picked ?e for ?r)
         ?bb <- (object (is-a BasicBlock)
                        (id ?e)
                        (Successors $?a&:(not (eq (length$ $?a) 1))))
         =>
         ;we don't need to assert anything since the block isn't going to get
         ;scheduled
         (retract ?fct))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-identify::IdentifySpans
         (declare (salience 4))
         ?fct <- (Picked ?block for ?)
         ?bb <- (object (is-a BasicBlock)
                        (id ?block)
                        (Successors ?) ; we only have one successor
                        (Paths $?paths))
         =>
         (retract ?fct)
         (modify-instance ?bb (IsOpen TRUE))
         ; originally I had a rule here that took a fact asserted in the form
         ; ?e => $?paths which would be inverted individually by separate rule
         ; fires. While this is more like an expert system, it is extremely
         ; inefficient because the agenda has to be updated after each rule
         ; fire. Using this technique allows me to minimize the number of rule
         ; fires to one yet do the same amount of work.
         (progn$ (?path $?paths)
                 (assert (message (to wavefront-scheduling)
                                  (action check-path)
                                  (arguments ?path for block ?block)))))
;------------------------------------------------------------------------------
; defmodule is wavefront-scheduling-pathing
(defrule wavefront-scheduling-pathing::GetFactsBeforePathing
         (declare (salience 10000))
         (message (action Debug))
         (message (action Facts))
         =>
         (printout t "BEFORE: Wavefront Pathing " crlf crlf)
         (facts)
         (printout t crlf crlf))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pathing::DispatchDivideBlock
         (declare (salience 200))
         ?fct <- (message (to wavefront-scheduling)
                          (action check-path)
                          (arguments ?path for block ?block))
         (object (is-a Path)
                 (id ?path)
                 (values $? ?block $?rest))
         ;we don't need to explicitly match for ?block
         =>
         (retract ?fct)
         (assert (message (to wavefront-scheduling-pathing)
                          (action scan-path)
                          (arguments ?path ?block => $?rest))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pathing::AnalyzePathElements
         ?fct <- (message (to wavefront-scheduling-pathing)
                          (action scan-path)
                          (arguments ?p ?e => ?curr $?rest))
         ?bb <- (object (is-a BasicBlock)
                        (id ?curr)
                        (Successors $?succ)
                        (HasCallBarrier ?hcb)
                        (HasMemoryBarrier ?hmb))
         =>
         (bind ?sLen (length$ $?succ))
         (if (= 0 ?sLen) then
           (assert (message (to wavefront-scheduling)
                            (action completely-invalid-blocks)
                            (arguments ?e => ?curr)))
           (retract ?fct)
           else
           (if (or (> ?sLen 1) ?hcb) then
             (assert (message (to wavefront-scheduling)
                              (action completely-invalid-blocks)
                              (arguments ?e => $?rest))
                     (message (to wavefront-scheduling)
                              (action potentially-valid-blocks)
                              (arguments ?e => ?curr)))
             (retract ?fct)
             else
             (if ?hmb then
               (assert (message (to wavefront-scheduling)
                                (action element-has-memory-barrier)
                                (arguments ?curr => ?e))))
             (modify ?fct (arguments ?p ?e => $?rest))
             (assert (message (to wavefront-scheduling)
                              (action potentially-valid-blocks)
                              (arguments ?e => ?curr))))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pathing::AnalyzePathElements-Region
         ?fct <- (message (to wavefront-scheduling-pathing)
                          (action scan-path)
                          (arguments ?p ?e => ?curr $?rest))
         ?bb <- (object (is-a Region)
                        (id ?curr)
                        (HasCallBarrier ?hcb)
                        (HasMemoryBarrier ?hmb))
         =>
         (if ?hcb then
           (assert (message (to wavefront-scheduling)
                            (action completely-invalid-blocks)
                            (arguments ?e => $?rest))
                   (message (to wavefront-scheduling)
                            (action potentially-valid-blocks)
                            (arguments ?e => ?curr)))
           (retract ?fct)
           else
           (if ?hmb then
             (assert (message (to wavefront-scheduling)
                              (action element-has-memory-barrier)
                              (arguments ?curr => ?e))))
           (modify ?fct (arguments ?p ?e => $?rest))
           (assert (message (to wavefront-scheduling)
                            (action potentially-valid-blocks)
                            (arguments ?e => ?curr)))))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pathing::RetractCompletedFact
         ?fct <- (message (to wavefront-scheduling-pathing)
                          (action scan-path)
                          (arguments ? ? =>))
         =>
         (retract ?fct))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pathing::PrintoutCompletedFacts
         (declare (salience -999))
         (message (action Debug))
         (message (action Facts))
         =>
         (printout t "AFTER: Wavefront Pathing" crlf crlf)
         (facts)
         (printout t crlf crlf))
;------------------------------------------------------------------------------


Modified GLConstantConversion.clp to output code with correct formatting

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