Path: utzoo!utgpu!jarvis.csri.toronto.edu!mailrus!iuvax!cica!tut.cis.ohio-state.edu!snorkelwacker!bloom-beacon!TUB.BITNET!net
From: net@TUB.BITNET (Oliver Laumann)
Newsgroups: comp.lang.scheme
Subject: Re: X bindings in Scheme [long]
Message-ID: <9002011531.AA14140@tub.UUCP>
Date: 1 Feb 90 15:31:13 GMT
Sender: root@athena.mit.edu (Wizard A. Root)
Organization: The Internet
Lines: 99

> Actually, what I'd like is Xt (or, even better, Motif) from Scheme. It
> would be even better to be able to write widgets in Scheme!  The problem
> is that the architecture of Xt involves a lot of callbacks, and,
> generally (unless you're using the DECWRL compiler) you can't call
> Scheme from C.

The `Elk' Scheme interpreter provides an interface to the Motif widget
set.  It allows you to interactively `explore' the Motif widgets.

Here is a small example program that allows you to set up and use Motif
pulldown, popup, and option menus:


-----------------------------------------------------------------
;;; -*-Scheme-*-

(define (create-menu type parent args)
  (define grand-parent (widget-parent parent))
  (if (and (not (eq? grand-parent 'none))
           (eq? (widget-class grand-parent) (find-class 'menu-shell)))
      (set! parent grand-parent))
  (let ((shell (create-popup-shell (find-class 'menu-shell)
                                   parent 'width 100 'height 100)))
    (apply create-widget (find-class 'row-column) shell
                         'row-column-type type args)))

(define (create-popup-menu parent . args)
  (create-menu 'menu-popup parent args))

(define (create-pulldown-menu parent . args)
  (create-menu 'menu-pulldown parent args))

(define (create-option-menu parent . args)
    (apply create-managed-widget (find-class 'row-column) parent
                                 'row-column-type 'menu-option args))

(define (create-cascade-pulldown parent pulldown . args)
  (let ((button (create-managed-widget (find-class 'cascade-button) parent)))
    (set-values! button 'sub-menu-id pulldown)
    (apply set-values! button args)
    button))

(define (menu-add-item! type menu args)
  (let ((item (create-managed-widget (find-class type) menu)))
    (apply set-values! item args)
    item))

(define (menu-add-label! menu . args)
  (menu-add-item! 'label menu args))

(define (menu-add-separator! menu . args)
  (menu-add-item! 'separator menu args))

(define (menu-add-button! menu . args)
  (menu-add-item! 'push-button menu args))

-----------------------------------------------------------------

The following is a small example how you would use the above module to
create a popup menu:

-----------------------------------------------------------------

(require 'motif)
(load-widgets shell row-column cascade-button push-button label separator
              drawing-area)
(load 'menu-stuff)

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

(define w (create-managed-widget (find-class 'drawing-area) top))
(set-values! w 'width 350 'height 100)

(define menu (create-popup-menu w 'which-button 1))

(menu-add-label! menu 'label-string "Popup menu" 'font-list "9x15")
(menu-add-separator! menu)
(menu-add-button! menu 'label-string "item 1")
(menu-add-button! menu 'label-string "item 2")
(menu-add-button! menu 'label-string "item 3")
(menu-add-separator! menu)
(define quit-button (menu-add-button! menu 'label-string "quit"))

(add-callback quit-button 'activate-callback (lambda args (exit)))

(popup-menu-attach-to! menu w)

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

-----------------------------------------------------------------

If you have any questions about Elk drop me a letter.

Regards,
--
Oliver Laumann     net@TUB.BITNET     net@tub.cs.tu-berlin.de     net@tub.UUCP