#!/usr/local/bin/stk -f
;;;;
;;;; a m i b . s t k l o s  --  A mini interface builder. I hope it will serve 
;;;;			        as the basis of something more complete...
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works.  Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.  
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 22-May-1995 14:56
;;;; Last file update:  3-Jun-1995 00:43


;;  <Destroy> doit appliquer destroy a tous les fils d'un fenetre
;; Quand on depose trouver la toplevel qui est la mere
;; Grille
;; Faut il laisser les binding partout? Si oui alors oter les binds  dans deposit

(require "Tk-classes")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Definitions.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define *amib-version*		 0.2)
(define *pretty-names*		(make-hash-table))
(define *current-file*		#f)
(define *special-slots*		'("id" "eid" "parent"))
(define @ 			address-of)


;;;;
;;;; All the widgets and their defaults
;;;;
(define *table-defaults*
  `(("Button"		,<Button>
			(:text "Button"))
    ("Canvas"		,<Canvas>
			(:width 200 :height 100 :borderwidth 3 :relief "raised"))
    ("Check button"	,<Check-button>	
			(:text "Check" :anchor "w"))
    ("Frame"		,<Frame>
			(:geometry "50x50" :relief "ridge" :border-width 2))
    ("Label"		,<Label>
			(:text "Label"))
    ("Labeled entry"	,<Labeled-entry>
			(:title "Title"))
    ("Listbox"		,<Listbox>
		        (:relief raised))
    ("Message"		,<Message>
			(:text "Message" :relief "raised" :aspect 1000))
   ("Radio button"	,<Radio-button>	
			(:text "Radio" :anchor "w"))
   ("Scale"		,<Scale>
			())	))

(define *help-text* '("STF-0.1" 
"			AMIB  (A Mini Interface Builder)

To create a widget, click on the widget listbox and drop the widget on the Toplevel

To resize a widget, place the mouse on the desired widget and click on <Shift-1>
Handles will appear for resizing. 

To move a widget, place the mouse on the desired widget and click on <Shift-1>
Central handle permits to move the widget.

To customize a widget click on <Button-2>. A menu will appear; Using \"Packed\" will use the pack geometry manager rather than place.

To delete a widget, place the mouse on the desired widget and click on <Button-3>."
 ((bold-italic-12 ("11.91" "11.95" "11.125" "11.130")) (italic-12 ("3.3" "3.9" "5.3" "5.9" "8.3" "8.7" "11.3" "11.12")) (roman-18 ("1.3" "1.8")) (roman-14 ("1.10" "1.13" "1.17" "1.18" "1.27" "1.28")) (roman-12 ("5.71" "5.80" "8.69" "9.0" "11.31" "11.42" "13.71" "13.82" "14.0" "15.0")) (normal ("11.42" "11.91" "11.95" "11.125" "11.130" "13.71" "13.82" "14.0")))))

(define *about-text* '("STF-0.1" 
"			AMIB  (A Mini Interface Builder)

This is only a simple demo. A volunteer to make it more friendly would be greatly appreciated.

Erick Gallesio (eg@unice.fr)"
((italic-12 ("5.16" "5.27")) (roman-18 ("1.3" "1.8")) (roman-14 ("1.10" "1.13" "1.17" "1.18" "1.27" "1.28")))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Drag and Drop stuff
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define d-n-d-widget   #f)	; The widget whih we can drag and drop
(define d-n-d-defaults #f)	; Its defaults

;; Default bindings
(bind 'all "<Motion>"		'(Drag-n-Drop-Motion (+ |%X| 1) (+ |%Y| 1)))
(bind 'all "<ButtonRelease-1>"	'(Drag-n-Drop-Finish (Id->instance |%W|) %x %y))

;; Those binding permit to use AMIB on code written by hand (and not with AMIB)
;; Useful? If this behaviour is not wanted. Delete the 3 following lines.
(bind 'all "<Button-2>"    '(edit-widget (Id->instance |%W|)))
(bind 'all "<Button-3>"    '(destroy (Id->instance |%W|)))
(bind 'all "<Shift-1>"     '(widget-resize-start (Id->instance |%W|) |%X| |%Y|))


(define (make-drag-n-drop-widget type initargs)
  (let ((m (make <Menu> :border-width 12 :background "Blue")))
    (pack (apply make type :parent m initargs) :padx 2 :pady 2)
    m))

(define (Drag-n-Drop-Motion x y)
  (if d-n-d-widget
      (menu-post d-n-d-widget x  y)))

(define (Drag-n-Drop-deposit parent x y)
  (let ((w (apply make (car d-n-d-defaults) :parent parent (cadr d-n-d-defaults))))
    (let ((pw     (winfo 'width  parent))
	  (ph     (winfo 'height parent))
	  (width  0)
	  (height 0)
	  (relx   0)
	  (rely   0))
      ;; Calculate the relative width and height of the widget 
      (unless (= pw 0)
	 (set! width (/ (winfo 'width d-n-d-widget) pw))
	 (set! relx  (/ x pw)))
      (unless (= ph 0)
	 (set! height (/ (winfo 'height d-n-d-widget) ph))
	 (set! rely (/ y ph)))
      
      ;; Associate bindings for manipulating the new widget
      (bind w "<Button-2>"    `(edit-widget ,(@ w)))
      (bind w "<Button-3>"    `(destroy ,(@ w)))
      (bind w "<Shift-1>"     `(widget-resize-start ,(@ w) |%X| |%Y|))
      (place w :x x :y y :relx relx :rely rely :relwidth width :relheight height)
      (raise w))))
  
(define (Drag-n-Drop-Finish parent X Y)
  (when d-n-d-widget
     ;; Deposit the window
     (Drag-n-Drop-deposit parent X Y)
     ;; Destroy the drag and drop window
    (destroy d-n-d-widget)
    (set! d-n-d-widget #f)))

(define (create-new-widget lb x y Xabs Yabs)
  (let* ((index  (nearest lb y))
	 (type   (list-ref (value lb) index))
	 (search (assoc type *table-defaults*)))
    (when search 
       ;; Create a drag and drow window and post it unde the mouse
       (let ((W (apply make-drag-n-drop-widget (cadr search) (cddr search))))
	 (menu-post W Xabs Yabs)
	 (set! d-n-d-widget   W)
	 (set! d-n-d-defaults (cdr search))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Define a Toplevel for working
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define new-amib-toplevel
  (let ((count 0))
    (lambda ()
      (let* ((n (* count 20))
	     (t (make <Toplevel> :title "Toplevel" :maximum-size '(1000 1000)
		      :geometry (format #f "450x300+~A+~A" n n))))
	(set! count (+ count 1))
	(pack  (make <Frame> :parent t) :expand #t :fill "both")))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; build-interface		-- construct the button panel
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (build-interface)
  (let* ((mess   (make <Label> :relief "ridge" :border-width 3 :foreground "blue"
			       :text (format #f "A Mini Interface Builder (V~A)" 
					     *amib-version*)))
	 ;; Menus
	 (menus  `((" File "
		      ("Load"	 ,load-file)
		      ("Save"	 ,save-file)
		      ("Save as" ,write-file)
		      ("")
		      ("Quit"	 ,quit))
		   (" Toplevel "
		      ("Create"	,new-amib-toplevel))
		   ((" Help " :side "right" :fill "x")
		      ("About"	,(lambda () (stk:make-help *about-text*)))
		      ("Help"   ,(lambda () (stk:make-help *help-text*))))))
	 ;; Menu bar
	 (bar     (make-menubar *top-root* menus))
	 ;; Widget Panel
	 (chooser (make <Scroll-Listbox> :value (map car *table-defaults*)))
	 (lb      (listbox-of chooser)))

    ;; Associate new bindings to the listbox
    (bind lb "<ButtonRelease-1>"  `(create-new-widget ,(@ lb) %x %y |%X| |%Y|))
    (bind lb "<B1-Motion>" 	  "list")
    (bind lb "<3>" 	   	  "list")

    ;; Change characteristics of root window
    (set! (title *top-root*) 	     (format #f "AMIB ~A" *amib-version*))
    (set! (maximum-size *top-root*) '(1000 1000))
    (set! (geometry *top-root*)	    "+10-10")

    ;; Pack everybody
    (pack mess bar :fill "x" :ipadx 30)
    (pack chooser :expand #t :fill 'both :ipadx 5 :ipady 5 :padx 5 :pady 5)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Widget resize
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define *cursors* #("top_left_corner"    "top_side"    "top_right_corner"
		    "left_side"          "crosshair"   "right_side"
		    "bottom_left_corner" "bottom_side" "bottom_right_corner"))

(define *positions* #(NW N NE W center E SW S SE))

(define *grips-on* #f)
(define *vector-of-grips* (make-vector 9 #f))

(define (widget-resize-start W X Y)
  (let ((parent (parent W))
	(width  (winfo 'width  W))
	(height (winfo 'height W))
	(bw     (if (slot-exists? W 'border-width) (border-width W) 0)))
    (if (equal? *grips-on* W)
	(begin
	  (widget-resize-clear)
	  (set! *grips-on* #f))
	(begin
	  (widget-resize-clear)
	  (set! *grips-on* W)
	  (dotimes (i 9)
		   (let ((butt (make <Frame> :parent parent :geometry"8x8" 
				             :background "blue"
					     :border-width 2 :relief "raised" 
					     :cursor (vector-ref *cursors* i))))
		     (place butt :in W :bordermode "outside" 
			    :anchor (vector-ref *positions* (- 8 i))
			    :relx (* 0.5 (modulo i 3))
			    :rely (* 0.5 (quotient i 3)))

		     ;; Associate a binding to the grip
		     (bind butt "<B1-Motion>" 
			   	`(widget-resize-motion  ,(@ W) 
							',(vector-ref *positions* i)
							|%X| |%Y|))
		     (bind butt "<ButtonRelease-1>" `(widget-resize-release ,(@ W)))

		     ;; Keep the grip in the global vector
		     (vector-set! *vector-of-grips* i butt)))

	  ;; Place the central button on top (its index is 4)
	  (raise W)
	  (raise (vector-ref *vector-of-grips* 4))))))

(define (widget-resize-clear)
  (for-each (lambda (x) (if (Tk-widget? x) (destroy x)))
	    (vector->list *vector-of-grips*)))

(define (widget-resize-motion W index X Y)
  (let* ((parent (parent W))
	 (pos-x  (winfo 'rootx parent))
	 (pos-y  (winfo 'rooty parent))
	 (width  (winfo 'width W))
	 (height (winfo 'height W))
	 (x1     (- (winfo 'rootx W) pos-x))
	 (y1	 (- (winfo 'rooty W) pos-y))
	 (x2     (+ x1 width))
	 (y2	 (+ y1 height))
	 (x      (- X pos-x))
	 (y	 (- Y pos-y)))
    (case index
      ((NW) 	(set! x1 x)	        	(set! y1 y))
      ((N) 					(set! y1 y))
      ((NE)	(set! x2 x)			(set! y1 y))
      ((W)	(set! x1 x))
      ((center) (set! x1 (- x (quotient width 2)))
		(set! y1 (- y (quotient height 2)))
		(set! x2 (+ x1 width))		
		(set! y2 (+ y1 height)))
      ((E) 	(set! x2 x))
      ((SW) 	(set! x1 x)			(set! y2 y))
      ((S) 					(set! y2 y))
      ((SE) 	(set! x2 x)			(set! y2 y)))
    (place 'forget W)
    (place W :in parent :x x1 :y y1 :width (- x2 x1) :height (- y2 y1))))

(define (widget-resize-release W)
  ;; Calculate the relative width and height of the widget 
  (let* ((parent (parent W))
	 (pw     (winfo 'width  parent))
	 (ph     (winfo 'height parent))
	 (pos-x  (winfo 'rootx parent))
	 (pos-y  (winfo 'rooty parent))
	 (width  (winfo 'width W))
	 (height (winfo 'height W))
	 (x      (- (winfo 'rootx W) pos-x))
	 (y	 (- (winfo 'rooty W) pos-y)))
    (place 'forget W)
    (place W :in parent 
	     :x x :y y 
	     :relx      (if (= pw 0) 0 (/ x pw))
	     :rely      (if (= ph 0) 0 (/ y ph))
	     :relwidth  (if (= pw 0) 0 (/ width pw))
	     :relheight (if (= ph 0) 0 (/ height ph)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Widget Geometry management
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (MAKE-PACKING-WINDOW W)

  (define (build-var-name x)
    (string->symbol (format #f "amib-~A~A" x (widget-name (Id W)))))

  (define (make-var v)
    ;; Very UGLY: should be changed
    (let* ((var (build-var-name v))
	   (-v  (string->symbol (format #f "-~A" v)))
	   (opt (member -v (pack 'newinfo W))))
      (eval `(define ,var ',(and opt (cadr opt))))
      var))

  (define (change-pack-opt W)
    (pack 'forget W)
    (pack W :fill    (eval (build-var-name 'fill))
	    :anchor  (eval (build-var-name 'anchor))
	    :expand  (eval (build-var-name 'expand))
	    :side    (eval (build-var-name 'side))
	    :padx    (eval (build-var-name 'padx))
	    :pady    (eval (build-var-name 'pady))
	    :ipadx   (eval (build-var-name 'ipadx))
	    :ipady   (eval (build-var-name 'ipady))))

  (define (make-side parent)
    (let ((f (make <Frame> :parent parent :relief "groove" :border-width 2))
	  (v (make-var 'side)))
      (pack (make <Label> :text "Side: " :parent f :font "fixed") :side "left")
      (for-each (lambda (x)
		  (pack (make <Radio-button> :parent f :text x :variable v
			      :command (list (@ change-pack-opt) (@ W)))
			:side "left" :expand #t :fill "x"))
		'("top" "bottom" "left" "right"))
      f))

  (define (make-position parent)
    (let ((f (make <Frame> :parent parent :relief "groove" :border-width 2))
	  (v (make-var 'anchor)))
      (dotimes (i 3)
	(let ((g (make <Frame> :parent f)))
	   (dotimes (j 3)
	      (let* ((anchor (vector-ref *positions* (+ (* i 3) j)))
		     (b (make <Radio-Button> :text anchor :width 10 :parent g
			      :variable v :anchor "w"
			      :command (list (@ change-pack-opt) (@ W)))))
		(pack b :side "left" :expand #t :fill "x")))
	   (pack g :side "top")))
	 f))
  
  (define (make-fill parent)
    (let ((f (make <Frame> :parent parent :relief "groove" :border-width 2))
	  (v (make-var 'fill)))
      (pack (make <Label> :text "Fill: " :parent f :font "fixed") :side "left")
      (for-each (lambda (x)
		  (pack (make <Radio-button> :parent f :text x :variable v
			      :command  (list (@ change-pack-opt) (@ W)))
			:side "left" :expand #t :fill "x"))
		'("none" "x" "y" "both"))
      f))

  (define (make-expand parent)
    (make <Check-button> :parent parent :relief "groove" :border-width 2
	  		 :text "Expand" :variable (make-var 'expand)
			 :command  (list (@ change-pack-opt) (@ W))))
  
  (define (make-padding parent)
    (let ((f (make <Frame> :parent parent :relief "groove" :border-width 2)))
      (for-each (lambda (x)
		  (let ((s (make <Scale> :orientation "h" :parent f :text x))
			(v (make-var x)))
		    (pack s :expand #t :fill "x")
		    (set! (command s) `(begin
					 (set! ,v  (value ,(@ s)))
					 (,(@ change-pack-opt) ,(@ W))))))
		'(ipadx ipady padx pady))
      f))

  ;; MAKE-PACKING-WINDOW starts here
  (let ((top (make <Toplevel> :title "Packer options" :class "Amib" 
		   :geometry "-100+100")))
    (pack (make-side top)
	  (make-position top)
	  (make-fill top) 
	  (make-expand top)
	  (make-padding top)
	  :padx 5 :pady 5 :fill "x")
    (pack (make <Button> :parent top :text "Dismiss" :command `(destroy ,(@ top)))
	  :fill "x")))  

(define (use-pack-for-widget W)
  (place 'forget W)
  (pack W :in (parent W))
  (update)
  (make-packing-window W))

(define (use-place-for-widget W)
    (pack 'forget W)
    (place W :in (parent W))
    (update))	   

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; edit-widget		-- Interactively change widget options
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(define (edit-widget w)
  (letrec ((top    (make <Toplevel> :class "Amib" :title "Widget Editor"
			 	    :geometry "-10+10"))
	   (slots  (map (lambda (x) (symbol->string (if (pair? x) (car x) x)))
			(class-slots (class-of w))))
	   (filter (lambda (slots forget)
		     (let loop ((l slots) (res '()))
		       (cond 
			((null? l) 	      	 res)
			((member (car l) forget) (loop (cdr l) res))
			(else		      	 (loop (cdr l) 
						       (cons (car l) res)))))))
	   (maxl  0))
    
    ;; Display only useful slots
    (set! slots (sort (filter slots *special-slots*) string<?))
    (set! maxl (apply max (map string-length slots)))
    
    ;; Pretty name of this object
    (let ((name-editor (make <Labeled-Entry> 
			     :parent top 
			     :title "Widget name"
			     :value (hash-table-get *pretty-names* w "?none?"))))
      (bind (entry-of name-editor) "<Return>"
	    `(hash-table-put! *pretty-names* ,(address-of w) 
			      (value ,(address-of name-editor))))
      (pack name-editor :expand #t :fill 'x))

    ;; Display the geometry manager used for this widget
    (let* ((f  (make <Frame> :border-width 2 :relief "ridge" :parent top))
	   (v  (string->symbol (format #f "cb-var~A" (widget-name (Id w)))))
	   (c1 (make <Radio-Button> :text "Packed" :variable v :parent f
		     		    :value "pack" 
				    :command `(Use-pack-for-widget ,(@ w))))
	   (c2 (make <Radio-Button> :text "Placed" :variable v :parent f
		     		    :value "place"
				    :command `(Use-place-for-widget ,(@ w)))))
      ;; Set the valid check button
      (eval `(set! ,v ,(if (null? (place 'info w)) "pack" "place")))
      (pack c1 c2 :side "left" :expand #t :fill "x")
      (pack f :expand #t :fill "x"))

    ;; Display the widget editor
    (for-each (lambda (s)
		(let* ((name (string->symbol s))
		       (le   (make <Labeled-Entry> :parent top :title name
				   :width 40 :value (slot-ref w 
							      (string->symbol s)))))
		  ;; Customize label
		  (set! (width  (label-of le))  maxl)
		  (set! (anchor (label-of le)) "e")
		  ;; Customize entry
		  (bind (entry-of le) "<Return>" 
			`(slot-set! ,(address-of w) 
				    ',name (value ,(address-of le))))

		  ;; Pack the new entry
		  (pack le :fill "y" :expand #t)))
	      slots)
    ;; Dismiss button
    (pack (make <Button> :text "Dismiss" :parent top
			 :command `(destroy ,(address-of top)))
	  :expand #t 
	  :fill 'x)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Code generation
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (Pretty-name w)
  (let ((name (hash-table-get *pretty-names* w #f)))
    (unless name
       ;; If this object has no name, a name is generated for it
       (set! name (if (eqv? w *root*) "*root*" (gensym "W")))
       (hash-table-put! *pretty-names* w name))
    name))

;;;;
;;;; Generate-placement: generate pack or place depending of the geometry manager
;;;; used.
;;;;
(define-method generate-placement ((w <Tk-widget>))
  (let* ((infos      (place 'info w))
	 (use-pack?  (null? infos)))
    (if use-pack? 
	(set! infos (pack 'newinfo w)))

    (format #t "(~A ~A " (if use-pack? "pack " "place") (pretty-name w))

    ;; Display informations returned by Tk
    (let loop ((i infos))
      (cond 
         ((null? i)		(display ")\n\n"))
	 ((eqv? (car i) '-in)	(format #t "\n       :in ~A" 
					(pretty-name 
					    (Id->instance (eval (cadr i)))))
				(loop (cddr i)))
	 (ELSE			(let ((s   (symbol->string (car i)))
				      (val (cadr i)))
				  (format #t "\n       :~A "
					  (substring s 1 (string-length s)))
				  (if (number? val)
				      (display val)
				      (format #t "\"~A\"" val)))
				(loop (cddr i)))))))

(define-method generate-placement ((w <Toplevel>))
  (format #f ";; End of Toplevel ~A\n\n" (pretty-name w)))

;;;;
;;;; Generate-code-for-widget methods
;;;;
(define-method generate-code-for-widget ((w <Toplevel>))
  (format #t "\n;; Start of Toplevel ~A\n" (pretty-name w))
  (next-method))

(define-method generate-code-for-widget ((w <Tk-widget>))
  ;; Generate name
  (format #t ";-----------\n(define ~A (make ~A\n\t:parent ~A\n" 
	     (pretty-name w) (class-name (class-of w)) (pretty-name (parent w)))

  ;; Generate non special slots
  (for-each (lambda (slot)
	      (unless (member slot *special-slots*)
		    (unless (member (symbol->string (car slot)) *special-slots*)
		       ;; Generate code for this slot (which is for sure a list)
		       (let* ((slot-name (car slot))
			      (val       (slot-ref w slot-name))
			      (init-key  (get-keyword :init-keyword (cdr slot) #f)))
		      (when (and init-key (not (equal? (slot-ref w slot-name) "")))
			 (format #t "\t~S ~A~S\n"
				init-key (if (list? val) "'" "") val))))))
	    (class-slots (class-of w)))
  ;; Close parenthesis
  (format #t "))\n\n")
  
  ;; Generate code for embedded widgets. Don't do this if w is a composite
  (unless (is-a? w <Tk-composite-widget>)
     (for-each generate-code-for-widget
	       (map Id->instance (winfo 'children w))))
  
  ;; Generate placement for this widget
  (generate-placement w))

;;;;
;;;; Generate-code (the entry point of code generation)
;;;;
(define (generate-code file)
  (with-output-to-file file
    (lambda ()
      (format #t ";;\n;; Code generated by Amib (v~A)\n;;\n" *amib-version*)
      (for-each (lambda (x)
		  (when (and (is-a? x <Toplevel>) 
			     (not (equal? (toplevel-class x) "Amib")))
			(generate-code-for-widget x)))
		(map Id->instance (winfo 'children *root*))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; File Management
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (save-file)
  (if *current-file*
      (generate-code *current-file*)
      (write-file)))

(define (load-file)
  (let ((f (make-file-box)))
    (when f (load f))))

(define (write-file)
  (let ((f (make-file-box)))
    (when f
      (set! *current-file* f)
      (generate-code f))))
	  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Inits
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-amib-toplevel)
(build-interface)