/src/slider.sc

https://bitbucket.org/bunny351/ezd · Scala · 294 lines · 265 code · 29 blank · 0 comment · 3 complexity · a24aaa4c793e9f5906c878e946a0d47e MD5 · raw file

  1. ;;; ezd - easy drawing for X11 displays.
  2. ;;;
  3. ;;; A SLIDER is a horizontal or vertical rectangular area with a movable
  4. ;;; indicator. The operations supported are:
  5. ;;;
  6. ;;; Click button 1 on background move indicator one "jump" toward
  7. ;;; the mouse and then evaluate the action.
  8. ;;;
  9. ;;; Click button 2 on background move indicator to that position and
  10. ;;; then evaluate the action.
  11. ;;;
  12. ;;; Drag indicator with button 1 follow the mouse, evaluating the action
  13. ;;; as it moves.
  14. ;;;
  15. ;;; The following attributes are accessible:
  16. ;;;
  17. ;;; X
  18. ;;; Y
  19. ;;; WIDTH
  20. ;;; HEIGHT
  21. ;;; INDICATOR-SIZE
  22. ;;; MIN-VALUE
  23. ;;; MAX-VALUE
  24. ;;; VALUE
  25. ;;; JUMP-SIZE
  26. ;;; ACTION
  27. ;;; FOREGROUND
  28. ;;; BACKGROUND
  29. ;;; FOREGROUND-STIPPLE
  30. ;;;
  31. ;;; DELETE-OBJECT
  32. ;;; ATTRIBUTES
  33. ;* Copyright 1990-1993 Digital Equipment Corporation
  34. ;* All Rights Reserved
  35. ;*
  36. ;* Permission to use, copy, and modify this software and its documentation is
  37. ;* hereby granted only under the following terms and conditions. Both the
  38. ;* above copyright notice and this permission notice must appear in all copies
  39. ;* of the software, derivative works or modified versions, and any portions
  40. ;* thereof, and both notices must appear in supporting documentation.
  41. ;*
  42. ;* Users of this software agree to the terms and conditions set forth herein,
  43. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  44. ;* right and license under any changes, enhancements or extensions made to the
  45. ;* core functions of the software, including but not limited to those affording
  46. ;* compatibility with other hardware or software environments, but excluding
  47. ;* applications which incorporate this software. Users further agree to use
  48. ;* their best efforts to return to Digital any such changes, enhancements or
  49. ;* extensions that they make and inform Digital of noteworthy uses of this
  50. ;* software. Correspondence should be provided to Digital at:
  51. ;*
  52. ;* Director of Licensing
  53. ;* Western Research Laboratory
  54. ;* Digital Equipment Corporation
  55. ;* 250 University Avenue
  56. ;* Palo Alto, California 94301
  57. ;*
  58. ;* This software may be distributed (but not offered for sale or transferred
  59. ;* for compensation) to third parties, provided such third parties agree to
  60. ;* abide by the terms and conditions of this notice.
  61. ;*
  62. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  63. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  64. ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT
  65. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  66. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  67. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  68. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  69. ;* SOFTWARE.
  70. (module slider)
  71. (include "commands.sch")
  72. (include "ginfo.sch")
  73. (include "interact.sch")
  74. (include "events.sch")
  75. (include "match.sch")
  76. (include "ezd.sch")
  77. (define (MAKE-SLIDER name x y width height indicator-size min-value max-value
  78. value jump-size action foreground-color background-color stipple)
  79. (define FOREGROUND (or foreground-color 'black))
  80. (define BACKGROUND (or background-color 'white))
  81. (define VERTICAL (< width height))
  82. (define FIXED-VALUE (and (fixed? indicator-size) (fixed? min-value)
  83. (fixed? max-value) (fixed? value)
  84. (fixed? jump-size)))
  85. (define PAD (if (< width height) (quotient width 15) (quotient height 15)))
  86. (define INSIDE #f)
  87. (define WAS-INSIDE #f)
  88. (define RESTORE-CURSOR #f)
  89. (define USER-RANGE (+ indicator-size (- max-value min-value)))
  90. (define INDICATOR
  91. (ceiling (* (max height width) (/ indicator-size user-range))))
  92. (define INDICATOR-NAME (string->symbol (string-append (symbol->string name)
  93. "-INDICATOR")))
  94. (define (VALUE->D)
  95. (* (max height width) (/ (- value min-value) user-range)))
  96. (define (MOUSE->VALUE)
  97. (let ((value (+ (* user-range
  98. (/ (if vertical
  99. (- *user-event-y* y)
  100. (- *user-event-x* x))
  101. (max height width)))
  102. (- min-value (/ indicator-size 2)))))
  103. (if fixed-value (inexact->exact (round value)) value)))
  104. (define (DRAW-BACKGROUND)
  105. (ezd `(object ,name
  106. (fill-rectangle ,x ,y ,width ,height ,foreground)
  107. ,(if vertical
  108. `(fill-rectangle ,(+ x pad) ,y
  109. ,(- width pad pad) ,height ,background)
  110. `(fill-rectangle ,x ,(+ y pad)
  111. ,width ,(- height pad pad) ,background)))))
  112. (define (DRAW-INDICATOR)
  113. (ezd `(object ,indicator-name
  114. ,(if vertical
  115. `(fill-rectangle ,x ,(+ y (value->d))
  116. ,width ,indicator ,foreground
  117. ,@(if stipple (list stipple) '()))
  118. `(fill-rectangle ,(+ x (value->d)) ,y
  119. ,indicator ,height ,foreground
  120. ,@(if stipple (list stipple) '()))))))
  121. (define (ENTER)
  122. (cond (inside)
  123. ((and (not *mouse-button1*) (not *mouse-button2*))
  124. (set! inside #t)
  125. (set! restore-cursor `(restore-cursor ,*user-event-window*))
  126. (ezd `(save-cursor ,*user-event-window*)
  127. `(set-cursor ,*user-event-window*
  128. ,(if vertical
  129. 'xc_sb_v_double_arrow
  130. 'xc_sb_h_double_arrow))))
  131. ((and *mouse-button1* (not *mouse-button2*)
  132. (eq? was-inside 'on))
  133. (set! inside 'on)
  134. (set! restore-cursor `(restore-cursor ,*user-event-window*))
  135. (ezd `(save-cursor ,*user-event-window*)
  136. `(set-cursor ,*user-event-window*
  137. ,(if vertical
  138. 'xc_sb_v_double_arrow
  139. 'xc_sb_h_double_arrow)))
  140. (motion))))
  141. (define (EXIT)
  142. (when (and inside
  143. (not (and (eq? *user-event-window*
  144. (car *user-event-misc*))
  145. (eq? *user-event-drawing*
  146. (cadr *user-event-misc*))
  147. (or (eq? name (caddr *user-event-misc*))
  148. (eq? indicator-name
  149. (caddr *user-event-misc*))))))
  150. (set! was-inside inside)
  151. (set! inside #f)
  152. (set! restore-cursor #f)
  153. (ezd `(restore-cursor ,*user-event-window*))))
  154. (define (BUTTON1DOWN)
  155. (let ((mv (mouse->value))
  156. (ind2 (/ indicator-size 2)))
  157. (cond ((<= mv (- value ind2)) (set! inside 'before))
  158. ((>= mv (+ value ind2)) (set! inside 'after))
  159. (else (set! inside 'on)))))
  160. (define (TAKE-ACTION new-value)
  161. (set! value (max min-value (min max-value new-value)))
  162. (draw-indicator)
  163. (set! *user-event-misc* (list value))
  164. (if (procedure? action) (action) (eval action))
  165. (ezd '(draw-now)))
  166. (define (BUTTON1UP)
  167. (case inside
  168. ((before) (take-action (- value jump-size)))
  169. ((after) (take-action (+ value jump-size)))
  170. ((on) #t)
  171. (else (enter))))
  172. (define (BUTTON2UP) (if inside (take-action (mouse->value)) (enter)))
  173. (define (MOTION)
  174. (if (and *mouse-button1* (eq? inside 'on))
  175. (take-action (mouse->value))))
  176. (define (GET-ATTRIBUTES)
  177. (map (lambda (a)
  178. (case a
  179. ((X) x)
  180. ((Y) y)
  181. ((WIDTH) width)
  182. ((HEIGHT) height)
  183. ((INDICATOR-SIZE) indicator-size)
  184. ((MIN-VALUE) min-value)
  185. ((MAX-VALUE) max-value)
  186. ((VALUE) value)
  187. ((JUMP-SIZE) value)
  188. ((ACTION) action)
  189. ((FOREGROUND) foreground)
  190. ((BACKGROUND) background)
  191. ((FOREGROUND-STIPPLE) stipple)
  192. ((ATTRIBUTES) '(x y width height indicator-size
  193. min-value max-value value
  194. jump-size action foreground
  195. background foreground-stipple
  196. delete-object attributes))
  197. (else (ezd-error 'check-button
  198. "Illegal attribute: ~s" a))))
  199. *user-event-misc*))
  200. (define (SET-ATTRIBUTES)
  201. (let ((delete #f))
  202. (for-each
  203. (lambda (a)
  204. (cond ((match? (X number?) a)
  205. (set! x (cadr a)))
  206. ((match? (Y number?) a)
  207. (set! y (cadr a)))
  208. ((match? (WIDTH positive-number?) a)
  209. (set! width (cadr a)))
  210. ((match? (HEIGHT positive-number?) a)
  211. (set! height (cadr a)))
  212. ((match? (INDICATOR-SIZE non-negative?) a)
  213. (set! indicator-size (cadr a)))
  214. ((match? (MIN-VALUE number?) a)
  215. (set! min-value (cadr a)))
  216. ((match? (MAX-VALUE number?) a)
  217. (set! max-value (cadr a)))
  218. ((match? (VALUE number?) a)
  219. (set! value (cadr a)))
  220. ((match? (JUMP-SIZE non-negative?) a)
  221. (set! jump-size (cadr a)))
  222. ((match? (ACTION any?) a)
  223. (set! action (cadr a)))
  224. ((match? (FOREGROUND color?) a)
  225. (set! foreground (cadr a)))
  226. ((match? (BACKGROUND color?) a)
  227. (set! background (cadr a)))
  228. ((match? (FOREGROUND-STIPPLE stipple?) a)
  229. (set! stipple (cadr a)))
  230. ((equal? '(DELETE-OBJECT) a)
  231. (set! delete #t))
  232. (else (ezd-error 'slider
  233. "Illegal attribute: ~s" a))))
  234. *user-event-misc*)
  235. (if restore-cursor (ezd restore-cursor))
  236. (if delete
  237. (ezd `(object ,name)
  238. `(when ,name * #f)
  239. `(object ,indicator-name)
  240. `(when ,indicator-name * #f))
  241. (make-slider name x y width height indicator-size
  242. min-value max-value value jump-size action
  243. foreground background stipple))))
  244. (draw-background)
  245. (draw-indicator)
  246. (ezd `(when ,indicator-name enter ,enter)
  247. `(when ,indicator-name exit ,exit)
  248. `(when ,indicator-name button1down ,button1down)
  249. `(when ,indicator-name button1up ,button1up)
  250. `(when ,indicator-name button2up ,button2up)
  251. `(when ,indicator-name motion ,motion)
  252. `(when ,name enter ,enter)
  253. `(when ,name exit ,exit)
  254. `(when ,name button1down ,button1down)
  255. `(when ,name button1up ,button1up)
  256. `(when ,name button2up ,button2up)
  257. `(when ,name motion ,motion)
  258. `(when ,name get-attributes ,get-attributes)
  259. `(when ,name set-attributes ,set-attributes)))
  260. (define-ezd-command
  261. `(slider ,symbol? ,number? ,number? ,positive-number? ,positive-number?
  262. ,positive-number? ,number? ,number? ,number? ,non-negative?
  263. ,any? (optional ,color?) (optional ,color?) (optional ,stipple?))
  264. "(slider name x y width height indicator-size min-value max-value value jump-size action [foreground [background]] [stipple])"
  265. make-slider)