;******************************************************************************
;
; File name    : mkTextBind.stk
; Creation     : Aug-2-1993
; Modification : Aug-2-1993
;
;******************************************************************************
;
; STk adaptation of the Tk widget demo.
;
; mkTextBind:
; Create a top-level window that illustrates how you can bind Tcl commands
; to regions of text in a text widget.
;
;******************************************************************************

(provide "mkTextBind")

(define (mkTextBind)
  (let ((bold ()) (normal ()))
    (catch (destroy .top-text-bind))
    (toplevel ".top-text-bind")
    (dpos .top-text-bind)
    (wm 'title .top-text-bind "Text Demonstration - Tag Bindings")
    (wm 'iconname .top-text-bind "Text Bindings")
    (button ".top-text-bind.ok" :text "OK" :command '(destroy .top-text-bind))
    (text ".top-text-bind.t" 
	  :relief "raised" :bd 2 :width 60 :height 28 :setgrid "true"
	  :font "-Adobe-Helvetica-Bold-R-Normal-*-120-*"
	  :yscroll ".top-text-bind.s 'set")
    (scrollbar ".top-text-bind.s" 
	       :relief "flat" :command ".top-text-bind.t 'yview")
    (pack .top-text-bind.ok :side "bottom" :fill "x")
    (pack .top-text-bind.s :side "right" :fill "y")
    (pack .top-text-bind.t :expand "yes" :fill "both")

    ; Set up display styles

    (if (equal? (tk 'colormodel .top-text-bind) "color")
	(begin
	  (set! bold '(:foreground "red"))
	  (set! normal '(:foreground "black")))
	(begin
	  (set! bold '(:foreground "white" :background "black"))
	  (set! normal '(:foreground "black" :background "white"))))

    (.top-text-bind.t 'insert "end"
"The same tag mechanism that controls display styles in text
widgets can also be used to associate STk commands with regions
of text, so that mouse or keyboard actions on the text cause
particular STk commands to be invoked.  For example, in the
text below the descriptions of the canvas demonstrations have
been tagged.  When you move the mouse over a demo description
the description lights up, and when you press button 3 over a
description then that particular demonstration is invoked.

This demo package contains a number of demonstrations of Tk's
canvas widgets.  Here are brief descriptions of some of the
demonstrations that are available:

")

    (insertWithTags .top-text-bind.t
"1. Samples of all the different types of items that can be
created in canvas widgets." 'd1)
    (insertWithTags .top-text-bind.t "\n\n")
    (insertWithTags .top-text-bind.t
"2. A simple two-dimensional plot that allows you to adjust
the positions of the data points." 'd2)
    (insertWithTags .top-text-bind.t "\n\n")
    (insertWithTags .top-text-bind.t
"3. Anchoring and justification modes for text items." 'd3)
    (insertWithTags .top-text-bind.t "\n\n")
    (insertWithTags .top-text-bind.t
"4. An editor for arrow-head shapes for line items." 'd4)
    (insertWithTags .top-text-bind.t "\n\n")
    (insertWithTags .top-text-bind.t
"5. A ruler with facilities for editing tab stops." 'd5)
    (insertWithTags .top-text-bind.t "\n\n")
    (insertWithTags .top-text-bind.t
"6. A grid that demonstrates how canvases can be scrolled." 'd6)

    (for-each (lambda (tag)
		(.top-text-bind.t 'tag 'bind tag "<Any-Enter>"
				`(.top-text-bind.t 'tag 'config ,tag ,@bold))
		(.top-text-bind.t 'tag 'bind tag "<Any-Leave>"
				`(.top-text-bind.t 'tag 'config ,tag ,@normal)))
	      '("d1" "d2" "d3" "d4" "d5" "d6"))

    (.top-text-bind.t 'tag 'bind 'd1 "<3>" '(mkItems))
    (.top-text-bind.t 'tag 'bind 'd2 "<3>" '(mkPlot))
    (.top-text-bind.t 'tag 'bind 'd3 "<3>" '(mkCanvText))
    (.top-text-bind.t 'tag 'bind 'd4 "<3>" '(mkArrow))
    (.top-text-bind.t 'tag 'bind 'd5 "<3>" '(mkRuler))
    (.top-text-bind.t 'tag 'bind 'd6 "<3>" '(mkScroll))

    (.top-text-bind.t 'mark 'set "insert" "0.0")
    (bind .top-text-bind "<Any-Enter>" '(focus .top-text-bind.t))))


; The procedure below inserts text into a given text widget and
; applies one or more tags to that text.  The arguments are:
;
; w		Window in which to insert
; text		Text to insert (it's inserted at the "insert" mark)
; args		One or more tags to apply to text.  If this is empty
;		then all tags are removed from the text.

(define (insertWithTags w text . args)
  (let ((start (w 'index 'insert)) (PIPO ()))
    (w 'insert 'insert text)
    (map (lambda (tag) (w 'tag 'remove tag start 'insert))
	 (tk-tag-names w start))
    (map (lambda (i) (w 'tag 'add i start 'insert)) args)))


(define (tk-tag-names w index)
  (let ((tag-names (w 'tag 'names index)))
    (cond ((equal? tag-names @undefined) ())
	  ((list? tag-names) tag-names)
	  (else (list tag-names)))))