;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: DEMO-TEXT; Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; This file contains demo code for testing the text interactor
;;;
;;; This is intended as a test and demonstration of the text interactor
;;; as part of the Garnet project.
;;; 
;;; ** Call (Do-Go) to start and (Do-Stop) to stop **
;;;
;;; Designed and implemented by Brad A. Myers

#|
============================================================
Change log:
	 4/2/92 Rich McDaniel - New multifont-text
	 8/6/91 Ed Pervin - Made :strings of the-feedback-obj = NIL
	 6/18/91 Ed Pervin - Changed to multifont-text
	 3/15/90 Ed Pervin - Changed to variable width font
         10/10/89 Brad Myers - New interactor changes
         8/21/89 Brad Myers - Changes to use multi-line text
         6/26/89 Brad Myers - Fixed to have quote for create-schema
         6/19/89 Brad Myers - Fixed to print a message
         4/20/89 Brad Myers - call-parent-method -> call-prototype-method
	 4/7/89 Brad Myers and Dario Giuse - change for new KR
         3/28/89 Brad Myers - New cursor-text works with 0-length strings
         3/2/89 Philippe Marchal - Titles for window and icon
         3/1/89 Brad Myers - started
============================================================
|#

(in-package "DEMO-TEXT" :use '("LISP" "KR"))

(export '(Do-Go Do-Stop))
(defvar *test-debug* NIL)

;; Load multifont stuff.
(unless (get :garnet-modules :multifont)
   (load (merge-pathnames "multifont-loader"
                          #+cmu "opal:"
                          #+(not cmu) user::Garnet-Opal-PathName)
         :verbose T)
)
  
;;; ================================================================

(defun Create-string (copy-string-obj agg)
  (let (obj)
    (setq obj (create-instance NIL opal:multifont-text
		   (:left (g-value copy-string-obj :left))
		   (:top (g-value copy-string-obj :top))
		   (:strings (opal:get-text copy-string-obj))))
    (opal:add-component agg obj)))

;;; ================================================================

(defun Do-Go (&key dont-enter-main-event-loop double-buffered-p)
  ;;; create a viewport
  (create-instance 'vp inter:interactor-window (:left 300) (:top 10)
			 (:width 650) (:height 400)
			 (:double-buffered-p double-buffered-p)
 			 (:title "GARNET TEXT") (:icon-title "Text"))
  (s-value vp :aggregate
	   (create-instance 'top-agg opal:aggregate
				 (:overlapping T)))
  (create-instance 'agg opal:aggregate
				 (:overlapping T)
				 (:left 0)(:top 0)(:width 650)(:height 400))
  (opal:add-component top-agg agg)

  (create-instance 'variable-font opal:font
		   (:family :serif)
		   (:face :roman)
		   (:size :large))

  (create-instance 'text-obj opal:multifont-text
			     (:strings
				(list
				  (list
				    (cons "left edit; middle create; right either"
					  variable-font))))
			     (:left 10) (:top 10))
  (opal:add-component agg text-obj)

  (create-instance 'special-obj opal:multifont-text
			(:strings
			   (list
			     (list
			       (cons "Press with shift-left anywhere to edit me"
				     variable-font))))
			(:left 10) (:top 40))
  (opal:add-component agg special-obj)

  (create-instance 'the-feedback-obj
			     opal:multifont-text
			     (:strings NIL)
			     (:visible NIL)
			     (:left (o-formula (first (gvl :box))))
			     (:top (o-formula (second (gvl :box)))))
  (opal:add-component top-agg the-feedback-obj)
 
  (opal:update vp)

  (create-instance 'edit-text-inter
				  inter:multifont-text-interactor
				  (:feedback-obj NIL)
				  (:start-event
				   (list :any-leftdown :except :shift-leftdown))
				  (:start-where
				   `(:element-of ,agg))
				  (:window vp)
				  (:abort-event :control-\g) ; \g so lower case
				  (:stop-event '(:any-mousedown :control-\j)))
  ;;-------------

   (create-instance 'create-text-inter
	      inter:multifont-text-interactor
	      (:feedback-obj the-feedback-obj)
	      (:start-where T)
	      (:window vp)
	      (:start-event :any-middledown)
	      (:abort-event :control-\g)
	      (:stop-event '(:any-mousedown :control-\j))
	      (:stop-action
	       #'(lambda (an-interactor obj-over stop-event)
		   ;; call parent to turn off feedback object visibility
		   (call-prototype-method an-interactor obj-over stop-event)
		   (let* ((feedback (g-value an-interactor :feedback-obj)))
		     (create-string feedback agg)
		     (opal:set-strings feedback NIL)))))

;;-------------

      (create-instance
		    'create-or-edit-text-inter
		    inter:multifont-text-interactor
		    (:feedback-obj (o-formula (if (eq :none (gvl :first-obj-over))
				; then create a new object, so use feedback-obj
					the-feedback-obj
				; else use object returned by mouse
					NIL)))
		    (:start-where `(:element-of-or-none ,agg :type
							,opal:multifont-text))
		    (:window vp)
		    (:start-event :any-rightdown)
		    (:abort-event :control-\g)
		    (:stop-event '(:any-mousedown :control-\j))
		    (:stop-action
		     #'(lambda (an-interactor obj-over stop-event)
			 ;; call parent to turn off feedback object visibility
			 (call-prototype-method an-interactor obj-over stop-event)
			 (when (eq :none (g-value an-interactor :first-obj-over))
			   (let* ((feedback (g-value an-interactor :feedback-obj)))
			     (create-string feedback agg)
			     (opal:set-strings feedback NIL))))))

;;-------------

      (create-instance 'anywhere-press inter:multifont-text-interactor
		    (:feedback-obj NIL)
		    (:start-where T)
		    (:window vp)
		    (:start-event :shift-leftdown)
		    (:stop-event '(:any-mousedown :control-\j))
		    (:obj-to-change special-obj))

  (opal:update vp)
  (Format T "~%Demo-Text:
  This creates and edits multi-line text objects.
  Type RETURN (ENTER) to go to a new line in the same string.
  Press with the left mouse button over a string to start editing it.
  Press with middle button to create a new string and start editing.
  Press with the right button to edit a string if over one, otherwise create one.
  Press with shift-left button over anywhere to edit the second string.
  Stop by pressing any mouse button or hitting ^J.
  Abort by typing ^G.~%")
  (format t "~%  Function key commands:
F1              exit main event loop
F2              set type face to roman
F3              set type face to italic
F4              set type face to bold
F5              set type face to bold-italic
F6              set type size one step bigger
F7              set type size one step smaller
F8              set type family to serif
F9              set type family to sans-serif
F10             set type family to fixed~%")
  (unless dont-enter-main-event-loop #-cmu (inter:main-event-loop))
  )


(defun do-stop ()
  (opal:destroy vp))

