waltz: renamed duplicate since its a keyword in SFP

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

;;; **********************************************************************
;;; 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 duplicate))
	?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 duplicate))
	(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)))


Added basic user input prompt logic

Added basic user input prompt logic

;The Adventure Engine
;Copyright (c) 2012-2016, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of The Adventure Engine nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; The user input prompt, located in the USER-INPUT module
;------------------------------------------------------------------------------
(defmodule USER-INPUT
           (export ?ALL))
(defclass USER-INPUT::input-state
 (is-a USER)
 (slot should-prompt
       (type SYMBOL)
       (allowed-symbols TRUE
                        FALSE))
 (slot prompt
       (type STRING)
       (storage local)
       (visibility public)
       (default ?NONE))
 (slot raw-input
       (type STRING)
       (default-dynamic ""))
 (multislot decomposed-elements
            (visibility public)))

(definstances USER-INPUT::initialization-of-input-state
              (of input-state
                  (prompt "> ")))

(defrule USER-INPUT::read-input
         "Read input from the end user"
         ?f <- (object (is-a input-state)
                       (should-prompt TRUE)
                       (prompt ?prompt))
         =>
         (printout t ?prompt tab)
         (modify-instance ?f
                          (should-prompt FALSE)
                          (raw-input (bind ?rinput (readline)))
                          (decomposed-elements (explode$ ?rinput))))

(defrule USER-INPUT::reset-input
         (declare (salience -1))
         ?f <- (object (is-a input-state)
                       (should-prompt FALSE))
         =>
         (modify-instance ?f (should-prompt TRUE)))

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


added loop to get back to the main menu after the user chooses an option and finishes it

(defrule ShowMainMenu
	(not (Selected ?))
=>
	(printout t "- Infering relations about:" crlf)
	(printout t "      11- cousins " crlf)
	(printout t "      12- Nephews" crlf)
	(printout t "      13- Nieces" crlf)
	(printout t "      14- Uncle" crlf)
	(printout t "      15- Aunt" crlf)
	(printout t "      16- Grandfather" crlf)
	(printout t "      17- Grandmother" crlf)
	(printout t "- Familly knowledge base" crlf)
	(printout t "      21- Display a familly member by name" crlf)
	(printout t "      22- Display a familly member by parent" crlf)
	(printout t "      23- Add family member" crlf)
	(printout t "      24- Remove family member" crlf)
	(printout t "- Modify family member properties" crlf)
	(printout t "      31- Modify familly member name" crlf)
	(printout t "      32- Modify familly member gender" crlf)
	(printout t "      33- Modify familly member birthyear" crlf)
	(printout t "      34- Modify familly member height" crlf)
	(printout t "      35- Modify familly member parents" crlf)
	(printout t "      36- Modify familly member siblings" crlf)
	(printout t "      37- Modify familly member spouse" crlf)
	(printout t "- Search familly members by properties" crlf)
	(printout t "      41- Show all individuals that match a combination of properties familly knowledge base" crlf)

	(bind ?selectedOption (read))

	(assert(Selected ?selectedOption))
)

(defrule ClearSelected
	(declare (salience -10000))

	?selectedIndex <- (Selected ?)
=>
	(retract ?selectedIndex)
)

(defrule GetQueryData
	(Selected 41)
=>
	(printout t "Enter the criteria to search upon in the same order, write 'all' if you do not care about a specific property:" crlf)

	(printout t "What is the gender ? (m or f) or write 'all'" crlf)
	(bind ?answer (read))
	(assert (QueryGender ?answer))

	(printout t "What is the spouse name ? or write 'all'" crlf)
	(bind ?answer (read))
	(assert (QuerySpouse ?answer))

	(printout t "What is the name of one of parents ?  or write 'all'" crlf)
	(bind ?answer (read))
	(assert (QueryParent ?answer))

	(printout t "What is the name of one of siblings ?  or write 'all'" crlf)
	(bind ?answer (read))
	(assert (QuerySiblings ?answer))

	(printout t "What is the height range ? (equals to|greater than|less than) then press enter then input the height  or write 'all'" crlf)
	(bind ?type (readline))
	(bind ?height (read))
	(assert (QueryHeight ?type ?height))
	(printout t ?type crlf)

)

(defrule ShowMainMenu

=>
	(printout t "- Infering relations about:" crlf)
	(printout t "      11- cousins " crlf)
	(printout t "      12- Nephews" crlf)
	(printout t "      13- Nieces" crlf)
	(printout t "      14- Uncle" crlf)
	(printout t "      15- Aunt" crlf)
	(printout t "      16- Grandfather" crlf)
	(printout t "      17- Grandmother" crlf)
	(printout t "- Familly knowledge base" crlf)
	(printout t "      21- Display a familly member by name" crlf)
	(printout t "      22- Display a familly member by parent" crlf)
	(printout t "      23- Add family member" crlf)
	(printout t "      24- Remove family member" crlf)
	(printout t "- Modify family member properties" crlf)
	(printout t "      31- Modify familly member name" crlf)
	(printout t "      32- Modify familly member gender" crlf)
	(printout t "      33- Modify familly member birthyear" crlf)
	(printout t "      34- Modify familly member height" crlf)
	(printout t "      35- Modify familly member parents" crlf)
	(printout t "      36- Modify familly member siblings" crlf)
	(printout t "      37- Modify familly member spouse" crlf)
	(printout t "- Search familly members by properties" crlf)
	(printout t "      41- Show all individuals that match a combination of properties familly knowledge base" crlf)

	(bind ?selectedOption (read))

	(assert(Selected ?selectedOption))
)

(defrule GetQueryData
	(Selected 41)
=>
	(printout t "Enter the criteria to search upon in the same order, write 'all' if you do not care about a specific property:" crlf)

	(printout t "What is the gender ? (m or f) or write 'all'" crlf)
	(bind ?answer (read))
	(assert (QueryGender ?answer))

	(printout t "What is the spouse name ? or write 'all'" crlf)
	(bind ?answer (read))
	(assert (QuerySpouse ?answer))

	(printout t "What is the name of one of parents ?  or write 'all'" crlf)
	(bind ?answer (read))
	(assert (QueryParent ?answer))

	(printout t "What is the name of one of siblings ?  or write 'all'" crlf)
	(bind ?answer (read))
	(assert (QuerySiblings ?answer))

	(printout t "What is the height range ? (equals to|greater than|less than) then press enter then input the height  or write 'all'" crlf)
	(bind ?type (readline))
	(bind ?height (read))
	(assert (QueryHeight ?type ?height))
	(printout t ?type crlf)

)


Interactable.clp: Added a description slot and associate message handler

The message handler prints the description out to the screen

;------------------------------------------------------------------------------
;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.
;------------------------------------------------------------------------------
; Interactable.clp - Base class of all interactable things
;
; Written by Joshua Scoggins
; Started on 3/6/2013
;------------------------------------------------------------------------------
(defclass dendrite::Interactable
  "Base class of all interactable things"
  (is-a Object)
  (slot description (visibility public))
  (message-handler describe primary))
;------------------------------------------------------------------------------
(defmessage-handler dendrite::Interactable describe primary ()
						  (printout t ?self:description 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.
;------------------------------------------------------------------------------
; Interactable.clp - Base class of all interactable things
;
; Written by Joshua Scoggins
; Started on 3/6/2013
;------------------------------------------------------------------------------
(defclass dendrite::Interactable
          "Base class of all interactable things"
          (is-a Object))
;TODO: Add more slots if necessary
;------------------------------------------------------------------------------


Added x.clp, the easiest way to build a library

(defclass Pointer
  (is-a USER)
  (slot pointer
        (type EXTERNAL-ADDRESS)
        (access initialize-only)
        (storage local)
        (visibility public)
        (default ?NONE))
  (slot pointer-class
        (type SYMBOL)
        (storage shared)
        (create-accessor read)
        (visibility public)
        (access read-only)
        (default unknown)))
; /lib/chicanery/input.clp - Contains methods and classes for handling the
; chicanery input layer

(defgeneric translate/kbd/query)
(defgeneric translate/mouse/buttons)
(defgeneric bool)
(defmethod bool ((?number INTEGER)) (if (= ?number 0) then FALSE else TRUE))

(defmethod translate/mouse/buttons
  ()
  ; Mouse combinations
  ; m.buttons & 1 => left-click
  ; m.buttons & 2 => middle-click
  ; m.buttons & 3 => left + middle
  ; m.buttons & 4 => right-click
  ; m.buttons & 5 => left + right
  ; m.buttons & 6 => middle + right
  ; m.buttons & 7 => left + middle + right
  (bind ?z (mouse/buttons))
  (return (create$
            (if (bool (binary-and ?z 1)) then button1 else (create$))
            (if (bool (binary-and ?z 2)) then button2 else (create$))
            (if (bool (binary-and ?z 4)) then button3 else (create$)))))

(defmethod translate/kbd/query
  ()
  ; This method has to be defined by the programmer because it is application
  ; specific. By default, if we don't know what the value is then just return
  ; the original rune value.
  (bind ?rune (kbd/query))
  (return (switch ?rune
          (case -1 then NIL)
          (case 0 then NIL)
          (case 27 then ESC)
          (case 61454 then UP)
          (case 63488 then DOWN) ; Plan9's down :/
          (case 128 then DOWN) ; this is the value I get for down
          (case 61457 then LEFT)
          (case 61458 then RIGHT)
          (default ?rune))))
; /lib/chicanery/menu.clp - Contains methods and classes to simplify accessing
; menus
(defgeneric quickmenu)
(defgeneric quickmenu/show)
(defgeneric defmenu)
(defgeneric translate-menu-id)
(defclass Menu
  (is-a Pointer)
  (slot pointer-class
        (source composite)
        (default menu))
  (multislot menu-elements
             (type LEXEME)
             (storage local)
             (access initialize-only)
             (default ?NONE))
  (message-handler show-menu primary))

(defmessage-handler Menu show-menu primary
                    "shows the target menu and translates it to the corresponding symbolic
                    representation"
                    (?button)
                    (translate-menu-id (menu/show ?self:pointer ?button)
                                       ?self:menu-elements))

(defmethod quickmenu
  "Defines a menu pointer without any associated object"
  (($?entries LEXEME))
  (quickmenu ?entries))

(defmethod quickmenu
  "Defines a menu pointer without any associated object"
  ((?entries MULTIFIELD LEXEME))
  (new menu (expand$ ?entries)))

(defmethod defmenu
  "Constructs a Menu object and corresponding pointer"
  ((?name SYMBOL)
   ($?entries LEXEME))
  (defmenu ?name ?entries))
(defmethod defmenu
  "Constructs a Menu object and corresponding pointer"
  ((?name SYMBOL)
   (?entries MULTIFIELD LEXEME))
  (make-instance ?name of Menu
                 (pointer (quickmenu ?entries))
                 (menu-elements ?entries)))

(defmethod translate-menu-id
  "If we get -1 back then return the nil symbol"
  ((?id INTEGER (= ?id -1))
   (?elements MULTIFIELD LEXEME))
  nil)

(defmethod translate-menu-id
  "Translates numeric input from menu/show to symbolic representation"
  ((?id INTEGER (> ?id -1))
   (?elements MULTIFIELD LEXEME))
  ; We are one indexed while libevent is zero indexed
  (return (nth$ (+ ?id 1) ?elements)))

(defmethod translate-menu-id
  "Translates numeric input from menu/show to symbolic representation"
  ((?id INTEGER)
   ($?elements LEXEME))
  (translate-menu-id ?id ?elements))

(defmethod quickmenu/show
  "Construct a quick list and return a symbolic representation"
  ((?elements MULTIFIELD LEXEME)
   (?button INTEGER))
  (translate-menu-id (menu/show (quickmenu ?elements) ?button) ?elements))
(defgeneric defrectangle)
(defgeneric quickrect)
(defgeneric defpixel)
(defgeneric pixel:nxn)
(defgeneric pixel:1x1)

(defclass Rectangle
  (is-a Pointer)
  (slot pointer-class
        (source composite)
        (default Rectangle))
  (slot x
        (type INTEGER)
        (access initialize-only)
        (storage local)
        (default ?NONE))
  (slot y
        (type INTEGER)
        (access initialize-only)
        (storage local)
        (default ?NONE))
  (slot bx
        (type INTEGER)
        (access initialize-only)
        (storage local)
        (default ?NONE))
  (slot by
        (type INTEGER)
        (access initialize-only)
        (storage local)
        (default ?NONE))
  (message-handler get-points primary))

(defmessage-handler Rectangle get-points ()
                    (create$ ?self:x ?self:y ?self:bx ?self:by))

(defmethod defrectangle
  "Creates a new rectangle object and corresponding pointer"
  ((?name SYMBOL INSTANCE-NAME)
   (?x INTEGER)
   (?y INTEGER)
   (?bx INTEGER)
   (?by INTEGER))
  (make-instance ?name of Rectangle
                 (x ?x)
                 (y ?y)
                 (bx ?bx)
                 (by ?by)
                 (pointer (quickrect ?x ?y ?bx ?by))))
(defmethod defrectangle
  ((?x INTEGER)
   (?y INTEGER)
   (?bx INTEGER)
   (?by INTEGER))
  (defrectangle (gensym*) ?x ?y ?bx ?by))

(defmethod quickrect
  ((?x INTEGER)
   (?y INTEGER)
   (?bx INTEGER)
   (?by INTEGER))
  (new Rectangle ?x ?y ?bx ?by))

(defmethod quickrect
  ((?mf MULTIFIELD INTEGER (>= (length$ ?mf) 4)))
  (quickrect (expand$ (subseq$ ?mf 1 4))))

(defmethod quickrect
  (($?mf MULTIFIELD INTEGER (>= (length$ ?mf) 4)))
  (quickrect ?mf))

(defmethod defpixel
  ((?name SYMBOL INSTANCE-NAME)
   (?x INTEGER)
   (?y INTEGER)
   (?factor INTEGER))
  (defrectangle ?name ?x ?y (+ ?x ?factor) (+ ?y ?factor)))

(defmethod pixel:nxn
  ((?x INTEGER)
   (?y INTEGER)
   (?n INTEGER))
  (quickrect ?x ?y (+ ?x ?n) (+ ?y ?n)))

(defmethod pixel:nxn
  ((?n INTEGER))
  (pixel:nxn 0 0 ?n))

(defmethod pixel:1x1
  ((?x INTEGER)
   (?y INTEGER))
  (pixel:nxn ?x ?y 1))

(defmethod pixel:1x1 ()
  (pixel:1x1 0 0))

(definstances default-rect-classes
              (rect:single-pixel of Rectangle
                (x 0)
                (y 0)
                (bx 1)
                (by 1)
                (pointer (quickrect 0 0 1 1))))

; /lib/chicanery/color.clp - Routines for handling chicanery color features

(defgeneric translate/standard-color)
(defgeneric intensity-to-cmap)
(defmethod translate/standard-color
  ((?color LEXEME))
  (switch (lowcase (string-to-field ?color))
          (case opaque then 0)
          (case transparent then 1)
          (case black then 2)
          (case white then 3)
          (case red then 4)
          (case green then 5)
          (case blue then 6)
          (case cyan then 7)
          (case magenta then 8)
          (case yellow then 9)
          (case paleyellow then 10)
          (case darkyellow then 11)
          (case darkgreen then 12)
          (case palegreen then 13)
          (case medgreen then 14)
          (case darkblue then 15)
          (case palebluegreen then 16)
          (case paleblue then 17)
          (case bluegreen then 18)
          (case greygreen then 19)
          (case palegreygreen then 20)
          (case yellowgreen then 21)
          (case medblue then 22)
          (case greyblue then 23)
          (case palegreyblue then 24)
          (case purpleblue then 25)
          (case notacolor then 26)
          (case nofill then 27)
          (default 28)))

(defmethod get-standard-color
  ((?color LEXEME INSTANCE-NAME))
  (get-standard-color
    (translate/standard-color ?color)))

(defmethod intensity-to-cmap
  "Converts an intensity value to a greyscale color"
  ((?intensity INTEGER (<= 0 ?intensity 255)))
  (rgb-to-cmap ?intensity
               ?intensity
               ?intensity))

(defmethod rgb-to-cmap
  ((?tuple INTEGER MULTIFIELD (>= (length$ ?tuple) 3)))
  (rgb-to-cmap (nth$ 1 ?tuple)
               (nth$ 2 ?tuple)
               (nth$ 3 ?tuple)))

; point.clp - classes and methods to wrap around the Point native type

(defgeneric quickpoint)
(defgeneric defpoint)
(defgeneric to-point)
(defclass Point
  (is-a Pointer)
  (slot pointer-class
        (source composite)
        (default Point))
  (slot x
        (type INTEGER)
        (access initialize-only)
        (storage local)
        (default ?NONE))
  (slot y
        (type INTEGER)
        (access initialize-only)
        (storage local)
        (default ?NONE))
  (message-handler get-points primary))

(defmessage-handler Point get-points ()
                    (create$ ?self:x ?self:y))

(defmethod defpoint
  "Creates a new point object and corresponding pointer"
  ((?name SYMBOL INSTANCE-NAME)
   (?x INTEGER)
   (?y INTEGER))
  (make-instance ?name of Point
                 (x ?x)
                 (y ?y)
                 (pointer (quickpoint ?x ?y))))

(defmethod defpoint
  ((?x INTEGER)
   (?y INTEGER))
  (defpoint (gensym*) ?x ?y))

(defmethod quickpoint
  ((?x INTEGER)
   (?y INTEGER))
  (new Point ?x ?y))

(defmethod to-point
  ((?mf INTEGER MULTIFIELD (= (length$ ?mf) 2)))
  (quickpoint (expand$ ?mf)))

(defmethod to-point
  ((?mf INTEGER MULTIFIELD (> (length$ ?mf) 2)))
  (quickpoint (nth$ 1 ?mf)
              (nth$ 2 ?mf)))
(defmethod to-point
  (($?mf INTEGER (>= (length$ ?mf) 2)))
  (to-point ?mf))

(definstances default-point-classes
              (ZP of Point
                  (x 0)
                  (y 0)
                  (pointer (quickpoint 0 0))))

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


Moved the delete-still-existing-elements rule to build-groups

This was done so that I could make the following module for updating grouping
elements and generating associated code.

;------------------------------------------------------------------------------
;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 read-input
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule modify-input
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule identify-lines
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule convert-templates
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule build-groups
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule grouping-update
           (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))
;------------------------------------------------------------------------------
(defclass types::file-line
  (is-a USER)
  (slot id)
  (slot index)
  (slot parent)
  (slot type)
  (multislot contents))
;------------------------------------------------------------------------------
(defmessage-handler types::file-line init after ()
                    (bind ?self:id (instance-name-to-symbol (instance-name ?self))))
;------------------------------------------------------------------------------
(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::grouping
  (is-a USER)
  (slot group-name)
  (slot parent)
  (slot from (type INTEGER) (range 0 ?VARIABLE))
  (slot to (type INTEGER) (range 0 ?VARIABLE))
  (multislot contents))
;------------------------------------------------------------------------------
; 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 (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)
                         (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)))
;------------------------------------------------------------------------------
(defrule modify-input::identify-symbols-with-commas
         ?fct <- (object (is-a file-line)
                         (contents $?before ?symbol $?after))
         (test (and (neq 0 (str-compare (str-cat ?symbol) ","))
                    (str-index "," (str-cat ?symbol))))
         =>
         (bind ?str (if (stringp ?symbol) then ?symbol else (str-cat ?symbol)))
         (bind ?ind (str-index "," ?str))
         (bind ?p0 (sub-string 1 (- ?ind 1) ?str))
         (bind ?p1 (sub-string (+ ?ind 1) (str-length ?str) ?str))
         (modify-instance ?fct (contents $?before ?p0 , ?p1 $?after)))
;------------------------------------------------------------------------------
(defrule modify-input::identify-symbols-with-open-parens
         ?fct <- (object (is-a file-line)
                         (contents $?before ?symbol $?after))
         (test (and (neq 0 (str-compare (str-cat ?symbol) "("))
                    (str-index "(" (str-cat ?symbol))))
         =>
         (bind ?str (if (stringp ?symbol) then ?symbol else (str-cat ?symbol)))
         (bind ?ind (str-index "(" ?str))
         (bind ?p0 (sub-string 1 ?ind ?str))
         (bind ?p1 (sub-string ?ind (str-length ?str) ?str))
         (modify-instance ?fct (contents $?before ?p0 "(" ?p1 $?after)))
;------------------------------------------------------------------------------
(defrule modify-input::identify-symbols-with-close-parens
         ?fct <- (object (is-a file-line)
                         (contents $?before ?symbol&~")" $?after))
         (test (and (neq 0 (str-compare (str-cat ?symbol) ")"))
                    (str-index ")" (str-cat ?symbol))))
         =>
         (bind ?str (if (stringp ?symbol) then ?symbol else (str-cat ?symbol)))
         (bind ?ind (str-index ")" ?str))
         (bind ?p0 (sub-string 1 ?ind ?str))
         (bind ?p1 (sub-string ?ind (str-length ?str) ?str))
         (modify-instance ?fct (contents $?before ?p0 ")" ?p1 $?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 (heading-span (from ?i)
                                    (parent ?parent))))
         (object (is-a 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))
         (object (is-a file-line)
                 (type heading)
                 (parent ?parent)
                 (index ?i2&:(> ?j ?i2 ?i)))
         =>
         (modify ?f (to ?i2)
                 (distance (- ?i2 ?i))))
;------------------------------------------------------------------------------
(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 <- (heading-span (from ?i)
                             (to ?i2)
                             (parent ?parent)
                             (contents $?c))
         (object (is-a file-line)
                 (parent ?parent)
                 (index ?loc&:(> ?i2 ?loc ?i))
                 (id ?id))
         ?msg <- (message (to build-groups)
                          (action add-to-span)
                          (arguments ?id))
         =>
         (retract ?msg)
         (modify ?f (contents $?c ?id)))
;------------------------------------------------------------------------------
(defrule build-groups::delete-still-existing-elements
         (declare (salience -100))
         ?msg <- (message (to build-groups)
                          (action add-to-span)
                          (arguments ?id))
         ?obj <- (object (is-a file-line)
                         (id ?id))
         =>
         (unmake-instance ?obj)
         (retract ?msg))
;------------------------------------------------------------------------------
;(defrule grouping-update::

;------------------------------------------------------------------------------
;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 read-input
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule modify-input
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule identify-lines
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule convert-templates
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule build-groups
           (import types ?ALL))
;------------------------------------------------------------------------------
(defmodule retract-invalid-elements
           (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))
;------------------------------------------------------------------------------
(defclass types::file-line
  (is-a USER)
  (slot id)
  (slot index)
  (slot parent)
  (slot type)
  (multislot contents))
;------------------------------------------------------------------------------
(defmessage-handler types::file-line init after ()
                    (bind ?self:id (instance-name-to-symbol (instance-name ?self))))
;------------------------------------------------------------------------------
(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::grouping
  (is-a USER)
  (slot group-name)
  (slot parent)
  (slot from (type INTEGER) (range 0 ?VARIABLE))
  (slot to (type INTEGER) (range 0 ?VARIABLE))
  (multislot contents))
;------------------------------------------------------------------------------
; 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 (message (to identify-lines)
                            (action read-file)
                            (arguments ?name)))
           (focus read-input
            modify-input
                  identify-lines
                  convert-templates
                  build-groups
                  retract-invalid-elements)
           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)
                         (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)))
;------------------------------------------------------------------------------
(defrule modify-input::identify-symbols-with-commas
         ?fct <- (object (is-a file-line)
                         (contents $?before ?symbol $?after))
         (test (and (neq 0 (str-compare (str-cat ?symbol) ","))
                    (str-index "," (str-cat ?symbol))))
         =>
         (bind ?str (if (stringp ?symbol) then ?symbol else (str-cat ?symbol)))
         (bind ?ind (str-index "," ?str))
         (bind ?p0 (sub-string 1 (- ?ind 1) ?str))
         (bind ?p1 (sub-string (+ ?ind 1) (str-length ?str) ?str))
         (modify-instance ?fct (contents $?before ?p0 , ?p1 $?after)))
;------------------------------------------------------------------------------
(defrule modify-input::identify-symbols-with-open-parens
         ?fct <- (object (is-a file-line)
                         (contents $?before ?symbol $?after))
         (test (and (neq 0 (str-compare (str-cat ?symbol) "("))
                    (str-index "(" (str-cat ?symbol))))
         =>
         (bind ?str (if (stringp ?symbol) then ?symbol else (str-cat ?symbol)))
         (bind ?ind (str-index "(" ?str))
         (bind ?p0 (sub-string 1 ?ind ?str))
         (bind ?p1 (sub-string ?ind (str-length ?str) ?str))
         (modify-instance ?fct (contents $?before ?p0 "(" ?p1 $?after)))
;------------------------------------------------------------------------------
(defrule modify-input::identify-symbols-with-close-parens
         ?fct <- (object (is-a file-line)
                         (contents $?before ?symbol&~")" $?after))
         (test (and (neq 0 (str-compare (str-cat ?symbol) ")"))
                    (str-index ")" (str-cat ?symbol))))
         =>
         (bind ?str (if (stringp ?symbol) then ?symbol else (str-cat ?symbol)))
         (bind ?ind (str-index ")" ?str))
         (bind ?p0 (sub-string 1 ?ind ?str))
         (bind ?p1 (sub-string ?ind (str-length ?str) ?str))
         (modify-instance ?fct (contents $?before ?p0 ")" ?p1 $?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 (heading-span (from ?i)
                                    (parent ?parent))))
         (object (is-a 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))
         (object (is-a file-line)
                 (type heading)
                 (parent ?parent)
                 (index ?i2&:(> ?j ?i2 ?i)))
         =>
         (modify ?f (to ?i2)
                 (distance (- ?i2 ?i))))
;------------------------------------------------------------------------------
(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 <- (heading-span (from ?i)
                             (to ?i2)
                             (parent ?parent)
                             (contents $?c))
         (object (is-a file-line)
                 (parent ?parent)
                 (index ?loc&:(> ?i2 ?loc ?i))
                 (id ?id))
         ?msg <- (message (to build-groups)
                          (action add-to-span)
                          (arguments ?id))
         =>
         (retract ?msg)
         (modify ?f (contents $?c ?id)))
;------------------------------------------------------------------------------
(defrule retract-invalid-elements::delete-still-existing-elements
         ?msg <- (message (to build-groups)
                          (action add-to-span)
                          (arguments ?id))
         ?obj <- (object (is-a file-line)
                         (id ?id))
         =>
         (send ?obj print)
         (unmake-instance ?obj)
         (retract ?msg))
;------------------------------------------------------------------------------