(in-package "KPML")

;;; File: systems.lisp
;;; 
;;; Contains definition of the linguistic object: chooser.
;;; Fully multilingual.

(defstruct chooser  
  (name nil :type (or symbol list))
  (definition nil :type list)
  (comments "" :type (or string list))
  (date "" :type (or string list))
  (editor "" :type (or string list))
  (patch-status nil :type (or symbol list))    ;; added KPML 0.9
  (LS-set nil :type list) )

;;; ----------------------------------------------------------------------
;;; User access...

(defmacro chooser (&REST body)
  `(load-ml-chooser ',body))

(defun CHOOSER-DEFINED-FOR-LG-P (name lg)
  (let ((chooser-instance (gethash name choosers)))
    (and 
     chooser-instance
     (member lg (chooser-ls-set chooser-instance))
     (eq name (strip-lx (parse-clause (chooser-name chooser-instance) lg)))))) 


(defun LIST-CHOOSERS (&optional (lg nil))
  (let ((chooser-names (hashtable-to-list choosers)))
    (if lg
	(for c in chooser-names
	     when (chooser-defined-for-lg-p c lg)
	     collect c)
      chooser-names)))
		

;;; ----------------------------------------------------------------------
;;; Management functions...

;;; Following from ml-penman-chooser-class. Only the definition was 
;;; allowed to be ml-conditionalized. Changes for all slots.
;;; NOTE: this required change in the structure definition also.
;;; This has been made in the original file.
;;; 0.9 patch-status added.

(defun FETCH-CHOOSER-INFO (chsr-name fld-name &optional ls)
  (let ((x (gethash chsr-name choosers)) tmp)
    
    (unless x (return-from fetch-chooser-info nil))
    (unless ls (setq ls CurLan))
    (when (eq fld-name 'ls-set)
	  (return-from fetch-chooser-info (chooser-ls-set x)))
    (if (and ls (not (member ls (chooser-LS-set X))))
        (return-from fetch-chooser-info nil))

    (case fld-name
      ((everything instance) 
       (unless ls (return-from fetch-chooser-info X))
       (setf tmp (copy-chooser X))
       (setf (chooser-definition tmp) (parse-clause (chooser-definition X) ls)
	     (chooser-name tmp) (parse-clause (chooser-name X) ls)
	     (chooser-comments tmp) (parse-clause (chooser-comments X) ls)
	     (chooser-date tmp)(parse-clause (chooser-comments X) ls)
	     (chooser-editor tmp)(parse-clause (chooser-editor X) ls)
	     (chooser-patch-status tmp)(strip-ml (chooser-patch-status X) ls))
       tmp)
      (name                  (if ls (strip-ml (chooser-name X) ls)
			       (chooser-name X)))
      (definition            (if ls (parse-clause (chooser-definition X) ls)
			       (chooser-definition X)))
      (comments              (if ls (strip-ml (chooser-comments X) ls)
			       (chooser-comments X)))
      (date                  (if ls (strip-ml (chooser-date X) ls)
			       (chooser-date X)))
      (patch-status          (if ls (strip-ml (chooser-patch-status X) ls)
			       (chooser-patch-status X)))
      (editor                (if ls (strip-ml (chooser-editor X) ls)
			       (chooser-editor X)))
      )
))

;--------------------------------------------------------------------------------------------------
; SYNTAX: replace-chooser-info (chooser-name, field-name, new-value, &optional ls)
; RETURN: the replaced value of the specified field in the chooser; the field of the chooser record
;         is changed to new value;
; TARGET: as indicated;
; ASSUME: due to the complexity of modifying LX expression, we assume that new-value is a LX. Hence
;         ls does not play any role. We simply replace the field with the whole new-value. This func
;         will not create new chooser when the given chooser name is not found in the database;
; GLOBAL: ALL_LANGUAGES; choosers;
; SYMBOL: X = an instance from chooser DB;
; PSEUDO: if chooser-name not in choosers, then return nil else X is instantiated; 
;         according to field-name, return(replace (chooser-field-name X) with the new-value);
;--------------------------------------------------------------------------------------------------

(defun replace-chooser-info (chsr-name fld-name new-value &optional ls)
  (declare (ignore ls))
  (let ((x (gethash chsr-name choosers)))
    (unless x (return-from replace-chooser-info nil))
    (case fld-name
      ((everything instance)  (setf (gethash chsr-name choosers) new-value))
      (name       (setf (chooser-name X) new-value))
      (definition (setf (chooser-definition X) new-value))
      (comments   (setf (chooser-comments X) new-value))
      (date       (setf (chooser-date X) new-value))
      (editor     (setf (chooser-editor X) new-value))
      (patch-status (setf (chooser-patch-status X) new-value))
      (LS-set     (setf (chooser-LS-set X) new-value))
      )
))

(defsetf fetch-chooser-info (chsr-name fld-name &optional LS) (new-value) 
  `(replace-chooser-info ,chsr-name ,fld-name ,new-value ,LS) )


;;; ----------------------------------------------------------------------
;;; Loading...

(defun LOAD-ML-CHOOSER (body)
  (let ((seed-instance (apply #'make-chooser body)))

; 0.7.29 fix combination of defaults and explicit conditionalizations.
    (when (symbolp (chooser-name seed-instance))
	  (setf (chooser-name seed-instance)
		(append 
		 (cond 
		  ((and *in-ml-region* *current-default-languages*)
		   (check-language-availability *current-default-languages*)
		   *current-default-languages*)
		  (t  all_languages))
		 (cons (chooser-name seed-instance) nil))))

; 0.9 add in correct patch status... 
    (setf (chooser-patch-status seed-instance)
      (append (extract-lg-specifiers (chooser-name seed-instance))
	      (cons *patch-status* nil)))

    ;; 1.0
    (when *patch-status* (setf *patches-exist* T))

    (let ((NameLst (get-atom-ls (chooser-name seed-instance)))
	  instance)
      (for name in NameLst do
	   (setf instance 
		 (merge-new-and-old-chooser name seed-instance (cdr name)))

;   register chooser entries
	   (setf (chooser-LS-set instance) 
		 (union (cdr name) (chooser-LS-set instance)))
	   (setf (chooser-name instance) (append (chooser-LS-set instance)
						 (list (car name))))
	   (setf (gethash (car name) choosers) (copy-chooser instance)))
    )
    (setf *network-updated?* all_languages)))



;;; ----------------------------------------------------------------------
;;; Removing...

(defun DELETE-CHOOSER (chooser-name)
  (remhash chooser-name choosers))

(defun ERASE-CHOOSERS ()
  (setq chooser-db nil)
  (setq *ml-chooser-db* nil)
  (clrhash choosers))

;;; Old Penman function replaced: delete-all-choosers.

;;; ----------------------------------------------------------------------
;;; Access utilities...

;;; 0.9 made multilingual...
(defun FETCH-CHOOSER-DB-ELT (field chooser-name)
  (if (equal field 'choosername)
      chooser-name
      (cdr (assoc field (cdr (assoc chooser-name (ml-chooser-db)))))))


;;; ----------------------------------------------------------------------
;;; The chooser actions are now also defined along with the rest of
;;; the details concerning choosers...

;;;This is a chooser operator comparable to Ask and Choose. Causes a particular feature to be
;;;chosen provided that there is no preselection governing the system.  
;;;Preselection is used free. It comes from Choice-Master.

(DEFUN DefaultChoose (Choice-Feature)
  (cond
    (Preselection 
     (Choose Preselection))
    (T (Choose Choice-Feature))))


(DEFUN Choice-Error (culprit)
  (Warning "In system  -- " Message-Sender " -- a decision which should be unreachable " 
	   " has been reached.  Blame inquiries about "  CULPRIT))


;;;CHOOSE: must be augmented to deal with choice in conflict with preselection
;;;KPML:   behaviour changed when interface is up and loaded: instead of bundling
;;;        the system and choice info together in a string, these are passed
;;;        on separately. No change should occur when the interface is not present.
;;;        John: March 2, 1994.
(DEFUN Choose (Feature-Name)
  (when Current-Choice
    (Warning "Overriding previous choice of " Current-Choice " with " Feature-Name))
  (when english-trace-flag
    (if window-interface-flag
	(printwindow :system-feature-choice-pane 
		     (list message-sender Feature-Name))
	(printwindow
	  :display-pane
	  (indent-and-fill
	    (format nil "Chooser ~a chooses feature ~a." 
		    (fetch-system-chooser Message-Sender)  Feature-Name )
	    :left-margin 7))))
  (unless (member Feature-Name (fetch-output-features Message-Sender))	
    (Warning "The choice of " Feature-Name " in system " 
	     Message-Sender " is not one of the options."))
  (SETQ Current-Choice Feature-Name))



;;; ----------------------------------------------------------------------
;;; 3.1 the next function here appeared to be assuming that concatenate can coerce
;;;     its symbol arguments into strings. This is wrong, so corrected here by the
;;;     expedient of making a new function that does what was assumed to be being
;;;     done (this is probably due do a semi-automatic conversion away from using
;;;     string-append, which is also provided by, e.g., lispworks, but is not
;;;     Common Lisp).
;;; ----------------------------------------------------------------------

(DEFUN CopyHub (From-Function To-Function)
  (cond ((and from-function to-function)
;speed-patch: The two references to *associations-table* below replace
;references to the Associations list.
         (PROG ((Source   (gethash From-Function *associations-table*))
                (Was (gethash To-Function *associations-table*)))
               (cond
                 (Was (Warning 
                       (format nil  ;; 3.1 
                               "Under ~A, Copy-Hub is superseding these associations of ~S -- ~S" 
                               Message-Sender To-Function Was))))
               (RETURN
                 (cond
                   ((not source)
                    (warning 
                     (string-append
                      "Under " Message-Sender ", CopyHub cannot copy the function "
                      from-function " because it has no entry in the Function Association Table.")))
                   ((and (not (function-association-concept source))
                         (not (function-association-presentation-spec source))
                         (not (function-association-term-set source))
                         (not (function-association-term source)))
                    (warning 
                     (string-append
                      "Under " Message-Sender ", CopyHub is copying an empty grammatical function " 
                      from-function)))
                   (T (let ((temp (Copy-Function-Association Source)))
                        (setf (function-association-function temp) to-function)
                        (push temp associations)
;speed-patch:  The (setf ...) below supercedes the above (push ...)
;instruction; the latter can probably be removed.
			(setf (gethash to-function *associations-table*)
				temp))
                      (cond
                        (Display-Association-Flag
                         (printwindow
                           :display-pane
                           (indent-and-fill
                             (format nil "In ~a -- Copy-hub: ~a --> ~a" Message-Sender From-Function to-function)))
                         (print-fat)))
                      To-Function)))))
        (t
         (unless from-function
           (warning (string-append
                                 "Under " Message-Sender ", CopyHub cannot copy from NIL function.")))
         (unless to-function
           (warning 
            (string-append
             "Under " Message-Sender ", CopyHub cannot copy to a NIL function.")))
         )))

;;; 0.9 (very) selective inquiry tracing added...

(defun IDENTIFY (target-function grammar-inquiry)
  (let ((op-name (car grammar-inquiry))
	Identification Outer-Inquiry)
    (SETQ Outer-Inquiry 
	  (Cons Op-Name (Inquiry-Associations-Getter Grammar-Inquiry)))
    (PushNew Op-Name Used-Inquiry-Operators)

    (when (or English-Trace-Flag
	      (and (not (eq *cumulate-chooser-activity* :traced))
		   (member op-name *traced-inquiries*)))
      (Print-inquiry-to-window Grammar-Inquiry Outer-Inquiry))
    (when (or (eq *cumulate-chooser-activity* :all)
	      (and (eq *cumulate-chooser-activity* :traced)
		   (trace-inquiry-p op-name)))
      (record-inquiry-to-history grammar-inquiry outer-inquiry))

    (let ((case-var (Or (fetch-inquiry-info (CAR Outer-Inquiry) 'mode)
			Default-Inquiry-Mode)))  
      (SETQ Identification 
	    (Case Case-Var
		  (MANUAL (Identify-Manual Outer-Inquiry)) 
		  ;;;had target-function as parameter
		  (deimplemented (Inquire-Environment Outer-Inquiry T))
		  (IMPLEMENTED (Inquire-Implementation Outer-Inquiry T))
		  (RANDOM (identify-random Outer-Inquiry ))
		  (default (identify-default outer-inquiry))
		  (otherwise 
		   (Warning "Unrecognized operator mode in Identifying. " 
			    case-var)))))

    (when (or English-Trace-Flag
	      (and (not (eq *cumulate-chooser-activity* :traced))
		   (member op-name *traced-inquiries*)))
      (Print-Response Identification Op-Name))
    (when (or (eq *cumulate-chooser-activity* :all)
	      (and (eq *cumulate-chooser-activity* :traced)
		   (trace-inquiry-p op-name)))
      (record-inquiry-response-to-history Identification Op-Name))

    (when (member op-name *inquiries-to-pause-upon*)
      (askwindow :any-key-to-continue 
		 `(,(format nil "Pausing at ~a" Op-Name) 
		   "Hit any key to continue.")))
    (funcall 'Associate
	     Target-Function Identification 
	     (fetch-inquiry-info Op-Name 'createdassociationtype)
	     op-name)            ;; 1.1 added for better diagnostics...
    (return-from IDENTIFY identification)))

(DEFUN Identify-Manual (Grammar-Inquiry) ;;;had target-function as parameter
  (let ((ans nil)
	(old-flag  Manual-Response-Mode-Flag))
    (SETQ Manual-Response-Mode-Flag T)
    (SETQ ANS (Inquire-Environment Grammar-Inquiry T))
    (SETQ Manual-Response-Mode-Flag OLD-FLAG)
    ans))

(defun identifyoperator-1 (body)
    (let* ((instance (apply #'make-inquiry-operator body))
	   (name (inquiry-operator-name instance)))
      (SETF (inquiry-operator-preselectionguidance instance)
		       (for Element in (inquiry-operator-preselectionguidance instance) collect 
			    (Let ((Guide (make-preselection-guide)))
				  (SETF (preselection-guide-selection guide) (car element))
				  (SETF (preselection-guide-answer guide) (cdr element))
			       guide)))
      (setf (gethash name quiry-operators) instance)
      (pushnew name inquiry-operators)
      name))

(DEFUN Pledge (Presentation-Extract Target)
  (when Show-Pledges-Flag
    (printwindow
      :display-pane
      (indent-and-fill
	(format nil "System ~a pledges to express ~a ( ~a ) toward expression of ~a ( ~a ). "
		Message-Sender Presentation-Extract (Find-Association Presentation-Extract 'Term)
		Target (Find-Association Target 'Presentation-Spec))
	:left-margin 7)))
  (Push (LIST Message-Sender Presentation-Extract Target) Pledges))

(DEFUN TermPledge (Presentation-Extract Target)
  (when Show-Pledges-Flag
    (printwindow
      :display-pane
      (indent-and-fill
	(format nil "System ~a pledges to express ~a (~a) toward expression of ~a (~a)."
		Message-Sender Presentation-Extract (Find-Association Presentation-Extract 'Term)
		Target (Find-Association Target 'Presentation-Spec))
	:left-margin 7)))
  (Push (LIST Message-Sender Presentation-Extract Target) Pledges))

;;; there is a warning given whenever term-resolve-id is called more than once
;;; on a single function and the result is associated with a grammatical function.
;;; This is now restricted so that an error occurs only if a *new* association
;;; occurs, if we just try to make the same association twice, then this is
;;; now not signalled as a warning.


;;; 1.1 Place where associate called for added for better diagnostics.

(DEFUN Associate (Function-Name Hub-Name Field &optional (locus nil))
  "creates associations between grammatical functions and hubs. Warns if there was already one which is different from the new."
  (PROG (Association-Hub-Name)
	(cond
	 ((And (not (equal Field 'Termset))
	       (not (equal function-name 'where-am-i))
	       (SETQ Association-Hub-Name 
		     (Find-Association Function-Name Field))
	       (not (equal Association-Hub-Name Hub-Name)))
	  (Warning 
	   "The existing association of " Field 
	   " of function " Function-Name " with " 
	   Association-Hub-Name " is being superseded by " Hub-Name 
	   " under " Message-Sender))))
  (PROG1 (Put-Association Function-Name Hub-Name Field Locus) ;; 1.1
	 (when English-trace-flag ;previously was display-associations-flag
	   (if window-interface-flag
	       (printwindow 
		:function-association-table-pane
		(list 
		 (format  nil "Function:          ~a" 
			  (find-association function-name 'function))
		 (format nil "Concept:           ~a" 
			 (find-association function-name 'concept))
		 (format nil "Presentation Spec: ~a" 
			 (find-association function-name 'presentation-spec))
		 (format nil "Term Set:          ~a" 
			 (find-association function-name 'termset))
		 (format nil "Term:              ~a" 
			 (find-association function-name 'term))))
	     (printwindow 
	      :display-pane
	      (indent-and-fill
	       (format nil "System ~a associates hub ~a with ~a as ~a"
		       Message-sender
		       (cond ((or (not (equal field 'termset))
				  (nigel-nlistp hub-name)
				  (< (length hub-name)
				     term-set-print-limit))
			      hub-name)
			     (t
			      (format nil " a list of ~a terms " 
				      (length hub-name))))
		       function-name
		       field ) :left-margin 7))))))

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

(defun MERGE-NEW-AND-OLD-CHOOSER 
  (name-para new-instance new-languages)
  (setf (chooser-ls-set new-instance) new-languages)
  (when *show-loading-actions*
	(format t "~%Loading chooser:  ~A" name-para))
  (cond ((and *merging-active*
	      (gethash (first name-para) choosers))
	 (let* ((name (first name-para))
		(old-instance (gethash name choosers))
		(old-languages (remove name (chooser-name old-instance)))
		(merged-instance nil)
		(old-lg-instance-pairs 
		 (create-set-of-mono-lingual-instances name :chooser))
		(new-lg-instance-pairs
		 (create-set-of-mono-lingual-instances new-instance :chooser)))

	   (when *show-loading-actions*
		 (format t "~%...merging; old languages: ~A; new languages: ~A" 
			 old-languages new-languages))

	   (cond ((equal new-languages old-languages)
		  (when (member :choosers *show-merging-actions*)
			(format t "~%Chooser ~A multiply defined, new definition wins."
				name))
		  new-instance)
		 ((intersection new-languages old-languages)
		  (when (member :choosers *show-merging-actions*)
			(format t "~%Merging for chooser ~A: shared languages" name))
		  (merge-overlapping-chooser-instances
		   name old-lg-instance-pairs new-lg-instance-pairs))

		 (t
		  (when (member :choosers *show-merging-actions*)
			(format t 
				"~%Merging for chooser ~A: disjunctive languages" name))
		  (delete-chooser name)
;;; Following necessary just because of the double use of * as
;;; comment in both systems and choosers! And to avoid application
;;; of strip-lx to definition fields of choosers!
		  (setf *chooser-merging-mode* t)
		  (setf merged-instance 
			(apply #'merge-chooser-instances 
			       (list
				(append old-lg-instance-pairs 
				        new-lg-instance-pairs))))
		  (setf *chooser-merging-mode* nil)

		  (when (and *step-by-step-merging-behavior*
			     (member :choosers *show-merging-actions*))
			(format t 
				"~%***Merged: old instance: ~%     ~A~%~
  ***new instance: ~A~%  ***and merged:~A~%" old-instance new-instance merged-instance))
		  merged-instance))))
	(t
	 (let* ((chooser-name (first name-para))
		(old-instance (gethash chooser-name choosers)))
	   (when old-instance
		 (unless (subsetp (chooser-ls-set old-instance) 
				  (cdr name-para))
			 (warning "Previously existing chooser: " 
				  chooser-name
				  " is being overwritten by a definition with narrower language coverage: " (cdr name-para) " instead of " 
				  (chooser-ls-set old-instance) "."))
		 (delete-chooser chooser-name)))
	 (return-from merge-new-and-old-chooser new-instance))))


;;; See definition for systems and object merging...

(defun MERGE-OVERLAPPING-CHOOSER-INSTANCES
  (name old-lg-instance-pairs new-lg-instance-pairs)
  
  (let ((merged-instance nil))
    (delete-chooser name)
    (setf *chooser-merging-mode* t)
    (setf merged-instance 
	  (apply #'merge-chooser-instances 
		 (list (replace-keyed-elements
			old-lg-instance-pairs 
			new-lg-instance-pairs))))
    (setf *chooser-merging-mode* nil)
    
    (when (and *step-by-step-merging-behavior*
	       (member :choosers *show-merging-actions*))
	  (format t 
		  "~%***Merged: old language instance pairs: ~%     ~S~%~
  ***new language instance pairs: ~S~%  ***and merged instance:~A~%" old-lg-instance-pairs new-lg-instance-pairs merged-instance))
    merged-instance))



(defun MERGE-CHOOSER-INSTANCES (list-of-lg-instance-pairs)
  (let ((instance   (generalized-merge-instance
		     list-of-lg-instance-pairs
		     '(chooser-name chooser-definition
		       chooser-comments
		       chooser-date chooser-editor
		       chooser-patch-status chooser-ls-set)
		     #'make-chooser)))
    (setf (chooser-ls-set instance)
	  (mapcar #'first list-of-lg-instance-pairs))

;;;------------------------------------------------------------------
;;; Following hopefully avoided by refraining from strip-lx when
;;; we are merging choosers!
;;; following ugliness is necessary because of chooser 
;;; definitions and ml-expressions
;;; competing for the use of embeddings!
;    (unless (consp (first (chooser-definition instance)))
;	    (setf (chooser-definition instance) 
;		  (list (chooser-definition instance))))
;;;------------------------------------------------------------------
    instance))

;;; ----------------------------------------------------------------------
;;; List conversions...

(defun CHOOSER-TO-LIST-MULTI-TO-MONO (chooser &optional (language-variety curlan))
  (cond ((chooser-defined-for-lg-p chooser language-variety)
	 `(chooser
	  :name ,chooser 
	  :definition ,(fetch-chooser-info chooser 'definition language-variety)
	  :comments ,(fetch-chooser-info chooser 'comments language-variety)
	  :editor ,(fetch-chooser-info chooser 'editor language-variety)
	  :patch-status ,(fetch-chooser-info chooser 'patch-status
					     language-variety)
	  :date ,(fetch-chooser-info chooser 'date language-variety)
	  ))
	(t nil)))

(defun CHOOSER-TO-LIST-MULTI-TO-MULTI (chooser-name)
  (let ((chooser (gethash chooser-name choosers)))
    `(chooser
     :name ,(chooser-name chooser)
     :definition ,(chooser-definition chooser)
     :comments ,(chooser-comments chooser)
     :editor ,(chooser-editor chooser)
     :patch-status ,(chooser-patch-status chooser)
     :date ,(chooser-date chooser)
     )))

(defun CHOOSER-INSTANCE-TO-LIST-MULTI-TO-MULTI (chooser)
  `(chooser
    :name ,(chooser-name chooser)
    :definition ,(chooser-definition chooser)
    :comments ,(chooser-comments chooser)
    :editor ,(chooser-editor chooser)
    :patch-status ,(chooser-patch-status chooser)
    :date ,(chooser-date chooser)
    ))


(defun CHOOSER-INSTANCE-TO-LIST-MULTI-TO-MONO 
  (instance &optional (language-variety curlan))
  `(chooser
    :name ,(strip-lx (parse-clause (chooser-name instance) language-variety))
;;; Note: never do a strip-lx on a chooser definition!
    :definition ,(parse-clause (chooser-definition instance) language-variety)
    :editor ,(strip-lx (parse-clause (chooser-editor instance) language-variety))
    :comments ,(strip-lx (parse-clause (chooser-comments instance) language-variety))
    :patch-status ,(strip-lx 
		    (parse-clause 
		     (chooser-patch-status instance) language-variety))
    :date ,(strip-lx (parse-clause (chooser-date instance) language-variety))
    ))

;;; ----------------------------------------------------------------------
;;; The following takes the chooser digestion stuff originally
;;; developed for the grammar extraction tool and 
;;; makes it more generally available since it is now of more use
;;; than just for the GREX tool.
;;; 1.1 labels added for every node for easier manipulation.

(defstruct digested-chooser-node
  (label nil :type symbol)
  (actions nil)
  (branch nil)
  (children nil)
  (choice nil))

(defstruct digested-chooser-branch
  (label nil :type symbol)
  (response nil)
  (covers nil)
  (path nil))

;;; ----------------------------------------------------------------------
;;; Following digests the chooser into a more explicitly annotated recursive
;;; structure where each branching node also contains information 
;;; concerning the features that are selected below it. This enables us
;;; to simply prune according to desired target features during a
;;; subsequent recursive descent.


(defun DIGEST-CHOOSER (chnode)
  (let ((covers nil))
    (loop for action in chnode
	when (or (equal (car action) 'choose)
		 (equal (car action) 'defaultchoose))
	collect (second action) into choices
	when (equal (car action) '*)
	do (progn nil) ;;  nothing (the progn is for LispWorks)
	else
	unless (equal (car action) 'ask)
	collect action into actions
	else
	do 
	(let ((children (loop for branch in (cddr action)
			    collect
			      (multiple-value-bind (digested subchoices)
				  (DIGEST-CHOOSER (cdr branch))
				(setf covers (union covers subchoices))
				(make-digested-chooser-branch
				 :label (gensym)
				 :covers subchoices
				 :response (first branch)
				 :path digested)))))
	  (return-from DIGEST-CHOOSER
	    (values
	     (make-digested-chooser-node
	      :label (gensym)
	      :actions actions
	      :choice choices
	      :branch (second action)
	      :children children)
	     covers)))
	finally
	  (return-from DIGEST-CHOOSER
	    (values
	     (make-digested-chooser-node
	      :label (gensym)
	      :actions actions
	      :choice choices
	      :children nil)
	     choices)))))


;;; And the inverse of the digestion function...

(defun UNDIGEST-CHOOSER (digest)
  `( ,@(digested-chooser-node-actions digest)
       ,@(if (digested-chooser-node-branch digest)
	     (list
	      `(ask 
		,(digested-chooser-node-branch digest)
		,@(mapcar #'(lambda (c) 
			      (cons (digested-chooser-branch-response c)
				    (UNDIGEST-CHOOSER
				     (digested-chooser-branch-path c))))
			  (digested-chooser-node-children digest))))
	   nil)))
  


