home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / blt1.000 / blt1 / blt-1.7-for-STk / demos / barchart.stk next >
Encoding:
Text File  |  1995-02-11  |  4.5 KB  |  149 lines
  1. #!../test-stk -f
  2.  
  3. (define global list)    ; Kludge
  4.  
  5. ;;;;
  6. ;;;; Bitmap definitions
  7. ;;;;
  8. (blt_bitmap 'define 'pattern1 "(4 4) (01 02 04 08)")
  9. (blt_bitmap 'define 'pattern2 "(4 4) (08 04 02 01)")
  10. (blt_bitmap 'define 'pattern3 "(2 2) (01 02 )")
  11. (blt_bitmap 'define 'pattern4 "(4 4) (0f 00 00 00)")
  12. (blt_bitmap 'define 'pattern5 "(4 4) (01 01 01 01)")
  13. (blt_bitmap 'define 'pattern6 "(2 2) (01 00 )")
  14. (blt_bitmap 'define 'pattern7 "(4 4) (0f 01 01 01)")
  15. (blt_bitmap 'define 'pattern8 "(8 8) (ff 00 ff 00 ff 00 ff 00 )")
  16. (blt_bitmap 'define 'pattern9 "(4 4) (03 03 0c 0c)")
  17. (blt_bitmap 'define 'hobbes   "(25 25) (
  18.    00 00 00 00 00 00 00 00 00 c0 03 00 78 e0 07 00 fc f8 07 00 cc 07 04 00
  19.    0c f0 0b 00 7c 1c 06 00 38 00 00 00 e0 03 10 00 e0 41 11 00 20 40 11 00
  20.    e0 07 10 00 e0 c1 17 00 10 e0 2f 00 20 e0 6f 00 18 e0 2f 00 20 c6 67 00
  21.    18 84 2b 00 20 08 64 00 70 f0 13 00 80 01 08 00 00 fe 07 00 00 00 00 00
  22.    00 00 00 00 )")
  23.  
  24. ;;;;
  25. ;;;; Default Colors
  26. ;;;;
  27. (option 'add "*Blt_htext.Font"         "*Times-Bold-R*14*")
  28. (option 'add "*graph.xTitle"         "X Axis Label")
  29. (option 'add "*graph.yTitle"         "Y Axis Label")
  30. (option 'add "*graph.title"         "A Simple Barchart")
  31. (option 'add "*graph.xFont"         "*Times-Medium-R*12*")
  32. (option 'add "*graph.elemBackground"    "white")
  33. (option 'add "*graph.elemRelief"     "raised")
  34.  
  35. (define visual (winfo 'screenvisual *root*))
  36. (unless (or (eq? visual 'staticgray) (eq? visual 'grayscale))
  37.     (option 'add "*print.background" "yellow")
  38.     (option 'add "*quit.background"  "red"))
  39.  
  40. ;;;;
  41. ;;;; Header hypertext
  42. ;;;;
  43. (blt_htext '.header :text "This is an example of the blt_barchart widget. The barchart has many components; 
  44. x and y axis, legend, crosshairs, elements, etc.
  45. To create a postscript file \"bar.ps\", press the %%BEGIN 
  46. (button '.header.print :text \"Print\"
  47.                    :command  '(.graph 'postscript \"bar.ps\"
  48.                       :pagewidth '6.5i
  49.                       :pageheight '9i
  50.                       :landscape #t))
  51. (.header 'append .header.print)
  52. %% button.")
  53.  
  54. ;;;;" 
  55. ;;;; The barchart
  56. ;;;;
  57. (blt_barchart '.graph)
  58. (.graph 'xaxis 'configure :rotate 90 :command "FormatLabel")
  59.  
  60.  
  61. ;;;;
  62. ;;;; Footer hypertext
  63. ;;;;
  64.  
  65. (blt_htext '.footer :text "Hit the %%BEGIN
  66. (button '.footer.quit :text \"quit\" :command '(destroy *root*))
  67. (.footer 'append .footer.quit)
  68. %% button when you've seen enough.%%BEGIN
  69. (label '.footer.logo :bitmap '|BLT|)
  70. (.footer 'append .footer.logo :padx 20)
  71. %%")
  72.  
  73. ;;;;"
  74. ;;;; Callbacks  
  75. ;;;;
  76. (define (TurnOnHairs graph)
  77.   (bind graph "<Any-Motion>" '(|%W| 'crosshairs 'configure :position "@%x,%y")))
  78.  
  79. (define (TurnOffHairs graph)
  80.   (bind graph "<Any-Motion>" '(|%W| 'crosshairs 'configure :position "@%x,%y")))
  81.  
  82. (bind .graph "<Enter>" '(TurnOnHairs |%W|))
  83. (bind .graph "<Leave>" '(TurnOffHairs |%W|))
  84.  
  85. (define (FormatLabel w value)
  86.   ;; Determine the element name from the value
  87.   (let ((displaylist (w 'element 'show))
  88.      (index      (1- (inexact->exact (floor value)))))
  89.     (list-ref displaylist index)))
  90.  
  91.  
  92. (define names         '(One Two Three Four Five Six Seven Eight ))
  93. (define fgcolors     '(red green blue purple orange brown cyan navy))
  94. (define bgcolors    '(green blue purple orange brown cyan navy red))
  95. (define numColors    (length names))
  96.  
  97. (when (or (eq? visual 'staticgray) (eq? visual 'grayscale))
  98.       (set! fgcolors '(white white white white white white white white ))
  99.       (set! bgcolors '(black black black black black black black black )))
  100.  
  101.  
  102. (do ((i 0 (+ i 1)))
  103.     ((= i numColors))
  104.   (.graph 'element 'create (list-ref names i)
  105.      :data (format #f "~A ~A" (+ i 1) (+ i 1))
  106.      :fg (list-ref fgcolors i)
  107.      :bg (list-ref bgcolors i)
  108.      :stipple (format #f "pattern~A" (+ i 1))
  109.      :relief "raised"
  110.      :bd 2))
  111.  
  112. (.graph 'element 'create 'Nine    :data "9 -0.5" :fg "red" :relief "sunken")
  113. (.graph 'element 'create 'Ten    :data "10 2" :fg "seagreen" :stipple "hobbes"
  114.     :background "palegreen")
  115.  
  116. (.graph 'element 'create 'Eleven :data "11 3.3" :fg "blue")
  117.  
  118. (pack .header :padx 20 :pady 10)
  119. (pack .graph )
  120. (pack .footer :padx 20 :pady 10)
  121.     
  122. (wm 'min *root* 0 0)
  123.  
  124. ;;;;
  125. ;;;; Bindings
  126. ;;;;
  127.  
  128. (define info "")
  129.  
  130. (bind .graph "<B1-ButtonRelease>" '(|%W| 'crosshairs 'toggle))
  131. (bind .graph "<ButtonPress-3>"    '(begin
  132.                      (set! info (|%W| 'element 'closest %x %y))
  133.                      (if (eq? info "")
  134.                      (blt_bell)
  135.                      (format #t "~A\n" info))))
  136.     
  137. (define (TurnOnHairs graph)
  138.   (bind graph "<Any-Motion>" '(|%W| 'crosshairs 'configure :position "@%x,%y")))
  139.  
  140. (define (TurnOffHairs graph)
  141.   (bind graph "<Any-Motion>" '(|%W| 'crosshairs 'configure :position "@%x,%y")))
  142.  
  143. (bind .graph "<Enter>" '(TurnOnHairs |%W|))
  144. (bind .graph "<Leave>" '(TurnOffHairs |%W|))
  145.  
  146.  
  147. ;;;;
  148. ;;;; FEATURES.TCL has not been rewritten for STk. If someone can do it....
  149. ;;;;