;;; Common Process Methodology
;;; Use -clips loader.clp on HARDY command line.
;;; Create a CPM card, create a root with the custom menu,
;;; then keep clicking on nodes to create children.

(defglobal ?*cpm-root* = 0)
(defglobal ?*debug* = 0)
(defglobal ?*error-count* = 0)
(defglobal ?*working-ref* = "")

;;; Handler for initialisation
(deffunction cpm-init ()
  (hardy-set-title "Common Process Methodology")
  (hardy-set-name "Common Process Methodology")
  (hardy-set-author "Steve Polyak, Dept. of AI")
  (hardy-set-about-string "Common Process Methodology v.1.0")
  (message-box "Common Process Methodology, version 1.0");
  (unwatch all)
  (hardy-send-command 
   (hardy-command-string-to-int "HardyShowDevelopmentWindow"))
  (return 1)
  )

;;; Creates new diagram item and sets label and size
(deffunction cpm-new-item (?card-id ?item-type ?label-text ?x ?y)
  (bind ?image1 (create-node-image ?card-id ?item-type))
  (diagram-image-move ?card-id ?image1 ?x ?y)
  ;; Find it's underlying node object
  (bind ?object1 (get-object-from-image ?card-id ?image1))
  ;; Set the name attribute
  (set-object-string-attribute ?card-id ?object1 "label" ?label-text)
  ;; Format the text on the image
  (format-object-text ?card-id ?object1)
  )

;;; Creates new diagram line
(deffunction cpm-new-line (?card-id ?item-type ?x ?y ?width ?height)
  (bind ?image1 (create-node-image ?card-id ?item-type))
  (diagram-image-move ?card-id ?image1 ?x ?y)
  (diagram-image-resize ?card-id ?image1 ?width ?height)
  )

;;; Handler for drawing tabular entry diagrams
(deffunction cpm-draw-ted (?card-id)
  
  ;; create base form items
  (cpm-new-item ?card-id "Text" "Title:" 25 18)
  (cpm-new-item ?card-id "Title" "[Todo: add title]" 120 18)
  (cpm-new-item ?card-id "Text" "Ref:" 25 33)
  (cpm-new-item ?card-id "Ref" "[Todo: add ref]" 120 33)
  (cpm-new-item ?card-id "Text" "Parent:" 25 48)
  (cpm-new-item ?card-id "Parent" "[Todo: add parent]" 120 48)
  (cpm-new-item ?card-id "Text" "Level:" 25 63)
  (cpm-new-item ?card-id "Level" "[Todo: add level]" 120 63)
  
  ;; Create new lines
  (cpm-new-line ?card-id "Horizontal" 420 70 850 1)
  (cpm-new-line ?card-id "Horizontal" 420 110 850 1)
  (cpm-new-line ?card-id "Vertical" 125 495 1 850)
  (cpm-new-line ?card-id "Vertical" 325 495 1 850)
  (cpm-new-line ?card-id "Vertical" 525 495 1 850)
  (cpm-new-line ?card-id "Vertical" 725 495 1 850)
  
  ;; Create new labels
  (cpm-new-item ?card-id "Text" "Source" 45 90)
  (cpm-new-item ?card-id "Text" "Input" 225 90)
  (cpm-new-item ?card-id "Text" "Action" 425 90)
  (cpm-new-item ?card-id "Text" "Output" 625 90)
  (cpm-new-item ?card-id "Text" "Destin." 805 90)
  (diagram-card-redraw ?card-id)
  )

;;; Handler for general frame drawing
(deffunction cpm-draw-frame (?card-id)
  
  ;; create base form items
  (cpm-new-item ?card-id "Text" "Title:" 25 18)
  (cpm-new-item ?card-id "Title" "[Todo: add title]" 120 18)
  (cpm-new-item ?card-id "Text" "Ref:" 25 33)
  (cpm-new-item ?card-id "Reference" "[Todo: add ref]" 120 33)

  ;; Create new lines
  (cpm-new-line ?card-id "Horizontal" 420 48 850 1)
  (cpm-new-line ?card-id "Vertical" 0 475 1 850)
  (cpm-new-line ?card-id "Vertical" 845 475 1 850)
  (diagram-card-redraw ?card-id)
  )

(deffunction cpm-assert-object (?object ?card)
  (if  (eq "Action" 
	   (diagram-object-get-string-attribute ?card ?object "type")) then
    (bind ?label (strip-multiple-newline (diagram-object-get-string-attribute 
				     ?card ?object "label")))
    ;;(printout t "Got an action... " ?label crlf)
    (assert (action ?*working-ref* ?label)
	    (invalid ?*working-ref* ?label))
    else
    (if  (eq "Input" 
	     (diagram-object-get-string-attribute ?card ?object "type"))
	then
      (bind ?label (strip-multiple-newline (diagram-object-get-string-attribute 
				       ?card ?object "label")))
      ;;(printout t "Got an input... " ?label crlf)
      (assert (input ?*working-ref* ?label)
	      (invalid ?*working-ref* ?label)
	      (inconsistent ?*working-ref* ?label))
      else
      (if  (eq "Output" 
	       (diagram-object-get-string-attribute ?card ?object "type"))
	  then
	(bind ?label (strip-multiple-newline (diagram-object-get-string-attribute 
					 ?card ?object "label")))
	;;(printout t "Got an output... " ?label crlf)
	(assert (output ?*working-ref* ?label)
		(invalid ?*working-ref* ?label)
		(inconsistent ?*working-ref* ?label))	
	else
	(if  (eq "Source" 
		 (diagram-object-get-string-attribute ?card ?object "type"))
	    then
	  (bind ?label 
		(strip-multiple-newline (diagram-object-get-string-attribute 
				    ?card ?object "label")))
	  ;;(printout t "Got an source... " ?label crlf)
	  (assert (source ?*working-ref* ?label)
		  (invalid ?*working-ref* ?label))
	  else
	  (if  (eq "Destination" 
		   (diagram-object-get-string-attribute ?card ?object "type"))
	      then
	    (bind ?label 
		  (strip-multiple-newline (diagram-object-get-string-attribute 
				      ?card ?object "label")))
	    ;;(printout t "Got an destination... " ?label crlf)
	    (assert (destination ?*working-ref* ?label)
		    (invalid ?*working-ref* ?label))
            else
	    
	    (if  (eq "Parent" 
		     (diagram-object-get-string-attribute 
		      ?card ?object "type"))
		then
	      (bind ?label (diagram-object-get-string-attribute 
			    ?card ?object "label"))
	      (assert (has-parent ?card ?label)))

            else
	    
	    (if  (eq "Title" 
		     (diagram-object-get-string-attribute 
		      ?card ?object "type"))
		then
	      (bind ?label (diagram-object-get-string-attribute 
			    ?card ?object "label"))
	      (assert (has-title ?card ?label))
	      )

            else 
	    (if  (eq "Level" 
		     (diagram-object-get-string-attribute 
		      ?card ?object "type"))
		then
	      (bind ?label (diagram-object-get-string-attribute 
			    ?card ?object "label"))
	      (assert (has-level ?card ?label))
	      )
	 
	    )
	  )
	)
      )
    )
  )

(deffunction cpm-assert-arc (?arc ?card)
  ;; 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")))

  (if  (eq "S-I" 
	   (diagram-object-get-string-attribute ?card ?arc "type")) then
    ;;(printout t "Got a S-I... " crlf)
    (assert (has-source ?*working-ref* ?to-label ?from-label))
    else
    (if  (eq "I-A" 
	     (diagram-object-get-string-attribute ?card ?arc "type"))
	then
      ;;(printout t "Got a I-A... " crlf)
      (assert (has-input ?*working-ref* ?to-label ?from-label))
      else
      (if  (eq "A-O" 
	       (diagram-object-get-string-attribute ?card ?arc "type"))
	  then
	;;(printout t "Got a A-O... " crlf)
	(assert (has-output ?*working-ref* ?from-label ?to-label))
	else
	(if  (eq "O-D" 
		 (diagram-object-get-string-attribute ?card ?arc "type"))
	    then
	  ;;(printout t "Got a O-D... " crlf)
	  (assert (has-destination ?*working-ref* ?from-label ?to-label))
	  )
	)
      )
    )
  )

;; cpm-assert-entries iterates thru a tab. entry diagram card and
;; asserts the structure of the specifications.
(deffunction cpm-assert-entries (?card)
  (card-show ?card 1)

  ;; find the card ref number and store it in global var
  (bind ?found -1)
  (bind ?object (diagram-card-get-first-node-object ?card))
  (while (and (neq ?object -1) (neq ?found 1))  
    (if  (eq "Ref" 
	     (diagram-object-get-string-attribute 
	      ?card ?object "type"))
	then
      (bind ?*working-ref* (diagram-object-get-string-attribute 
			    ?card ?object "label"))
      (assert (has-reference ?card ?*working-ref*))
      (bind ?found 1)
      )
    (bind ?object (diagram-card-get-next-node-object))
    )
  
  ;; iterate thru nodes
  (bind ?object (diagram-card-get-first-node-object ?card))
  (while (neq ?object -1)   
    (cpm-assert-object ?object ?card)
    (bind ?object (diagram-card-get-next-node-object))
    )
  ;; iterate thru arcs
  (bind ?arc (diagram-card-get-first-arc-object ?card))
  (while (neq ?arc -1)   
    (cpm-assert-arc ?arc ?card)
    (bind ?arc (diagram-card-get-next-arc-object))
    )
  )

;; cpm-assert-all iterates thru the tabular entry diagrams and
;; calls for the assertion of the structure of the specifications.
(deffunction cpm-assert-all ()
  (bind ?card (hardy-get-first-card))
  (while (neq ?card -1)   
    (if  (eq "Tabular Entry Diagram" 
	     (card-get-string-attribute ?card "diagram-type")) then
      ;;(printout t "Got a ted... " 
      ;;	(card-get-string-attribute ?card "title") crlf)
      (cpm-assert-entries ?card)
      )
    (bind ?card (hardy-get-next-card))
    )
  )

;;; Handler for Consistency Checks
(deffunction cpm-consistency-check (?card-id)
  (unwatch all)
  (reset)
  (bind ?*error-count* 0)

  ;; asserting the facts. 
  (cpm-assert-all)
  
  ;; running check phase
  (format t "Checking the CPM specification... %n")
  (run)

  ;; Running the report phase
  (assert (phase report))
  (run)

  (if (> ?*error-count* 0) then
    (format t "Check found %d error(s)! %n" ?*error-count*)
    (message-box (str-cat "Check found " ?*error-count* " error(s)")) else
    (message-box "Consistency check found no errors !")
    (format t "Consistency check found no errors !%n"))
  )

;;; Handler for Print All
(deffunction cpm-print-all (?card-id)
  (bind ?card (hardy-get-first-card))
  (while (neq ?card -1)   
    (if  (eq "Text Card" 
	     (card-get-string-attribute ?card "diagram-type")) then
      ;;; text card must be handled specially
      (execute 
        (str-cat "lpr " (card-get-string-attribute ?card "diagram-type")) 1)
      else
      (card-show ?card 1)
      (card-send-command ?card 
			 (hardy-command-string-to-int "DiagramPrintEPS"))
      )
    (bind ?card (hardy-get-next-card))
    )
  )

;;; Callback for custom menu
(deffunction cpm-menu-handler (?card-id ?option)
  (if (eq ?option "Consistency Checks") then
    (cpm-consistency-check ?card-id) 
    else
    (if (eq ?option "Info") then
      (message-box "Common Process Methodology, Version 1.0"))
    else
    (if (eq ?option "Print All") then
      (cpm-print-all ?card-id))
    else
    (if (eq ?option "Export to CPL") then
      (cpm-export-to-cpl ?card-id))
  ))
