33 lines
1.0 KiB
Scheme
33 lines
1.0 KiB
Scheme
;;; -*-Scheme-*-
|
|
;;;
|
|
;;; Scroll box demo
|
|
|
|
(require 'xaw)
|
|
|
|
(define items (list 'Helvetica 'Courier 'Times 'Palatino 'Zapf\ Chancery
|
|
'Zapf\ Dingbats))
|
|
(set-cdr! (last-pair items) items)
|
|
|
|
(define top (application-initialize 'scrollbox))
|
|
(define dpy (widget-display top))
|
|
|
|
(define dia-bits "\0\0\100\0\340\0\360\1\370\3\374\7\376\17\374\7\370\3\360\1\340\0\100\0\0\0")
|
|
(define dia (create-bitmap-from-data (display-root-window dpy) dia-bits 13 13))
|
|
|
|
(define box (create-managed-widget (find-class 'box) top))
|
|
(set-values! box 'width 200)
|
|
|
|
(define button (create-managed-widget (find-class 'command) box))
|
|
(set-values! button 'bitmap dia)
|
|
|
|
(define label (create-managed-widget (find-class 'label) box))
|
|
(set-values! label 'width 130 'label (car items) 'resize #f 'justify 'left
|
|
'font (open-font dpy "*courier-bold-r-normal--14*"))
|
|
(add-callback button 'callback
|
|
(lambda (w)
|
|
(set! items (cdr items))
|
|
(set-values! label 'label (car items))))
|
|
|
|
(realize-widget top)
|
|
(context-main-loop (widget-context top))
|