;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: XIT; Base: 10; -*-
;;;_________________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: VIRTUALS
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Hohl, Hubertus
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/examples/virtual-examples.lisp
;;; File Creation Date: 6/06/90 16:41:33
;;; Last Modification Time: 07/22/92 10:56:56
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;________________________________________________________________________________ 


(in-package :xit)

;_______________________________________________________________________________

(proclaim '(special demo-window icon-menu *display* *toplevel*))

;;;___________________________
;;; 
;;; Demo Window for Virtuals
;;;___________________________

(defcontact frame-for-virtuals (window-icon-mixin popup-part-connection
				margined-window)
	    ((popup-part :initform :default)
	     (reactivity :initform
			 '((:select) (:move) (:menu)
			   (:double-left-button "Shrink to icon"
			    (call :self shrink))))))

;;; Where the virtuals live in...
;;;
(defcontact window-for-virtuals (intel
				 composite-for-virtuals)
  ((exposure-by-region? :initform T
			:allocation :class))
  )

;;; since a window-for-virtuals may contain both virtuals and non-virtuals,
;;; we use exposure-by-region? = T, i.e. moving non-virtuals causes exposure
;;; events whereby exposure is restricted to the old area occupied by the 
;;; non-virtual.
;;;
;;; obsolete (see before-display graphical-feedback-window)
;;; 04/22/1991 (Hubertus)
;;; (defmethod before-display ((self window-for-virtuals) &optional clear-first?)
;;;   nil)

(defmethod change-layout ((self window-for-virtuals) &optional newly-managed)
  ;; only used to allow triggers to invalidate the bbox-size cache and update margins
  (with-slots (layout-window?) self
    (when layout-window?
      (adjust-window-size self))))

(defmethod scroll-layouted-window ((self window-for-virtuals) dx dy)
  (with-final-update-of-virtuals self
    (call-next-method)))


(defparameter frame-for-virtuals
    (make-window 'frame-for-virtuals
		 :x 100 :y 100 :width 700 :height 500
		 :window-icon `(intel-example-icon :parent ,icon-menu
						   :text "Virtual Dispels")
		 :adjust-size? nil
		 :border-width 1
		 :margins
		 `((standard-margins-with-scroll-bars
		    :label-options (:text "Virtual Dispels"
				    :font (:face :bolditalic)
				    :display-position :left-center)))
		 :client-window
		 `(window-for-virtuals
		   :name :virtual-examples
		   :mouse-feedback :border
		   :background .06
		   :border-width 0)))

(defparameter window-for-virtuals (client-window frame-for-virtuals))

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


;;; a default reactivity for Line dispels
;;;
(defparameter *line-default-reactivity*
	      '((:single-left-button "Move line"
		 move-window)
		(:single-middle-button "Move inner point"
		 move-line-inner-point-with-mouse)
		(:single-right-button
		  "Insert inner point"
		  insert-line-inner-point-with-mouse)
		(:shift-right-button
		  "Remove inner point"
		  remove-line-inner-point-with-mouse )))


;;; a labelled-arrow-dispel with bigger arrowheads 
;;;
(defcontact labelled-big-arrow (labelled-arrow-dispel)
  ((arrow-head-length :type integer
		      :initform 30
		      :allocation :class
		      :documentation
		      "ratio of the length of the arrowhead to
                       the thickness of the arrow shaft.")
   (arrow-base-width :type integer
		     :initform 12
		     :allocation :class
		     :documentation
		     "ratio of the base width of the arrowhead to
                      the thickness of the arrow shaft.")))

;;; 
;;; Some Virtual Text Dispels
;;;

;;; mouse-feedback :inverse, adjust-size? nil
;;; 
(defparameter v-text-1
	      (make-window 'virtual-text-dispel
			   :parent window-for-virtuals
			   :x 20 :y 70
			   :font  '(:face :bold)
			   :mouse-feedback :inverse
			   :adjust-size? t
			   :text "Text-1 (Feedback inverse, adjust-size? t)"
			   :reactivity-entries
			   `((:edit) (:move)
			     (:single-right-button "Resize text" resize-window))))


;;; shaded, mouse-feedback :border, adjust-size? nil
;;;
(defparameter v-text-2
	      (make-window 'virtual-text-dispel
			   :parent window-for-virtuals
			   :x 305 :y 185
			   :font '(:face :bolditalic :size :huge)
			   :mouse-feedback :border
			   :adjust-size? nil
			   :shaded? t
			   :inverse? nil
			   :text
			   "Text-2 (shaded, Feedback border, adjust-size? nil)"
			   :reactivity-entries
			   `((:edit) (:move)
			     (:single-right-button "Resize text" resize-window))))

;;; mouse-feedback :border, adjust-size? nil
;;;
(defparameter v-text-3
	      (make-window 'virtual-text-dispel
			   :parent window-for-virtuals
			   :x 296 :y 307
			   :font '(:face :bolditalic :size :very-large)
			   :mouse-feedback :border
			   :adjust-size? nil
			   :text "Text-3 (Feedback border, adjust-size? nil)"
			   :reactivity-entries
			   `((:edit) (:move)
			     (:single-right-button "Resize text" resize-window))))


;;;
;;; Some Lines
;;;

(defparameter lines
	      (let ((lines nil)
		    (center (point 200 200))
		    (offset 10)
		    (length 100))
		(dotimes (i 8)
		  (let ((rad (* pi .25 i)))
		    (push (make-window 'labelled-arrow-dispel 
				       :name
				       (intern (format nil "LINE-~D[~D]" i (1+ i)) 'keyword)
				       :parent window-for-virtuals
				       :mouse-feedback (if (oddp i) :border :inverse)
				       :text (format nil "Line ~D" (1+ i))
				       :arrow-position (case (mod i 3)
							 (0 :start)
							 (1 :end)
							 (2 :both))
				       :line-width (1+ i)
				       :line-dashes
				       (case (mod i 3)
					 (0 nil)
					 (1 T)
					 (2 (list 8 8)))
				       :start
				       (point-add center
						  (point (round (* (cos rad) offset))
							 (round (* (sin rad) offset))))
							 
				       :end
				       (point-add center
						  (point (round (* (cos rad) length))
							 (round (* (sin rad) length))))
				       :reactivity-entries *line-default-reactivity*)
			  lines)))
		lines))

(defparameter line
	      (make-window 'labelled-line-dispel
			   :parent window-for-virtuals
			   :reactivity-entries
			   '((:select "Bend Line to Circular-Arc"
			       (call :self line<->circular-arc))
			     (:move "Move line"
			       move-window)) 
			   :mouse-feedback :inverse
			   :line-width 1
			   :start (point 10 440)
			   :end (point 250 440)
			   :text "Bend me"
			   ))

(defparameter labelled-arrow
	      (make-window 'labelled-arrow-dispel
			   :parent window-for-virtuals
			   :reactivity-entries
			   '((:single-left-button "Make me thicker"
			      (call :eval (incf (line-width *self*))))
			     (:move "Move line" move-window)
			     (:single-right-button "Make me thinner"
			      (call :eval
			       (when (> (line-width *self*) 1)
				 (decf (line-width *self*))))))
			   :mouse-feedback :border
			   :line-width 1
			   :start (point 200 20)
			   :end (point 500 20)
			   :text "default arrow"
			   ))

(defparameter labelled-big-arrow
	      (make-window 'labelled-big-arrow
			   :parent window-for-virtuals
			   :reactivity-entries
			   '((:single-left-button "Make me thicker"
			      (call :eval (incf (line-width *self*))))
			     (:move "Move line" move-window)
			     (:single-right-button "Make me thinner"
			      (call :eval
			       (when (> (line-width *self*) 1)
				 (decf (line-width *self*))))))
			   :mouse-feedback :border
			   :line-width 1
			   :start (point 200 40)
			   :end (point 500 40)
			   :text "bigger arrow"
			   ))

(defparameter thick-arrow
	      (make-window 'arrow-dispel
			   :parent window-for-virtuals
			   :reactivity-entries *line-default-reactivity*
			   :mouse-feedback :border
			   :line-width 40
			   :start (point 620 85)
			   :end (point 460 180)))

(defparameter labelled-line
	      (make-window 'labelled-line-dispel
			   :parent window-for-virtuals
			   :mouse-feedback :border
			   :line-width 4
			   :start (point 350 250)
			   :end (point 650 250)
			   :text "Rotate me"
			   :reactivity-entries
			   '((:select "Rotate me"
			      (call :self rotate-line))
			     (:move "Move line"
			      move-window))
			   ))

(defparameter polyline
	      (make-window 'labelled-arrow-dispel
			   :parent window-for-virtuals
			   :reactivity-entries *line-default-reactivity*
			   :mouse-feedback :inverse
			   :start (point 290 400)
			   :end (point 310 50)
			   :inner-points (list (point 99 -68)
					       (point 81 43)
					       (point 168 26)
					       (point 106 -62)
					       (point 234 -62)
					       (point 211 7)
					       (point 369 -59))
			   :relative-p t	; for end and inner points!
			   :text "a_polyline"
			   :arrow-position :both))

;;;
;;; Examples for manipulating start-, end- and inner-points of line-dispels:
;;;

(defun line-center (line)
  "Returns center-x, center-y and radius of the line connecting line's start-and endpoints"
  (multiple-value-bind (start-x start-y end-x end-y)
      (line-point-coordinates line)
    (values (round (+ start-x end-x) 2)
	    (round (+ start-y end-y) 2)
	    (round (sqrt (+ (expt (- start-x end-x) 2)
			    (expt (- start-y end-y) 2)))
			 2))))

(defun rotate-line (line)
  "Rotate line around center of start-end line-connection in clockwise direction"
  (declare (special *display*))
  (with-final-layout (contact-parent line)
    ;; prevent intermediate updates for margins etc.
    (let ((rad (/ pi 18)))
      (sleep 0.5)
      (multiple-value-bind (center-x center-y radius) (line-center line)
	(dotimes (i 18)
	  (set-line-point-coordinates
	   line
	   (+ center-x (round (* radius (cos (* i rad)))))
	   (+ center-y (round (* radius (sin (* i rad)))))
	   (- center-x (round (* radius (cos (* i rad)))))
	   (- center-y (round (* radius (sin (* i rad))))))
	  (display-force-output *display*)
	  (sleep 0.5))))))


(defun line<->circular-arc (line)
  "Convert line to a circluar-arc and vice versa by adding/removing inner-points"
  (declare (special *display*))
  (with-final-layout (contact-parent line)
    ;; prevent intermediate updates for margins etc.
    (set-line-inner-points line nil)
    (display-force-output *display*)
    (sleep 1)
    (multiple-value-bind (center-x center-y radius) (line-center line)
      (dotimes (n 12)
	(do ((pts (- (* 2 (1+ n)) 1))
	     (rad (/ pi (* 2 (1+ n))))
	     (i 1 (1+ i))
	     (inner-pts nil inner-pts))
	    ((> i pts)
	     (setf (text line) (format nil "Bends: ~D" pts))
	     (set-line-inner-points line (nreverse inner-pts))
	     (display-force-output *display*)
	     (sleep 0.5))
	  (push (point (- center-x (round (* radius (cos (* i rad)))))
		       (- center-y (round (* radius (sin (* i rad))))))
		inner-pts))))))

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

(shrink frame-for-virtuals)

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









