← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to gcl-tk/demos/mkTextBind.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
gcl-tk/demos/mkTextBind.lisp
 
1
;;# mkTextBind w
 
2
;;
 
3
;; Create a top-level window that illustrates how you can bind
 
4
;; Tcl commands to regions of text in a text widget.
 
5
;;
 
6
;; Arguments:
 
7
;;    w -       Name to use for new top-level window.
 
8
 
 
9
(in-package "TK")
 
10
(defun mkTextBind (&optional (w '.bindings) &aux bold normal
 
11
                             (textwin (conc w '.t ) ))
 
12
    (if (winfo :exists w :return 'boolean) (destroy w))
 
13
    (toplevel w)
 
14
    (dpos w)
 
15
    (wm :title w "Text Demonstration - Tag Bindings")
 
16
    (wm :iconname w "Text Bindings")
 
17
    (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w))
 
18
    (scrollbar (conc w '.s) :relief "flat" :command (tk-conc w ".t yview"))
 
19
    (text textwin :relief "raised" :bd 2 :yscrollcommand
 
20
          (tk-conc w ".s set") :setgrid "true" 
 
21
            :width 60 :height 28 
 
22
            :font "-Adobe-Helvetica-Bold-R-Normal-*-120-*")
 
23
 
 
24
    (pack (conc w '.ok) :side "bottom" :fill "x")
 
25
    (pack (conc w '.s) :side "right" :fill "y")
 
26
    (pack textwin :expand "yes" :fill "both")
 
27
 
 
28
    ;; Set up display styles
 
29
 
 
30
    (if (equal (tk :colormodel w) "color")
 
31
        (progn 
 
32
          (setq bold '(:foreground "red"))
 
33
          (setq normal '(:foreground ""))
 
34
          );;else 
 
35
      (progn 
 
36
        (setq bold '(:foreground "white" :background "black"))
 
37
        (setq normal '(:foreground "" :background ""))
 
38
        ))
 
39
    (funcall textwin :insert 0.0
 
40
"The same tag mechanism that controls display styles in text
 
41
widgets can also be used to associate Tcl commands with regions
 
42
of text, so that mouse or keyboard actions on the text cause
 
43
particular Tcl commands to be invoked.  For example, in the
 
44
text below the descriptions of the canvas demonstrations have
 
45
been tagged.  When you move the mouse over a demo description
 
46
the description lights up, and when you press button 3 over a
 
47
description then that particular demonstration is invoked.
 
48
 
 
49
This demo package contains a number of demonstrations of Tk's
 
50
canvas widgets.  Here are brief descriptions of some of the
 
51
demonstrations that are available:
 
52
"
 
53
)
 
54
   (let ((blank-lines (format nil "~2%")))
 
55
    (insertWithTags textwin 
 
56
"1. Samples of all the different types of items that can be
 
57
created in canvas widgets." "d1")
 
58
    (insertWithTags textwin blank-lines)
 
59
    (insertWithTags textwin 
 
60
"2. A simple two-dimensional plot that allows you to adjust
 
61
the :positions of the data points." "d2")
 
62
    (insertWithTags textwin blank-lines)
 
63
    (insertWithTags textwin 
 
64
"3. Anchoring and justification modes for text items." "d3")
 
65
    (insertWithTags textwin blank-lines)
 
66
    (insertWithTags textwin 
 
67
"4. An editor for arrow-head shapes for line items." "d4")
 
68
    (insertWithTags textwin blank-lines)
 
69
    (insertWithTags textwin 
 
70
"5. A ruler with facilities for editing tab stops." "d5")
 
71
    (insertWithTags textwin blank-lines)
 
72
    (insertWithTags textwin 
 
73
"6. A grid that demonstrates how canvases can be scrolled." "d6"))
 
74
 
 
75
    (dolist (tag '("d1" "d2" "d3" "d4" "d5" "d6"))
 
76
        (funcall textwin :tag :bind tag "<Any-Enter>"
 
77
                 `(,textwin :tag :configure ,tag ,@bold))
 
78
        (funcall textwin :tag :bind tag "<Any-Leave>"
 
79
                 `(,textwin :tag :configure  ,tag ,@normal))
 
80
        )
 
81
    (funcall textwin :tag :bind "d1" "<3>" 'mkItems)
 
82
    (funcall textwin :tag :bind "d2" "<3>" 'mkPlot)
 
83
    (funcall textwin :tag :bind "d3" "<3>" "mkCanvText")
 
84
    (funcall textwin :tag :bind "d4" "<3>" "mkArrow")
 
85
    (funcall textwin :tag :bind "d5" "<3>" 'mkRuler)
 
86
    (funcall textwin :tag :bind "d6" "<3>" "mkScroll")
 
87
 
 
88
    (funcall textwin :mark 'set 'insert 0.0)
 
89
    (bind w "<Any-Enter>" (tk-conc "focus " w ".t"))
 
90
)
 
91
 
 
92
;; The procedure below inserts text into a given text widget and
 
93
;; applies one or more tags to that text.  The arguments are:
 
94
;;
 
95
;; w            Window in which to insert
 
96
;; text         Text to insert (it's :inserted at the "insert" mark)
 
97
;; args         One or more tags to apply to text.  (if :this is empty
 
98
;;              then all tags are removed from the text.
 
99
 
 
100
(defun insertWithTags (w text &rest args) 
 
101
  (let (( start (funcall w :index 'insert :return 'string)))
 
102
    (funcall w :insert 'insert text)
 
103
    (dolist (v (funcall w :tag "names" start :return 'list-strings))
 
104
            (funcall w :tag 'remove v start "insert"))
 
105
    (dolist (i args)
 
106
            (funcall w :tag 'add i start 'insert))))
 
107
    
 
108