;;; Copyright (c) 1998--2018
;;;   John Carroll, Ann Copestake, Robert Malouf, Stephan Oepen;
;;;   see `LICENSE' for conditions.

;;;
;;; Tools to help build a treebank
;;;

;;;
;;; ToDO
;;;
;;; - at least one-level of `Undo';
;;; - Shift and Ctrl accelerators on `Next' et al.;
;;; - define equivalence classes of discriminants (possibly based on equality
;;;   of in and out sets), so that `yes' selections can propagate;
;;; - group equivalent discriminators somehow;
;;; - add info bar: show numbers of in and out trees per discriminant
;;; - bug fix: identify multiple applications of unary rule at same position;
;;; - investigate lack of edge for leafs in tree in interactive mode;
;;;

(in-package :lkb)

(def-lkb-parameter *tree-comparison-threshold* 10000)

(def-lkb-parameter *tree-display-threshold* 20)

(def-lkb-parameter *tree-display-view* :classic)

(def-lkb-parameter *tree-display-trees-width* 530)

(def-lkb-parameter *tree-display-discriminants-width* 430)

(def-lkb-parameter *tree-display-height* 630)

;;;
;;; a switch to control auto-advance in update mode: set to non-nil to enable
;;; auto-save in updates; set to a (positive) number to cause that many seconds
;;; delay before the auto-save and only auto-save (and -advance) on unambiguous
;;; items (i.e. where the recorded decisions completely disambiguate the new
;;; parses).
;;;
(def-lkb-parameter *tree-automatic-update-p* nil)

(def-lkb-parameter *tree-skeptical-update-p* nil)

(def-lkb-parameter *tree-update-match-hook* nil)

(def-lkb-parameter *tree-save-on-reject-p* t)

(def-lkb-parameter *tree-display-semantics-p* t)

(defparameter *tree-initialization-hook* nil)

(defparameter *tree-completion-hook* nil)

#+:debug
(defvar %frame%)
#+:debug
(defvar %frame)

;;
;; _fix_me_ i am curious: why should the defstruct() be wrapped?
;;
(eval-when (:load-toplevel :compile-toplevel :execute)
  (defstruct ctree 
    edge
    id
    score
    flags
    symbol
    record
    ink))

(eval-when (:load-toplevel :compile-toplevel :execute)
  (clim:define-presentation-type ctree ()))

(defun compare-parses (&optional (edges *parse-record*)
                       &key input mode view)

  ;; JAC 6-Jan-2022 - removed now-obsolete code intended to fix up .from.
  ;; and .to. in each edge
  ;;
  (when edges 
    (mp:run-function "Tree Comparison"
     #'(lambda ()
         (let ((*tree-discriminants-mode* 
                (or mode *tree-discriminants-mode*))
               (*tree-display-view*
                (or view *tree-display-view*)))
           (compare edges :input input))))))

(defun compare (edges &key (runp t) input)
                           
  (let* ((title
           (or input
             (format nil "Compare \"~a\""
               (shortened-sentence-string (edge-leaves (first edges)) 128))))
         (frame
           (apply #'clim:make-application-frame 'compare-frame
             :pretty-name title (unless runp (list :frame-manager nil)))))
    #+:debug
    (setf %frame% frame)
    (setf (compare-frame-chart frame) *chart-generation-counter*)
    (setf (compare-frame-runp frame) runp)
    (set-up-compare-frame frame edges :input input)
    (when runp
      (funcall #'clim:run-frame-top-level frame))
    frame))

(defun run-compare-frame (frame)
  (clim:run-frame-top-level frame))

(defun set-up-compare-frame (frame edges 
                             &key (runp (compare-frame-runp frame)) 
                                  input
                                  (display (let ((foo (getenv "DISPLAY")))
                                             (and (stringp foo) 
                                                  (not (string= foo "")) 
                                                  foo))))

  (setf (compare-frame-runp frame) runp)
  ;;
  ;; when called in error analysis mode, i.e. against the scoring results of
  ;; some stochastic parse selection model, throw out all edges that are not 
  ;; part of the set of trees for closer inspection.
  ;;
  (when (compare-frame-inspect frame)
    (setf (compare-frame-display frame) :inspect)
    (loop
        with result = nil
        with inspect = (compare-frame-inspect frame)
        with all = (append (first inspect) 
                           (list (second inspect)) 
                           (third inspect))
        for edge in edges
        for id = (edge-foo edge)
        for score = (find id all :key #'(lambda (foo)
                                          (rest (assoc :result-id foo))))
        when score do 
          (setf (edge-score edge) (rest (assoc :score score)))
          (push edge result)
        finally
          (setf edges (nreverse result))))

  ;;
  ;; large sets of edges can take some time (and memory :-{) to display; query
  ;; for user confirmation before moving on.
  ;;
  (when (and runp display
             (integerp *tree-comparison-threshold*)
             (> (length edges) *tree-comparison-threshold*)
             (or *tree-automatic-update-p*
                 ;; avoid implementation-dependent notify-user ... :style :question
                 (null (lkb-y-or-n-p
                        (format 
                         nil 
                         "Excessive Set of Trees (~a).  Continue?"
                         (length edges))))))
    (frame-cursor frame :horizontal-scroll)
    (record-decision (make-decision :type :skip) frame)
    (return-from set-up-compare-frame :skip))

  (when (and runp display) (frame-cursor frame :vertical-scroll))
  ;;
  ;; _fix_me_
  ;; probably, we should move this further down, until after extraction of
  ;; discriminants, so that start-up time is not reflected.
  ;;                                                           (6-jun-04; oe)
  ;;
  (setf (compare-frame-decisions frame) (list (make-decision :type :start)))
  (when (null (compare-frame-input frame))
    (setf (compare-frame-input frame) 
      (or input (format nil "~{~a~^ ~}" (edge-leaves (first edges))))))

  ;;
  ;; wrap each edge into a `ctree' structure, so that we can record additional
  ;; information (associated parse tree symbol, CLIM output record, et al.).
  ;;
  (setf (compare-frame-trees frame)
    (loop
        with inspect = (compare-frame-inspect frame)
        with gold = (rest (assoc :result-id (second inspect)))
        for i from 0
        for edge in edges
        for id = (if (numberp (edge-foo edge))
                   (edge-foo edge)
                   i)
        for score = (edge-score edge)
        for symbol = (when (and *tree-use-node-labels-p*
                                (eq (compare-frame-view frame) :classic))
                       (make-new-parse-tree edge))
        for flags = (when (and gold (= id gold)) (list :gold))
        for tree = (make-ctree :edge edge :id id 
                               :score score :flags flags :symbol symbol)
        collect tree
        when (and runp *tree-use-node-labels-p* (zerop (mod i 50))) do
          #+:allegro
          (format
           excl:*initial-terminal-io*
           "~&[~a] set-up-compare-frame(): expanding tree # ~a~%"
           (current-time :long :short) i)
          #-:allegro
          (identity nil) ; ccl complains if 'do' body is empty
        finally
          #+:allegro
          (when (and runp *tree-use-node-labels-p*)
            (format
             excl:*initial-terminal-io*
             "~&[~a] set-up-compare-frame(): rebuilt ~a tree~p.~%"
             (current-time :long :short) (length edges) (length edges)))
          #-:allegro
          (identity nil)))
  ;;
  ;; keep copy of original set of trees; needed for full resets
  ;;
  (setf (compare-frame-otrees frame) (copy-list (compare-frame-trees frame)))

  ;;
  ;; extract (minimal) set of elementary properties to discriminate analyses
  ;;
  (unless (compare-frame-exact frame)
    ;;
    ;; _fix_me_
    ;; there are different usages of the 'exact' mode, including picking out
    ;; derivations among realization results that can be aligned (in various
    ;; interpretations of that term) with the 'gold' parse that provided the
    ;; input semantics for generation.  i dimly recall that discriminants in
    ;; that setup ended up ill-defined (presumably because one and the same
    ;; edge can occur in different surface positions), hence we disabled the
    ;; extraction of discriminants below.  in another 'exact' use case, viz.
    ;; finding matching lexical sub-trees in a lexical-only profile, it would
    ;; seem possible to extract discriminants, which would then have their
    ;; values determined by an update-discriminants() call below.  however, we
    ;; would need another flag or something, to communicate whether or not the
    ;; compare frame would actually extract discriminants.  so far, at least,
    ;; there is no practical benefit to having available discriminants for the
    ;; above use cases, however.                              (12-aug-11; oe)
    ;;
    (setf (compare-frame-discriminants frame)
      (find-discriminants
       edges
       :mode (compare-frame-mode frame)
       :tags (compare-frame-tags frame)))
    #+:allegro
    (when runp
      (format
       excl:*initial-terminal-io*
       "~&[~a] set-up-compare-frame(): found ~a discriminant~p.~%"
       (current-time :long :short)
       (length (compare-frame-discriminants frame)) 
       (length (compare-frame-discriminants frame)))))

  ;;
  ;; preset discriminants from recorded decisions or gold decisions (during an
  ;; update); record `gold' discriminants that are no longer pertinent.
  ;;
  (unless (compare-frame-exact frame)
    (setf (compare-frame-lead frame)
      (preset-discriminants 
       (compare-frame-discriminants frame) 
       (compare-frame-preset frame)
       (compare-frame-gold frame)
       (compute-discriminant-skew edges))))

  #+:allegro
  (when runp
    (loop
        initially
          (format
           excl:*initial-terminal-io*
           "~&~%[~@[~a~]] `~a'~%~%"
           (compare-frame-item frame) (compare-frame-input frame))
        for foo in (compare-frame-lead frame)
        do
          (format
           excl:*initial-terminal-io*
           "  [~2,'0d ~2,'0d] ~a ~a | ~a~@[ `~a'~]~%"
           (discriminant-start foo) (discriminant-end foo)
           (discriminant-state-as-string foo)
           (discriminant-toggle-as-string foo)
           (discriminant-key foo) (discriminant-value foo))
        finally (when (compare-frame-lead frame)
                  (format excl:*initial-terminal-io* "~%"))))

  (setf (compare-frame-edges frame) edges)
  (unless (compare-frame-exact frame)
    (recompute-in-and-out frame t))

  ;;
  ;; when running in `exact match' update mode, adjust discriminants and most
  ;; everything else to zoom in on the matching derivation, if any
  ;;
  (when (compare-frame-exact frame)
    (setf (compare-frame-lead frame) nil)
    (when (compare-frame-discriminants frame)
      (update-discriminants 
       (compare-frame-discriminants frame)
       (compare-frame-exact frame) t)
      #+:null
      (recompute-in-and-out frame))
    (setf (compare-frame-in frame) nil)
    (setf (compare-frame-out frame) nil)

    (loop
        for edge in (compare-frame-edges frame)
        when (member edge (compare-frame-exact frame))
        do (push edge (compare-frame-in frame))
        else do (push edge (compare-frame-out frame))))

  (when *tree-initialization-hook*
    (let* ((hook *tree-initialization-hook*)
           (extras (and (consp hook) (rest hook)))
           (hook (if (consp hook) (first hook) hook))
           (hook (typecase hook
                   (function hook)
                   (symbol (and (fboundp hook) (symbol-function hook)))
                   (string (ignore-errors 
                            (symbol-function (read-from-string hook)))))))
      (multiple-value-bind (result condition) 
          (when (functionp hook)
            (ignore-errors (apply hook (cons frame extras))))
        (cond
         ((= (length result) (length (compare-frame-discriminants frame)))
          (loop
              for discriminant in (compare-frame-discriminants frame)
              for state in result
              unless (eq state :unknown) do
                (setf (discriminant-toggle discriminant) state)
                (setf (discriminant-state discriminant) state)
              finally (recompute-in-and-out frame)))
         ((null result))
         (t
          (format
           #+:allegro excl:*initial-terminal-io* #-:allegro *initial-terminal-io*
           "tree-initialization-hook(): ~
            discriminant count mismatch (~a vs. ~a).~%"
           (length result) (length (compare-frame-discriminants frame)))))
        (when condition
          (clim:beep)
          (format
           #+:allegro excl:*initial-terminal-io* #-:allegro *initial-terminal-io*
           "tree-initialization-hook(): error `~a'.~%"
           (normalize-string (format nil "~a" condition)))))))

  ;;
  ;; extract some quantitative summary measures on update procedure; entirely
  ;; for record keeping purposes.
  ;;
  (when (and runp (compare-frame-update frame))
    (push (cons :u-matches
                (loop
                    for foo in (compare-frame-discriminants frame)
                    count (discriminant-gold foo)))
          (compare-frame-update frame))
    (push (cons :u-mismatches (length (compare-frame-lead frame)))
          (compare-frame-update frame))
    (push (cons :u-pin (length (compare-frame-in frame)))
          (compare-frame-update frame))
    (push (cons :u-pout (length (compare-frame-out frame))) 
          (compare-frame-update frame)))

  ;;
  ;; in case the preferred tree was selected directly from the tree display,
  ;; we may not have recorded active decisions, i.e. the choice was reflected
  ;; in entailed discriminant states only.
  ;;
  (when (find :select (compare-frame-preset frame) :key #'discriminant-type)
    (loop
        for discriminant in (compare-frame-discriminants frame)
        for preset = (discriminant-preset discriminant)
        when preset do
          (setf (discriminant-state discriminant) 
            (discriminant-state preset)))
    (recompute-in-and-out frame))
  (when (find :reject (compare-frame-preset frame) :key #'discriminant-type)
    (setf (compare-frame-in frame) nil)
    (setf (compare-frame-out frame) edges))

  (when (and runp *tree-skeptical-update-p*)
    (let ((gactive (compare-frame-gactive frame)))
      (when (and (numberp gactive) (zerop gactive))
        (setf (compare-frame-in frame) nil)
        (setf (compare-frame-out frame) (compare-frame-edges frame)))))

  ;;
  ;; always update tree and discriminant state here: this will cause the frame
  ;; to redraw both lower panes.
  ;; 
  (when (and runp display)
    #+:mcclim (when (clim:frame-panes frame) (clim:redisplay-frame-panes frame :force-p t))
    #-:mcclim (clim:redisplay-frame-pane frame 'top :force-p t)
    #-:mcclim (clim:redisplay-frame-pane frame 'comment :force-p t)
    #-:mcclim (clim:redisplay-frame-pane frame 'status :force-p t))
  (when display (update-trees frame))

  ;;
  ;; _fix_me_
  ;; need to disable input from frame for this to work reliably. 
  ;;                                                         (14-oct-02 ; oe)
  (when (and runp *tree-automatic-update-p*)
    (when (numberp *tree-automatic-update-p*)
      (sleep *tree-automatic-update-p*))
    (record-decision 
     (make-decision :type (if (update-match-p frame) :save :flag))
     frame)
    (return-from set-up-compare-frame :skip))

  (setf (compare-frame-gactive frame) nil)
  (when (and runp display) (frame-cursor frame :default)))

(defun reset-or-reconsider-compare-frame (frame &optional mode)

  #+:debug
  (setf %frame frame)
  (setf (compare-frame-trees frame) (compare-frame-otrees frame))
  (setf (compare-frame-in frame) (compare-frame-edges frame))
  (setf (compare-frame-out frame) nil)
  (loop
      for foo in (compare-frame-discriminants frame)
      do
        (setf (discriminant-time foo) (get-universal-time))
        (setf (discriminant-gold foo) nil)
        (setf (discriminant-preset foo) nil)
        (setf (discriminant-state foo) :unknown)
        (setf (discriminant-toggle foo) :unknown))

  ;;
  ;; preset discriminants from recorded decisions or gold decisions (during an
  ;; update); record `gold' discriminants that are no longer pertinent.
  ;;
  (unless (compare-frame-exact frame)
    (setf (compare-frame-lead frame)
      (preset-discriminants 
       (compare-frame-discriminants frame) 
       (compare-frame-preset frame)
       (compare-frame-gold frame)
       (compute-discriminant-skew (compare-frame-edges frame))
       nil)))

  (unless (compare-frame-exact frame)
    (recompute-in-and-out frame t))

  (unless (eq mode :reconsider)  
    (when (find :reject (compare-frame-preset frame) :key #'discriminant-type)
      (setf (compare-frame-in frame) nil)
      (setf (compare-frame-out frame) (compare-frame-edges frame))))

  ;;
  ;; always update tree and discriminant state here: this will cause the frame
  ;; to redraw both lower panes.
  ;; 
  #+:mcclim (when (clim:frame-panes frame) (clim:redisplay-frame-panes frame :force-p t))
  #-:mcclim (clim:redisplay-frame-pane frame 'top :force-p t)
  #-:mcclim (clim:redisplay-frame-pane frame 'comment :force-p t)
  #-:mcclim (clim:redisplay-frame-pane frame 'status :force-p t)
  (update-trees frame))

(defstruct decision
  type
  value
  (time (get-universal-time)))

(defun record-decision (decision &optional frame)
  (if frame
    (let ((value (decision-value decision)))
      (when (discriminant-p value) 
        (setf (discriminant-time value) (decision-time decision)))
      (push decision (compare-frame-decisions frame)))
    (clim:with-application-frame (frame)
      (record-decision decision frame))))
  
(defun comparison-top-font ()
  (clim:make-text-style :sans-serif :roman 12))

(defun comparison-tree-font ()
  (clim:make-text-style :sans-serif :roman (or *comparison-tree-font-size* 8)))

(defun comparison-dependencies-font ()
  (clim:make-text-style :sans-serif :roman (or *comparison-dependencies-font-size* 12)))

(defun comparison-comment-font ()
  (clim:make-text-style :sans-serif :roman (or *comparison-discriminant-font-size* 8)))

(defun comparison-status-font ()
  (clim:make-text-style :sans-serif :roman (or *comparison-discriminant-font-size* 8)))

(defun comparison-discriminant-font ()
  (clim:make-text-style :sans-serif :roman (or *comparison-discriminant-font-size* 8)))

(declaim (notinline comparison-top-font comparison-tree-font comparison-dependencies-font
    comparison-comment-font comparison-status-font comparison-discriminant-font))

(clim:define-application-frame compare-frame ()
  ((runp :initform 0 :accessor compare-frame-runp)
   (item :initform nil :accessor compare-frame-item)
   (input :initform nil :accessor compare-frame-input)
   (tags :initform nil :accessor compare-frame-tags)
   (start :initform nil :accessor compare-frame-start)
   (end :initform nil :accessor compare-frame-end)
   (edges :initform nil :accessor compare-frame-edges)
   (derivations :initform nil :accessor compare-frame-derivations)
   (trees :initform nil :accessor compare-frame-trees)
   (otrees :initform nil :accessor compare-frame-otrees)
   (preset :initform nil :accessor compare-frame-preset)
   (exact :initform nil :accessor compare-frame-exact)
   (gold :initform nil :accessor compare-frame-gold)
   (lead :initform nil :accessor compare-frame-lead)
   (mode :initform *tree-discriminants-mode* :accessor compare-frame-mode)
   (view :initform *tree-display-view* :accessor compare-frame-view)
   (show :initform *tree-results-show* :accessor compare-frame-show)
   (discriminants :initform nil :accessor compare-frame-discriminants)
   (decisions :initform nil :accessor compare-frame-decisions)
   (confidence :initform nil :accessor compare-frame-confidence)
   (in :initform nil :accessor compare-frame-in)
   (out :initform nil :accessor compare-frame-out)
   (display :initform :concise :accessor compare-frame-display)
   (threshold 
    :initform *tree-display-threshold* :accessor compare-frame-threshold)
   (tstream :initform nil :accessor compare-frame-tstream)
   (chart :initform nil :accessor  compare-frame-chart)
   (comment :initform " " :accessor compare-frame-comment)
   (version :initform nil :accessor compare-frame-version)
   (gversion :initform nil :accessor compare-frame-gversion)
   (gactive :initform nil :accessor compare-frame-gactive)
   (gderivation :initform nil :accessor compare-frame-gderivation)
   (inspect :initform nil :accessor compare-frame-inspect)
   (update :initform nil :accessor compare-frame-update)
   (ids :initform nil :accessor compare-frame-ids)
   (controller :initform nil :accessor compare-frame-controller))
  (:panes
    (top
      (clim:outlining (:thickness 1)
        (clim:spacing (:thickness 2 :background clim:+white+)  
          (clim:make-pane 'lkb-pane ; JAC 10-Dec-2018 - was clim:application-pane, and also below
                          :display-function 'draw-top-window
                          :text-cursor nil
                          :text-style (comparison-top-font)
                          :height '(#+:mcclim 1 #-:mcclim 1.1 :line)
                          :min-height '(#+:mcclim 1 #-:mcclim 1.1 :line)
                          :max-height '(#+:mcclim 1 #-:mcclim 1.1 :line)
                          :end-of-line-action :allow
                          :end-of-page-action :allow
                          :display-time t
                          :background clim:+white+
                          :foreground clim:+black+))))
    (trees  
      (clim:outlining (:thickness 1)
        (clim:scrolling (:scroll-bar :both :scroll-bars :both) ; CLIM spec ambiguous
          (clim:make-pane 'lkb-pane
                          :display-function 'draw-trees-window
                          :text-cursor nil
			  :text-style (comparison-tree-font)
			  :width *tree-display-trees-width*
                          :height *tree-display-height*
                          ;; no margins in Allegro CLIM; wrapping with spacing prevents scrolling
                          #+:mcclim :text-margins
                          #+:mcclim '(:left 3 :top 3 :bottom 3 :right 3)
			  :end-of-line-action :allow
			  :end-of-page-action :allow
			  :display-time t
			  :background clim:+white+
			  :foreground clim:+black+))))
    (comment 
      (clim:outlining (:thickness 1)
        (clim:spacing (:thickness 1 :background clim:+white+)  
          (clim:make-pane 'lkb-pane
                          :display-function 'draw-comment-window
                          :text-cursor nil
                          :text-style (comparison-comment-font)
                          :height '(#+:mcclim 1 #-:mcclim 1.1 :line)
                          :min-height '(#+:mcclim 1 #-:mcclim 1.1 :line)
                          :max-height '(#+:mcclim 1 #-:mcclim 1.1 :line)
                          :end-of-line-action :allow
                          :end-of-page-action :allow
                          :display-time t
                          :background clim:+white+
                          :foreground clim:+black+))))
    (status 
      (clim:outlining (:thickness 1)
        (clim:spacing (:thickness 1 :background clim:+white+)  
          (clim:make-pane 'lkb-pane
                          :display-function 'draw-status-window
                          :text-cursor nil
                          :text-style (comparison-status-font)
                          :height '(#+:mcclim 1 #-:mcclim 1.1 :line)
                          :min-height '(#+:mcclim 1 #-:mcclim 1.1 :line)
                          :max-height '(#+:mcclim 1 #-:mcclim 1.1 :line)
                          :end-of-line-action :allow
                          :end-of-page-action :allow
                          :display-time t
                          :background clim:+white+
                          :foreground clim:+black+))))
    (discriminants  
      (clim:outlining (:thickness 1)
        (clim:scrolling (:scroll-bar :both :scroll-bars :both)
	  (clim:make-pane 'lkb-pane
			  :display-function 'draw-discriminants-window
			  :text-cursor nil
			  :text-style (comparison-discriminant-font)
			  :width *tree-display-discriminants-width*
                          #+:mcclim :text-margins
                          #+:mcclim '(:left 3 :top 3 :bottom 3 :right 3)
			  :end-of-line-action :allow
			  :end-of-page-action :allow
			  :incremental-redisplay t
			  :background clim:+white+
			  :foreground clim:+black+)))))
  (:layouts
    (:default (clim:vertically ()
                top
                (clim:horizontally () 
                  trees 
                  (clim:vertically () comment status discriminants))))))

(defmethod initialize-instance :around ((frame compare-frame) &rest initargs)
  (if *manage-window-placement*
    (multiple-value-bind (left top width height)
        (compute-frame-position-and-size frame)
      (apply #'call-next-method
        frame :left left :top top :width width :height height initargs))
    (call-next-method)))

(define-compare-frame-command (com-exit-compare-frame :menu "Close")
    ()
 (clim:with-application-frame (frame)
   (record-decision (make-decision :type :close) frame)
   (setf *tree-display-threshold* (compare-frame-threshold frame))
   (if (compare-frame-controller frame)
     (mp:process-revoke-arrest-reason (compare-frame-controller frame) :wait)
     (clim:frame-exit frame))))

#+:null
(define-compare-frame-command (com-first-compare-frame :menu "First")
    ()
  (clim:with-application-frame (frame)
    (frame-cursor frame :horizontal-scroll)
    (record-decision (make-decision :type :first) frame)
    (when (compare-frame-controller frame)
      (mp:process-revoke-arrest-reason 
       (compare-frame-controller frame) :wait))))

(define-compare-frame-command (com-previous-compare-frame :menu "Previous")
    ()
  (clim:with-application-frame (frame)
    (frame-cursor frame :horizontal-scroll)
    (record-decision (make-decision :type :previous) frame)
    (when (compare-frame-controller frame)
      (mp:process-revoke-arrest-reason 
       (compare-frame-controller frame) :wait))))

(define-compare-frame-command (com-next-compare-frame :menu "Next")
    ()
  (clim:with-application-frame (frame)
    (frame-cursor frame :horizontal-scroll)
    (record-decision (make-decision :type :next) frame)
    (when (compare-frame-controller frame)
      (mp:process-revoke-arrest-reason 
       (compare-frame-controller frame) :wait))))

#+:null
(define-compare-frame-command (com-last-compare-frame :menu "Last")
    ()
  (clim:with-application-frame (frame)
    (frame-cursor frame :horizontal-scroll)
    (record-decision (make-decision :type :last) frame)
    (when (compare-frame-controller frame)
      (mp:process-revoke-arrest-reason 
       (compare-frame-controller frame) :wait))))

(define-compare-frame-command (com-reject-compare-frame :menu "Reject")
    ()
  (clim:with-application-frame (frame)
    (record-decision (make-decision :type :reject) frame)
    (setf (compare-frame-in frame) nil)
    (setf (compare-frame-out frame) (compare-frame-edges frame))
    (update-trees frame t :discriminant)
    (when *tree-save-on-reject-p*
      (record-decision (make-decision :type :save))
      (when (compare-frame-controller frame) 
        (mp:process-revoke-arrest-reason 
         (compare-frame-controller frame) :wait)))))

(define-compare-frame-command (com-clear-compare-frame :menu "Clear")
    ()
  (clim:with-application-frame (frame)
    (record-decision (make-decision :type :clear) frame)
    (reset-discriminants frame)))

(define-compare-frame-command (com-reset-compare-frame :menu "Reset")
    ()
  (clim:with-application-frame (frame)
    (record-decision (make-decision :type :reset) frame)
    (reset-or-reconsider-compare-frame frame)))

(define-compare-frame-command (com-reconsider-compare-frame :menu "Reconsider")
    ()
  (clim:with-application-frame (frame)
    (record-decision (make-decision :type :reset) frame)
    (reset-or-reconsider-compare-frame frame :reconsider)))

(define-compare-frame-command (com-ordered-compare-frame :menu "Ordered")
    ()
  (clim:with-application-frame (frame)
    (setf (compare-frame-display frame) :ordered)
    (update-trees frame)))


(define-compare-frame-command (com-concise-compare-frame :menu "Concise")
    ()
  (clim:with-application-frame (frame)
    (setf (compare-frame-display frame) :concise)
    (update-trees frame)))


(define-compare-frame-command (com-full-compare-frame :menu "Full")
    ()
  (clim:with-application-frame (frame)
    (setf (compare-frame-display frame) nil)
    (update-trees frame)))

(define-compare-frame-command (com-save-compare-frame :menu "Save")
    ()
  (clim:with-application-frame (frame)
    (frame-cursor frame :horizontal-scroll)
    (record-decision (make-decision :type :save))
    (when (compare-frame-controller frame) 
      (mp:process-revoke-arrest-reason 
       (compare-frame-controller frame) :wait))))

(define-compare-frame-command (com-confidence-compare-frame :menu "Confidence")
    ()
  (clim:with-application-frame (frame)
    (pop-up-menu
      '(("High (3)" :value 3)
        ("Fair (2)" :value 2)
        ("Low (1)" :value 1)
        ("Zero (0)" :value 0))
      #'(lambda (confidence)
          (setf (compare-frame-confidence frame) confidence)))
    (clim:redisplay-frame-pane frame 'top :force-p t)))

(define-compare-frame-command (com-toggle-compare-frame :menu "Toggle")
    ()
  (clim:with-application-frame (frame)
    (if (and (integerp *tree-display-threshold*)
             (= *tree-display-threshold* (compare-frame-threshold frame)))
      (setf *tree-display-threshold* nil)
      (setf *tree-display-threshold* (compare-frame-threshold frame)))
    (update-trees frame)))

(defun draw-top-window (frame stream &rest rest)

  (declare (ignore rest))
  ;;
  ;; first test whether we are displaying the window with an initialized frame
  ;;
  (if (compare-frame-edges frame)
    (clim:formatting-table (stream)
      (clim:formatting-row (stream)
        (let ((record 
                (clim:formatting-cell (stream :align-x :center :min-width 950)
                  (format
                    stream
                    "~:[~*~;(~a) ~][~a : ~a~@[ @ ~a~]]  ~a"
                    (compare-frame-item frame) (compare-frame-item frame)
                    (length (compare-frame-in frame)) 
                    (length (compare-frame-out frame))
                    (let ((foo (compare-frame-confidence frame)))
                      (when (and (integerp foo) (>= foo 0) (<= foo 3))
                        (aref #("zero" "low" "fair" "high") foo)))
                    (compare-frame-input frame)))))
          (when (= (length (compare-frame-in frame)) 1)
            (recolor-record record clim:+blue+)
            (clim:replay record stream))
          (when (update-match-p frame)
            (recolor-record record clim:+magenta+)
            (clim:replay record stream)))))

    (clim:formatting-table (stream)
      (clim:formatting-row (stream)
        (let ((record 
                (clim:formatting-cell (stream :align-x :center :min-width 950)
                  (format
                    stream
                    "- analyzing the parse forest; please wait -"))))
          (recolor-record record clim:+red+)
          (clim:replay record stream))))))

(defun draw-trees-window (frame stream &rest rest)

  (declare (ignore rest))
  ;;
  ;; in case we were displaying the window with an uninitialized frame
  ;;
  (when (null (compare-frame-edges frame))
    (return-from draw-trees-window))

  (setf (compare-frame-tstream frame) stream)
  (when (and (compare-frame-trees frame) ; JAC - don't attempt to display an empty table
           (or (not (integerp *tree-display-threshold*))
               (<= (length (compare-frame-trees frame)) 
                   *tree-display-threshold*)))
    (clim:formatting-table (stream :x-spacing "X")
      (loop
          for tree in (compare-frame-trees frame)
          do
            (setf (ctree-ink tree) clim:+foreground-ink+)
            (setf (ctree-record tree)
              (clim:with-new-output-record (stream)
                (clim:with-output-recording-options (stream :record t)
                  (clim:formatting-row (stream)
                    (clim:formatting-cell 
                        (stream :align-x :center :align-y :top)
                      (with-text-style-bold-face (stream (comparison-dependencies-font))
                        (format stream "~%[~a]" (ctree-id tree))))
                    (clim:formatting-cell 
                        (stream :align-x :left :align-y :center)
                      (clim:formatting-row (stream)
                        (clim:formatting-cell 
                            (stream :align-x :left :align-y :top)
                          (format stream "~@[(~a)~]~%" (ctree-score tree)))
                        (clim:formatting-cell 
                            (stream :align-x :center :align-y :top)
                          (clim:with-output-as-presentation 
                              (stream tree 'ctree :single-box t)
                            (if (eq (compare-frame-view frame) :classic)
                              (clim:format-graph-from-root
                               (or (ctree-symbol tree)
                                   (setf (ctree-symbol tree)
                                     (make-new-parse-tree (ctree-edge tree))))
                               #'(lambda (node stream)
                                   (multiple-value-bind (s lex-p) 
                                       (get-string-for-edge node)
                                     (if lex-p
                                       (with-text-style-bold-face (stream) (write-string s stream))
                                       (write-string s stream))))
                               #'(lambda (node) (get node 'daughters))
                               :graph-type :parse-tree
                               :stream stream 
                               :merge-duplicates nil
                               :orientation :vertical
                               :generation-separation 7
                               :move-cursor t
                               :within-generation-separation 7
                               :center-nodes nil)
                              (let* ((edge (ctree-edge tree))
                                     (mrs (or (edge-mrs edge)
                                              (setf (edge-mrs edge)
                                                (ignore-errors
                                                 (mrs::extract-mrs edge))))))
                                (when mrs
                                  (mrs:eds-output-psoa
                                   mrs :stream stream))))))))
                    ;; (terpri stream) ; JAC - not in conformance with the CLIM spec
                    )))))
      (when (and (compare-frame-trees frame)
                 (null (rest (compare-frame-trees frame))))
        (draw-trees-window-completion frame stream)))
    (update-tree-colours frame)
    #+:mcclim (clim:change-space-requirements stream))) ; update scroll bars

(define-compare-frame-command (com-tree-popup)
    ((tree 'ctree :gesture (:select :menu nil)))

  (let ((mrsp *mrs-loaded*)
        (edge (ctree-edge tree)))
    (pop-up-menu
      `(("Yes" :value yes :active t)
        #+:null
        ("No" :value no :active t)
        ("Enlarged Tree" :value show)
        ("MRS" :value mrs :active ,mrsp)
        ("RMRS" :value rmrs :active ,mrsp)
        ("Indexed MRS" :value indexed :active ,mrsp)
        ("Scoped MRS" :value scoped :active ,mrsp)
        #+:logon
        ("UTool MRS" :value utool :active ,mrsp)
        ("Dependencies" :value dependencies :active ,mrsp)
        ("Rephrase" :value rephrase :active ,mrsp))
      (yes 
             (record-decision 
              (make-decision :type :select :value edge))
             (clim:with-application-frame (frame)
               (update-discriminants 
                (compare-frame-discriminants frame) edge t)
               (recompute-in-and-out frame)
               (if (member (compare-frame-display frame) 
                           '(:concise :ordered :inspect))
                 (update-trees frame)
                 (update-tree-colours frame))))
      #+:null
      (no
             ;;
             ;; _fix_me_
             ;; not sure what to do here: there may be no discriminant(s) to
             ;; exclusively rule out this single tree; we would presumably have
             ;; to create one and add it to the global list of discriminants;
             ;; not clear this is so desirable.                (12-oct-02; oe)
             ;;
             (record-decision 
              (make-decision :type :drop :value edge))
             (clim:with-application-frame (frame)
               (update-discriminants 
                (compare-frame-discriminants frame) edge nil)
               (if (member (compare-frame-display frame) 
                           '(:concise :ordered :inspect))
                 (update-trees frame)
                 (update-tree-colours frame))))
      (show 
             (clim:with-application-frame (frame)
               (display-parse-tree
                nil nil
                :symbol (or (ctree-symbol tree)
                            (setf (ctree-symbol tree)
                              (make-new-parse-tree (ctree-edge tree))))
                :title (format nil "Parse Tree #~a" (ctree-id tree))
                :counter (compare-frame-chart frame))))
      (mrs
             (when edge
               (ignore-errors (funcall 'show-mrs-window edge))))
      (rmrs 
             (when edge
               (ignore-errors (funcall 'show-mrs-rmrs-window edge))))
      (indexed
             (when edge
               (ignore-errors (funcall 'show-mrs-indexed-window edge))))
      (scoped
             (when edge
               (ignore-errors (funcall 'show-mrs-scoped-window edge))))
      #+:logon
      (utool
             (when edge
               (ignore-errors (funcall 'show-mrs-utool-window edge))))
      (dependencies
             (when edge
               (ignore-errors (funcall 'show-mrs-dependencies-window edge))))
      (rephrase
             (let ((symbol (when (find-package :mt)
                             (find-symbol "REPHRASE" :mt))))
               (when (and symbol (fboundp symbol))
                 (funcall symbol edge)))))))

(defun draw-trees-window-completion (frame stream)
  (let* ((hook *tree-completion-hook*)
         (hook (typecase hook
                 (null nil)
                 (function hook)
                 (symbol (and (fboundp hook) (symbol-function hook)))
                 (string (ignore-errors 
                          (symbol-function (read-from-string hook))))))
         (tree (first (compare-frame-trees frame)))
         (edge (ctree-edge tree))
         (mrs (or (edge-mrs edge)
                  (ignore-errors (mrs::extract-mrs edge))))
         (eds (when mrs (ignore-errors (mrs:eds-convert-psoa mrs)))))
    
    (multiple-value-bind (result condition) 
        (when (functionp hook) (ignore-errors (funcall hook edge mrs)))
      (when condition
        (clim:beep)
        (format
         #+:allegro excl:*initial-terminal-io* #-:allegro *initial-terminal-io*
         "tree-completion-hook(): error `~a'.~%"
         (normalize-string (format nil "~a" condition))))
      ;; if the hook result specifies a font/face/size then it must stay within the
      ;; CLIM 2.0 protocol, and not stray into the McCLIM font family protocol extension
      (let* ((comment (if (stringp result)
                        result
                        (rest (assoc :comment result))))
             (result (unless (stringp result) result))
             (font (rest (assoc :font result)))
             (face (rest (assoc :face result)))
             (size (rest (assoc :size result)))
             (style (when (or font face size)
                      (clim:merge-text-styles
                        (list font face size) (comparison-dependencies-font))))
             (color (rest (assoc :color result)))
             (color (ignore-errors (apply #'clim:make-rgb-color color)))
             (bottomp (rest (assoc :bottom result)))
             (align (or (rest (assoc :align result)) :center)))
        (when (and comment (null bottomp))
          (clim:formatting-row (stream)
            (clim:formatting-cell (stream :align-x :center :align-y :top)
              (format stream " ")))
          (clim:with-drawing-options (stream :ink color)
            (clim:formatting-row (stream)
              (clim:formatting-cell (stream :align-x :center :align-y :top)
                (format stream "")) ; JAC - removed superfluous (ctree-id tree)
              (clim:formatting-cell (stream :align-x align)
                (clim:with-text-style (stream style)
                  (format stream "~%~a" comment))))))
        (when (and eds (not (eq (compare-frame-view frame) :modern)))
          (clim:formatting-row (stream)
            (clim:formatting-cell (stream :align-x :center :align-y :top)
              (format stream " ")))
          (let* ((status (mrs:eds-suspicious-p eds))
                 (orange (or #-:mcclim
                             (clim:find-named-color
                               "orange" (clim:frame-palette frame) :errorp nil)
                             #+:mcclim clim:+orange+))
                 (color
                   (cond
                     ((member :cyclic status) clim:+red+)
                     ((member :fragmented status) orange)
                     (t (if (update-match-p frame) clim:+magenta+ clim:+blue+)))))
            (clim:with-drawing-options (stream :ink color)
              (clim:formatting-row (stream)
                (clim:formatting-cell (stream :align-x :center :align-y :top)
                  (with-text-style-bold-face (stream (comparison-dependencies-font))
                    (format stream "~%[~a]" (ctree-id tree))))
                (clim:formatting-cell (stream :align-x :left)
                  (clim:formatting-column (stream)
                    (clim:formatting-cell (stream :align-x :left)
                      (format stream "~@[(~a)~]~%" (ctree-score tree)))
                    (clim:formatting-cell (stream :align-x :center)
                      (clim:with-text-style (stream (comparison-dependencies-font))
                        (format stream "~a" eds)))))))))
        (when (and comment bottomp)
          (clim:formatting-row (stream)
            (clim:formatting-cell (stream :align-x :center :align-y :top)
              (format stream " ")))
          (clim:with-drawing-options (stream :ink color)
            (clim:formatting-row (stream)
              (clim:formatting-cell (stream :align-x :center :align-y :top)
                (format stream "")) ; JAC - removed superfluous (ctree-id tree)
              (clim:formatting-cell (stream :align-x align)
                (clim:with-text-style (stream style)
                  (format stream "~%~a" comment))))))))))

(defun draw-comment-window (frame stream &rest rest)
  
  (declare (ignore rest))

  (clim:formatting-table (stream)
    (clim:formatting-row (stream)
      (clim:formatting-cell (stream :align-x :center :min-width 410)
        (let* ((comment (compare-frame-comment frame))
               (comment (if (or (null comment) (equal comment ""))
                          " "
                          comment)))
          (format stream "~a" comment))))))

(defun draw-status-window (frame stream &rest rest)
  
  (declare (ignore rest))

  (clim:formatting-table (stream)
    (clim:formatting-row (stream)
      (clim:formatting-cell (stream :align-x :center :min-width 410)
        (let ((version (compare-frame-version frame))
              (gold (compare-frame-gversion frame)))
          (if (and version (not (equal version "")))
            (format 
             stream 
             "~a~:[    ~;~]" 
             version (or (null gold) (equal gold "")))
            (format stream " "))
          (when (and gold (not (equal gold "")))
            (let ((record (clim:with-new-output-record (stream)
                            (format stream "~a" gold))))
              (recolor-record 
               record 
               (if (update-match-p frame) clim:+magenta+ clim:+blue+))
              (clim:replay record stream))))))))

(eval-when (:load-toplevel :compile-toplevel :execute)
  (clim:define-presentation-type discriminant ()))

(defun draw-discriminants-window (frame stream &rest rest)
  (declare (ignore rest))

  ;;
  ;; in case we are displaying the window with an uninitialized frame
  ;;
  (when (or (null (compare-frame-edges frame))
            (null (compare-frame-discriminants frame)))
    (return-from draw-discriminants-window))

  (let ((discriminants (compare-frame-discriminants frame)))
    (clim:stream-set-cursor-position stream 0 0)
    (clim:formatting-table (stream :x-spacing "X")
      (loop
          for item in discriminants
          for record = (discriminant-record item)
          when record do (clim:clear-output-record record)
          unless (discriminant-hidep item) do
            (clim:formatting-row (stream)
              (setf (discriminant-record item)
                (clim:with-new-output-record (stream)
                  (let ((ink (if (discriminant-gold item)
                                 (if (update-match-p frame) clim:+magenta+ clim:+blue+)
                                 clim:+foreground-ink+)))
                    (clim:with-drawing-options (stream :ink ink)
                      (clim:with-output-as-presentation (stream item 'discriminant)
                        (clim:updating-output 
                            (stream :cache-value (discriminant-state item))
                          (clim:formatting-cell 
                              (stream :align-x :center :min-width "+")
                            (write-string
                              (discriminant-state-as-string item) stream)))
                        (clim:updating-output 
                            (stream :cache-value (discriminant-toggle item))
                          (clim:formatting-cell 
                              (stream :align-x :center :min-width "+")
                            (write-string 
                              (discriminant-toggle-as-string item) stream)))
                        (clim:formatting-cell (stream :align-x :left)
                          (format stream "~a" (discriminant-key item)))
                        (clim:formatting-cell (stream :align-x :left)
                          (format stream "~@[~a~]" (discriminant-value item)))))))))))
    #+:mcclim (clim:change-space-requirements stream)))

(define-compare-frame-command (com-discriminant-popup)
    ((discriminant 'discriminant :gesture (:select :menu nil)))
  (pop-up-menu
    `(("Yes" :value yes)
      ("No" :value no)
      ("Unknown" :value unknown)
      (,(format nil "In Parses (~a)" (length (discriminant-in discriminant)))
       :value in)
      (,(format nil "Out Parses (~a)" (length (discriminant-out discriminant)))
       :value out))
    (yes
      (record-decision (make-decision :type :yes :value discriminant))
      (setf (discriminant-state discriminant) t)
      (setf (discriminant-toggle discriminant) t))
    (no 
      (record-decision (make-decision :type :no :value discriminant))
      (setf (discriminant-state discriminant) nil)
      (setf (discriminant-toggle discriminant) nil))
    (unknown 
      (record-decision 
        (make-decision :type :unknown :value discriminant))
      (setf (discriminant-state discriminant) :unknown)
      (setf (discriminant-toggle discriminant) :unknown))
    ;;
    ;; _fix_me_
    ;; in concise mode, at least, make these only show trees that are
    ;; still available globally, i.e. ignore all trees that have become
    ;; out already.                                    (20-jan-03; oe)
    ;;
    (in (show-parse-summary (discriminant-in discriminant)))
    (out (show-parse-summary (discriminant-out discriminant))))
  (clim:with-application-frame (frame)
    (recompute-in-and-out frame)
    (update-trees frame t :discriminant)))

(defun update-trees (frame 
                     &optional (redrawp t) (context nil)
                     &key (runp (compare-frame-runp frame)))

  #+:mcclim (declare (ignore context))
  (when runp (frame-cursor frame :vertical-scroll))
  (if (null redrawp)
    (when runp (update-tree-colours frame))
    (let ((in (compare-frame-in frame)))
      (when runp
        (loop
            for tree in (compare-frame-trees frame)
            when (ctree-record tree) do
              (clim:clear-output-record (ctree-record tree))
              (setf (ctree-record tree) nil))
        (loop
            for discriminant in (compare-frame-discriminants frame)
            for record = (discriminant-record discriminant)
            when record do
              (clim:clear-output-record record)
              (setf (discriminant-record discriminant) nil)))
      (case (compare-frame-display frame)
        (:ordered
         (setf (compare-frame-trees frame)
           (stable-sort 
            (copy-list (compare-frame-otrees frame))
            #'(lambda (foo bar)
                (let ((foop (member (ctree-edge foo) in :test #'eq))
                      (barp (member (ctree-edge bar) in :test #'eq)))
                  (if (and foop (null barp))
                    t
                    (let ((foo (ctree-id foo))
                          (bar (ctree-id bar)))
                      (and (numberp foo) (numberp bar) (<= foo bar))))))))
         (loop
             for discriminant in (compare-frame-discriminants frame)
             do
               (setf (discriminant-hidep discriminant) nil)))
        (:inspect
         (setf (compare-frame-trees frame)
           (stable-sort 
            (copy-list (compare-frame-otrees frame))
            #'(lambda (foo bar)
                (let ((flags (ctree-flags foo))
                      (foo (ctree-score foo))
                      (bar (ctree-score bar)))
                  (when (and (numberp foo) (numberp bar))
                  (or (> foo bar)
                      (and (= foo bar) (member :gold flags))))))))

         (loop
             for discriminant in (compare-frame-discriminants frame)
             do
               (setf (discriminant-hidep discriminant) nil)))
        (:concise
         (setf (compare-frame-trees frame)
           (loop
               for tree in (compare-frame-otrees frame)
               when (member (ctree-edge tree) in :test #'eq)
               collect tree))
         (loop
             with trees = (compare-frame-trees frame)
             with n = (length trees)
             for discriminant in (compare-frame-discriminants frame)
             for in = (discriminant-in discriminant)
             do
               (setf (discriminant-hidep discriminant)
                 (or (not (eq (discriminant-state discriminant) :unknown))
                     (and (<= n (length in))
                          (not (loop
                                   for tree in trees
                                   for edge = (ctree-edge tree)
                                   for match = (find edge in :test #'eq)
                                   thereis (null match))))))))
        (t
         (setf (compare-frame-trees frame) 
           (copy-list (compare-frame-otrees frame)))
         (loop
             for discriminant in (compare-frame-discriminants frame)
             do
               (setf (discriminant-hidep discriminant) nil))))

      #-:mcclim
      (when (and runp (not (eq context :tree)))
        (clim:redisplay-frame-pane frame 'trees :force-p t))
      ;;
      ;; _fix_me_
      ;; always force complete redraw: omitting this causes rather disturbing
      ;; glitches in the state and toggle displays in non-concise display mode
      ;; and the overlay of old ink with new ink in concise display; maybe our
      ;; drawing function needs improvement.                   (15-oct-02; oe)
      ;;
      (when runp
        #+:mcclim (when (clim:frame-panes frame) (clim:redisplay-frame-panes frame :force-p t))
        #-:mcclim (clim::redisplay-frame-pane frame 'discriminants :force-p t)
        #-:mcclim (clim::redisplay-frame-pane frame 'top :force-p t))))
  
  (when runp (frame-cursor frame :default)))

(defun update-tree-colours (frame)

  (let ((stream (compare-frame-tstream frame)))
    (loop
        with in = (compare-frame-in frame)
        for tree in (compare-frame-trees frame)
        for ink = (cond ((not (member (ctree-edge tree) in :test #'eq))
                         clim:+red+)
                        ((and (not (rest in)) 
                              (eq (ctree-edge tree) (first in)))
                         (if (update-match-p frame) 
                           clim:+magenta+
                           clim:+blue+))
                        (t clim:+foreground-ink+))
        for record = (ctree-record tree)
        unless (or (null record) (eq ink (ctree-ink tree)))
        do
          (setf (ctree-ink tree) ink)
          (recolor-record record ink)
          (clim:replay record stream))))

(defun recolor-record (record ink)
  (labels ((recolor-node (node) 
             (when (clim:displayed-output-record-p node)
               ;; !!! the function (setf clim:displayed-output-record-ink) is not in any
               ;; CLIM specification (2.0, 2.2.2 or II), so this code is non-portable
               #-:mcclim (setf (clim:displayed-output-record-ink node) ink)
               #+:mcclim (ignore-errors (setf (slot-value node 'climi::ink) ink)))
             (clim:map-over-output-records #'recolor-node node)))
    (recolor-node record)))

(defun frame-cursor (frame &optional (cursor :default))
  
  (cond
   ((clim:application-frame-p frame)
    (let* ((sheet (clim:frame-top-level-sheet frame))
           (port (clim:find-port))
           (pointer (and port (clim:port-pointer port))))
      #-:null
      (declare (ignore pointer))
      (when (clim:sheetp sheet)
        (frame-cursor sheet cursor))
      #+:null
      (when pointer
        (setf (clim:pointer-cursor pointer) cursor))))
   ((clim:sheetp frame)
    (setf (clim:sheet-pointer-cursor frame) cursor)
    #+(and :allegro (not :mswindows))
    (loop
        for child in (clim:sheet-children frame)
        ;;
        ;; _fix_me_
        ;; although the CLIM 2.2 User Guide claims that all sheets (can) have
        ;; children, sheet-children() actually throws an exception on some of
        ;; the native Motif widgets; this calls for a bug report to Franz.
        ;;                                                    (16-oct-02; oe)
        unless (or (eq (class-of child) 
                       (find-class 'tk-silica::motif-menu-bar))
                   (eq (class-of child) 
                       (find-class 'tk-silica::motif-scroll-bar)))
        do (frame-cursor child cursor)))))

(defun reset-discriminants (frame)
  (setf (compare-frame-trees frame) (compare-frame-otrees frame))
  (setf (compare-frame-in frame) (compare-frame-edges frame))
  (setf (compare-frame-out frame) nil)
  (loop
      for foo in (compare-frame-discriminants frame)
      do
        (setf (discriminant-time foo) (get-universal-time))
        (setf (discriminant-state foo) :unknown)
        (setf (discriminant-toggle foo) :unknown)
        ;;
        ;; loose all memory of preset values at this point; no way back.
        ;;
        (setf (discriminant-preset foo) nil)
        (setf (discriminant-gold foo) nil))
  (recompute-in-and-out frame t)
  (update-trees frame))

(defun recompute-in-and-out (frame &optional resetp)
  ;;
  ;; apply inference rules from [Carter, 1997] until a fixpoint is reached
  ;; _fix_me_
  ;; now that some of the other parts are reasonably efficient, we can look at
  ;; sets of a thousand or more discriminants; propagation of discriminants 
  ;; becomes noticeably sluggish with more than a few hundred.
  ;;                                                          (5-nov-02; oe)
  (let ((threshold *tree-display-threshold*)
        (initial (length (compare-frame-in frame)))
        (decision (first (compare-frame-decisions frame))))
    (cond
     ((and (decision-p decision) (eq (decision-type decision) :reject))
      (setf (compare-frame-in frame) nil)
      (setf (compare-frame-out frame) (compare-frame-edges frame))
      ;;
      ;; always needs tree redraw, unless active set was empty before.
      ;;
      (not (zerop initial)))
     ((and (decision-p decision) (eq (decision-type decision) :select))
      (let ((active (decision-value decision)))
        (setf (compare-frame-in frame) (list active))
        (setf (compare-frame-out frame)
          (remove active (compare-frame-edges frame))))
      t)
     (t
      (let ((donep nil))
        (setf (compare-frame-in frame) (compare-frame-edges frame))
        (setf (compare-frame-out frame) nil)
        (when resetp
          ;;
          ;; we risk loosing preset (gold) assignments here; maybe check for a
          ;; preset value and restore that here?              (12-oct-02; oe)
          ;;
          ;; _fix_me_
          ;; give more thought to propagation of decisions through updates: a
          ;; hard decision (i.e. toggle) may be lost during an upddate and only
          ;; survive as a soft decision (i.e. entailed state).  over time, this
          ;; could lead to primarily soft annotations, and the distinction from
          ;; the original annotation cycle will be completely washed out.  one
          ;; option could be to promote entailments from `gold' to hard when
          ;; performing the update, but that appears to blur the distinction
          ;; between actual decisions and entailment just as much.  maybe have
          ;; additional values for toggle (and presumably state): inherited on
          ;; or off, or even hard inherited vs. soft inherited?
          ;;                                                  (14-oct-02; oe)
          ;;
          (loop
              for foo in (compare-frame-discriminants frame)
              for preset = (discriminant-preset foo)
              for gold = (discriminant-gold foo)
              do
                (setf (discriminant-state foo) (discriminant-toggle foo))
              when gold do
                (setf (discriminant-state foo) (discriminant-state gold))
              when preset do
                (setf (discriminant-state foo) (discriminant-state preset))))
        (loop 
            until donep
            do
              (setf donep t)
              (loop
                  for foo in (compare-frame-discriminants frame)
                  when (null (discriminant-state foo)) do
                    (mark-out (discriminant-in foo) frame)
                  when (eq (discriminant-state foo) t) do
                    (mark-out (discriminant-out foo) frame))
              (setf (compare-frame-in frame) 
                (set-difference 
                 (compare-frame-edges frame) (compare-frame-out frame)
                 :test #'eq))
              (loop
                  for foo in (compare-frame-discriminants frame)
                  when (null (intersection 
                              (discriminant-in foo) (compare-frame-in frame)
                              :test #'eq)) do
                    (when (discriminant-state foo)
                      (setf (discriminant-state foo) nil)
                      (setf donep nil))
                  else when (subsetp 
                             (compare-frame-in frame) (discriminant-in foo)
                             :test #'eq) do
                    (when (not (discriminant-state foo))
                      (setf (discriminant-state foo) t)
                      (setf donep nil)))))
      
      (and (integerp threshold) 
           (or (and (> initial threshold) 
                    (<= (length (compare-frame-in frame)) threshold))
               (and (<= initial threshold)
                    (> (length (compare-frame-in frame)) threshold))))))))
        
(defun mark-out (edges frame)
  (loop
      for edge in edges
      do 
        (pushnew edge (compare-frame-out frame) :test #'eq)
        (setf (compare-frame-in frame) 
          (remove edge (compare-frame-in frame)))))

(defun update-match-p (frame)
  (when (and *tree-automatic-update-p* *tree-update-match-hook*)
    (let ((hook (typecase *tree-update-match-hook*
                  (null nil)
                  (function *tree-update-match-hook*)
                  (symbol (and (fboundp *tree-update-match-hook*)
                               (symbol-function *tree-update-match-hook*)))
                  (string (ignore-errors 
                           (symbol-function 
                            (read-from-string *tree-update-match-hook*)))))))
      (when hook (ignore-errors (funcall hook frame))))))

;;;
;;; from here on, HTML output routines; this should probably be reorganized, so
;;; that the comparison class is generic, and only the CLIM-specific parts are
;;; in the segregated directory.                                (6-aug-03; oe)
;;;
(defun html-compare (frame &key (stream t) (indentation 0))

  #+:debug
  (setf %frame% frame)

  (let ((treep (or (not (integerp *tree-display-threshold*))
                   (<= (length (compare-frame-trees frame)) 
                       *tree-display-threshold*))))

    (format
     stream
     "~v,0t<table class=compare>~%~
      ~v,0t  <tr>~%~v,0t    <td class=compareTop colspan=2 align=center>~%~
      ~v,0t      ~:[~*~;(~a)  ~]~a [~a : ~a~@[ @ ~a~]]</td></tr>~%~
      ~v,0t  <tr>~%"
     indentation
     indentation indentation
     indentation
     (compare-frame-item frame) (compare-frame-item frame)
     (compare-frame-input frame)
     (length (compare-frame-in frame)) 
     (length (compare-frame-out frame))
     (let ((foo (compare-frame-confidence frame)))
       (when (and (integerp foo) (>= foo 0) (<= foo 3))
         (aref #("zero" "low" "fair" "high") foo)))
     indentation)
    (when treep
      (format
       stream
       "~v,0t    <td class=compareTrees align=left valign=top>~%"
       indentation)
      (html-trees frame :stream stream :indentation (+ indentation 6))
      (format stream "~%~v,0t    </td>~%" indentation))
    (let ((mrsp (when (and *tree-display-semantics-p*
                           (compare-frame-trees frame)
                           (null (rest (compare-frame-trees frame))))
                  (let ((edge (ctree-edge 
                               (first (compare-frame-trees frame)))))
                    (or (edge-mrs edge)
                        (when (edge-dag edge) (mrs::extract-mrs edge)))))))
      (format
       stream
       "~v,0t    <td class=compare~:[Discriminants~;Mrs~] ~
                     align=right valign=top>~%"
       indentation mrsp)
      (if (not mrsp)
        (html-discriminants 
         frame :stream stream :onlyp (not treep) 
         :indentation (+ indentation 6))
        #+:mrs
        (mrs::output-mrs1 mrsp 'mrs::html stream))))
  (format
   stream
   "~v,0t    </td>~%~v,0t  </tr>~%~v,0t</table>"
   indentation indentation indentation))

(defun html-trees (frame &key (stream t) (indentation 0))

  (unless (and (integerp *tree-display-threshold*)
               (> (length (compare-frame-trees frame)) 
                  *tree-display-threshold*))
    (loop
        initially
          (format 
           stream
           "~v,0t<table class=compareTrees>~%" indentation)
        finally
          (format stream "~v,0t</table>" indentation)
        with in = (compare-frame-in frame)
        for tree in (compare-frame-trees frame)
        for color = (unless (member (ctree-edge tree) in :test #'eq) "red")
        do
          (format 
           stream 
           "~v,0t  <tr>~%~v,0t    ~
            <td class=compareTreeLabel valign=top>~%~v,0t      ~
            <table class=compareTreeLabel>~%~v,0t        ~
            <tr><td class=compareTreeId>[~a]</td></tr>~%~v,0t        ~
            <tr><td class=compareTreeScore>~:[~*&nbsp;~;~a~]</td>~
            </tr>~%~v,0t      </table></td>~%~v,0t    ~
            <td class=compareTree>~%"
           indentation indentation
           indentation
           indentation
           (ctree-id tree) indentation
           (ctree-score tree) (ctree-score tree)
           indentation indentation)
          (html-tree 
           (ctree-edge tree) :tree (ctree-symbol tree)
           :indentation (+ indentation 6) :color color :stream stream)
          (format
           stream
           "~%~v,0t    </td></tr>~%" indentation))))

(defun html-discriminants (frame &key (stream t) onlyp (indentation 0))

  (let ((discriminants (compare-frame-discriminants frame)))
    (format 
     stream 
     "~v,0t<table class=compareDiscriminants~@[Only~] cellpadding=2>~%" 
     indentation onlyp)
    (loop
        for i from 0
        for item in discriminants
        for state = (discriminant-state-as-string item)
        for toggle = (discriminant-toggle item)
        unless (discriminant-hidep item) do
          (format
           stream
           "~v,0t  <tr>~%~v,0t    ~
            ~:[<td class=compareDiscriminantState>~a</td>~%~v,0t      ~;~2*~]~
            <td class=compareDiscriminantToggle>~%~v,0t      ~
            <select size=1 name=\"~a\"~%~v,0t              ~
                    onChange=\"this.form.submit()\">~%~v,0t        ~
            <option value=\"?\"~@[ selected~*~]>?</option>~%~v,0t        ~
            <option value=\"+\"~@[ selected~*~]>+</option>~%~v,0t        ~
            <option value=\"-\"~@[ selected~*~]>-</option>~%~v,0t        ~
            </select></td>~%~v,0t      ~
            <td class=compareDiscriminantKey>~a</td>~%~v,0t    ~
            ~@[<td class=compareDiscriminantValue>~a</td>~]</tr>~%"
           indentation indentation
           (eq (compare-frame-display frame) :concise) state indentation
           indentation
           i indentation
           indentation
           (eq toggle :unknown) indentation
           (eq toggle t) indentation
           (null toggle) indentation
           indentation
           (discriminant-key item) indentation
           (discriminant-value item))) ; JAC: removed superfluous arg
    (format stream "~v,0t</table>" indentation)))

(defun ptb-compare-hook (frame &key size)
  (let* ((input (compare-frame-input frame))
         (input (if (stringp input)
                  (let ((symbol (find-symbol "READ-PTB-FROM-STRING" :tsdb)))
                    (when symbol (funcall (symbol-function symbol) input))
                    input)))
         (comment (compare-frame-comment frame)))
    (when (and (consp input) (stringp comment))
      (setf (compare-frame-input frame) comment)
      (lui-display-tree input comment :size size))
    nil))

#+:null
(setf lkb::*tree-initialization-hook* '("lkb::ptb-compare-hook" :size 8))