;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Margin Examples
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Hubertus Hohl
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/examples/margin-examples.lisp
;;; File Creation Date: 6/1/90 9:00:15
;;; Last Modification Time: 07/22/92 10:49:55
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;_____________________________________________________________________________

(in-package :xit)

;_______________________________________________________________________________

(proclaim '(special demo-window icon-menu margined-windows-window
		    margin-frame-1 margin-frame-2 margin-frame-3
		    margin-frame-3a margin-frame-4 margin-frame-5
		    *display* *toplevel*))


;;;__________________________________
;;; 
;;; Demo Window for Margined-Windows
;;;__________________________________

(setq margined-windows-window
      (make-window 'intel-example-window
		   :x 50 :y 50 :width 800 :height 600
		   :window-icon `(intel-example-icon :parent ,icon-menu
						     :text "Margined Windows")
		   :title "Margined Windows"))


;;;___________________________________________
;;; 
;;; A Margined-Window with default reactivity and popup-part
;;;___________________________________________

(defcontact default-margined-window (margined-window popup-part-connection)
   ((reactivity :initform '((:select) (:move) (:menu)))
    (popup-part :initform :default)))


;;;__________________________________
;;; 
;;; various kinds of client-windows
;;;__________________________________

(setq client-1
      `(basic-menu
	 :adjust-size? nil		
	 :border-width 0
	 :view-of ,(toplevel-window margined-windows-window)
	 :part-class menu-example-dispel
	 :layouter (distance-layouter :orientation :down)
	 :reactivity-entries
	 ((:keyboard client-1-keyboard-action)
	  (:single-left-button "Scroll leftwards by raster"
	   (call :self scroll-x-raster 1))
	  (:shift-left-button  "Scroll rightwards by raster"
	   (scroll-x-raster -1))
	  (:single-middle-button "Scroll home"
	   (call :self scroll-home))
	  (:single-right-button "Scroll upwards by raster"
	   (call :self scroll-y-raster 1))
	  (:single-right-button "Scroll downwards by raster"
	   (scroll-y-raster -1))		   
	  (:part-event "Change toplevel background"
	   (call :eval
		 (change-window-background
		   (view-of *self*)
		   *part-value*))))
	 :part-mouse-feedback :border
	 :parts  ((:background "white"
		   :view-of "white"
		   :action-docu
		   "Set background of toplevel window to 0%gray")
		  (:background .12
		   :view-of .12
		   :action-docu
		   "Set background of toplevel window to 12%gray")
		  (:background .25
		   :view-of .25
		   :action-docu
		   "Set background of toplevel window to 25%gray")
		  (:background .37
		   :view-of .37
		   :action-docu
		   "Set background of toplevel window to 37%gray")
		  (:background .50
		   :view-of .50
		   :action-docu
		   "Set background of toplevel window to 50%gray")
		  (:background .75
		   :view-of .75
		   :action-docu
		   "Set background of toplevel window to 75%gray")
		  (:background "black"
		   :view-of "black"
		   :action-docu
		   "Set background of toplevel window to 100%gray"))))

(defun client-1-keyboard-action (self)
  (with-event (character)
    (case character
      (#\b (scroll-x-raster self 1))
      (#\f (scroll-x-raster self -1))
      (#\p (scroll-y-raster self 1))
      (#\n (scroll-y-raster self -1)))))


(setq client-2
      (let ((client (copy-tree client-1)))
	(setf (getf (cdr client) :adjust-size?) t)
	(setf (getf (cdr client) :layouter)
	      '(distance-layouter :orientation :down :distance 10))
	(mapc #'(lambda (part)
		  (setf (getf part :action-docu) "Delete this bitmap"))
	      (getf (cdr client) :parts))
	(setf (getf (cdr client) :reactivity-entries)
	      '((:keyboard client-1-keyboard-action)
		(:single-left-button "Toggle border-width of children randomly"
		 toggle-border-width)
		(:single-middle-button "Change Margin-Label Properties randomly"
		 change-margin-label-properties)
		(:single-right-button "Change margin-space thickness"
		 change-margin-space-thickness)
		(:part-event "Delete this bitmap"
		 (call :eval
		       (destroy *part*)))))
	client))

(defun toggle-border-width (self)
  (flet ((toggle (contact)
	   (if (zerop (contact-border-width contact))
	       (change-window-border-width contact 1)
	       (change-window-border-width contact 0))))
    (case (random 2)
      (0 (with-slots (parent) self
	   (accessing-margins (margin parent)
	     (toggle margin))))
      (1 (toggle self))))
  (change-layout self))

(defun change-margin-label-properties (self)
  (with-slots (parent) self
    (accessing-margins (label parent 'margin-label)
      (when (eq (contact-name label) :label)
	(case (random 6)
	  (0 (setf (margin-location label)
		   (if (eq (margin-location label) :bottom)
		       :top :bottom)))
	  (1 (setf (display-position label)
		   (case (random 3)
		     (0 :left-center)
		     (1 :center)
		     (2 :right-center))))
	  (2 (setf (font label) '(:face :normal :size 12))
	     (setf (text label)
		   (format nil "FooBarBaz ~D" (random 1000))))
	  (3 (setf (font label)
		   (case (random 3)
		     (0 '(:face :bolditalic :size :huge))
		     (1 '(:face :bold))
		     (2 '(:face :bolditalic))
		     (3 '()))))
	  (4 (let ((background (contact-background label)))
	       (change-window-background label (foreground label))
	       (change-window-foreground label background)))
	  (5 (setf (margin-thickness label)
		   (if (< (margin-thickness label)
			  (text-height (font label)))
		       (+ (text-height (font label))
			  30)
		       1)))
	  )))))

(defun change-margin-space-thickness (self)
  (with-slots (parent) self
    (with-final-layout parent
      (accessing-margins (space parent 'margin-space)
	(incf (margin-thickness space) 4)))))

#||
(setq client-3
      `(text-menu
	 :adjust-size? nil
	 :border-width 0
	 :reactivity-entries
	 ((:part-event
	    (call :eval
		  (accessing-margins (l (contact-parent *self*) 'margin-label)
		    (setf (font l) *part-value*))))
	  (:keyboard client-1-keyboard-action)
	  (:single-left-button "Scroll leftwards by raster"
	   (call :self scroll-x-raster 1))
	  (:shift-left-button  "Scroll rightwards by raster"
	   (scroll-x-raster -1))
	  (:single-middle-button "Scroll home"
	   (call :self scroll-home))
	  (:single-right-button "Scroll upwards by raster"
	   (call :self scroll-y-raster 1))
	  (:shift-rigth-button "Scroll downwards by raster"
	   (scroll-y-raster -1)))
	 :parts ((:view-of "hl8"
		  :text "hl8"
		  :font (:family :helvetica :face :normal :size 8)
		  :action-docu
		  "Set label-font to hl8")
		 (:view-of "hl8b"
		  :text "hl8b"
		  :font (:family :helvetica :face :bold :size 8)
		  :action-docu
		  "Set label-font to hl8b")
		 (:view-of "hl8i"
		  :text "hl8i"
		  :font (:family :helvetica :face :italic :size 8)
		  :action-docu
		  "Set label-font to hl8i")
		 (:view-of "hl10"
		  :text "hl10"
		  :font (:family :helvetica :face :normal :size 10)
		  :action-docu
		  "Set label-font to hl10")
		 (:view-of "hl10b"
		  :text "hl10b"
		  :font (:family :helvetica :face :bold :size 10)
		  :action-docu
		  "Set label-font to hl10b")
		 (:view-of "hl12"
		  :text "hl12"
		  :font (:family :helvetica :face :normal :size 12)
		  :action-docu
		  "Set label-font to hl12")
		 (:view-of "hl12b"
		  :text "hl12b"
		  :font (:family :helvetica :face :bold :size 12)
		  :action-docu
		  "Set label-font to hl12b")
		 (:view-of "hl12i"
		  :text "hl12i"
		  :font (:family :helvetica :face :italic :size 12)
		  :action-docu
		  "Set label-font to hl12i")
		 (:view-of "hl12bi"
		  :text "hl12bi"
		  :font (:family :helvetica :face :bolditalic :size 12)
		  :action-docu
		  "Set label-font to hl12bi")
		 (:view-of "hl8"
		  :text "hl8"
		  :font (:family :helvetica :face :normal :size 8)
		  :action-docu
		  "Set label-font to hl8")
		 (:view-of "hl8b"
		  :text "hl8b"
		  :font (:family :helvetica :face :bold :size 8)
		  :action-docu
		  "Set label-font to hl8b")
		 (:view-of "hl8i"
		  :text "hl8i"
		  :font (:family :helvetica :face :italic :size 8)
		  :action-docu
		  "Set label-font to hl8i")
		 (:view-of "hl10"
		  :text "hl10"
		  :font (:family :helvetica :face :normal :size 10)
		  :action-docu
		  "Set label-font to hl10")
		 (:view-of "hl10b"
		  :text "hl10b"
		  :font (:family :helvetica :face :bold :size 10)
		  :action-docu
		  "Set label-font to hl10b")
		 (:view-of "hl12"
		  :text "hl12"
		  :font (:family :helvetica :face :normal :size 12)
		  :action-docu
		  "Set label-font to hl12")
		 (:view-of "hl12b"
		  :text "hl12b"
		  :font (:family :helvetica :face :bold :size 12)
		  :action-docu
		  "Set label-font to hl12b")
		 (:view-of "hl12i"
		  :text "hl12i"
		  :font (:family :helvetica :face :italic :size 12)
		  :action-docu
		  "Set label-font to hl12i")
		 (:view-of "hl12bi"
		  :text "hl12bi"
		  :font (:family :helvetica :face :bolditalic :size 12)
		  :action-docu
		  "Set label-font to hl12bi")
		 )))
||#


;;;________________________
;;;
;;; the margined-windows
;;;________________________

;;; standard margins with scroll-bars
;;;
(setq margin-frame-1
      (make-window 'default-margined-window
		   :parent margined-windows-window
		   :x 16 :y 24
		   :width 200
		   :height 200
		   :border-width 1
		   :adjust-size? nil
		   :margins
		   `((standard-margins-with-scroll-bars
		       :label-options (:name :label
				       :text "MarginedWindow 1"
				       :display-position :right-center)
		       ;:scroll-bar-options (:inside-border 2)
		       :quad-space-options (:name :space
					    :left 20 :top 15 :right 10 :bottom 5)))
		   :client-window client-1))


;;; various kinds of margin-space and margin-labels
;;;
(setq margin-frame-2
      (make-window 'default-margined-window
		   :parent margined-windows-window
		   :x 20 :y 230
		   :adjust-size? t
		   :border-width 4
		   :margins
		   `((standard-margins
		       :label-options (:name :top-label
				       :text "Adjusting MarginWindow 2"
				       :font (:size 10)
				       :display-position :left-center
				       :background "white"
				       :foreground "black")
		       :quad-space-options (:name :space
					    :left 20 :top 15 :right 10 :bottom 5
					    :background .75))
		     (margin-space :name :sp1
				   :location :left
				   :thickness 10
				   :background .75)
		     (margin-space :name :sp2
				   :location :top
				   :thickness 10
				   :background .37)
		     (margin-space :name :sp3
				   :location :right
				   :thickness 10
				   :background .25)
		     (margin-space :name :sp4
				   :location :bottom
				   :thickness 10
				   :background .12)
		     (margin-label :name :label
				   :text "A bottom label"
				   :font (:face :bold :size 10)
				   :display-position :center
				   :location :bottom) 
		     (margin-quad-space :name :sp5
					:thickness 5
					:background "white"))
		   :client-window client-2))

;;; nested margined-windows with scroll-bars... hmmm!
;;;
(setq margin-frame-3
      (make-window 'default-margined-window
		   :parent margined-windows-window
		   :x 215 :y 310
		   :width 250
		   :height 250
		   :border-width 3
		   :adjust-size? nil
		   :margins
		   `((standard-margins-with-scroll-bars
		       :label-options (:name :top-label
				       :text "Nested MarginWindow 3"
				       :display-position :right-center)
		       :scroll-bar-options (:locations (:right :bottom)
					    :thickness 15)
		       :quad-space-options (:name :space :thickness 10)))
		   :client-window
		   `(margined-window
		      :border-width 3
		      :adjust-size? nil
		      :margins
		      ((standard-margins-with-scroll-bars
		       :label-options (:name :inner-top-label
				       :text "Inner MarginedWindow 1"
				       :display-position :left-center)
		       :scroll-bar-options (:locations (:right :bottom))
		       :quad-space-options (:name :inner-space :thickness 10)))
		      :client-window ,client-1)))

;;; a margined-window with a menu of margined-windows...
;;;

#||
(setq margin-frame-3a
      (make-window 'default-margined-window
		   :parent margined-windows-window
		   :x 510 :y 24
		   :width 250
		   :height 290
		   :border-width 3
		   :adjust-size? nil
		   :margins
		   `((standard-margins-with-scroll-bars
		       :label-options (:name :top-label
				       :text "Menu MarginWindow 3a"
				       :display-position :right-center)
		       :scroll-bar-options (:locations (:right :bottom)
					    :thickness 13)
		       :quad-space-options (:name :space :thickness 10)))
		   :client-window
		   `(basic-menu
		      :border-width 0
		      :adjust-size? nil
		      :view-of ,(toplevel-window margined-windows-window)
		      :part-class margined-window
		      :part-mouse-feedback :border
		      :parts
		      ((:width 200
			:height 200
			:border-width 3
			:adjust-size? nil
			:margins
			((standard-margins-with-scroll-bars
			   :label-options (:name :inner-top-label-1
					   :text "Inner MarginedWindow 1"
					   :font (:face :bold :size 12)
					   :display-position :left-center)
			   :scroll-bar-options (:locations (:right :bottom))
			   :quad-space-options (:name :inner-space :thickness 10)))
			:client-window ,client-1)
		       (:width 200
			:height 200
			:border-width 2
			:adjust-size? nil
			:margins
			((symbolics-lookalike-margins-with-scroll-bars 
			   :label-options (:name :inner-top-label-2
					   :text "Inner MarginedWindow 2"
					   :font (:size 12)
					   :display-position :left-center)))
			:client-window ,client-3))
		      )))
||#

;;; a symbolics lookalike scrollable margined-window
;;;
(setq margin-frame-4
      (make-window 'default-margined-window
		   :parent margined-windows-window
		   :x 270 :y 24
		   :width 200
		   :height 250
		   :border-width 2
		   :adjust-size? nil
		   :margins
		   `((symbolics-lookalike-margins-with-scroll-bars 
		       :label-options (:name :top-label
				       :text "Symbolics Look&Feel"
				       :font (:face :bolditalic)
				       :display-position :left-center)))
		   :client-window client-1))

;;; scrolling a bitmap-dispel
;;;
(defparameter *demo-bitmaps*
	      (let ((bitmaps '("calvix" "haegar")))
		(nconc bitmaps bitmaps)))

(setq margin-frame-5
      (make-window 'default-margined-window
		   :parent margined-windows-window
		   :x 480 :y 334
		   :width 300
		   :height 250
		   :border-width 5
		   :adjust-size? nil
		   :margins
		   `((margin-quad-space :thickness 4 :background "white")
		     (margin-quad-space :thickness 3 :background "black")
		     (margin-quad-space :thickness 2 :background "white")
		     (symbolics-lookalike-margins-with-scroll-bars 
		       :label-options (:name :top-label
				       :location :bottom
				       :text "A Bitmap-Dispel Scroller"
				       :font (:face :italic)
				       :display-position :left-center)
		       :scroll-bar-options (:thickness 8
					    :locations (:left :top :right :bottom))))
		   :client-window
		   `(scrollable-bitmap-dispel
		     :name example-scrollable-bitmap-dispel
		      :bitmap ,(pop *demo-bitmaps*)
		      :mouse-feedback :border
		      :reactivity-entries
		      ((:single-left-button
			 "Next Bitmap...(may take some time for the first time)"
			 (call :eval
			       (progn
				 (change-window-cursor *self* "watch")
				 (display-force-output (contact-display *self*))
				 (setf (bitmap *self*)
				   (pop *demo-bitmaps*))
				 (scroll-home *self*)
				 (change-window-cursor *self* "arrow"))))))))

(update-state *display*)
(process-all-events *display*)

(shrink margined-windows-window)

(update-state *display*)
(process-all-events *display*)
