;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: 
;;;                       Module: 
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Matthias Ressel
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/utilities/fancy-dispels.lisp
;;; File Creation Date: 04/29/91 16:35:42
;;; Last Modification Time: 10/08/92 17:33:09
;;; Last Modification By: Matthias Ressel
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;; 10/07/1992 (Matthias) replaced identify-window-with-mouse by identify-window
;;; 04/29/1991 (Matthias) from identifier.lisp and resource-sheet.lisp:
;;;      editable-value-dispel, identifier-mixin,
;;;      diverse input-output-text-fields and -identifers
;;;
;;; 10/08/1991 (Hubertus) Changes due to FUNCTIONP
;;;
;;; 05/21/1992 (Juergen) Renamed window-identifier by window-identifier-dispel
;;; 08/04/1992 (Matthias) get-pixel-name moved to kernel/windows.lisp
;;;_____________________________________________________________________________

;;; Dispels used in color-sheet.lisp and resource-sheet.lisp
;;; and useful for many other things.

(in-package :xit)

;;;---------------------------------------------------------------------
;;;          Bold text field
;;;---------------------------------------------------------------------

(defcontact bold-text-dispel (text-dispel)
  ((font-defaults :allocation :class :initform '(:face :bold))))

;;;---------------------------------------------------------------------
;;;          Bold property field
;;;---------------------------------------------------------------------

(defcontact bold-property-field (property-field)
  ((name :initform :bold-property-field)
   (inside-border :initform 0)
   (layouter :initform '(distance-layouter :orientation :right :distance 10))
   (label-class :initform 'bold-text-dispel)
   (value-class :initform 'active-text-dispel :allocation :instance
		:initarg :value-class)))

;;;---------------------------------------------------------------------
;;;                   Editable value text field
;;;---------------------------------------------------------------------

(defcontact editable-value-dispel (minimax-mixin text-dispel)
  ((name :initform :editable-value-dispel)
   (internal-value :accessor internal-value :initarg :internal-value :initform nil)
   (value-text-transformation :initform #'convert-to-readable-string)
   (text-value-transformation :initform #'convert-from-string)
   (text-test :initform nil)
   (min-width :initform 20)
   (border-width :initform 1)
   (mouse-feedback :initform :border)
   (reactivity :initform '((:edit "Edit value"
						(call :contact edit-text)))))
  (:documentation "A text-dispel representing an editable text"))

(defmethod convert-value-to-text ((self editable-value-dispel) value)
  (with-slots (value-text-transformation) self
    (cond ((null value-text-transformation) value)
	  ((functionp value-text-transformation)
	   (funcall value-text-transformation value))
	  (t (funcall `(lambda (*contact*)
			,value-text-transformation)
		      self)))))

(defmethod convert-text-to-value ((self editable-value-dispel) text)
  (with-slots (text-value-transformation) self
    (cond ((null text-value-transformation) text)
	  ((functionp text-value-transformation)
	   (funcall text-value-transformation text))
	  (t (funcall `(lambda (*contact*)
			,text-value-transformation)
		      self)))))

(defmethod test-text ((self editable-value-dispel) text)
  (with-slots (text-test) self
    (cond ((null text-test) t)
	  ((functionp text-test)
	   (funcall text-test text))
	  (t (funcall `(lambda (*contact*)
			,text-test)
		      self)))))

(defmethod identification ((self editable-value-dispel))
  (internal-value self))

(defmethod (setf identification) (value (self editable-value-dispel))
  (setf (internal-value self) value)
  (setf (text self) (convert-value-to-text self value)))

(defmethod (setf editable-text) (value (self editable-value-dispel))
  (setf (text self) value)
  (setf (internal-value self) (convert-text-to-value self value)))

(defmethod accept-text ((self editable-value-dispel))
  (with-slots (edit-value? text text-test text-value-transformation) self
    (when edit-value?
      ;;(setf edit-value? nil)
      ;;(change-reactivity self :keyboard :none)
      (make-ineditable self) ;; 05/22/1992 (Juergen) does more!
      (cond ((test-text self text)
	       (let ((value (convert-text-to-value self text)))
		 (setf (identification self) value)
		 (send-part-event self value)))
	    (t (bell (contact-display self))
		 (display-force-output (contact-display self))
		 (sleep .5)
		 (reject-text self))))))

;;;--------------------------------------------------------------------------
;;; Identifier Mixin
;;;--------------------------------------------------------------------------

(defclass identifier-mixin ()
  ())

(defmethod identify-toplevel-window ((self identifier-mixin))
   (let* ((my-toplevel (toplevel-window self)))
      (multiple-value-bind (x y)
	  (translate-coordinates self
	   (floor (contact-total-width self) 10)
	   (floor (contact-total-height self) 2)
	    my-toplevel)
	(identify-window my-toplevel
	     :feedback? t
	     :anchor nil ;(point x y)
	     :mouse-documentation "Identify window with mouse."))))

(defclass property-identifier-mixin (identifier-mixin)
  ())

(defmethod identify-property ((self property-identifier-mixin) property-reader
			      &key test)
  (let ((window (identify-toplevel-window self)))
    (and (or (null test) (funcall test window))
	 (funcall property-reader window))))

;;;---------------------------------------------------------------------
;;;                   Window identifiers
;;;---------------------------------------------------------------------


(defcontact window-dispel (editable-value-dispel)
  ((name :initform :window-dispel)
   (value-text-transformation :initform '(string (contact-name (identification *contact*))))
   (text-value-transformation :initform
			      '(symbol-value
				(convert-from-string (text *contact*))))
   (text-test :initform '(let ((input (convert-from-string (text *contact*))))
			  (and (symbolp input) (boundp input)
			   (typep (symbol-value input) 'basic-contact))))))

(defmethod initialize-instance :around ((self window-dispel)
					&rest initargs
					&key (editable? t))
  (unless editable?
      (setq initargs `(,@initargs
			      :reactivity-entries
			      ((:single-left-button :none))
			      :mouse-feedback :none
			      :border-width 0)))
  (apply #'call-next-method self  initargs))
    

(defcontact window-identifier-dispel (identifier-mixin window-dispel)
  ())

(defmethod initialize-instance :around ((self window-identifier-dispel)
					&rest initargs
					&key reactivity-entries)
  (apply #'call-next-method self
	 :reactivity-entries
	 (append '((:single-right-button
		    "Identify window"
		    (call :eval
			  (let ((window 
				 (identify-toplevel-window  *contact*)))
			    (setf (value *contact*) window)
			    (send-part-event *contact* window) )))) 
		 reactivity-entries)
	 initargs))

;;;---------------------------------------------------------------------
;;;                  Foreground Background Identifier Mixin
;;;---------------------------------------------------------------------

(defcontact bg-fg-identifier-mixin ()
  ((foreground-reader :accessor foreground-reader :initform #'foreground
		      :initarg :foreground-reader)
   (background-reader :accessor background-reader :initform #'contact-background
		      :initarg :background-reader)))

(defmethod background-defined ((self t))
  nil)

(defmethod background-defined ((self contact))
  t)

(defmethod foreground-defined ((self t))
  nil)

(defmethod foreground-defined ((self foreground-color-mixin))
  t)

(defmethod identify-background ((self bg-fg-identifier-mixin))
  (let ((value (identify-property self (background-reader self)
				  :test 'background-defined)))
    (when value
      (setf (value self) value)
    (send-part-event self value))))

(defmethod identify-foreground ((self bg-fg-identifier-mixin))
  (let ((value (identify-property self (foreground-reader self)
				  :test 'foreground-defined)))
    (when value
      (setf (value self) value)
    (send-part-event self value))))

(defmethod initialize-instance :around ((self bg-fg-identifier-mixin)
					&rest initargs
					&key reactivity-entries)
  (apply #'call-next-method self :reactivity-entries
	 (append 
	   '((:single-middle-button
	     "Identify window background"
	     (call :contact identify-background))
	     (:shift-middle-button
	     "Identify window foreground"
	     (call :contact identify-foreground)))
	   reactivity-entries)
	 initargs))

;;;---------------------------------------------------------------------
;;;                   Color Identifier Field
;;;---------------------------------------------------------------------

(defcontact color-dispel (editable-value-dispel)
  ((name :initform :pixel-dispel)
   (value-text-transformation :initform #'get-color-name)
   (text-value-transformation :initform
			      '(multiple-value-bind (color exact)
				(convert *contact*
				(convert-from-string (text *contact*)) 'color)
				exact))
   (text-test :initform '(convert *contact*
			  (convert-from-string (text *contact*)) 'color))))

(defmethod bg-color ((self contact))
  (pixel-to-color (background-color self)))
(defmethod fg-color ((self contact))
  (pixel-to-color (foreground self)))

(defcontact color-identifier (bg-fg-identifier-mixin
			      property-identifier-mixin color-dispel)
  ((background-reader :initform #'bg-color)
   (foreground-reader :initform #'fg-color)))

;;;---------------------------------------------------------------------
;;;                   Pixel Identifier Field
;;;---------------------------------------------------------------------

(defcontact pixel-dispel (editable-value-dispel)
  ((name :initform :pixel-dispel)
   (value-text-transformation :initform
			      '(get-pixel-name *contact* (value *contact*)))
   (text-value-transformation :initform
			      '(convert *contact*
				(convert-from-string (text *contact*)) 'pixel))
   (text-test :initform '(convert *contact*
			  (convert-from-string (text *contact*)) 'pixel))
   (border-width :initform 1)
   (mouse-feedback :initform :border)))

(defcontact pixel-identifier (bg-fg-identifier-mixin
			      property-identifier-mixin pixel-dispel)
  ((background-reader :initform #'background)))

;;;---------------------------------------------------------------------
;;;                   Filename Dispel
;;;---------------------------------------------------------------------

(defcontact filename-dispel (editable-value-dispel)
  ((name :initform :filename-dispel)
   (pathname-default :initform (merge-pathnames "xit-file"
						(user-homedir-pathname))
		     :accessor pathname-default
		     :initarg pathname-default)
   (value-text-transformation :initform
			      #'namestring)
   (text-value-transformation
    :initform
    '(let* ((merged (merge-pathnames (text *contact*)
		     (pathname-default *contact*))))
      (setf (pathname-default *contact*) (namestring merged))
      merged))))

(defmethod initialize-instance :after ((self filename-dispel)
				       &rest initargs
				       &key pathname)
  (when pathname
    (setf (value self)
	(merge-pathnames pathname (pathname-default self)))
    (send-part-event self)))

(defmethod key-press ((self filename-dispel) (char (eql #\Tab)))
  (with-slots (cursor-position text) self
    (while-busy ()
		(cond ((= (length text) cursor-position)
	   (multiple-value-bind (best-completion completions)
	       (filename-completion text :result-type t)
	     (cond ((and completions
			 (null (cdr completions)))
		    (setf (text self) best-completion))
		   (completions
		    (let ((completion
			   (single-select "Possible filename completions:"
					  :entries
					 (mapcar #'(lambda (completion)
						      (cons completion completion))
						  completions))))
		      (when (stringp completion)
			(setf (text self) completion)))))))
	  (t (call-next-method))))))
	  
	  

