;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Example Definitions
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/examples/definitions.lisp
;;; File Creation Date: 6/23/89 10:31:37
;;; Last Modification Time: 07/22/92 10:48:33
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;_____________________________________________________________________________

(in-package :xit)

;_______________________________________________________________________________

(defcontact intel-example-icon (text-dispel)
  ((mouse-feedback :initform :border)))

(defcontact intel-example-icon-menu (window-icon-mixin popup-part-connection
				     title-window uniform-part-intel)
  ((part-class :initform 'text-dispel)
   (layouter :initform 'distance-layouter)
   (popup-part :initform :default)
   (reactivity :initform '((:select "Put window to top")
			   (:move)
			   (:menu)
			   (:double-left-button "Shrink to icon"
			    (call :self shrink)))))
  (:resources
   (inside-border :initform 2)))

(defcontact intel-example-window (minimax-mixin window-icon-mixin
				  popup-part-connection
				  title-window intel)
  ((adjust-size? :initform nil)
   (popup-part :initform :default)
   (reactivity :initform '((:select "Put window to top")
			   (:move)
			   (:menu)
			   (:double-left-button "Shrink to icon"
			    (call :self shrink)))))
  (:resources
   (inside-border :initform 2)))

(defcontact layouter-example-window (title-window intel)
  ((inside-border :initform 10)))

(defcontact menu-example-dispel (dispel)
  ((adjust-size? :initform nil)
   (mouse-feedback-border-width :initform 2
				:allocation :class)))

;(defcontact menu-example-dispel (dispel) ())

(defcontact shadow-popup-property-sheet (shadow-borders-mixin
					 popup-window property-sheet)
  ())

(defmethod popup-for :after ((self shadow-popup-property-sheet) obj)
  (read-from-application self))

;;;______________________________
;;; 
;;;   Making Dispels scrollable
;;; 
;;; ToDo: include in dispel class
;;;______________________________

(defcontact scrollable-dispel (dispel)
     ())

;;;
;;; internal scrolling methods for dispels
;;;

(defmethod extent-size ((self scrollable-dispel))
  (values (display-width self)
	  (display-height self)))

(defmethod scroll-to ((self scrollable-dispel) &optional x y)
  (let ((origin (extent-origin self)))
    (multiple-value-bind (new-x new-y) (new-scroll-position self x y)
      (when new-x
	(setf (point-x origin) new-x))
      (when new-y
	(setf (point-y origin) new-y))
      (when (or new-x new-y)
	(update self)))))

(defmethod scroll-relative ((self scrollable-dispel) dx dy)
  (let ((origin (extent-origin self)))
    (multiple-value-bind (new-x new-y) (new-scroll-position self dx dy :relative)
      (when new-x
	(setf (point-x origin) new-x))
      (when new-y
	(setf (point-y origin) new-y))
      (when (or new-x new-y)
	(update self)))))

;;; scrolling is performed by overriding the display-x/y-offset
;;;
(defmethod display-x-offset ((self scrollable-dispel))
  (+ (point-x (extent-origin self)) (x-margin self)))
       

(defmethod display-y-offset ((self scrollable-dispel))
  (+ (point-y (extent-origin self)) (y-margin self)))
  
;;; updating scroll-bars
;;;
(defmethod update :after ((self scrollable-dispel))
  (with-slots (parent) self
    (when (typep parent 'margined-window)
      (update-margins parent 'margin-scroll-bar))))

;;; a scrollable bitmap dispel
;;;
(defcontact scrollable-bitmap-dispel (scrollable-dispel bitmap-dispel)
  ())


#+(and lucid clos (not pcl))
(pmds::load-system :lucid-clos-patch)
