← Back to branch summary

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

« back to all changes in this revision

Viewing changes to gcl-tk/demos/mkRuler.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/mkRuler.lisp
 
1
;;# mkRuler w
 
2
;;
 
3
;; Create a canvas demonstration consisting of a ruler.
 
4
;;
 
5
;; Arguments:
 
6
;;    w -       Name to use for new top-level window.
 
7
;; This file implements a canvas widget that displays a ruler with tab stops
 
8
;; that can be set individually.  The only procedure that should be invoked
 
9
;; from outside the file is the first one, which creates the canvas.
 
10
 
 
11
(in-package "TK")
 
12
 
 
13
(defun mkRuler (&optional (w '.ruler)) 
 
14
    (if (winfo :exists w :return 'boolean) (destroy w))
 
15
    (toplevel w)
 
16
    (dpos w)
 
17
    (wm :title w "Ruler Demonstration")
 
18
    (wm :iconname w "Ruler")
 
19
    (setq c (conc w '.c))
 
20
 
 
21
    (message (conc w '.msg) :font :Adobe-Times-Medium-R-Normal-*-180-* :width "13c" 
 
22
            :relief "raised" :bd 2 :text "This canvas widget shows a mock-up of a ruler.  You can create tab stops by dragging them out of the well to the right of the ruler.  You can also drag existing tab stops.  (if :you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button.")
 
23
    (canvas c :width "14.8c" :height "2.5c" :relief "raised")
 
24
    (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w))
 
25
    (pack (conc w '.msg) (conc w '.c) :side "top" :fill "x")
 
26
    (pack (conc w '.ok) :side "bottom" :pady 5)
 
27
    (setf *v* (gensym))
 
28
    (setf (get *v* 'grid) '.25c)
 
29
    (setf (get *v* 'left) (winfo :fpixels c "1c" :return t))
 
30
    (setf (get *v* 'right) (winfo :fpixels c "13c" :return t))
 
31
    (setf (get *v* 'top) (winfo :fpixels c "1c" :return t))
 
32
    (setf (get *v* 'bottom) (winfo :fpixels c "1.5c" :return t))
 
33
    (setf (get *v* 'size) (winfo :fpixels c '.2c :return t))
 
34
    (setf (get *v* 'normalStyle) '(:fill "black"))
 
35
    (if (equal (tk :colormodel c) "color")
 
36
        (progn 
 
37
          (setf (get *v* 'activeStyle) '(:fill "red" :stipple ""))
 
38
          (setf (get *v* 'deleteStyle)
 
39
                `(:stipple "@" : ,*tk-library* :"/demos/bitmaps/grey.25" 
 
40
                           :fill "red"))
 
41
          );;else 
 
42
      (progn 
 
43
        (setf (get *v* 'activeStyle) '(:fill "black" :stipple "" ))
 
44
        (setf (get *v* 'deleteStyle)
 
45
              `(:stipple "@" : ,*tk-library* : "/demos/bitmaps/grey.25"
 
46
                         :fill "black"))
 
47
        ))
 
48
 
 
49
    (funcall c :create "line" "1c" "0.5c" "1c" "1c" "13c" "1c" "13c" "0.5c" :width 1)
 
50
    (dotimes
 
51
     (i  12)
 
52
     (let (( x (+ i 1)))
 
53
       (funcall c :create "line" x :"c" "1c" x :"c" "0.6c" :width 1)
 
54
       (funcall c :create "line" x :".25c" "1c"  x :".25c" "0.8c" :width 1)
 
55
       (funcall c :create "line"  x :".5c" "1c"  x :".5c" "0.7c" :width 1)
 
56
       (funcall c :create "line"  x :".75c" "1c"  x :".75c" "0.8c" :width 1)
 
57
       (funcall c :create "text"  x :".15c" '.75c :text i :anchor "sw")
 
58
       ))
 
59
    (funcall c :addtag "well" "withtag"
 
60
             (funcall c :create "rect" "13.2c" "1c" "13.8c" "0.5c" 
 
61
                      :outline "black" :fill
 
62
                      (nth 4 (funcall c :config :background
 
63
                                      :return 'list-strings))))
 
64
    (funcall c :addtag "well" "withtag"
 
65
             (rulerMkTab c (winfo :pixels c "13.5c" :return t)
 
66
                         (winfo :pixels c '.65c :return t)))
 
67
 
 
68
    (funcall c :bind "well" "<1>" `(rulerNewTab ',c |%x| |%y|))
 
69
    (funcall c :bind "tab" "<1>" `(demo_selectTab  ',c |%x| |%y|))
 
70
    (bind c "<B1-Motion>" `(rulerMoveTab ',c |%x| |%y|))
 
71
    (bind c "<Any-ButtonRelease-1>" `(rulerReleaseTab ',c))
 
72
)
 
73
 
 
74
(defun rulerMkTab (c x y) 
 
75
 
 
76
    (funcall c :create "polygon" x y (+ x (get *v* 'size))
 
77
             (+ y (get *v* 'size))
 
78
             (- x (get *v* 'size))
 
79
             (+ y (get *v* 'size))
 
80
             :return 'string
 
81
             )
 
82
 
 
83
)
 
84
 
 
85
(defun rulerNewTab (c x y) 
 
86
 
 
87
    (funcall c :addtag "active" "withtag" (rulerMkTab c x y))
 
88
    (funcall c :addtag "tab" "withtag" "active")
 
89
    (setf (get *v* 'x) x)
 
90
    (setf (get *v* 'y) y)
 
91
    (rulerMoveTab c x y)
 
92
)
 
93
(defvar *recursive* nil)
 
94
;; prevent recursive calls
 
95
(defun rulerMoveTab (c x y &aux cx cy (*recursive* *recursive*) )
 
96
  (cond (*recursive* (return-from rulerMoveTab))
 
97
        (t (setq *recursive* t)))
 
98
  (if (equal (funcall c :find "withtag" "active" :return 'string) "")
 
99
      (return-from rulerMoveTab nil))
 
100
  (setq cx (funcall c :canvasx x (get *v* 'grid) :return t))
 
101
  (setq cy (funcall c :canvasy y :return t))
 
102
  (if (<  cx  (get *v* 'left))(setq cx (get *v* 'left)))
 
103
  (if (> cx  (get *v* 'right))(setq cx (get *v* 'right)))
 
104
 
 
105
  (if (and (>= cy (get *v* 'top)) (<= cy (get *v* 'bottom)))
 
106
      (progn 
 
107
        (setq cy (+ 2 (get *v* 'top)))
 
108
        (apply c :itemconf "active" (get *v* 'activestyle)))
 
109
    
 
110
    (progn 
 
111
      (setq cy (- cy (get *v* 'size) 2))
 
112
      (apply c :itemconf "active"(get *v* 'deletestyle)))
 
113
    )
 
114
  (funcall c :move "active" (- cx (get *v* 'x))
 
115
           (- cy (get *v* 'y)) )
 
116
  (setf (get *v* 'x) cx)
 
117
  (setf (get *v* 'y) cy)
 
118
  )
 
119
 
 
120
(defun demo_selectTab (c x y) 
 
121
 
 
122
    (setf (get *v* 'x) (funcall c :canvasx x (get *v* 'grid) :return t))
 
123
    (setf (get *v* 'y) (+ 2  (get *v* 'top)))
 
124
    (funcall c :addtag "active" "withtag" "current")
 
125
    (apply  c :itemconf "active" (get *v* 'activeStyle))
 
126
    (funcall c :raise "active")
 
127
)
 
128
 
 
129
(defun rulerReleaseTab (c )
 
130
 
 
131
    (if (equal (funcall c :find "withtag" "active" :return 'string)
 
132
               "") (return-from rulerReleaseTab nil))
 
133
 
 
134
    (if (not (eql (get *v* 'y) (+ 2 (get *v* 'top))))
 
135
        (funcall c :delete "active")
 
136
     (progn
 
137
        (apply c :itemconf "active" (get *v* 'normalStyle))
 
138
        (funcall c :dtag "active")
 
139
    )
 
140
))