(in-package "KPML-I")

;;; File: chooser-editor.lisp
;;; John:Nov97:Edinburgh
;;;
;;; 1.1 Graphical editing of choosers.
;;;
;;; All the functionality is there, so just wrap it up in graphics.
;;; Method: take the digested choosers of the grammar extractor and
;;; and display these in the graph of the chooser displayer with
;;; actions for modifying the chooser actions. Then export as done
;;; with system-editing with similar checks.

(defvar *cut-chooser-subtree* nil) ;; allow basic cut and paste
(defvar *cut-chooser-action* nil)  ;; allow basic cut and paste
(defvar *cut-chooser-nodes* nil)   ;; more basic cut and paste
(defvar *cut-q-inquiry* nil)

(defvar *highlighted-path* nil)    ;; for better diagnostics

(defvar *auto-define-undefined-inquiries* nil 
  "when T, undefined inquiries bring up a definition dialog")

(clim:define-presentation-type chooser-actions ())
(clim:define-presentation-type chooser-action  ())
(clim:define-presentation-type chooser-branch  ())
(clim:define-presentation-type chooser-ask-action  ())

;;; ----------------------------------------------------------------------
;;; Basic frame, etc.

(clim:define-application-frame CHOOSER-EDITOR-GRAPH ()
  ((root-definition :initform nil)
   (modified :initform nil)
   (comments :initform "")
   (edited-chooser-name :initform nil))
  (:top-level (clim:default-frame-top-level  :prompt clim-prompt-function))
  (:panes (graph       :application
		       :display-function 'edited-chooser-displayer
		       :initial-cursor-visibility :inactive
		       :incremental-redisplay T
		       :foreground resource-graph-fg
		       :background resource-graph-bg
		       :text-style *fix--bold--10*)
	  (menu        :command-menu
		       :stream-foreground menu-fg
		       :stream-background menu-bg			
		       :default-text-style *fix--bold--12*)
	  (mouse-doc   :pointer-documentation
		       :foreground  mouse-doc-fg
		       :background  mouse-doc-bg))
  (:layouts (default (clim:vertically 
			 () 
		       (:fill graph)
		       #-lispworks (20 mouse-doc))))
  (:command-table 
  (chooser-editor-commands
   :inherit-from (kpml-resource-inspector))))

(define-chooser-editor-graph-command 
  (com-QUIT-CHOOSER-EDITOR :name "Quit" :menu t)
  ()
  (with-slots (modified edited-chooser-name root-definition) 
      clim:*application-frame*
    (when (and modified
	       (eq (startup-user-response-frame
		    '("Modified chooser has not been saved. Save it first?"))
		   :yes))
      (export-edited-chooser edited-chooser-name root-definition)
      (setf modified nil))
    (close-a-window clim:*application-frame*)))

(define-chooser-editor-graph-command 
  (com-CHECK-CHOOSER-EDITOR :name "Check" :menu t)
  ()
  (if (slot-value clim:*application-frame* 'modified)
      (check-edited-chooser 
       (slot-value clim:*application-frame* 'edited-chooser-name)
       (slot-value clim:*application-frame* 'root-definition))
    (clim:notify-user 
       clim:*application-frame*
       "No modifications pending.")))

(define-chooser-editor-graph-command 
    (com-EXPORT-CHOOSER-EDITOR :name "Export" :menu t)
  ()
  (export-edited-chooser 
   (slot-value clim:*application-frame* 'edited-chooser-name)
   (slot-value clim:*application-frame* 'root-definition))
  (setf (slot-value clim:*application-frame* 'modified) nil))

(define-chooser-editor-graph-command 
    (com-RENAME-CHOOSER-EDITOR :name "Rename" :menu t)
    ()
  (with-slots (modified edited-chooser-name) clim:*application-frame*
    (let ((edit (edit-element
		 clim:*application-frame*
		 edited-chooser-name :expand-p nil)))
      (when edit
	(setf edited-chooser-name edit)
	(setf modified T)))))

(define-chooser-editor-graph-command 
    (com-CHOOSER-EDITING-COMMENTS :name "Comments" :menu t)
    ()
  (with-slots (modified comments) clim:*application-frame*
    (let ((edit (edit-string-block 
		 (if (and comments (not (string= comments "")))
		     comments
		   "no comments")
		 :label "Edit chooser comment (click middle to modify)"
		 :height 100 :width 200)))
      (when edit
	(setf comments edit)
	(setf modified T)))))

(define-chooser-editor-graph-command 
  (com-REVERT-CHOOSER-EDITOR :name "Revert" :menu t)
  ()
  (with-slots (modified
	       edited-chooser-name
	       root-definition) clim:*application-frame*
    (when (and modified
	       (eq (startup-user-response-frame
		    '("Modified chooser has not been saved. Save it first?"))
		   :yes))
      (export-edited-chooser edited-chooser-name root-definition))
    
    (setf *highlighted-path* nil)
    (setf root-definition
      (kpml::digest-chooser
       (kpml::fetch-chooser-info edited-chooser-name 'kpml::definition)))
    (setf modified nil)))

(define-chooser-editor-graph-command 
  (com-CLEAR-CHOOSER-EDITOR :name "Clear" :menu t)
  ()
  (with-slots (modified
	       edited-chooser-name
	       root-definition) clim:*application-frame*
    (setf *highlighted-path* nil)
    (setf root-definition (kpml::make-digested-chooser-node
			   :label (gensym)))
    (setf modified nil)))


;;; ----------------------------------------------------------------------
;;; Starter wrapper...

(defun RUN-CHOOSER-EDITOR (*package* frame)
  (declare (special *package*))
  (setf *package* (find-package "KPML"))
  (clim:run-frame-top-level frame))

;;; ----------------------------------------------------------------------
;;;

(defun MAKE-A-CHOOSER-EDITOR (chooser-name)
  (let* ((window-name (concatenate 'string
			"chooser editor: "
			(if chooser-name
			    (string chooser-name)
			  "NEW CHOOSER")
			" ("
			(string kpml::curlan)
			")"
			(if (kpml::fetch-chooser-info 
			     chooser-name 'kpml::patch-status)
			    "  (***patched***)"
			  "")))
	 (frame (clim:make-application-frame
		 'chooser-editor-graph
		 :pretty-name window-name
		 :left (first *current-offsets*) 
		 :top (second *current-offsets*)
		 :width *resource-graph-width*
		 :height *resource-graph-height*)))

    (setf *highlighted-path* nil)
    (setf (slot-value frame 'root-definition)
      (kpml::digest-chooser
       (kpml::fetch-chooser-info chooser-name 'kpml::definition)))
    (setf (slot-value frame 'comments)
      (kpml::fetch-chooser-info chooser-name 'kpml::comments)) 
    (setf (slot-value frame 'edited-chooser-name) chooser-name)
    (process-run-function 
     "KPML-CHOOSER-EDITOR"
     #'run-chooser-editor
     *package* frame)
    ))

(defmethod EDITED-CHOOSER-DISPLAYER ((frame chooser-editor-graph) stream)
  (with-slots (root-definition) frame
    (clim:updating-output 
	(stream 
	 :unique-id (gensym
		     (string 
		      (kpml::digested-chooser-node-label root-definition))))
      (clim:format-graph-from-root
       (list :node 
	     (kpml::digested-chooser-node-label root-definition)
	     root-definition)
       #'(lambda (node s)
	   (clim:updating-output (s :cache-value node)
	     (print-digested-chooser-node node s)))
       #'get-digested-chooser-node-children
       :orientation :vertical
       :center-nodes T
       :generation-separation 20
       :within-generation-separation 20
       :move-cursor t
       :orientation :vertical
       :stream stream))))

;;; ----------------------------------------------------------------------
;;; Graph building/displaying functions

(defun PRINT-DIGESTED-CHOOSER-NODE (pres stream)
  (with-slots (edited-chooser-name) clim:*application-frame*
    (if (kpml::fetch-chooser-info 
	 edited-chooser-name 'kpml::patch-status)
	(clim:with-text-face (stream :italic)
	  (print-digested-chooser-node-intern pres stream))
      (print-digested-chooser-node-intern pres stream))))

(defun PRINT-DIGESTED-CHOOSER-NODE-INTERN (pres stream)
  (let ((type (car pres))
	(label (second pres))
	(value (third  pres)))
    (case type
      (:node 
       (let ((*standard-output* stream)
	     (*print-right-margin* 20))
	 (clim:with-output-as-presentation 
	     (stream label 'chooser-actions)
	   (clim:surrounding-output-with-border (stream :shape :rectangle)
              (multiple-value-bind (x y)
		 (clim:stream-cursor-position stream)
		 (clim:with-drawing-options 
		  (stream :ink clim:+green+)
		  (clim:draw-circle* stream (+ x 3) (+ y 3) 4)))
	      (clim:with-text-style (stream kpml-i::*fix--bold--8*)
	       (loop for action in (kpml::digested-chooser-node-actions value)
		   if (member (first action)
				'(kpml::choose kpml::defaultchoose))
		   do 
		     (clim:with-drawing-options 
			 (stream :ink clim:+magenta+)
		       (clim:with-output-as-presentation 
			   (stream (cons label action) 'chooser-action)
			 (pen-pprint-for-clim action nil stream)))
		   else
		   do 
		   (clim:with-output-as-presentation 
		       (stream (cons label action) 'chooser-action)
		     (pen-pprint-for-clim action nil stream)))
	       (when (kpml::digested-chooser-node-branch value)
		 (clim:with-output-as-presentation 
		     (stream (cons label 
				   (kpml::digested-chooser-node-branch value))
			     'chooser-ask-action)
		   (clim:with-drawing-options 
		       (stream :ink clim:+red+)
		     (pen-pprint-for-clim 
		      (kpml::digested-chooser-node-branch value)
		      nil stream)))))))))
      (:branch
       (let ((r (kpml::digested-chooser-branch-response value)))
	 (macrolet 
	     ((branch-writer ()
		'(clim:with-text-style (stream kpml-i::*fix--bold--8*)
		  (clim:with-text-face (stream '(:italic))
		    (clim:with-output-as-presentation
			(stream (cons label value) 'chooser-branch)
		      (format stream  "~A" r))))))
	   (if (member r *highlighted-path*)
	       (clim:with-drawing-options (stream :ink clim:+green+)
		 (branch-writer))
	     (branch-writer)))))
      )))

(defun GET-DIGESTED-CHOOSER-NODE-CHILDREN (pres)
  (let ((type (first pres))
	(current (third pres)))
    (case type
      (:node
       (if (kpml::digested-chooser-node-children current)
	   (mapcar #'(lambda (c) 
		       (list :branch 
			      (kpml::digested-chooser-branch-label c)
			      c))
		   (kpml::digested-chooser-node-children current))
	 nil))
      (:branch
       (if (kpml::digested-chooser-branch-path current)
	   (list 
	    (list :node 
		  (kpml::digested-chooser-node-label 
		   (kpml::digested-chooser-branch-path current))
		  (kpml::digested-chooser-branch-path current)))
	 nil)))))

;;; ----------------------------------------------------------------------
;;; Actions on branches...

(clim:define-presentation-action PRESENT-CHOOSER-BRANCH
    (chooser-branch nil chooser-editor-commands
		    :documentation "Edit this branch label")
  (object)
  (let* ((label (car object))
	 (value (cdr object))
	 (new-value 
	  (edit-element clim:*application-frame* 
			(kpml::digested-chooser-branch-response value)
			:expand-p nil)))
    (when new-value
      (replace-chooser-branch-at-node 
       new-value label 
       (slot-value clim:*application-frame* 'root-definition))
      (setf (slot-value clim:*application-frame* 'modified) T)
      (clim:redisplay-frame-pane 
       clim:*application-frame* 'graph :force-p nil))))

(clim:define-presentation-action DELETE-CHOOSER-BRANCH
    (chooser-branch nil chooser-editor-commands :gesture :menu
		    :documentation "Delete this branch and any descendents")
  (object)
  (let* ((label (car object)))
    (remove-chooser-branch-at-node 
     label 
     (slot-value clim:*application-frame* 'root-definition))
    (setf (slot-value clim:*application-frame* 'modified) T)
    (clim:redisplay-frame-pane clim:*application-frame* 'graph :force-p nil)))

;;; ----------------------------------------------------------------------

(clim:define-presentation-action PRESENT-CHOOSER-ACTIONS
    (chooser-actions nil chooser-editor-commands
		     :documentation "Chooser node editing menu")
  (object)
  (let ((stream (clim::frame-top-level-sheet clim:*application-frame*))
	(label object))
    (with-slots (root-definition) clim:*application-frame*
      (case
	  (menu-choose
	   `(("Add chooser action" :value :add-ch-act)
	     ("Add branch" :value :add-branch)
	     ("Add a branching inquiry" :value :add-q-inq)
	     ("Paste last deleted branching inquiry" :value :paste-q-inq)
	     ("Delete the branching inquiry" :value :delete-q-inq)
	     ("Delete subtrees" :value :delete-node)
	     ("Replace subtrees with last deleted subtrees" 
	      :value :replace-node)
	     ("Paste previously deleted action" :value :paste)
	     ("Paste previously delete subtree" :value :paste-tree)))
	(:add-ch-act
	 (add-new-chooser-action-at-node 
	  (build-chooser-action-menu stream :default nil)
	  label root-definition)
	 (setf (slot-value clim:*application-frame* 'modified) T))
	(:delete-q-inq
	 (delete-q-inquiry-at-node label root-definition))
	(:paste-q-inq
	 (add-new-branch-at-node *cut-q-inquiry* label root-definition)
	 (setf (slot-value clim:*application-frame* 'modified) T))
	(:paste
	 (add-new-chooser-action-at-node
	  *cut-chooser-action* label root-definition)
	 (setf (slot-value clim:*application-frame* 'modified) T))
	(:paste-tree
	 (add-new-subtree-at-node label root-definition)
	 (setf (slot-value clim:*application-frame* 'modified) T))
	(:delete-node
	 (delete-subtrees label root-definition))
	(:replace-node
	 (replace-subtrees label root-definition))
	(:add-branch
	 (add-new-branch-only-at-node
	  (edit-element clim:*application-frame* nil :expand-p nil)
	  label root-definition)
	 (setf (slot-value clim:*application-frame* 'modified) T))
	(:add-q-inq
	 (add-new-branch-at-node 
	  (build-ask-of-q-inquiry stream 
				  (find-defined-branch-at-node label))
	  label root-definition)
	 (setf (slot-value clim:*application-frame* 'modified) T))
	)
      (clim:redisplay-frame-pane 
       clim:*application-frame* 'graph :force-p nil))))

(clim:define-presentation-action PRESENT-CHOOSER-ACTION
    (chooser-action nil chooser-editor-commands
		    :documentation "Edit this chooser action" )
  (object)
  (let* ((stream (clim::frame-top-level-sheet clim:*application-frame*))
	 (action (cdr object))
	 (label (car object))
	 (edited-action (build-chooser-action-menu stream :default action)))
    (unless (equal edited-action action)
      (with-slots (root-definition modified) clim:*application-frame*
	(replace-chooser-action-at-node 
	 action edited-action label root-definition)
	(setf modified T))
      (clim:redisplay-frame-pane 
       clim:*application-frame* 'graph :force-p nil))))

(clim:define-presentation-action DELETE-CHOOSER-ACTION
    (chooser-action nil chooser-editor-commands 
		    :documentation "Delete this chooser action" :gesture :menu)
  (object)
  (let* ((action (cdr object))
	 (label (car object)))
    (delete-action-at-node 
     action label 
     (slot-value clim:*application-frame* 'root-definition))
    (setf (slot-value clim:*application-frame* 'modified) T)
    (clim:redisplay-frame-pane 
     clim:*application-frame* 'graph :force-p nil)))

;;; ----------------------------------------------------------------------
;;; The list of chooser actions accepted is as follows:
;;;  (defaultchoose choice-error choose copyhub identify pledge termpledge)
;;; these are defined as functions on objects/choosers.lisp. Operators
;;; found in the chooser definitions are just applied.
;;;
;;; Form of actions:
;;; 
;;;       (defaultchoose feature)
;;;       (choose feature)
;;;
;;;       (choice-error string)
;;;
;;;       (copyhub function1 function2)
;;;
;;;       (identify function (inquiry-ID args))
;;;
;;;       (pledge onus function)
;;;       (termpledge onus function)
;;;

(defun BUILD-CHOOSER-ACTION-MENU (stream &key (default nil))
  (let ((rs-op (if default (first default) 'kpml::defaultchoose))
	(op1 (if default (second default) nil))
	(op2 (if default (third default) nil)))
  (clim:accepting-values
      (stream :own-window *wide-own-window*
	      :width 400
	      :height 300
	      :scroll-bars :vertical
	      :resynchronize-every-pass t
	      :label "Chooser action maker" :exit-boxes 
	      '((:exit "Click here to accept")(:abort "Cancel")))
    (setf rs-op
      (clim:accept 
       '(clim:member-sequence 
	 (kpml::defaultchoose kpml::choice-error kpml::choose
	   kpml::copyhub kpml::identify kpml::pledge
	   kpml::termpledge))
       :stream stream
       :view #-lispworks 'clim:list-pane-view 
             #+lispworks clim:+textual-dialog-view+
       :prompt "Operator"
       :default rs-op))
    (kpml-i-terpri stream)
    (kpml-i-terpri stream)
    (case rs-op
      ((kpml::defaultchoose kpml::choose)
       (setf op1 (clim:accept 
		  'clim:symbol :stream stream
		  #+lispworks :view #+lispworks clim:+textual-dialog-view+
		  :prompt "Feature to be chosen"
		  :default op1))
       (when op1 (setf op1 (intern (string op1) "KPML"))))
      (kpml::choice-error
       (setf op1 
	 (clim:accept 
	  'clim:string :stream stream
	  #+lispworks :view #+lispworks clim:+textual-dialog-view+
	  :prompt "Choice error message"
	  :default (string op1))))
      (kpml::copyhub
       (setf op1 (clim:accept 
		  'clim:symbol :stream stream
		  #+lispworks :view #+lispworks clim:+textual-dialog-view+
		  :prompt "Function 1"
		  :default op1))
       (when op1 (setf op1 (intern (string op1) "KPML")))
       (kpml-i-terpri stream)
       (setf op2 (clim:accept 
		  'clim:symbol :stream stream
		  #+lispworks :view #+lispworks clim:+textual-dialog-view+
		  :prompt "Function 2"
		  :default (if (symbolp op2) op2 nil)))
       (when op2 (setf op2 (intern (string op2) "KPML"))))
      ((kpml::pledge kpml::termpledge)
       (setf op1 (clim:accept 
		  'clim:symbol :stream stream
		  #+lispworks :view #+lispworks clim:+textual-dialog-view+
		  :prompt "Hub"
		  :default op1))
       (when op1 (setf op1 (intern (string op1) "KPML")))
       (kpml-i-terpri stream)
       (setf op2 (clim:accept 
		  'clim:symbol :stream stream
		  #+lispworks :view #+lispworks clim:+textual-dialog-view+
		  :prompt "Function"
		  :default (if (symbolp op2) op2 nil)))
       (when op2 (setf op2 (intern (string op2) "KPML"))))
      (kpml::identify 
       (setf op1 (clim:accept 
		  'clim:symbol :stream stream
		  #+lispworks :view #+lispworks clim:+textual-dialog-view+
		  :prompt "Function"
		  :default op1))
       (when op1 (setf op1 (intern (string op1) "KPML")))
       (kpml-i-terpri stream)
       (setf op2
	 (clim:accept 'clim:expression :stream stream
		      #+lispworks :view #+lispworks clim:+textual-dialog-view+
		      :insert-default T
		      :prompt "Identify inquiry"
		      :default op2))))
    (clim:stream-set-cursor-position stream 30 210)
    (format stream "Chooser action: ~%")
    (clim:with-text-style (stream kpml-i::*sans-serif--bold--10*)
      (cond ((member rs-op 
		     '(kpml::defaultchoose kpml::choice-error kpml::choose))
	     (format stream "(~A ~A)" rs-op op1)
	     (kpml-i-terpri stream)
	     (list rs-op op1))
	    (t
	     (format stream "(~A ~A~@[~%   ~A~])" rs-op op1 op2)
	     (kpml-i-terpri stream)
	     (list rs-op op1 op2)))))))

(defun BUILD-ASK-OF-Q-INQUIRY (stream &optional (default nil))
  (let ((q-inq default))
    (clim:accepting-values
	(stream :own-window *wide-own-window*
		:width 400
		:height 200
		:scroll-bars :vertical
		:resynchronize-every-pass t
		:label "Branching inquiry input" :exit-boxes 
		'((:exit "Click here to accept")(:abort "Cancel")))
      (kpml-i-terpri stream)
      (setf q-inq
	 (clim:accept 'clim:expression :stream stream
		      #+lispworks :view #+lispworks clim:+textual-dialog-view+
		      :insert-default T
		      :prompt "Branching inquiry"
		      :default q-inq))
      (kpml-i-terpri stream)
      (kpml-i-terpri stream)
      (format stream "Asking Q-inquiry: ~%")
      (clim:with-text-style (stream kpml-i::*sans-serif--bold--10*)
	(format stream "~S" q-inq))
      (kpml-i-terpri stream))
    q-inq))

;;; ----------------------------------------------------------------------
;;; Locating chooser inquiry asks in the chooser tree as a whole...

(defun FIND-DEFINED-BRANCH-AT-NODE (label)
  (let ((digest (slot-value clim:*application-frame* 'root-definition)))
    (catch 'found
      (find-defined-branch-at-node-intern label digest))))

(defun FIND-DEFINED-BRANCH-AT-NODE-INTERN (label digest)
  (cond ((eq label (kpml::digested-chooser-node-label digest))
	 (throw 'found 
	   (kpml::digested-chooser-node-branch digest)))
	(t
	 (loop for c in (kpml::digested-chooser-node-children digest)
	     do (FIND-DEFINED-BRANCH-AT-NODE-INTERN 
		 label
		 (kpml::digested-chooser-branch-path c))))))

;;; ----------------------------------------------------------------------
;;; The functions for replacing parts of the digested chooser structure
;;; on requests from the editor frame... They are mostly all slight
;;; variations of one another.

(defun REPLACE-CHOOSER-ACTION-AT-NODE (old new label digest)
  "replace OLD by NEW at node LABEL in chooser structure DIGEST"
  (cond ((eq label (kpml::digested-chooser-node-label digest))
	 (setf (kpml::digested-chooser-node-actions digest)
	   (nsubstitute new old 
			(kpml::digested-chooser-node-actions digest)
			:test #'equal))
	 T)
	(t
	 (loop for c in (kpml::digested-chooser-node-children digest)
	     until
	       (REPLACE-CHOOSER-ACTION-AT-NODE 
		old new label (kpml::digested-chooser-branch-path c))))))


(defun ADD-NEW-CHOOSER-ACTION-AT-NODE (new label digest)
  "add NEW action at node LABEL in chooser structure DIGEST"
  (cond ((eq label (kpml::digested-chooser-node-label digest))
	 (setf (kpml::digested-chooser-node-actions digest)
	       (if (consp (kpml::digested-chooser-node-actions digest))
		   (append (kpml::digested-chooser-node-actions digest)
			   (list new))
		 (list new)))
	 T)
	(t
	 (loop for c in (kpml::digested-chooser-node-children digest)
	     until
	       (ADD-NEW-CHOOSER-ACTION-AT-NODE
		new label (kpml::digested-chooser-branch-path c))))))

(defun DELETE-Q-INQUIRY-AT-NODE (label digest)
  "Delete the branching inquiry of the  node LABEL in chooser structure DIGEST"
  (cond ((eq label (kpml::digested-chooser-node-label digest))
	 (setf *cut-q-inquiry* (kpml::digested-chooser-node-branch digest))
	 (setf (kpml::digested-chooser-node-branch digest) nil)
	 T)
	(t
	 (loop for c in (kpml::digested-chooser-node-children digest)
	     until
	       (DELETE-Q-INQUIRY-AT-NODE
		label (kpml::digested-chooser-branch-path c))))))

(defun DELETE-ACTION-AT-NODE (action label digest)
  "delete ACTION at node LABEL in chooser structure DIGEST"
  (cond ((eq label (kpml::digested-chooser-node-label digest))
	 (setf *cut-chooser-action* action)
	 (setf (kpml::digested-chooser-node-actions digest)
	   (remove action 
		   (kpml::digested-chooser-node-actions digest)
		   :test #'equal))
	 T)
	(t
	 (loop for c in (kpml::digested-chooser-node-children digest)
	     until
	       (DELETE-ACTION-AT-NODE
		action label (kpml::digested-chooser-branch-path c))))))

(defun ADD-NEW-BRANCH-AT-NODE (ask label digest)
  "add the branching ASK statement and dangling branches at LABEL in DIGEST"
  (cond ((eq label (kpml::digested-chooser-node-label digest))
	 (setf (kpml::digested-chooser-node-branch digest) ask)
	 (when (kpml::inquiry-defined-for-lg-p (first ask) kpml::curlan)
	   (let* ((answerset 
		   (kpml::fetch-inquiry-info (first ask) 'kpml::answerset))
		  (additions
		   (loop for a in answerset
		       unless (loop for b 
				  in (kpml::digested-chooser-node-children 
				      digest)
				  thereis 
				    (equal
				     a
				     (kpml::digested-chooser-branch-response
				      b)))
		       collect a)))
	     (setf (kpml::digested-chooser-node-children digest)
	       (append
		(mapcar #'(lambda (a) 
			    (kpml::make-digested-chooser-branch
			     :label (gensym)
			     :response a
			     :path (kpml::make-digested-chooser-node
				    :label (gensym))))
			additions)
		(kpml::digested-chooser-node-children digest)))))
	 T)
	(t
	 (loop for c in (kpml::digested-chooser-node-children digest)
	     until
	       (ADD-NEW-BRANCH-AT-NODE
		ask label (kpml::digested-chooser-branch-path c))))))


(defun ADD-NEW-BRANCH-ONLY-AT-NODE (branch label digest)
  "add BRANCH only at LABEL in DIGEST"
  (cond ((eq label (kpml::digested-chooser-node-label digest))
	 (setf (kpml::digested-chooser-node-children digest)
	   (cons 
	    (kpml::make-digested-chooser-branch
			     :label (gensym)
			     :response branch
			     :path (kpml::make-digested-chooser-node
				    :label (gensym)))
	    (kpml::digested-chooser-node-children digest)))
	 T)
	(t
	 (loop for c in (kpml::digested-chooser-node-children digest)
	     until
	       (ADD-NEW-BRANCH-ONLY-AT-NODE
		branch label (kpml::digested-chooser-branch-path c)))
	 nil)))


(defun DELETE-SUBTREES (label digest)
  "Delete the node at LABEL in DIGEST"
  (cond ((eq label (kpml::digested-chooser-node-label digest))
	 (setf *cut-chooser-nodes* 
	   (kpml::digested-chooser-node-children digest))
	 (setf (kpml::digested-chooser-node-children digest)
	   (list
	    (kpml::make-digested-chooser-branch
	     :label (gensym)
	     :response nil
	     :path (kpml::make-digested-chooser-node
		    :label (gensym)))))
	 T)
	(t
	 (loop for c in (kpml::digested-chooser-node-children digest)
	     until
	       (DELETE-SUBTREES
		label (kpml::digested-chooser-branch-path c)))
	 nil)))

(defun REPLACE-SUBTREES (label digest)
  "Replace the node at LABEL in DIGEST with the last deleted node"
  (cond ((eq label (kpml::digested-chooser-node-label digest))
	 (setf (kpml::digested-chooser-node-children digest)
	   *cut-chooser-nodes*)
	 T)
	(t
	 (loop for c in (kpml::digested-chooser-node-children digest)
	     until
	       (REPLACE-SUBTREES
		label (kpml::digested-chooser-branch-path c)))
	 nil)))


(defun ADD-NEW-SUBTREE-AT-NODE (label digest)
  "yank a chooser subtree at LABEL in DIGEST"
  (cond ((eq label (kpml::digested-chooser-node-label digest))
	 (setf (kpml::digested-chooser-node-children digest)
	   (cons
	    *cut-chooser-subtree*
	    (kpml::digested-chooser-node-children digest)))
	 T)
	(t
	 (loop for c in (kpml::digested-chooser-node-children digest)
	     until
	       (ADD-NEW-SUBTREE-AT-NODE
		label (kpml::digested-chooser-branch-path c)))
	 nil)))

(defun REPLACE-CHOOSER-BRANCH-AT-NODE (new label digest)
  "replace branch at node LABEL in chooser structure DIGEST with NEW"
  (loop for c in (kpml::digested-chooser-node-children digest)
      when (eq (kpml::digested-chooser-branch-label c) label)
      do (setf (kpml::digested-chooser-branch-response c) new)
	 (return-from REPLACE-CHOOSER-BRANCH-AT-NODE T))
  (loop for c in (kpml::digested-chooser-node-children digest)
      until (REPLACE-CHOOSER-BRANCH-AT-NODE
	     new label (kpml::digested-chooser-branch-path c)))
  nil)

(defun REMOVE-CHOOSER-BRANCH-AT-NODE (label digest) 
  "remove branch with node LABEL in chooser structure DIGEST"
  (loop for c in (kpml::digested-chooser-node-children digest)
      when (eq (kpml::digested-chooser-branch-label c) label)
      do (setf *cut-chooser-subtree* c)
	 (setf (kpml::digested-chooser-node-children digest)
	   (remove-if #'(lambda (c1)
			  (eq (kpml::digested-chooser-branch-label c1)
			      label))
		      (kpml::digested-chooser-node-children digest)))
	 (return-from REMOVE-CHOOSER-BRANCH-AT-NODE T))
  (loop for c in (kpml::digested-chooser-node-children digest)
      until (REMOVE-CHOOSER-BRANCH-AT-NODE
	     label (kpml::digested-chooser-branch-path c)))
  nil)
  
;;; ----------------------------------------------------------------------
;;; The checking and exporting functionality...

(defun CHECK-EDITED-CHOOSER (name digest &optional (path nil))
  (let* ((branch (kpml::digested-chooser-node-branch digest))
	 (inq (first branch))
	 (paras (rest branch))
	 (branches 
	  (mapcar #'kpml::digested-chooser-branch-response
		 (kpml::digested-chooser-node-children digest))))
    (cond ((not name)
	   (clim:notify-user
	    clim:*application-frame*
	    "No name for this chooser now defined.")
	   nil)
	  ((and branches (not branch))
	   (clim:notify-user 
	    clim:*application-frame*
	    "Chooser branches defined but no choice inquiry is present.")
	   (setf *highlighted-path* path)
	   nil)
	  ((and inq
		(not (kpml::inquiry-defined-for-lg-p inq kpml::curlan)))
	   (if (or *auto-define-undefined-inquiries* 
		   (eq (startup-user-response-frame
			`("Used inquiry " ,inq " undefined: define it now?"))
		       :yes))
	       (startup-an-inquiry-editor-frame 
		nil :id-inquiry T :answerset branches :name inq))
	   (setf *highlighted-path* path)
	   nil)
	  ((and inq
		(not 
		 (equal (length paras)
			(length 
			 (kpml::fetch-inquiry-info inq 'kpml::parameters)))))
	   (clim:notify-user 
	    clim:*application-frame*
	    (concatenate 'string 
	      "Parameters used for inquiry " (string inq) 
	      " do not match definition: "
	      (format nil "~{~A ~}" 
		      (kpml::fetch-inquiry-info inq 'kpml::parameters))))
	   (setf *highlighted-path* path)
	   nil)
	  ((and inq
		(not 
		 (kpml::set-equal 
		  branches 
		  (kpml::fetch-inquiry-info inq 'kpml::answerset))))
	   (clim:notify-user 
	    clim:*application-frame*
	    (concatenate 'string 
	      "Branches used for inquiry " (string inq) 
	      " do not match definition: "
	      (format nil "~{~A ~}" 
		      (kpml::fetch-inquiry-info inq 'kpml::answerset))))
	   (setf *highlighted-path* path)
	   nil)
	  (T 
	   (loop for c in (kpml::digested-chooser-node-children digest)
	       always (check-edited-chooser
		       name
		       (kpml::digested-chooser-branch-path c)
		       (cons (kpml::digested-chooser-branch-response c)
			     path)))))))
	      
(defun EXPORT-EDITED-CHOOSER (name digest)
  (setf *highlighted-path* nil)
  (when (check-edited-chooser name digest)
    (kpml::load-ml-chooser 
     `(:name ,(list kpml::curlan name)
	     :definition ,(kpml::undigest-chooser digest)
	     :comments ,(slot-value clim:*application-frame* 'comments)
	     :date ,(list (kpml::time-stamp))))
    (kpml::protocol-edit
     (kpml::systemic-display name
			     :object-type :chooser :stream nil))))

       


