34 lines
1.1 KiB
Scheme
34 lines
1.1 KiB
Scheme
;;; -*-Scheme-*-
|
|
;;;
|
|
;;; Porthole widget demo
|
|
;;; This only works with X11R5; there is no clock widget in X11R6-Xaw.
|
|
|
|
(require 'xaw)
|
|
|
|
(define top (application-initialize 'porthole))
|
|
|
|
(define form (create-managed-widget (find-class 'form) top))
|
|
|
|
(define panner (create-managed-widget (find-class 'panner) form))
|
|
(set-values! panner 'background-stipple 'grid2 'default-scale 15)
|
|
|
|
(define porthole (create-managed-widget (find-class 'porthole) form))
|
|
(set-values! porthole 'width 150 'height 150 'from-vert panner)
|
|
|
|
(define clock (create-managed-widget (find-class 'clock) porthole))
|
|
(set-values! clock 'width 300 'height 300)
|
|
|
|
(add-callback panner 'report-callback
|
|
(lambda (w xy)
|
|
(set-values! clock 'x (- (car xy)) 'y (- (cdr xy)))))
|
|
|
|
(add-callback porthole 'report-callback
|
|
(lambda (w args)
|
|
(multiple-value-bind (what x y sw sh cw ch) args
|
|
(set-values! panner 'slider-x x 'slider-y y)
|
|
(set-values! panner 'slider-width sw 'slider-height sh
|
|
'canvas-width cw 'canvas-height ch))))
|
|
|
|
(realize-widget top)
|
|
(context-main-loop (widget-context top))
|