;******************************************************************************
;
; File name    : mkStyles.stk
; Creation     : Jul-30-1993
; Modification : Aug-6-1993
;
;******************************************************************************
;
; STk adaptation of the Tk widget demo.
;
; mkStyle:
; Create a top-level window with a text widget that demonstrates the various
; display styles that are available in texts.
;
;******************************************************************************

(provide "mkStyles")

(define (mkStyles)
  (catch (destroy .top-styles))
  (toplevel ".top-styles")
  (dpos .top-styles)
  (wm 'title .top-styles "Text Demonstration - Display Styles")
  (wm 'iconname .top-styles "Text Styles")

  (button ".top-styles.ok" :text "OK" :command '(destroy .top-styles))
  (text ".top-styles.t"
	:relief "raised" :bd 2 :width 70 :height 28 :setgrid "true"
	:wrap "word" :yscroll ".top-styles.s 'set")
  (scrollbar ".top-styles.s" :relief "flat" :command ".top-styles.t 'yview")
  (pack .top-styles.ok :side "bottom" :fill "x")
  (pack .top-styles.s :side "right" :fill "y")
  (pack .top-styles.t :expand "yes" :fill "both")

  ; Set up display styles

  (.top-styles.t 'tag 'config "bold"
		:font "-Adobe-Courier-Bold-O-Normal-*-120-*")
  (.top-styles.t 'tag 'config "big"
		:font "-Adobe-Courier-Bold-R-Normal-*-140-*")
  (.top-styles.t 'tag 'config "verybig"
		:font "-Adobe-Helvetica-Bold-R-Normal-*-240-*")

  (if (equal? (tk 'colormodel .top-styles) "color")
      (begin
	(.top-styles.t 'tag 'config "color1" :background "#eed5b7")
	(.top-styles.t 'tag 'config "color2" :foreground "red")
	(.top-styles.t 'tag 'config "raised"
		      :background "#eed5b7" :relief "raised" :borderwidth 1)
	(.top-styles.t 'tag 'config "sunken"
		      :background "#eed5b7" :relief "sunken" :borderwidth 1))
      (begin
	(.top-styles.t 'tag 'config "color1"
		      :background "black" :foreground "white")
	(.top-styles.t 'tag 'config "color2"
		      :background "black" :foreground "white")
	(.top-styles.t 'tag 'config "raised" 
		      :background "white" :relief "raised" :borderwidth 1)
	(.top-styles.t 'tag 'config "sunken"
		      :background "white" :relief "sunken" :borderwidth 1)))

  (.top-styles.t 'tag 'config "bgstipple"
		:background "black" :borderwidth 0 :bgstipple "gray25")
  (.top-styles.t 'tag 'config "fgstipple" :fgstipple "gray50")
  (.top-styles.t 'tag 'config "underline" :underline "on")

;*** A priori on ne peut pas utiliser les abrev :bd :bg :fg dans le tags ***

  (.top-styles.t 'insert "0.0" "Text widgets like this one allow you to display information in a variety of styles.  Display styles are controlled using a mechanism called ")
  (insertWithTags .top-styles.t "tags" 'bold)
  (insertWithTags .top-styles.t ". Tags are just textual names that you can apply to one or more ranges of characters within a text widget.  You can configure tags with various display styles.  If you do this, then the tagged characters will be displayed with the styles you chose.  The available display styles are:\n")

  (insertWithTags .top-styles.t "\n1. Font." 'big)
  (insertWithTags .top-styles.t "  You can choose any X font, ")
  (insertWithTags .top-styles.t "large" 'verybig)
  (insertWithTags .top-styles.t " or ")
  (insertWithTags .top-styles.t "small.\n")

  (insertWithTags .top-styles.t "\n2. Color." 'big)
  (insertWithTags .top-styles.t "  You can change either the ")
  (insertWithTags .top-styles.t "background" 'color1)
  (insertWithTags .top-styles.t " or ")
  (insertWithTags .top-styles.t "foreground" 'color2)
  (insertWithTags .top-styles.t " color, or ")
  (insertWithTags .top-styles.t "both" 'color1 'color2)
  (insertWithTags .top-styles.t ".\n")

  (insertWithTags .top-styles.t "\n3. Stippling." 'big)
  (insertWithTags .top-styles.t "  You can cause either the ")
  (insertWithTags .top-styles.t "background" 'bgstipple)
  (insertWithTags .top-styles.t " or ")
  (insertWithTags .top-styles.t "foreground" 'fgstipple)
  (insertWithTags .top-styles.t "\ninformation to be drawn with a stipple fill instead of a solid fill.\n")

  (insertWithTags .top-styles.t "\n4. Underlining." 'big)
  (insertWithTags .top-styles.t "  You can ")
  (insertWithTags .top-styles.t "underline" 'underline)
  (insertWithTags .top-styles.t " ranges of text.\n")

  (insertWithTags .top-styles.t "\n5. 3-D effects." 'big)
  (insertWithTags .top-styles.t "  You can arrange for the background to be drawn with a border that makes characters appear either ")
  (insertWithTags .top-styles.t "raised" 'raised)
  (insertWithTags .top-styles.t " or ")
  (insertWithTags .top-styles.t "sunken" 'sunken)
  (insertWithTags .top-styles.t ".\n")

  (insertWithTags .top-styles.t "\n6. Yet to come." 'big)
  (insertWithTags .top-styles.t "  More display effects will be coming soon, such as the ability to change line justification and perhaps line spacing.")

  (.top-styles.t 'mark 'set "insert" "0.0")
  (bind .top-styles "<Any-Enter>" '(focus .top-styles.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)))))