; $Id: JessTestRules.txt,v 1.30 2005-09-22 20:03:21 hammond Exp $
; JessTestRules.java -- 
; Author: Tracy Hammond <hammond@ai.mit.edu> 
; Copyright: Copyright (C) 2002 by Tracy Hammond, 
; Design Rationale Group at MIT 
; Created: <Mon Nov 12 16:57:40 2002> 


(load-function edu.mit.sketch.language.constraints.JFAddShape)

(load-function edu.mit.sketch.language.constraints.JFAbove)
(load-function edu.mit.sketch.language.constraints.JFAcute)
(load-function edu.mit.sketch.language.constraints.JFAcuteDir)
(load-function edu.mit.sketch.language.constraints.JFAcuteMeet)
(load-function edu.mit.sketch.language.constraints.JFBisects)
(load-function edu.mit.sketch.language.constraints.JFCoincident) 
(load-function edu.mit.sketch.language.constraints.JFCollapsable)
(load-function edu.mit.sketch.language.constraints.JFCollinear)
(load-function edu.mit.sketch.language.constraints.JFConcentric)
(load-function edu.mit.sketch.language.constraints.JFConnected)
(load-function edu.mit.sketch.language.constraints.JFContains)
(load-function edu.mit.sketch.language.constraints.JFDrawOrder)
(load-function edu.mit.sketch.language.constraints.JFEqual)
(load-function edu.mit.sketch.language.constraints.JFEqualAngle)
(load-function edu.mit.sketch.language.constraints.JFEqualArea)
(load-function edu.mit.sketch.language.constraints.JFEqualLength)
(load-function edu.mit.sketch.language.constraints.JFFlipLine)
(load-function edu.mit.sketch.language.constraints.JFGreaterThan)
(load-function edu.mit.sketch.language.constraints.JFHorizAlign)
(load-function edu.mit.sketch.language.constraints.JFHorizontal)
(load-function edu.mit.sketch.language.constraints.JFIntersects)
(load-function edu.mit.sketch.language.constraints.JFLarger)
(load-function edu.mit.sketch.language.constraints.JFLeftOf)
(load-function edu.mit.sketch.language.constraints.JFLonger)
(load-function edu.mit.sketch.language.constraints.JFMergable)
(load-function edu.mit.sketch.language.constraints.JFNear)
(load-function edu.mit.sketch.language.constraints.JFNegSlope)
(load-function edu.mit.sketch.language.constraints.JFObtuse)
(load-function edu.mit.sketch.language.constraints.JFObtuseDir)
(load-function edu.mit.sketch.language.constraints.JFObtuseMeet)
(load-function edu.mit.sketch.language.constraints.JFOnOneSide)
(load-function edu.mit.sketch.language.constraints.JFOppositeSide)
(load-function edu.mit.sketch.language.constraints.JFParallel)
(load-function edu.mit.sketch.language.constraints.JFPerpendicular)
(load-function edu.mit.sketch.language.constraints.JFPointsLeft)
(load-function edu.mit.sketch.language.constraints.JFPointsDown)
(load-function edu.mit.sketch.language.constraints.JFPointsRight)
(load-function edu.mit.sketch.language.constraints.JFPointsUp)
(load-function edu.mit.sketch.language.constraints.JFPosSlope)
(load-function edu.mit.sketch.language.constraints.JFVertAlign)
(load-function edu.mit.sketch.language.constraints.JFVertical)

(deffunction smaller(?s1 ?s2)(return (larger ?s2 ?s1)))
(deffunction rightOf(?s1 ?s2)(return (leftOf ?s2 ?s1)))
(deffunction below(?s1 ?s2)(return (above ?s2 ?s1)))
(deffunction aboveRight(?s1 ?s2)
  (return ((rightOf ?s1 ?s2) && (above ?s1 ?s2))))
(deffunction belowRight(?s1 ?s2)
  (return ((rightOf ?s1 ?s2) && (below ?s1 ?s2))))
(deffunction aboveLeft(?s1 ?s2)
  (return ((leftOf ?s1 ?s2) && (above ?s1 ?s2))))
(deffunction centeredLeft(?s1 ?s2)
  (return ((leftOf ?s1 ?s2) && (sameX ?s1 ?s2))))
(deffunction centeredRight(?s1 ?s2)
  (return ((rightOf ?s1 ?s2) && (sameX ?s1 ?s2))))
(deffunction centeredAbove(?s1 ?s2)
  (return ((above ?s1 ?s2) && (sameY ?s1 ?s2))))
(deffunction centeredBelow(?s1 ?s2)
  (return ((below ?s1 ?s2) && (sameY ?s1 ?s2))))
(deffunction centeredIn(?s1 ?s2)
  (return ((contains ?s2 ?s1) && (concentric ?s1 ?s2))))

(deffunction checkLine(?l ?l_p1 ?l_p2)
  (if (> ?l_p1 ?l_p2) then 
    return (flipLine ?l))
)
  

(deffunction obtuseDir (?l1 ?l1_p1 ?l1_p2 ?l2 ?l2_p1 ?l2_p2)
  (if(and (< ?l1_p1 ?l1_p2)(< ?l2_p1 ?l2_p2)) then
	  (return obtuseDirX(?l1 ?l2)))
  (if(and (> ?l1_p1 ?l1_p2)(> ?l2_p1 ?l2_p2)) then
	  (return obtuseDirX(?l1 ?l2)))
  (if(and (< ?l1_p1 ?l1_p2) (> ?l2_p1 ?l2_p2)) then
	  (return acuteDirX(?l2 ?l1)))
	(if(and (> ?l1_p1 ?l1_p2) (< ?l2_p1 ?l2_p2)) then
	  (return acuteDirX(?l2 ?l1)))
)

(deffunction acuteDir (?l1 ?l1_p1 ?l1_p2 ?l2 ?l2_p1 ?l2_p2)
  (if(and (< ?l1_p1 ?l1_p2) (< ?l2_p1 ?l2_p2)) then
	  (return acuteDirX(?l1 ?l2)))
  (if(and (> ?l1_p1 ?l1_p2) (> ?l2_p1 ?l2_p2)) then
	  (return acuteDirX(?l1 ?l2)))
  (if(and (< ?l1_p1 ?l1_p2)(> ?l2_p1 ?l2_p2)) then
	  (return obtuseDirX(?l2 ?l1)))
	(if(and (> ?l1_p1 ?l1_p2)(< ?l2_p1 ?l2_p2)) then
	  (return obtuseDirX(?l2 ?l1)))
)

(deffunction sharefields (?mf1 ?mf2)
  "Tests if two multifields share any fields"
  (if (neq 0 (length$ (intersection$ ?mf1 ?mf2))) then
    (return TRUE)
  else
    (return FALSE)))

(deffunction uniquefields (?mf1 ?mf2)
  "Tests if two multifields don't share any fields"
  (if (= 0 (length$ (intersection$ ?mf1 ?mf2))) then
    (return TRUE)
  else
    (return FALSE)))

(defrule SetRecognizer
  (Recognizer ?num)
=>
  (addshape Recognizer ?num)
)
    
(defrule IndependentDomainShapes
  "Confirms that domain shapes don't share sub shapes"
  ?d1 <- (DomainShape ?type1 ?id1 ?time1)
  ?d2 <- (DomainShape ?type2 ?id2 ?time2)
  (test (< ?id1 ?id2))
  ?d3 <- (Subshapes ?type1 ?id1 $?mf1)
  ?d4 <- (Subshapes ?type2 ?id2 $?mf2)
  (test (sharefields $?mf1 $?mf2))
=>
  (bind ?l1 (length$ $?mf1))
  (bind ?l2 (length$ $?mf2))
  (if  (or (> ?l1 ?l2) (and (eq ?l1 ?l2) (>= ?time2 ?time1)) ) then
  (printout t "retracting domain shape " ?d2 crlf)
  (retract ?d2)
  (retract ?d4)
  else 
	(printout t "retracting domain shape " ?d1 crlf)
  (retract ?d1)
  (retract ?d3)
  )
)

(defrule RemoveSubParts1
  (RemoveSubshapes ?type ?id)  
  (Subshapes ?type ?id $?mf)	
	?subshape <- (Define ?subtype ?subid $?rest) 
  (test (member$ ?subid $?mf))
=>
  (retract ?subshape)
)

(defrule RemoveSubParts2
  (RemoveSubshapes ?type ?id)  
  (Subshapes ?type ?id $?mf)
  ?subfact <- (Subshapes ?subtype ?subid $?sublist)  
  (test (member$ ?subid $?mf))
=>
  (retract ?subfact)
)

(defrule mergeLines
  ?f0 <- (Subshapes Line ?l1 $?l1_list)
  ?f1 <- (Subshapes Line ?l2 $?l2_list)
  (test (uniquefields $?l1_list $?l2_list))
  (Line ?l1 ?l1_p1 ?l1_p2 ?l1_length)
  (Line ?l2 ?l2_p1 ?l2_p2 ?l2_length)
  (test (mergable ?l1 ?l2))
=>
  (printout t "merging two lines" crlf)
  (bind ?nextnum (addshape Line ?l1 ?l2))
  (assert (Line ?nextnum ?l1_p1 ?l2_p2 ?l1_length))
  (assert (Subshapes Line ?nextnum ?nextnum))
  (bind ?nextnum1 (addshape Line ?l2_2 ?l1_2))
  (assert (Line ?nextnum1 ?l2_p1 ?l1_p2 ?l1_length))
  (assert (Subshapes Line ?nextnum1 ?nextnum))
  (retract ?f0)
  (retract ?f1)
)

(defrule collapseLines
  ?f0 <- (Subshapes Line ?l1 $?l1_list)
  ?f1 <- (Subshapes Line ?l2 $?l2_list)
  (test (uniquefields $?l1_list $?l2_list))
  (Line ?l1 ?l1_p1 ?l1_p2 ?l1_length)
  (Line ?l2 ?l2_p1 ?l2_p2 ?l2_length)
  (test (collapsable ?l1 ?l2))
=>
  (printout t "collapsing two lines" crlf)
;  (bind ?nextnum (addshape Line ?l1 ?l2))
;  (assert (Line ?nextnum ?l1_p1 ?l2_p2 ?l1_length))
;  (assert (Subshapes Line ?nextnum (union$ $?l1_list $?l2_list)))
  (bind ?nextnum1 (addshape Line ?l2_2 ?l1_2))
  (assert (Line ?nextnum1 ?l2_p1 ?l1_p2 ?l1_length))
;  (assert (Subshapes Line ?nextnum1 (union$ $?l1_list $?l2_list)))
;  (retract ?f0)
;  (removeshape ?l2)
  (retract ?f1)
)
  


;(batch "/afs/csail.mit.edu/u/h/hammond/drg/code/src/edu/mit/sketch/language/jess/BatchList.clp")
;;;;;;(batch "u:/drg/code/src/edu/mit/sketch/language/jess/BatchList.clp")
;(batch "c:/drg/code/src/edu/mit/sketch/language/jess/BatchList.clp")
;(batch "jess/BatchList.clp")


;(defrule PolyLineCheck1
;  ?f1 <- (Subshapes Line ?l1 $?l1_list)
;  ?f2 <- (Subshapes Line ?l2 $?l2_list)
;  (test (uniquefields $?l1_list $?l2_list))
;  (Line ?l1 ?l1_p1 ?l1_p2 ?length1)
;  (Line ?l2 ?l2_p1 ?l2_p2 ?length2)
;  (test (coincident ?l1_p2 ?l2_p1))
;  =>
;  (printout t "Found PolyLine 1")
;  (bind ?head ?l1_p1)
;  (bind ?tail ?l2_p2)
;  (bind ?nextnum (addshape PolyLine1 -1 ?l2 ?head ?tail 2))
;  (assert (Subshapes PolyLine ?nextnum (union$ $?l1_list $?l2_list)))
;  (assert (PolyLine ?nextnum ?nextnum ?l2 ?head ?tail 2))
;)

;(defrule PolyLineCheck2
;  ?f2 <- (Subshapes PolyLine ?poly $?poly_list)
;  ?f1 <- (Subshapes Line ?l $?l_list)
;  (test (uniquefields $?l_list $?poly_list))
;  (Line ?l ?l_p1 ?l_p2 ?length)
;  (PolyLine ?poly ?poly_poly ?poly_l ?poly_head ?poly_tail ?poly_size)
;  (test (coincident ?poly_tail ?l_p1))
;=>
;  (printout t "Found PolyLine 2")
;  (bind ?head ?poly_head)
;  (bind ?tail ?l_p2)
;  (bind ?size (+ ?poly_size 1))
;  (bind ?nextnum (addshape PolyLine2 ?poly ?l ?head ?tail ?size))
;  (assert (Subshapes ?nextnum (union$ $?l_list $?poly_list)))
;  (assert (PolyLine ?nextnum ?poly ?l ?head ?tail ?size))
;)
