;;; CLIPS functions for exporting to CPL
;;; Steve Polyak, Dept. of AI, University of Edinburgh
;;; Date: August 3, 1998

;;; Global counters
(defglobal ?*action-count* = 1)
(defglobal ?*spec-count* = 1)
(defglobal ?*proc-count* = 1)
(defglobal ?*timepoint-count* = 1)
(defglobal ?*beg-count* = 1)
(defglobal ?*end-count* = 1)
(defglobal ?*ordering-count* = 1)
(defglobal ?*include-count* = 1)
;;; Global structures 
(defglobal ?*beg-tp* = "")
(defglobal ?*last-node-tp* = "")
(defglobal ?*visited-list* = "")

;;; Function pre-definition
(deffunction export-cpl-single-driver
(?file ?card ?object ?spec-id ?before-tp))

;;; Create cpl file header.
(deffunction export-cpl-header (?file ?title)

  (bind ?filename ?title)
  (bind ?title (strip-extension (get-file ?title)))
  (printout ?file 
	    "// Common Process Methodology, version 1.0, DAI, 1998" crlf)
  (bind ?date (now))
  (printout ?file (str-cat "// Date: " ?date) crlf)
  (printout ?file (str-cat "// File: " ?filename) crlf)
  (printout ?file "//------------" crlf)
  (printout ?file (str-cat "%define-domain(" ?title ")")  crlf)
)

;;; Function for expanding links from a given node.
(deffunction export-cpl-single-node
  (?file ?card ?object ?spec-id ?before-tp)

  ;;; activity.begin-timepoint(ACT)=TP1
  ;;; activity.end-timepoint(ACT)=TP2
  ;;; node.label(ACT)="string"
  ;;; activity.pattern(ACT)="string"
  ;;; include-node(C1)=ACT
  ;;; member(C1,AS)
  ;;; constraint.expression(C2)="before(BEG,TP1)"
  ;;; member(C2,AS)
  (bind ?tmp-label (strip-multiple-newline
		    (diagram-object-get-string-attribute 
		     ?card ?object "label")))
  (bind ?act-id (str-cat "ACT" ?*action-count*)) 
  (bind ?*action-count* (+ ?*action-count* 1))
  (bind ?act-beg-tp (str-cat "TP" ?*timepoint-count*)) 
  (bind ?*timepoint-count* (+ ?*timepoint-count* 1))
  ;;; cache up the assigned beg-tp on the node.temp prop
  (diagram-object-set-string-attribute ?card ?object "temp" ?act-beg-tp)
  (bind ?act-end-tp (str-cat "TP" ?*timepoint-count*)) 
  (bind ?*timepoint-count* (+ ?*timepoint-count* 1))
  (bind ?*last-node-tp* ?act-end-tp) ;;; Save the last timepoint
  (bind ?temp-constraint1 (str-cat "IC" ?*include-count*)) 
  (bind ?*include-count* (+ ?*include-count* 1))
  (bind ?temp-constraint2 (str-cat "OC" ?*ordering-count*)) 
  (bind ?*ordering-count* (+ ?*ordering-count* 1))
  (printout ?file (str-cat "activity.begin-timepoint(" ?act-id ")="  
			   ?act-beg-tp) crlf)
  (printout ?file (str-cat "activity.end-timepoint(" ?act-id ")="  
			   ?act-end-tp) crlf)
  (printout ?file (str-cat "node.label(" ?act-id ")=\""  
			   ?tmp-label
			   "\"") crlf)
  (printout ?file (str-cat "activity.pattern(" ?act-id ")=\""  
			   ?tmp-label
			   "\"") crlf)
  (printout ?file (str-cat "include-node(" ?temp-constraint1 
			   ")=" ?act-id) crlf)
  (printout ?file (str-cat "member(" ?temp-constraint1 
			   "," ?spec-id ")") crlf)
  (printout ?file (str-cat "constraint.expression(" ?temp-constraint2 
			   ")=\"before(" ?before-tp "," 
			   ?act-beg-tp ")\"" ) crlf)
  (printout ?file (str-cat "member(" ?temp-constraint2 
			   "," ?spec-id ")") crlf)

  ;;; add to list of visited nodes
  (bind ?*visited-list* (str-cat ?*visited-list* " " ?tmp-label))

  ;;;;;;;;;;;;;;Connected Outgoing Nodes;;;;;;;;;;;;;;;;;;;;;;;  
  ;;; iterate thru arcs
  (bind ?arc (node-object-get-first-arc-object ?card ?object))
  (while (neq ?arc -1) 

    ;; fetch image
    (bind ?image (diagram-object-get-first-image ?card ?arc))
    (bind ?to-object (diagram-image-get-object ?card
					       (arc-image-get-image-to 
						?card ?image)))
    (bind ?from-object (diagram-image-get-object ?card
						 (arc-image-get-image-from 
						  ?card ?image)))
    (bind ?to-label 
	  (strip-multiple-newline (diagram-object-get-string-attribute 
			      ?card ?to-object "label")))
    (bind ?from-label 
	  (strip-multiple-newline (diagram-object-get-string-attribute 
			      ?card ?from-object "label")))
    ;;; only interested in arcs from this node
    (if (eq  ?tmp-label (strip-multiple-newline 
			 (diagram-object-get-string-attribute 
			  ?card ?from-object "label"))) then
      
      ;;;(printout t (str-cat "Arc: " ?from-label " -> " ?to-label) crlf)
      (export-cpl-single-driver ?file ?card ?to-object ?spec-id ?act-end-tp))
    (bind ?arc (node-object-get-next-arc-object)))
  )

;;; Function for driving node expansion
(deffunction export-cpl-single-driver 
  (?file ?card ?object ?spec-id ?before-tp)

  (bind ?tmp-label (strip-multiple-newline
		    (diagram-object-get-string-attribute 
		     ?card ?object "label")))

  ;;;;;;;;;;;;;;Connected Incoming Nodes;;;;;;;;;;;;;;;;;;;;;;;  
  ;;; need to scan all the incoming links (to=?tmp-label)
  ;;; if from is an activity, need to make sure we haven't visited it.
  ;;; if haven't visited recurse, and omit rest of code to bottom

  (bind ?has-input "n")

  ;;; iterate thru arcs
  (bind ?arc (node-object-get-first-arc-object ?card ?object))
  (while (neq ?arc -1) 

    ;; fetch image
    (bind ?image (diagram-object-get-first-image ?card ?arc))
    (bind ?to-object (diagram-image-get-object ?card
					       (arc-image-get-image-to 
						?card ?image)))
    (bind ?from-object (diagram-image-get-object ?card
						 (arc-image-get-image-from 
						  ?card ?image)))
    (bind ?to-label 
	  (strip-multiple-newline (diagram-object-get-string-attribute 
			      ?card ?to-object "label")))
    (bind ?from-label 
	  (strip-multiple-newline (diagram-object-get-string-attribute 
			      ?card ?from-object "label")))
    ;;; only interested in arcs to this node, from action nodes
    (if (eq  ?tmp-label (strip-multiple-newline 
			 (diagram-object-get-string-attribute 
			  ?card ?to-object "label"))) then
      (if (eq "Action" (strip-multiple-newline 
			(diagram-object-get-string-attribute 
			 ?card ?from-object "type"))) then
	;;; scan the list
	(bind ?scan-result (str-index (strip-multiple-newline 
				       (diagram-object-get-string-attribute 
					?card ?from-object "label"))
				      ?*visited-list*))
        (if (eq FALSE ?scan-result) then
	  (export-cpl-single-driver 
	   ?file ?card ?from-object ?spec-id ?*beg-tp*)
	  (bind ?has-input "y"))))
    (bind ?arc (node-object-get-next-arc-object)))
  
  ;;; if no open input links, output this node info
  (if (eq  ?has-input "n") then
    (export-cpl-single-node
     ?file ?card ?object ?spec-id ?before-tp)

    else
    ;;; link the nodes, fetch from cached property
    (bind ?temp-constraint (str-cat "OC" ?*ordering-count*)) 
    (bind ?*ordering-count* (+ ?*ordering-count* 1))
    (printout ?file (str-cat "constraint.expression(" ?temp-constraint
			   ")=\"before(" ?before-tp "," 
			   (diagram-object-get-string-attribute 
			    ?card ?object "temp") ")\"" ) crlf)
    (printout ?file (str-cat "member(" ?temp-constraint
			     "," ?spec-id ")") crlf)
    ))

;;; Function for outputting a single path within a card.
(deffunction export-cpl-single-path 
  (?object ?multiple-count ?file ?card ?title)
  
  ;;; Clear last tp global
  (bind ?*last-node-tp* "")
  ;;; Clear visited list (used to remember which nodes have been visited)
  (bind ?*visited-list* "")

  ;;;;;;;;;;;;;;Process Items;;;;;;;;;;;;;;;;;;;;;;;
  ;;; process.label(P)="string"
  (bind ?process-id (str-cat "PROC" ?*proc-count*)) 
  (bind ?*proc-count* (+ ?*proc-count* 1)) 
  (printout ?file crlf (str-cat "process.label(" ?process-id ")=\""  
			   (sub-string 10 (length ?title) ?title)
			   "-" ?multiple-count "\"") crlf)

  ;;; process.activity-spec(P,AS)
  (bind ?spec-id (str-cat "AS" ?*spec-count*)) 
  (bind ?*spec-count* (+ ?*spec-count* 1))
  (printout ?file (str-cat "process.activity-spec(" ?process-id ","  
			   ?spec-id ")") crlf)

  ;;;;;;;;;;;;;;Begin Node;;;;;;;;;;;;;;;;;;;;;;;
  ;;; start.timepoint(BEG)=TP
  ;;; node.label(BEG)="Begin"
  ;;; include-node(C)=BEG
  ;;; member(C,AS)
  (bind ?beg-id (str-cat "BEG" ?*beg-count*)) 
  (bind ?*beg-count* (+ ?*beg-count* 1))
  (bind ?beg-tp (str-cat "TP" ?*timepoint-count*)) 
  (bind ?*timepoint-count* (+ ?*timepoint-count* 1))
  (bind ?*beg-tp* ?beg-tp)   ;;; save the begin point
  (bind ?temp-constraint (str-cat "IC" ?*include-count*)) 
  (bind ?*include-count* (+ ?*include-count* 1))
  (printout ?file (str-cat "start.timepoint(" ?beg-id ")="  
			   ?beg-tp) crlf)
  (printout ?file (str-cat "node.label(" ?beg-id 
			   ")=\"Begin\"" ) crlf)
  (printout ?file (str-cat "include-node(" ?temp-constraint 
			   ")=" ?beg-id) crlf)
  (printout ?file (str-cat "member(" ?temp-constraint 
			   "," ?spec-id ")") crlf)

  ;;;;;;;;;;;;;;End Node;;;;;;;;;;;;;;;;;;;;;;;
  ;;; finish.timepoint(END)=TP
  ;;; node.label(END)="End"
  ;;; include-node(C)=END
  ;;; member(C,AS)
  (bind ?end-id (str-cat "END" ?*end-count*)) 
  (bind ?*end-count* (+ ?*end-count* 1))
  (bind ?end-tp (str-cat "TP" ?*timepoint-count*)) 
  (bind ?*timepoint-count* (+ ?*timepoint-count* 1))
  (bind ?temp-constraint (str-cat "IC" ?*include-count*)) 
  (bind ?*include-count* (+ ?*include-count* 1))
  (printout ?file (str-cat "finish.timepoint(" ?end-id ")="  
			   ?end-tp) crlf)
  (printout ?file (str-cat "node.label(" ?end-id 
			   ")=\"End\"" ) crlf)
  (printout ?file (str-cat "include-node(" ?temp-constraint 
			   ")=" ?end-id) crlf)
  (printout ?file (str-cat "member(" ?temp-constraint 
			   "," ?spec-id ")") crlf)

  ;;; kick off first node
  (export-cpl-single-driver ?file ?card ?object ?spec-id ?beg-tp)

  ;;;;;;;;;;;;;;Link last node before End;;;;;;;;;;;;;;;;;;;;;;;  
  ;;; constraint.expression(C)="before(GTP,END)"
  ;;; member(C,AS)
  (bind ?temp-constraint (str-cat "OC" ?*ordering-count*)) 
  (bind ?*ordering-count* (+ ?*ordering-count* 1))
  (printout ?file (str-cat "constraint.expression(" ?temp-constraint 
			   ")=\"before(" ?*last-node-tp* "," 
			   ?end-tp ")\"" ) crlf)
  (printout ?file (str-cat "member(" ?temp-constraint 
			   "," ?spec-id ")") crlf)
  )


;;; Function for outputting a single card to cpl
(deffunction export-cpl-single-card (?file ?card ?title)

  (card-show ?card 1)

  ;; iterate thru nodes to scan for head nodes (modifier=1)
  (bind ?multiple-count 0)
  (bind ?object (diagram-card-get-first-node-object ?card))
  (while (neq ?object -1)   
     (if  (eq "Action" 
	     (diagram-object-get-string-attribute ?card ?object "type")) then
       (if (eq (get-object-string-attribute ?card ?object "modifier")
	      "1") then
	 (bind ?multiple-count (+ ?multiple-count 1))
	 (export-cpl-single-path ?object ?multiple-count ?file ?card ?title)
	 ))
     (bind ?object (diagram-card-get-next-node-object))
     ))

;;; Function for outputting individual schemas 
(deffunction export-cpl-main (?file ?card)

  (if  (eq "Combined Thread Diagram" 
	   (card-get-string-attribute ?card "diagram-type")) then
    (bind ?title (card-get-string-attribute ?card "title"))
    (printout ?file crlf (str-cat "// Processing card: " ?title)
			       crlf)
    (export-cpl-single-card ?file ?card ?title)))

;;; Function for outputting the sorts
(deffunction export-cpl-sorts (?file)

  ;;; SORT cpo-process={PROC1-PROCN}
  (bind ?tmp-count (- ?*proc-count* 1))
  (bind ?prefix "PROC")
  (bind ?output "PROC1")
  (while (> ?tmp-count 1)
    (bind ?output (str-cat ?output "," ?prefix ?tmp-count))
    (bind ?tmp-count (- ?tmp-count 1)))	
  (printout ?file crlf (str-cat "SORT cpo-process={" ?output "}") crlf)

  ;;; SORT cpo-activity-specification={AS1-ASN}
  (bind ?tmp-count (- ?*spec-count* 1))
  (bind ?prefix "AS")
  (bind ?output "AS1")
  (while (> ?tmp-count 1)
    (bind ?output (str-cat ?output "," ?prefix ?tmp-count))
    (bind ?tmp-count (- ?tmp-count 1)))	
  (printout ?file (str-cat "SORT cpo-activity-specification={" 
			   ?output "}") crlf)

  ;;; SORT cpo-action={ACT1-ACTN}
  (bind ?tmp-count (- ?*action-count* 1))
  (bind ?prefix "ACT")
  (bind ?output "ACT1")
  (while (> ?tmp-count 1)
    (bind ?output (str-cat ?output "," ?prefix ?tmp-count))
    (bind ?tmp-count (- ?tmp-count 1)))	
  (printout ?file (str-cat "SORT cpo-action={" 
			   ?output "}") crlf)

  ;;; SORT cpo-begin={BEG1-BEGN}
  (bind ?tmp-count (- ?*beg-count* 1))
  (bind ?prefix "BEG")
  (bind ?output "BEG1")
  (while (> ?tmp-count 1)
    (bind ?output (str-cat ?output "," ?prefix ?tmp-count))
    (bind ?tmp-count (- ?tmp-count 1)))	
  (printout ?file (str-cat "SORT cpo-begin={" ?output "}") crlf)

  ;;; SORT cpo-end={END1-ENDN}
  (bind ?tmp-count (- ?*end-count* 1))
  (bind ?prefix "END")
  (bind ?output "END1")
  (while (> ?tmp-count 1)
    (bind ?output (str-cat ?output "," ?prefix ?tmp-count))
    (bind ?tmp-count (- ?tmp-count 1)))	
  (printout ?file (str-cat "SORT cpo-end={" ?output "}") crlf)

  ;;; SORT cpo-timepoint={TP1-TPN}
  (bind ?tmp-count (- ?*timepoint-count* 1))
  (bind ?prefix "TP")
  (bind ?output "TP1")
  (while (> ?tmp-count 1)
    (bind ?output (str-cat ?output "," ?prefix ?tmp-count))
    (bind ?tmp-count (- ?tmp-count 1)))	
  (printout ?file (str-cat "SORT cpo-timepoint={" ?output "}") crlf)

  ;;; SORT cpo-ordering-constraint={OC1-OCN}
  (bind ?tmp-count (- ?*ordering-count* 1))
  (bind ?prefix "OC")
  (bind ?output "OC1")
  (while (> ?tmp-count 1)
    (bind ?output (str-cat ?output "," ?prefix ?tmp-count))
    (bind ?tmp-count (- ?tmp-count 1)))	
  (printout ?file (str-cat "SORT cpo-ordering-constraint={" ?output "}") crlf)

  ;;; SORT cpo-include-constraint={IC1-ICN}
  (bind ?tmp-count (- ?*include-count* 1))
  (bind ?prefix "IC")
  (bind ?output "IC1")
  (while (> ?tmp-count 1)
    (bind ?output (str-cat ?output "," ?prefix ?tmp-count))
    (bind ?tmp-count (- ?tmp-count 1)))	
  (printout ?file (str-cat "SORT cpo-include-constraint={" ?output "}") crlf)
  )

;;; Handler for Export to CPL
(deffunction cpm-export-to-cpl (?card-id)
 
  ;;; initialize globals
  (bind ?*action-count* 1)
  (bind ?*spec-count* 1)
  (bind ?*proc-count* 1)
  (bind ?*timepoint-count* 1)
  (bind ?*beg-count* 1)
  (bind ?*end-count* 1)
  (bind ?*ordering-count* 1)
  (bind ?*include-count* 1)

  ;;; get a filename
  (bind ?cplFile 
	(file-selector "Filename for CPL output" 
		       "" ""
		       "cpd" "*.cpd" 
		       (hardy-get-top-level-frame)
		       "wxSAVE|wxOVERWRITE_PROMPT"))
  ;(printout t "returning from file selector file = " ?cplFile crlf)
  (if (eq ?cplFile "") then
    (return 1)
    else
    (open ?cplFile File "w")
    (bind ?title ?cplFile)
    (export-cpl-header File ?title)

    ;;; kick out the schemas
    (bind ?card (hardy-get-first-card))
    (while (neq ?card -1)   
      (export-cpl-main File ?card)
      (bind ?card (hardy-get-next-card))
      )

    ;;; kick out the sorts
    (export-cpl-sorts File)

    (printout File "// End of File" crlf)
    (close File)
    )
  )
