38 lines
857 B
Scheme
38 lines
857 B
Scheme
;;; -*-Scheme-*-
|
|
;;;
|
|
;;; Tree widget demo
|
|
|
|
(define (make-tree tree parent x)
|
|
(let ((p (create-managed-widget (find-class 'label) tree 'label (car x))))
|
|
(if parent (set-values! p 'tree-parent parent))
|
|
(do ((l (cdr x) (cdr l))) ((null? l))
|
|
(if (pair? (car l))
|
|
(make-tree tree p (car l))
|
|
(let ((w (create-managed-widget (find-class 'label) tree
|
|
'label (car l))))
|
|
(set-values! w 'tree-parent p))))))
|
|
|
|
(require 'xaw)
|
|
|
|
(define top (application-initialize 'tree))
|
|
|
|
(define tree (create-managed-widget (find-class 'tree) top))
|
|
|
|
(make-tree tree #f
|
|
'(world
|
|
(america
|
|
(north
|
|
usa canada)
|
|
(middle
|
|
mexico cuba)
|
|
(south
|
|
brasilia ecuador chile))
|
|
(europe
|
|
france britain germany)
|
|
(asia
|
|
japan korea)
|
|
(antarctica)))
|
|
|
|
(realize-widget top)
|
|
(context-main-loop (widget-context top))
|