;******************************************************************************
;
; File name     : mkCanvText.stk
; Creation date : Aug-5-1993
; Last update   : Aug-10-1993
;
;******************************************************************************
;
; STk adaptation of the Tk widget demo.
;
; mkCanvText:
; Create a top-level window containing a canvas displaying a text string
; and allowing the string to be edited and re-anchored.
; 
;******************************************************************************

(provide "mkCanvText")

(define c ())
(define cwn ())


(define (mkCanvText)
  (let ((font "-Adobe-helvetica-medium-r-*-240-*")
	(x ()) (y ()) (item ()) (color ()))
    (catch (destroy .top-canv-text))
    (toplevel ".top-canv-text")
    (dpos .top-canv-text)
    (wm 'title .top-canv-text "Canvas Text Demonstration")
    (wm 'iconname .top-canv-text "Text")

    (message ".top-canv-text.m"
	     :font "-Adobe-Times-Medium-R-Normal-*-180-*" :width 420
	     :relief "raised" :bd 2
	     :text "This window displays a string of text to demonstrate the text facilities of canvas widgets.  You can point, click, and type.  You can also select and then delete with Control-w.  You can copy the selection with button 2.  You can click in the boxes to adjust the position of the text relative to its positioning point or change its justification.")
    (canvas ".top-canv-text.c" :relief "raised" :width 500 :height 400)
    (set! c .top-canv-text.c)
    (set! cwn (widget-name c))
    (button ".top-canv-text.ok" :text "OK" :command '(destroy .top-canv-text))

    (pack .top-canv-text.m :side "top" :fill "both")
    (pack c :side "top" :expand "yes" :fill "both")
    (pack .top-canv-text.ok :side "bottom" :pady 5 :anchor "center")

    (c 'create 'rectangle 245 195 255 205 :outline "black" :fill "red")

    ; First, create the text item and give it bindings so it can be edited.
    
    (c 'addtag "text" 'withtag 
	[c 'create 'text 250 200 :text "This is just a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type.  You can also select and then delete with Control-w." :width 440 :anchor "n" :font font :justify "left"])
    (c 'bind 'text "<1>" `(textB1Press ,cwn %x %y))
    (c 'bind 'text "<B1-Motion>" `(textB1Move ,cwn %x %y))
    (c 'bind 'text "<3>" `(,cwn 'select 'adjust 'current "@%x,%y"))
    (c 'bind 'text "<Shift-B1-Motion>" `(textB1Move ,cwn %x %y))
    (c 'bind 'text "<KeyPress>" `(,cwn 'insert 'text 'insert "%A"))
    (c 'bind 'text "<Shift-KeyPress>" `(,cwn 'insert 'text 'insert "%A"))
    (c 'bind 'text "<Return>" `(,cwn 'insert 'text 'insert "\n"))
    (c 'bind 'text "<Control-h>" `(textBs ,cwn))
    (c 'bind 'text "<Delete>" `(textBs ,cwn))
    (c 'bind 'text "<Control-w>" `(,cwn 'dchars 'text "sel.first" "sel.last"))
    (c 'bind 'text "<2>" 
       `(,cwn 'insert 'text 'insert (selection 'get)))

    ; Next, create some items that allow the text's anchor position
    ; to be edited. 

    (set! x 50)
    (set! y 50)
    (set! color "LightSkyBlue1")
    (mkTextConfig c x y :anchor "se" color)
    (mkTextConfig c (+ x 30) y :anchor "s" color)
    (mkTextConfig c (+ x 60) y :anchor "sw" color)
    (mkTextConfig c x (+ y 30) :anchor "e" color)
    (mkTextConfig c (+ x 30) (+ y 30) :anchor "center" color)
    (mkTextConfig c (+ x 60) (+ y 30) :anchor "w" color)
    (mkTextConfig c x (+ y 60) :anchor "ne" color)
    (mkTextConfig c (+ x 30) (+ y 60) :anchor "n" color)
    (mkTextConfig c (+ x 60) (+ y 60) :anchor "nw" color)
    (set! item 
	  [c 'create 'rect (+ x 40) (+ y 40) (+ x 50) (+ y 50)
	      :outline "black" :fill "red"])
    (c 'bind item "<1>" `(,(widget-name c) 'itemconfig 'text :anchor "center"))
    (c 'create 'text (+ x 45) (- y 5) :text "Text Position" :anchor "s"
	:font "-Adobe-times-medium-r-normal--*-240-*" :fill "brown")

    ; Lastly, create some items that allow the text's justification to be
    ; changed.
    
    (set! x 350)
    (set! y 50)
    (set! color "SeaGreen2")
    (mkTextConfig c x y :justify "left" color)
    (mkTextConfig c (+ x 30) y :justify "center" color)
    (mkTextConfig c (+ x 60) y :justify "right" color)
    (c 'create 'text (+ x 45) (- y 5) :text "Justification" :anchor "s"
	:font "-Adobe-times-medium-r-normal--*-240-*" :fill "brown")

    (c 'bind 'config "<Enter>" `(textEnter ,cwn))
    (c 'bind 'config "<Leave>" `(tki-set ,cwn 'current :fill textConfigFill))))


(define textConfigFill "")

(define (mkTextConfig w x y option value color)
  (let ((item (w 'create 'rect x y (+ x 30) (+ y 30):outline "black"
		 :fill color :width 1)))
    (w 'bind item "<1>" `(,(widget-name w) 'itemconfig 'text ,option ,value))
    (w 'addtag "config" 'withtag item)))


(define (textEnter w)
  (set! textConfigFill (tki-get w 'current :fill))
  (tki-set w 'current :fill "black"))


(define (textB1Press w x y)
  (w 'icursor 'current (@ x y))
  (w 'focus 'current)
  (focus w)
  (w 'select 'from 'current (@ x y)))


(define (textB1Move w x y)
  (w 'select 'to 'current (@ x y)))


(define (textBs w)
  (let ((char (- (w 'index 'text 'insert) 1)))
    (if (>= char 0) (w 'dchar 'text char))))