;;; -*-Scheme-*-
;;;
;;; HP menu demo

(require 'xwidgets)
(load-widgets bboard cascade menubutton menusep popupmgr shell toggle)

(define (make-menu name attach-to)
  (let* ((sh (create-popup-shell (find-class 'shell) attach-to))
	 (menu (create-managed-widget name (find-class 'popup-manager) sh)))
    menu))

(define (add-pane where title attach-to)
  (let* ((sh (create-popup-shell (find-class 'shell) where))
	 (pane (create-managed-widget (find-class 'cascade) sh)))
    (set-values! pane 'title-string title 'attach-to attach-to)
    pane))

(define (add-button where label)
  (let ((b (create-managed-widget label (find-class 'menu-button) where)))
    (set-values! b 'label label)
    b))

(define (add-separator where style)
  (let ((s (create-managed-widget (find-class 'menu-separator) where)))
    (set-values! s 'separator-type style)
    s))

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

(define bb (create-managed-widget (find-class 'bboard) top))
(define bb1 (create-managed-widget (find-class 'bboard) bb))
(set-values! bb1 'width 300 'height 30 'layout "ignore")
(define bb2 (create-managed-widget (find-class 'bboard) bb))
(set-values! bb2 'y 30 'width 300 'height 150)

(define menu (make-menu 'menu bb2))

(define pane1 (add-pane menu "main menu" 'menu))

(add-button pane1 'search)
(add-button pane1 'change)
(add-button pane1 'create)
(add-button pane1 'destroy)
(define sep (add-separator pane1 "single_line"))
(add-button pane1 'help)
(add-button pane1 'quit)

(define pane2 (add-pane menu "change menu" 'change))

(add-button pane2 'typeface)
(add-button pane2 'font)
(add-button pane2 'help)

(define pane3 (add-pane menu "typeface menu" 'typeface))

(add-button pane3 'bold)
(add-button pane3 'italic)
(add-button pane3 'underlined)
(add-button pane3 'double\ underlined)
(add-button pane3 'crossed\ out)
(add-button pane3 'negative)
(add-button pane3 'faint)

(define pane4 (add-pane menu "font menu" 'font))

(do ((i 0 (1+ i))) ((= i 10))
  (add-button pane4 (format #f "font #~s" i)))

(add-callback (name->widget pane1 'quit) 'select (lambda (w) (exit)))

(define (change-separator-style _)
  (set-values! sep 'separator-type
    (if (car (get-values t2 'set))
        (if (car (get-values t3 'set))
	    "double_dashed_line"
	    "double_line")
        (if (car (get-values t3 'set))
	    "single_dashed_line"
	    "single_line"))))

(define (change-sticky _)
  (set-values! menu 'sticky-menus (car (get-values t1 'set))))

(define t1 (create-managed-widget (find-class 'toggle) bb1))
(set-values! t1 'x 10 'y 10 'label "sticky")
(add-callback t1 'select change-sticky)
(add-callback t1 'release change-sticky)

(define t2 (create-managed-widget (find-class 'toggle) bb1))
(set-values! t2 'x 90 'y 10 'label 'double-line)
(add-callback t2 'select change-separator-style)
(add-callback t2 'release change-separator-style)

(define t3 (create-managed-widget (find-class 'toggle) bb1))
(set-values! t3 'x 190 'y 10 'label 'dashed-line)
(add-callback t3 'select change-separator-style)
(add-callback t3 'release change-separator-style)

(realize-widget top)
(context-main-loop con)