(define STRING-TYPE " ")
(define NUMBER-TYPE 0)
(define BOOLEAN-TYPE nil)

(define (make-wob parent type)
  (let ((wob (make-wob-Priv parent type)))
    (wob-set-children! parent 
		       (append (wob-get-children parent)
			       (list wob)))
    wob))

(define (get-method object message trueself)
  (object trueself message))

(define (invoke object message . args)
  (apply invoke-for (cons object (cons  object (cons message args)))))

(define (invoke-for behalf-of object message . args)
  (let ((method (get-method object message behalf-of)))
    (if method
	(apply method args)
	(print "ERROR: no such method: " message nl))))

(define whoopie-main-loop-return wob-main-loop-return)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;BEGIN OBJECTS;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;BEGIN OBJECTS;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;BEGIN OBJECTS;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WHOOPIE CLASS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; this is the parent of all window objects in whemey.  
(define wm-get-type 'wm-get-type)
(define wm-get-wob 'wm-get-wob)
(define wm-initialize 'wm-initialize)
(define wm-get-parent 'wm-get-parent)
(define wm-set-position-hints 'wm-set-position-hints)  ;; x y
(define wm-set-position 'wm-set-position)  ;; x y
(define wm-set-size 'wm-set-size) ;; x y
(define wm-show 'wm-show)
(define wm-hide 'wm-hide) 

(define (make-whoopie-from-wob wob parent)
  (lambda (me message)
    (cond ((equal? message wm-get-type)
	   (lambda () (wob-get-type wob)))

	  ((equal? message wm-get-wob) ;; this should be private within the whoopie system
	   (lambda () wob))

	  ((equal? message wm-hide)
	   (lambda ()
	     (wob-hide wob)))

	  ((equal? message wm-show)
	   (lambda ()
	     (wob-show wob)))

	  ((equal? message wm-get-parent)
	   (lambda () parent))

	  ((equal? message wm-set-size)
	   (lambda (w h)
	     (wob-set-value wob XtNresizable t)
	     (wob-set-value wob XtNwidth w)
	     (wob-set-value wob XtNheight h)))

	  ((equal? message wm-set-position)
	   (lambda (x y)
	     (invoke parent wm-set-child-position me x y)))

	  ((equal? message wm-set-position-hints)
	   (lambda (x y) 
	     (wob-set-value wob XtNresizable t)
	     (wob-set-value wob XtNx x)
	     (wob-set-value wob XtNy y)))

	  (else nil))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN WINDOW CLASS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; this is the main application window.  In the end (and the beginning and anytime
;; throughout), there can be only one. 
;;
;; the top-wob is for whemey internal use only.  it corresponds to the wob object
;; for Xt's toplevelWidget
(define wm-get-top-wob 'wm-get-top-wob)

(define *wob-initialized* nil)

(define (whoopie-main-loop)
  (if *wob-initialized* 
      (wob-main-loop)
      (print "Error: no main window" nl)))

(define (make-main-window)
  (cond (*wob-initialized* (print "Only one main window is allowed.  Reusing old window." nl)
			   *wob-initialized*)
	(else (let ((top-wob (wob-initialize)))
		(make-main-window-from-wob (make-wob top-wob WOB-TACKBOARD) top-wob)))))


(define (make-main-window-from-wob wob top-wob)
  (let ((superclass (make-tackboard-from-wob wob nil)))
    (define (self me message)
      (cond ((equal? message wm-get-top-wob) ;;; for whemey internal use only
	     (lambda () top-wob))
	    (else
	     (get-method superclass message me))))
    (set! *wob-initialized* self)
    self))

	 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; LABEL CLASS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; a string label class
(define wm-set-label 'wm-set-label)

(define (make-label parent . rest)
  (let ((label (make-label-from-wob (make-wob (invoke parent wm-get-wob) WOB-LABEL) parent)))
    (if rest
	(invoke label wm-set-label (car rest)))
    label))

(define (make-label-from-wob wob parent)
  (let ((superclass (make-whoopie-from-wob wob parent)))
    (lambda (me message)
      (cond ((equal? message wm-set-label )
	     (lambda (string) 
	       (wob-set-value wob XtNlabel string)))
	    (else 
	     (get-method superclass message me))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; PUSHBUTTON CLASS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; pushbutton is a subclass of label. 
;; it understands the message
(define wm-set-callback 'wm-set-callback)  ;; proc
;;

(define (make-pushbutton parent . rest)
  (let ((button (make-pushbutton-from-wob (make-wob (invoke parent wm-get-wob) WOB-PUSHBUTTON) parent)))
    (if rest
	(sequence
	  (invoke button wm-set-label (car rest))
	  (if (cdr rest)
	      (invoke menuitem wm-set-callback (cadr rest)))
	  ))
    button))

(define (make-pushbutton-from-wob wob parent)
  (let ((superclass (make-label-from-wob wob parent))
	(callback-proc nil))
    (lambda (me message)
      (cond ((equal? message wm-set-callback)
	     (lambda (proc)
	       (set! callback-proc (cons proc callback-proc))
	       (wob-set-callback wob XtNcallback proc)))
	    (else 
	     (get-method superclass message me))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; CONTAINER CLASS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; this is the base class for all objects that can contain other objects.
;; it is a virtual class.
(define wm-get-children 'wm-get-children)
(define wm-set-child-position 'wm-set-child-position)   ;; child x y

(define (make-container-from-wob wob parent)
  (let ((superclass (make-whoopie-from-wob wob parent)))
    (lambda (me message)
      (cond ((equal? message wm-get-children)
	     (lambda ()
	       (wob-get-children wob)))

	    ((equal? message wm-set-keyboard-focus)
	     (lambda (whoopie)
	       (wob-set-keyboard-focus wob (invoke whoopie wm-get-wob))))

	    ((equal? message wm-set-child-position)  
	     ;; this TRIES to set a child's position, it doesn't always work.
	     (lambda (child x y)
	       (invoke child wm-set-position-hints x y)))

	    (else 
	     (get-method superclass message me))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; BOX CLASS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; this is a container that auto-magically arranges things for you with
;; little to no work.  of course, you get what you pay for...
(define (make-box parent)
  (make-box-from-wob (make-wob (invoke parent wm-get-wob) WOB-BOX) parent))

(define (make-box-from-wob wob parent)
  (let ((superclass (make-container-from-wob wob parent)))
    (lambda (me message)
      (get-method superclass message me))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TACKBOARD CLASS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; this is a container that allows you to place things in x,y locations or to tack whoopies 
;; by other whoopies 
(define wm-vertical-tack 'wm-vertical-tack)
(define wm-horizontal-tack 'wm-horizontal-tack)
(define wm-reconfigure 'wm-reconfigure)
(define wm-set-keyboard-focus 'wm-set-keyboard-focus) ; whoppie
(define wm-nail-down 'wm-nail-down) ;; whoopie   this fixes the location

(define (make-tackboard parent)
  (make-tackboard-from-wob (make-wob (invoke parent wm-get-wob) WOB-TACKBOARD) parent))


(define (make-tackboard-from-wob wob parent)
  (let ((superclass (make-container-from-wob wob parent)))
    (lambda (me message)
      (cond ((equal? message wm-vertical-tack)
	     (lambda (top-whoopie bottom-whoopie)
	       (wob-set-value (invoke bottom-whoopie wm-get-wob)
			      XtNfromVert
			      (invoke top-whoopie wm-get-wob))))

	    ((equal? message wm-horizontal-tack)
	     (lambda (left-whoopie right-whoopie)
	       (wob-set-value (invoke right-whoopie wm-get-wob)
			      XtNfromHoriz
			      (invoke left-whoopie wm-get-wob))))
	    
	    ((equal? message wm-nail-down)
	     (lambda (child)
	       (let ((child-wob (invoke child wm-get-wob)))
		 (wob-set-value child-wob XtNleft XawChainLeft)
		 (wob-set-value child-wob XtNright XawChainLeft)
		 (wob-set-value child-wob XtNtop XawChainTop)
		 (wob-set-value child-wob XtNbottom XawChainTop))))


	    ((equal? message wm-set-child-position)
	     (lambda (child x y)
	       (let ((child-wob (invoke child wm-get-wob)))
		 (wob-set-value child-wob XtNfromHoriz nil)
		 (wob-set-value child-wob XtNhorizDistance x)
		 (wob-set-value child-wob XtNfromVert nil)
		 (wob-set-value child-wob XtNvertDistance y)
		 (invoke-for me superclass wm-set-child-position child x y))))

	    ;;; this only sorta works because XawForm is broken for position info
	    ((equal? message wm-reconfigure)
	     (lambda ()
	       (tackboard-reconfigure wob)))

	    (else (get-method superclass message me))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ScrollingWindow ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
       
(define wm-disable-scrollbar 'wm-disable-scrollbar) ; direction
(define wm-enable-scrollbar 'wm-enable-scrollbar) ; direction
(define wm-enable-auto-appear 'wm-enable-auto-appear) 
(define wm-disable-auto-appear 'wm-disable-auto-appear) 
(define wm-use-bottom 'wm-use-bottom)
(define wm-use-top 'wm-use-top)
(define wm-use-right 'wm-use-right)
(define wm-use-left 'wm-use-left)

(define horizontal 'horizontal)
(define vertical 'vertical)

(define (make-scrollingwindow parent)
  (define win
    (make-scrollingwindow-from-wob (make-wob (invoke parent wm-get-wob)
					     WOB-SCROLLINGWINDOW)
				   parent))
  (invoke win wm-enable-scrollbar horizontal)
  (invoke win wm-enable-scrollbar vertical)
  win)

(define (make-scrollingwindow-from-wob wob parent)
  (let ((superclass (make-container-from-wob wob parent)))
    (lambda (me message)
      (cond 
       
       ((equal? message wm-disable-scrollbar)
	(lambda (dir)
	  (wob-set-value wob 
			 (if (equal? dir horizontal) 
			     XtNallowHoriz 
			     XtNallowVert)
			 nil)))

       ((equal? message wm-enable-scrollbar)
	(lambda (dir)
	  (wob-set-value wob 
			 (if (equal? dir horizontal) 
			     XtNallowHoriz 
			     XtNallowVert)
			 t)))

       ((equal? message wm-enable-auto-appear)
	(lambda ()
	  (wob-set-value wob 
			 XtNforceBars nil)))

       ((equal? message wm-disable-auto-appear)
	(lambda ()
	  (wob-set-value wob 
			 XtNforceBars t)))

       ((equal? message wm-use-bottom)
	(lambda ()
	  (wob-set-value wob 
			 XtNuseBottom t)))

       ((equal? message wm-use-top)
	(lambda ()
	  (wob-set-value wob
			 XtNuseBottom nil)))

       ((equal? message wm-use-right)
	(lambda ()
	  (wob-set-value wob
			 XtNuseRight t)))

       ((equal? message wm-use-left)
	(lambda ()
	  (wob-set-value wob
			 XtNuseRight nil)))

       (else
	(get-method superclass message me))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TEXTEDITOR CLASS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define wm-set-text 'wm-set-text)
(define wm-auto-resize 'wm-auto-resize)
(define wm-set-readonly 'wm-set-readonly)
(define wm-get-text 'wm-get-text)
(define wm-h-resizable? 'wm-h-resizable)
(define wm-v-resizable? 'wm-v-resizable)

(define (make-texteditor parent)
  (make-texteditor-from-wob (make-wob (invoke parent wm-get-wob) WOB-TEXTEDITOR) parent))

(define (make-texteditor-from-wob wob parent)
  (let ((superclass (make-whoopie-from-wob wob parent))
	(hresizable t)
	(vresizable t))
    (wob-set-value wob XtNresize XawtextResizeBoth)
    (wob-set-value wob XtNeditType XawtextEdit)
    (lambda (me message)
      (cond 
	    ((equal? message wm-set-text)
	     (lambda (string)
	       (wob-set-value wob XtNstring string)))

	    ((equal? message wm-get-text)
	     (lambda ()
	       (wob-get-value wob XtNstring STRING-TYPE)))
		
	    ((equal? message wm-auto-resize)
	     (lambda (h v)
	       (set! hresizable h)
	       (set! vresizable v)
	       (cond ((and h v)
		      (wob-set-value wob XtNresize XawtextResizeBoth))
		     (h 
		      (wob-set-value wob XtNresize XawtextResizeWidth))
		     (v
		      (wob-set-value wob XtNresize XawtextResizeHeight))
		     (else 
		      (wob-set-value wob XtNresize XawtextResizeNever)))))

	    ((equal? message wm-h-resizable?)
	     (lambda ()
	       hresizable))

	    ((equal? message wm-v-resizable?)
	     (lambda ()
	       vresizable))

	    ((equal? message wm-set-readonly)
	     (lambda (y)
	       (if y 
		   (wob-set-value wob XtNeditType XawtextRead)
		   (wob-set-value wob XtNeditType XawtextEdit))))
		      
	    
	    (else
	     (get-method superclass message me))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MENUBAR CLASS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define wm-add-menubutton 'wm-add-menubutton) ;; panel
(define wm-setup-menu-structure 'wm-setup-menu-structure)
  ;; (list 
  ;;    (list "menu-panel1"
  ;;         (list "entry1" entry1-proc)
  ;;         (list "entry2" entry2-proc)
  ;;         (list "entry3" entry3-proc))
  ;;    (list "menu-panel2"
  ;;         (list "entry1" entry1-proc)
  ;;         (list "entry2" entry2-proc)
  ;;         (list "entry3" entry3-proc)))
         

(define (make-menubar parent . rest)
  (let ((menubar
	 (make-menubar-from-wob (make-wob (invoke parent wm-get-wob) WOB-TACKBOARD)
				parent)))
    (if rest
	(invoke menubar wm-setup-menu-structure (car rest)))
    (invoke menubar wm-initialize)
    menubar))


(define (make-menubar-from-wob wob parent)
  (let ((superclass (make-tackboard-from-wob wob parent))
	(buttons nil)     ;; list of menubutton whoopies
	)
    (lambda (me message)
      (cond 

       ((equal? message wm-add-menubutton)
	(lambda (button)
	  (let ((oldlast (list-ref buttons (- (length buttons) 1))))
	    (set! buttons (append buttons (list button)))
	    (if oldlast 
		(invoke me wm-horizontal-tack oldlast button))
	    (invoke me wm-nail-down button))))
       
       ((equal? message wm-setup-menu-structure)
	(lambda (struct)
	  (map (lambda (panel-struct)
		 (letrec ((new-button (make-menubutton me))
			  (new-panel  (make-menupanel new-button (cdr panel-struct))))
		   (invoke new-button wm-set-label (car panel-struct))
		   (invoke new-button wm-set-panel new-panel)
		   (invoke me wm-add-menubutton new-button)))
	       struct)
	  ))
	  
       ((equal? message wm-initialize)
	(lambda ()
	  (wob-set-value wob XtNleft XawChainLeft)
	  (wob-set-value wob XtNright XawChainLeft)
	  (wob-set-value wob XtNtop XawChainTop)
	  (wob-set-value wob XtNbottom XawChainTop)))
	
       (else
	(get-method superclass message me))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MENUPANEL CLASS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define wm-menu-blank 'wm-menu-blank)
(define wm-menu-line 'wm-menu-line)
(define wm-add-menuitem 'wm-add-menuitem)  ;; menuitem
(define wm-setup-menupanel-structure 'wm-setup-menupanel-structure)
  ;;    (list
  ;;         (list "entry1" entry1-proc)
  ;;         (list "entry2" entry2-proc)
  ;;         (list "entry3" entry3-proc))

(define (make-menupanel parent . rest)
  (let ((menupanel
	 (make-menupanel-from-wob (make-wob (invoke parent wm-get-wob) WOB-MENUPANEL)
				  parent)))
    (if rest
	(invoke menupanel wm-setup-menupanel-structure (car rest)))
    menupanel))

(define (make-menupanel-from-wob wob parent)
  (let ((superclass (make-popup-from-wob wob parent))
	(items nil)
	)
    (lambda (me message)
      (cond 
       
       ((equal? message wm-add-menuitem)
	(lambda (item)
	  (set! items (append items (list item)))))
       
       ((equal? message wm-setup-menupanel-structure)
	(lambda (struct)
	  (map (lambda (item-list)
		 (let ((item (cond ((equal? item-list wm-menu-blank)
				    (make-menublank me))
				   ((equal? item-list wm-menu-line)
				    (make-menuline me))
				   (else 
				    (apply make-menuitem (cons me item-list))))))
		   (invoke me wm-add-menuitem item)))
	       struct)))
       
       (else (get-method superclass message me))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MENUITEM CLASS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-menuitem parent . rest)
  (let ((menuitem 
	 (make-menuitem-from-wob (make-wob (invoke parent wm-get-wob) WOB-MENUITEM)
				 parent)))
    (if rest
	(sequence
	  (invoke menuitem wm-set-label (car rest))
	  (if (cdr rest)
	      (invoke menuitem wm-set-callback (cadr rest)))
	  ))
    menuitem))

(define (make-menuitem-from-wob wob parent)
  (let ((superclass (make-pushbutton-from-wob wob parent)))
    (lambda (me message)
      (get-method superclass message me))))

  ;;;; MENUBLANK CLASS ;;;;

(define (make-menublank parent)
  (make-menublank-from-wob (make-wob (invoke parent wm-get-wob) WOB-MENUITEM-BLANK)
			   parent))

  ;;;; MENULINE CLASS ;;;;

(define (make-menuline parent)
  (make-menublank-from-wob (make-wob (invoke parent wm-get-wob) WOB-MENUITEM-LINE)
				 parent))

(define (make-menublank-from-wob wob parent)
  (let ((superclass (make-menuitem-from-wob wob parent)))
    (define self 
      (lambda (me message)
	(cond 
	 ((equal? message wm-set-callback)
	  (lambda (proc) (print "warning: calling set-callback to blank")))
	 (else (get-method superclass message me)))))
    (invoke self wm-set-size 0 16)
    self))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MENUBUTTON CLASS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define wm-set-panel 'wm-set-panel) ;; menupanel
(define wm-get-panel 'wm-get-panel) 

(define (make-menubutton parent)
  (make-menubutton-from-wob (make-wob (invoke parent wm-get-wob) WOB-MENUBUTTON)
			    parent))


(define (make-menubutton-from-wob wob parent)
  (let ((superclass (make-pushbutton-from-wob wob parent))
	(menupanel nil))
    (lambda (me message)
      (cond 

       ((equal? message wm-set-panel)
	(lambda (panel)
	  (set! menupanel panel)
	  (wob-set-value wob XtNmenuName 
			 (wob-get-name (invoke panel wm-get-wob)))))

       ((equal? message wm-get-panel)
	(lambda ()
	  menupanel))

       (else (get-method superclass message me))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Popup Class ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (make-popup parent)
  (make-popup-from-wob (make-wob (invoke parent wm-get-top-wob) WOB-POPUP) parent))
  
(define (make-popup-from-wob wob parent)
  (let ((superclass (make-container-from-wob wob parent)))
    (lambda (me message)
      (get-method superclass message me))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MessageBox Class ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define wm-add-thunk-button 'wm-add-thunk-button)
(define wm-popup 'wm-popup)  ;; this pops up the dialog and sits until a button is pressed
(define wm-popdown 'wm-popdown)  ;; this pops down the dialog and sits until a button is pressed
(define wm-set-message 'wm-set-message)  ;; text    ... text of message
(define wm-add-button 'wm-add-button) ;; text value  
  ;;  .. text of button and value to be returned by dialog
  ;;  calling wm-add-button TEXT VALUE  will add a button to the dialog with the text TEXT.
  ;;  if the button is pressed when the dialog is popped up, then VALUE will be returned by wm-popup

(define (make-messagebox parent)
  (let ((popup (make-popup parent)))
    (define mbox (make-messagebox-from-wob (make-wob (invoke popup wm-get-wob) WOB-DIALOGBOX) popup))
    (invoke mbox wm-initialize)
    mbox))
  

(define (make-messagebox-from-wob wob parent)
  (let ((superclass (make-popup-from-wob wob parent))
	(popup-wob (invoke parent wm-get-wob))
	(buttons nil)
	(popdown (lambda () (wob-hide (invoke parent wm-get-wob)))))
    (lambda (me message)
      (cond 

       ((or (equal? message wm-popup)
	    (equal? message wm-show))
	(lambda ()
	  (wob-show popup-wob)
	  (wob-main-loop)))

       ((or (equal? message wm-popdown)
	    (equal? message wm-hide))
	(lambda ()
	  (popdown)))
       
       ((equal? message wm-set-message)
	(lambda (text)
	  (wob-set-value wob XtNlabel text)))
       
       ((equal? message wm-add-button)
	(lambda (text value)
	  (let ((new-button (make-pushbutton me)))
	    (set! buttons (cons new-button buttons))
	    (invoke new-button wm-set-label text)
	    (invoke new-button wm-set-callback popdown)
	    (invoke new-button wm-set-callback (make-return-value-proc value))
	    )))
       
       ((equal? message wm-add-thunk-button)
	(lambda (text thunk)
	  (let ((new-button (make-pushbutton me)))
	    (set! buttons (cons new-button buttons))
	    (invoke new-button wm-set-label text)
	    (invoke new-button wm-set-callback thunk))))

       ((equal? message wm-initialize)
	(lambda () 
	  (invoke me wm-add-button "Ok" t)))

       (else
	(get-method superclass message me))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; DialogBox Class ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define wm-get-input-string 'wm-get-input-string)

(define (make-dialogbox parent)
  (let ((popup (make-popup parent)))
    (define db (make-dialogbox-from-wob (make-wob (invoke popup wm-get-wob) WOB-DIALOGBOX) popup))
    (invoke db wm-initialize)
    db))

(define (make-dialogbox-from-wob wob parent)
  (let ((superclass (make-messagebox-from-wob wob parent)))
    (lambda (me message)
      (cond 

       ((equal? message wm-get-input-string)
	(lambda ()
	  (dialog-get-text wob)))

       ((equal? message wm-initialize)
	(lambda ()
	  (wob-set-value wob XtNvalue "")
	  (invoke me wm-add-thunk-button "Ok"
		  (lambda ()
		    (invoke me wm-popdown)
		    (wob-main-loop-return (invoke me wm-get-input-string))))
	  ))

       (else
	(get-method superclass message me))))))

(define (make-return-value-proc value)
  (lambda ()
    (wob-main-loop-return value)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; LIST CLASS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define wm-get-chosen-item 'wm-get-chosen-item)  ;; returns the item chosen by the user (eq)
(define wm-set-contents 'wm-set-contents) ;; list    set the list strings and numbers to be presented
(define wm-set-column-number 'wm-set-column-number) ;; n  = number of columns

(define (make-list parent . rest)
  (let ((lst-wob (make-list-from-wob (make-wob (invoke parent wm-get-wob) WOB-LIST) parent)))
    (invoke lst-wob wm-initialize)
    (if rest (invoke wm-set-contents (car rest)))
    lst-wob))

(define (make-list-from-wob wob parent)
  (let ((superclass (make-whoopie-from-wob wob))
	(user-list nil)
	(internal-list nil)
	(last-chosen -1)
	(callbacks nil))
    (define (set-index n)
      (set! last-chosen n))
    (lambda (me message)
      (cond 

       ((equal? message wm-get-chosen-item)
	(lambda ()
	  (list-ref user-list last-chosen)))

       ((equal? message wm-set-callback)
	(lambda (proc)
	  (set! callback-proc (cons proc callback-proc))
	  (wob-set-callback wob XtNcallback proc)))

       ((equal? message wm-set-contents)
	(lambda (lst)
	  (set! user-list (map (lambda (x) x) lst)) ;; copy the list
	  (set! internal-list (map convert-to-string lst))
	  (load-list-wob wob internal-list)))

       ((equal? message wm-set-column-number)
	(lambda (n)
	  (wob-set-value wob XtNdefaultColumns n)))
       
       ((equal? message wm-initialize)
	(lambda ()
	  (invoke me wm-set-column-number 1)
	  (set-list-callback wob set-index)))

       (else 
	(get-method superclass message me))))))

(define (convert-to-string obj)
  (cond ((string? obj) obj)
	((number? obj) (num2string obj))
	(else 
	 "Error.  Don't know how to make string from this")))

(define whoopie-demo-file "/afs/sipb/project/kcll/src/whoopie-demo.scm")
(add-library 'whoopie-demo
	     (lambda () 
	       (load whoopie-demo-file)))

;(load-noisily "testoo.scm")