Creating a widget hierarchy

[Sascha Ziemann <szi aibon ping de>]

Hi,

I spend some time on writing a program, that creates a widget
hierarchy from the gtk.defs file.  Here it is:

----------------------------------------------------------------------
#! /bin/sh
exec guile -e main -s "$0" "$@"
!#
;;
;; Time-stamp: <1999-01-16 17:51:44 szi>
;;
;; Print the Gtk+ widget tree from the gtk.defs file.
;;
;; Copyright (C) 1999 Sascha Ziemann
;;


(define (read-file filename)
  (let ((port (open-input-file filename))
	(data '()))
    (if port
	(let loop ((obj (read port)))
	  (if (eof-object? obj)
	      (close-input-port port)
	      (begin (set! data (append data (list obj)))
		     (loop (read port))))))
    (close-input-port port)
    data))

(define (find condition liste)
  (if (pair? liste)
      (let ((head (car liste))
	    (tail (cdr liste)))
	(if (condition head)
	    head
	    (find condition tail)))))

(define (grep condition liste)
  (let ((matching '()))
    (if (pair? liste)
	(let loop ((head (car liste))
		   (tail (cdr liste)))
	  (if (condition head)
	      (set! matching (append matching (cons head '()))))
	  (if (pair? tail)
	      (loop (car tail) (cdr tail)))))
    matching))

(define (split condition liste)
  (let ((matching '())
	(not-matching '()))
    (if (pair? liste)
	(let loop ((head (car liste))
		   (tail (cdr liste)))
	  (if (condition head)
	      (set! matching (append matching (cons head '())))
	      (set! not-matching (append not-matching (cons head '()))))
	  (if (pair? tail)
	      (loop (car tail) (cdr tail)))))
    (list matching not-matching)))


(define (build-widget-tree gtk.defs)
  (let ((gtk.objects (grep (lambda (obj)
			     (and (pair? obj)
				  (eq? (car obj) 'define-object)))
			   gtk.defs)))
    (let loop ((tree (cons (cadr (find (lambda (obj)
					 (null? (list-ref obj 2)))
				       gtk.objects)) '()))
	       (children (map (lambda (obj)
				(let ((parent (caddr obj)))
				  (if (null? (cdr parent))
				      (cons (car parent) (cons (cadr obj) '()))
				      (error "Can not handle multiple inheritance"))))
			      (grep (lambda (obj)
				      (not (null? (list-ref obj 2))))
				    gtk.objects))))
      (apply (lambda (children grandchildren)
	       (if (not (null? children))
		   (begin
		     (set-cdr! tree (map cdr children))
		     (for-each (lambda (child)
				 (loop child grandchildren))
			       (cdr tree)))))
	     (split (lambda (child)
		      (eq? (car child) (car tree)))
		    children))
      tree)))


(define (display-widget-tree tree)
  (define (display-list prefix last liste)
    (if (pair? liste)
	(let ((head (car liste))
	      (tail (cdr liste)))
	  (if (null? tail)
	      (display-tree prefix #t head)
	      (display-tree prefix #f head))
	  (display-list prefix last tail))))
  (define (display-tree prefix last tree)
    (if (pair? tree)
	(let ((head (car tree))
	      (tail (cdr tree)))
	  (display prefix)
	  (if (null? tail)
	      (begin
		(display "+---")
		(display head)
		(newline))
	      (begin
		(display "+-+-")
		(display head)
		(newline)
		(display-list (string-append prefix (if last "  " "| "))
			      #f tail))))))
  (display-tree "" #t tree))


(define (main argv)
  (if (< (length argv) 2)
      (display "Usage: print-widget-tree.scm <gtk.defs>\n")
      (let ((gtk.defs (read-file (cadr argv))))
	(display-widget-tree (build-widget-tree gtk.defs)))))
----------------------------------------------------------------------

This is the output for the gtk.defs of the current guile-gtk:

+-+-GtkObject
  +-+-GtkWidget
  | +-+-GtkContainer
  | | +---GtkFixed
  | | +---GtkTree
  | | +---GtkCList
  | | +-+-GtkBin
  | | | +---GtkEventBox
  | | | +-+-GtkWindow
  | | | | +---GtkFileSelection
  | | | | +---GtkFontSelectionDialog
  | | | | +---GtkColorSelectionDialog
  | | | | +-+-GtkDialog
  | | | |   +---GtkInputDialog
  | | | +---GtkHandleBox
  | | | +-+-GtkItem
  | | | | +---GtkTreeItem
  | | | | +-+-GtkMenuItem
  | | | | | +-+-GtkCheckMenuItem
  | | | | |   +---GtkRadioMenuItem
  | | | | +---GtkListItem
  | | | +-+-GtkFrame
  | | | | +---GtkAspectFrame
  | | | +---GtkViewport
  | | | +---GtkAlignment
  | | +-+-GtkBox
  | | | +-+-GtkButtonBox
  | | | | +---GtkHButtonBox
  | | | | +---GtkVButtonBox
  | | | +-+-GtkVBox
  | | | | +---GtkGammaCurve
  | | | | +---GtkColorSelection
  | | | +-+-GtkHBox
  | | |   +---GtkCombo
  | | |   +---GtkStatusbar
  | | +---GtkToolbar
  | | +---GtkTable
  | | +-+-GtkButton
  | | | +-+-GtkToggleButton
  | | | | +-+-GtkCheckButton
  | | | |   +---GtkRadioButton
  | | | +---GtkOptionMenu
  | | +-+-GtkMenuShell
  | | | +---GtkMenuBar
  | | | +---GtkMenu
  | | +---GtkScrolledWindow
  | | +---GtkList
  | | +---GtkNotebook
  | | +-+-GtkPaned
  | |   +---GtkHPaned
  | |   +---GtkVPaned
  | +-+-GtkMisc
  | | +-+-GtkLabel
  | | | +---GtkTipsQuery
  | | +---GtkPixmap
  | +---GtkArrow
  | +-+-GtkSeparator
  | | +---GtkHSeparator
  | | +---GtkVSeparator
  | +---GtkProgressBar
  | +-+-GtkEditable
  | | +-+-GtkEntry
  | | | +---GtkSpinButton
  | | +---GtkText
  | +-+-GtkDrawingArea
  | | +---GtkCurve
  | +---GtkPreview
  | +-+-GtkRange
  | | +-+-GtkScale
  | | | +---GtkHScale
  | | | +---GtkVScale
  | | +-+-GtkScrollbar
  | |   +---GtkHScrollbar
  | |   +---GtkVScrollbar
  | +-+-GtkRuler
  |   +---GtkHRuler
  |   +---GtkVRuler
  +-+-GtkData
    +---GtkAdjustment
    +---GtkTooltips

-- 
The second clause "open source code of derivative works" has been the
most controversial (and, potentially the most successful) aspect of
CopyLeft licensing.                             -- Halloween Document