(in-package "KPML-I")
;;; File: constructed-clim-subseq.lisp
;;; John:Edinburgh:Nov97
;;; 
;;; Only load this for ACLPC/CLIM2.1 or anywhere else where
;;; clim:subset-sequence doesn't work properly.
;;; (replaces ui-aclwin/utilities.lsp)
;;;
;;; ----------------------------------------------------------------------
;;; multiple selections (subsequence) in an accepting-values do
;;; not work very well (i.e., at all) in CLIM2.1 for PC-ACL3.0.
;;; Following frame provides a `from-scratch' equivalent functionality
;;; using stable bits of CLIM that work...
;;; Note that this is only worthwhile for ACL3.0/CLIM2.1 or other
;;; places where clim:subset-sequence don't work. Doesn't
;;; bother with multiprocessing in any case to get a popup behaviour.
;;; ----------------------------------------------------------------------

(defvar *selected-subsequence* nil "Result of a constructed subsequence")

(clim:define-application-frame 
 CONSTRUCTED-SUBSEQUENCE-SELECTION ()
 ((selected :initform nil)
  (possible :initform nil))
 (:menu-bar T)	
 (:top-level (clim:default-frame-top-level))
 (:panes 
  (s-pane
   :application :incremental-redisplay T :scroll-bars :vertical
   :initial-cursor-visibility :inactive
   :display-function 'selected-displayer
   :width 200 :foreground inspector-fg :background inspector-bg 
   :text-style *fix--bold--10*)
  (p-pane
   :application :incremental-redisplay T :scroll-bars :vertical
   :initial-cursor-visibility :inactive
   :display-function 'possible-displayer
   :width 100 :foreground inspector-fg :background inspector-bg 
   :text-style *fix--bold--10*)
  (mouse-doc   :pointer-documentation
	       :foreground  mouse-doc-fg
	       :background  mouse-doc-bg))
 (:layouts
  (one-and-only 
   (clim:vertically ()
     (clim:horizontally () 
       (1/2 s-pane)
       (1/2 p-pane))
     (20 mouse-doc)
     ))))

(clim:define-presentation-type SEQ-POSSIBLE ())
(clim:define-presentation-type SEQ-SELECTED ())

(clim:define-presentation-action ADD-TO-SEQUENCE
    (seq-possible nil constructed-subsequence-selection
		  :documentation "Include this item")
  (object)
  (with-slots (selected possible) clim:*application-frame*
    (setf selected (cons object  selected))
    (setf possible (copy-list (remove object possible)))
    (clim:redisplay-frame-pane clim:*application-frame* 'p-pane :force-p T)
    (clim:redisplay-frame-pane clim:*application-frame* 's-pane :force-p T)
  T))

(clim:define-presentation-action REMOVE-FROM-SEQUENCE
    (seq-selected nil constructed-subsequence-selection
		  :documentation "Exclude this item")
  (object)
  (with-slots (selected possible) clim:*application-frame*
    (setf possible (cons object possible))
    (setf selected (remove object selected))
    (clim:redisplay-frame-pane clim:*application-frame* 'p-pane :force-p T)
    (clim:redisplay-frame-pane clim:*application-frame* 's-pane :force-p T)
    T))

(defmethod POSSIBLE-DISPLAYER 
    ((frame CONSTRUCTED-SUBSEQUENCE-SELECTION) stream)
  (loop for ele in (sort (copy-list (slot-value frame 'possible))
			 #'(lambda (x y) (string< (string x)(string y))))
      do (clim:with-output-as-presentation (stream ele 'seq-possible)
	   (format stream "~%~A" ele))))

(defmethod SELECTED-DISPLAYER 
    ((frame CONSTRUCTED-SUBSEQUENCE-SELECTION) stream)
  (loop for ele in (sort (copy-list (slot-value frame 'selected))
			 #'(lambda (x y) (string< (string x)(string y))))
      do (clim:with-output-as-presentation (stream ele 'seq-selected)
	   (format stream "~%~A" ele))))

(define-CONSTRUCTED-SUBSEQUENCE-SELECTION-command 
    (com-CONSTRUCTED-SUBSEQUENCE-SELECTION-ACCEPT :name "Accept" :menu t)
    ()
  (setf *selected-subsequence* 
    (slot-value clim:*application-frame* 'selected))
  (clim:frame-exit clim:*application-frame*))

(define-CONSTRUCTED-SUBSEQUENCE-SELECTION-command 
    (com-CONSTRUCTED-SUBSEQUENCE-SELECTION-CANCEL :name "Cancel" :menu t)
    ()
  (setf *selected-subsequence* nil)
  (clim:frame-exit clim:*application-frame*))

(defun KPML::GET-A-SUBSET-FROM (possible selected prompt)
  (let ((subseq-frame
	 (clim:make-application-frame
	  'constructed-subsequence-selection
	  :pretty-name prompt
	  :left (first *current-offsets*) :top (second *current-offsets*)
	  :height (min (+ 20 (* (length possible) 50)) 400))))
    (setf (slot-value subseq-frame 'selected) (copy-list selected))
    (setf (slot-value subseq-frame 'possible) 
      (set-difference possible selected))
    (apply #'run-packaged-frame 
	   (list subseq-frame (find-package "KPML") ))
    *selected-subsequence*))





