← Back to branch summary

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

« back to all changes in this revision

Viewing changes to gcl-tk/demos/mkPlot.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/mkPlot.lisp
 
1
(in-package "TK")
 
2
;;# mkPlot w
 
3
;;
 
4
;; Create a top-level window containing a canvas displaying a simple
 
5
;; graph with data points that can be moved interactively.
 
6
;;
 
7
;; Arguments:
 
8
;;    w -       Name to use for new top-level window.
 
9
 
 
10
(defun mkPlot ( &optional (w '.plot ) &aux c font x y item)
 
11
    (toplevel w )
 
12
    (dpos w)
 
13
    (wm :title w  "Plot Demonstration " : w)
 
14
    (wm :iconname w "Plot")
 
15
    (setq c (conc w '.c))
 
16
 
 
17
    (message (conc w '.msg) :font :Adobe-Times-Medium-R-Normal-*-180-* :width 400 
 
18
            :bd 2 :relief "raised" :text "This window displays a canvas widget containing a simple 2-dimensional plot.  You can doctor the data by dragging any of the points with mouse button 1.")
 
19
    (canvas c :relief "raised" :width 450 :height 300)
 
20
    (button (conc w '.ok) :text "OK" :command  "destroy " : w)
 
21
    (pack (conc w '.msg) (conc w '.c) :side "top" :fill "x")
 
22
    (pack (conc w '.ok) :side "bottom" :pady 5)
 
23
 
 
24
    (setq font :Adobe-helvetica-medium-r-*-180-*)
 
25
 
 
26
    (funcall c :create "line" 100 250 400 250 :width 2)
 
27
    (funcall c :create "line" 100 250 100 50 :width 2)
 
28
    (funcall c :create "text" 225 20 :text "A Simple Plot" :font font :fill "brown")
 
29
    
 
30
    (sloop for i to 10 do 
 
31
        (setq x (+ 100 (* i 30)))
 
32
        (funcall c :create "line" x 250 x 245 :width 2)
 
33
        (funcall c :create "text" x 254 :text (* 10 i) :anchor "n" :font font))
 
34
 
 
35
    (sloop for i to 5 do  
 
36
        (setq y (- 250 (* i 40)))
 
37
        (funcall c :create "line" 100 y 105 y :width 2)
 
38
        (funcall c :create "text" 96 y :text  (* i 50) : ".0" :anchor "e" :font font))
 
39
 
 
40
    (sloop for point in '((12 56) (20 94) (33 98) (32 120) (61 180)
 
41
                          (75 160) (98 223))
 
42
       do
 
43
       (setq x (+ 100  (* 3 (nth 0 point))))
 
44
       (setq y (- 250 (truncate (* 4 (nth 1 point)) 5)))
 
45
       (setq item (funcall c :create "oval" (- x 6) (- y 6) 
 
46
                           (+ x 6) (+ y 6) :width 1 :outline "black" 
 
47
                           :fill "SkyBlue2" :return 'string ))
 
48
       (funcall c :addtag "point" "withtag" item)
 
49
    )
 
50
    
 
51
 
 
52
    (funcall c :bind "point" "<Any-Enter>"  c : " itemconfig current -fill red")
 
53
    (funcall c :bind "point" "<Any-Leave>"   c : " itemconfig current -fill SkyBlue2")
 
54
    (funcall c :bind "point" "<1>"  `(plotdown ',c |%x| |%y|))
 
55
    (funcall c :bind "point" "<ButtonRelease-1>"  c : " dtag selected")
 
56
    (bind c "<B1-Motion>" `(plotmove ',c |%x| |%y|))
 
57
)
 
58
 
 
59
(defvar plotlastX 0)
 
60
(defvar plotlastY 0)
 
61
 
 
62
(defun plotDown (w x y) 
 
63
    (funcall w :dtag "selected")
 
64
    (funcall w :addtag "selected" "withtag" "current")
 
65
    (funcall w :raise "current")
 
66
    (setq plotlastY y)
 
67
    (setq plotlastX x)
 
68
)
 
69
 
 
70
(defun plotMove (w x y &aux )
 
71
  (let ((oldx  plotlastX)
 
72
        (oldy  plotlastY))
 
73
    ;; Note plotmove may be called recursively... since
 
74
    ;; the funcall may call something which calls this.
 
75
    ;; so we must set the global plotlastx before the funcall..
 
76
    (setq plotlastx x)
 
77
    (setq plotlastY y) 
 
78
    (funcall w :move "selected" (- x oldx) (- y oldy))
 
79
    )
 
80
  )
 
81