;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: SWITCHES
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/switches.lisp
;;; File Creation Date: 09/13/90 15:40:00
;;; Last Modification Time: 10/09/92 14:53:54
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;; [Juergen  Tue Nov  6 11:18:31 1990] resources are mostly defined in 
;;;   initforms instead of in define-resources, so that they are inherited
;;;   much like defaults
;;;
;;;_____________________________________________________________________________

(in-package :xit)

;;;_____________________________________________________________________________
;;;
;;;                               SWITCH
;;;_____________________________________________________________________________

;; switch like menu classes implements an interaction object for selection
;; from a set of choices, where only one choice is visible at a time.
;; In contrast to menu classes actions are not performed on button-events
;; but when switch items pop up or down depending on value of slot action-mode.
;; Commonly used type of switches are binary switches or toggles.
;; 
;; Slots:
;; action-mode  determines when an action corresponding to an item is
;;              performed
;;              :up  action is performed when item pops up
;;              :down action is performed when item pops down
;; 
;; Note: In the different action-modes the switch items pop up in a different
;;       order

(defcontact switch (basic-menu)
  ((name :initform :switch)
   (layouter :initform '(basic-layouter :alignment :center))
   (action-mode :type (member :up :down)
		:initform :up
		:accessor action-mode
		:initarg :action-mode)
   (mouse-feedback :initform :border)
   (part-mouse-feedback :initform :none)
   (reactivity :initform '((:part-event (call :write))
			   (:select (call :self switch)))))
  (:documentation "switch implements selection from a set of choices
                   where only one choice is visible at a time"))

(defmethod mapped-part ((self switch))
  (find-part self #'(lambda (part) (eq (contact-state part) :mapped))))

(defmethod (setf mapped-part) (new-part (self switch))
  (with-slots (mouse-feedback-on? display) self
    (let ((old-part (mapped-part self))
	  (feedback? mouse-feedback-on?))
      (unless (eq new-part old-part)
	(when feedback? (show-mouse-feedback self))
	(setf mouse-feedback-on? nil) ;; ***
	(when old-part (setf (contact-state old-part) :managed))
	(when new-part (setf (contact-state new-part) :mapped))
        ;; the following is no longer triggered by display-after
	;;(process-all-events display) ;; ***
	;; *** seems to be needed for open windows
        (setf mouse-feedback-on? feedback?) ;; ***
	(when feedback? (show-mouse-feedback self))
	)))
  new-part)

(defmethod selected-part ((self switch))
  (with-slots (action-mode) self
    (let ((mapped-part (mapped-part self)))
      (when mapped-part
	(case action-mode
	  (:up mapped-part)
	  (:down (previous-layouted-sibling-rotated mapped-part)))))))

(defmethod (setf selected-part) (new-part (self switch))
  (with-slots (action-mode) self
    (setf (mapped-part self) new-part)
    (when (eq action-mode :down)
      (switch self)))
  new-part)

(defmethod selection ((self switch))
  (identification (selected-part self)))

(defmethod (setf selection) (identification (self switch))
  (setf (selected-part self) (part-with-identification self identification))
  identification)

(defmethod initialize-instance :after ((self switch)
				       &rest init-list
				       &key (selection nil selection-p))
  (if selection-p
    ;(setf (contact-state (part-with-identification self selection)) :mapped)
      (setf (selection self) selection) ; does this really work for mode :down?
    (read-from-application self)))

(defmethod part-event-type ((self switch))
  (with-slots (action-mode) self
    (case action-mode
      (:up :map-notify)
      (:down :unmap-notify))))

(defmethod (setf action-mode) :around (new-value (self switch))
  (let ((old-value (action-mode self))
	(old-part-event-type (part-event-type self)))
      (call-next-method)
      (unless (eq new-value old-value)
	(let ((new-part-event-type (part-event-type self)))
	  (dolist (part (parts self))
	    (apply #'change-reactivity part new-part-event-type
		   (reactivity-actions-for part old-part-event-type)))))))

(defmethod add-part :around ((self switch) &rest part-init-list &key)
  (setf (getf part-init-list :state) :managed)
  (apply #'call-next-method self part-init-list))

(defmethod identification ((self switch))
  (selection self))

(defmethod (setf identification) (value (self switch))
  (setf (selection self) value))

(defmethod switch-forward ((self switch))
  (let ((mapped-part (mapped-part self)))
    (setf (mapped-part self)
	(if mapped-part
	    (next-layouted-sibling-rotated mapped-part)
	  (first-layouted-sibling nil self)))))

(defmethod switch-backward ((self switch))
  (let ((mapped-part (mapped-part self)))
    (setf (mapped-part self)
      (if mapped-part
	  (previous-layouted-sibling-rotated mapped-part)
	(last-layouted-sibling nil self)))))

(defmethod switch ((self switch))
  (switch-forward self))

;;;_____________________________________________________________________________
;;;
;;;                            TEXT SWITCH
;;;_____________________________________________________________________________

(defcontact text-switch (switch text-menu)
  ((name :initform :text-switch))
  (:documentation "a switch with text-dispels as its parts"))

;;;_____________________________________________________________________________
;;;
;;;                            BITMAP SWITCH
;;;_____________________________________________________________________________

(defcontact bitmap-switch (switch bitmap-menu)
  ((name :initform :bitmap-switch))
  (:documentation "a switch with bitmap-dispels as its parts"))

