home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / examples / xaw / porthole < prev    next >
Encoding:
Text File  |  1991-09-26  |  1.0 KB  |  34 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; Porthole widget demo
  4.  
  5. (require 'xwidgets)
  6. (load-widgets shell clock form panner porthole)
  7.  
  8. (define top (application-initialize 'porthole))
  9.  
  10. (define form (create-managed-widget (find-class 'form) top))
  11.  
  12. (define panner (create-managed-widget (find-class 'panner) form))
  13. (set-values! panner 'background-stipple 'grid2 'default-scale 15)
  14.  
  15. (define porthole (create-managed-widget (find-class 'porthole) form))
  16. (set-values! porthole 'width 150 'height 150 'from-vert panner)
  17.  
  18. (define clock (create-managed-widget (find-class 'clock) porthole))
  19. (set-values! clock 'width 300 'height 300)
  20.  
  21. (add-callback panner 'report-callback
  22.   (lambda (w xy)
  23.     (set-values! clock 'x (- (car xy)) 'y (- (cdr xy)))))
  24.  
  25. (add-callback porthole 'report-callback
  26.   (lambda (w args)
  27.     (multiple-value-bind (what x y sw sh cw ch) args
  28.       (set-values! panner 'slider-x x 'slider-y y)
  29.       (set-values! panner 'slider-width sw 'slider-height sh
  30.                       'canvas-width cw 'canvas-height ch))))
  31.  
  32. (realize-widget top)
  33. (context-main-loop (widget-context top))
  34.