;;; -*-Scheme-*-
;;;
;;; HP widgets demo

(require 'xwidgets)
(set! widget-load-path '(xhp xaw))
(load-widgets arrow bboard box pbutton sash scroll shell stext toggle)
(load-widgets valuator vpw)

(define con (create-context))
(define dpy (initialize-display con #f 'widgets 'demo))
(define top (create-shell 'widgets 'demo (find-class 'application-shell) dpy))

(define box (create-managed-widget (find-class 'box) top))

(define t1 (create-managed-widget (find-class 'toggle) box))
(set-values! t1 'traversal-type "highlight_enter" 'highlight-thickness 3)
(define t2 (create-managed-widget (find-class 'toggle) box 'square #f))
(set-values! t2 'traversal-type "highlight_enter" 'highlight-thickness 3)

(define vpw (create-managed-widget (find-class 'vpw) box))

(define a1 (create-managed-widget (find-class 'arrow) vpw))
(set-values! a1 'width 75 'height 75)
(set-values! (name->widget vpw 'sash) 'background "black")
(define a2 (create-managed-widget (find-class 'arrow) vpw))
(set-values! a2 'height 75 'arrow-direction "arrow_down")

(define val (create-managed-widget (find-class 'valuator) box))
(set-values! val 'slider-origin 20 'cursor "sb_right_arrow")
(add-callback val 'slider-moved (lambda (w x)
  (set-values! s 'string (format #f "~s" x))))

(define s (create-managed-widget (find-class 'static-text) box 'string "20"))
(set-values! s 'recompute-size #f)

(define sb (create-managed-widget (find-class 'scrollbar) box))
(set-values! sb 'width 20 'height 150)

(realize-widget top)

(define bb (create-managed-widget (find-class 'bboard) box))
(set-values! bb 'background-tile "50_foreground")
(do ((x '(0 40 0 40) (cdr x)) (y '(0 0 40 40) (cdr y))) ((null? x))
  (define s (create-managed-widget (find-class 'static-text) bb 
    'string (format #f "~s,~s" (car x) (car y)) 'x (car x) 'y (car y))))

(define p1 (create-managed-widget (find-class 'push-button) box))
(set-values! p1 'label "Quit Button")
(add-callback p1 'select (lambda (w) (exit)))

(context-main-loop con)
