;; SUI
;; 6.891 Spring 2006
;;
;; Widget definitions
;;
;; $Id: widgets.scm 60 2006-05-17 09:29:43Z nelhage $

(load-option 'sos)
(load "sos-patch.scm" '(runtime generic-procedure))

(define-class (<widget>
               (constructor make-widget (name)
                            (attribs)))
  () 
  (name initial-value #f
        define accessor)
  (width initial-value 0
         define standard)
  (height initial-value 0
          define standard)
  (x initial-value 0
     define standard)
  (y initial-value 0
     define standard)
  (preferred-width initial-value 0
                   define standard)
  (preferred-height initial-value 0
                    define standard)
  (min-width initial-value #f
             define standard
             accessor %widget-min-width)
  (min-height initial-value #f
              define standard
              accessor %widget-min-height)
  (can-grow? initial-value #f
             define standard)
  (parent initial-value #f
          define standard))

(define-generic widget-min-width (widget))
(define-generic widget-min-height (widget))
(define-generic widget-absolute-x (widget))
(define-generic widget-absolute-y (widget))

(define-generic initialize-children! (widget))

(define (pack-widget! w)
  (set-widget-width! w (widget-preferred-width w))
  (set-widget-height! w (widget-preferred-height w))
  (initialize-children! w))

(define-method initialize-children! ((w <widget>))
  #t)

(define-method widget-min-width ((widget <widget>))
  (or (%widget-min-width widget)
      (widget-preferred-width widget)))

(define-method widget-min-height ((widget <widget>))
  (or (%widget-min-height widget)
      (widget-preferred-height widget)))

(define-method widget-absolute-x ((widget <widget>))
  (let* ((parent (widget-parent widget))
         (par-x (if parent (widget-absolute-x parent) 0)))
    (+ par-x (widget-x widget))))

(define-method widget-absolute-y ((widget <widget>))
  (let* ((parent (widget-parent widget))
         (par-y (if parent (widget-absolute-y parent) 0)))
    (+ par-y (widget-y widget))))

(define-method initialize-instance ((widget <widget>)
                                    attribs)
  (if (not (alist? attribs))
      (error:wrong-type-argument attribs "alist"
                                 'initialize-instance))
  (for-each (lambda (attrib)
              (let ((key (car attrib))
                    (value (cadr attrib)))
                (set-slot-value! widget key value)))
            attribs))

(define-class (<container>
               (constructor make-container (name contents)
                            (attribs)))
  (<widget>)
  (contents initial-value '()
            define standard))

(define-method initialize-instance ((container <container>) attribs)
  (call-next-method container attribs)
  (for-each (lambda (w) (set-widget-parent! w container))
            (container-contents container)))

(define-method initialize-children! ((container <container>))
  (for-each (lambda (c) (initialize-children! c))
            (container-contents container)))

(define-class (<frame>
               (constructor make-frame (name title contents)
                            (attribs)))
  (<container>)
  (title initial-value ""
         define standard))

(define-method initialize-instance ((frame <frame>) attribs)
  (call-next-method frame attribs)
  (if (not (null? (container-contents frame)))
      (let ((child (car (container-contents frame))))
        (pack-widget! child))))

(define-method widget-width ((frame <frame>))
  (widget-width (car (container-contents frame))))

(define-method widget-height ((frame <frame>))
  (widget-height (car (container-contents frame))))

(define-method set-widget-width! ((frame <frame>) width)
  (set-widget-width! (car (container-contents frame)) width))

(define-method set-widget-height! ((frame <frame>) height)
  (set-widget-height! (car (container-contents frame)) height))

(define-class (<button>
               (constructor make-button (name label onclick)
                            (attribs)))
  (<widget>)
  (preferred-height initial-value 30)
  (label initial-value ""
         define standard)
  (padding-top initial-value 10
               define standard)
  (padding-bottom initial-value 10
                  define standard)
  (padding-left initial-value 15
                define standard)
  (padding-right initial-value 15
                 define standard)
  (onclick initial-value (lambda () #f)
           define standard))

(define (button-recalculate-width! button)
  (set-widget-preferred-width! button
                               (+ (* 8 (string-length (button-label button)))
                                  (button-padding-left button)
                                  (button-padding-right button))))  

(define-method initialize-instance ((button <button>) attribs)
  (call-next-method button attribs)
  (button-recalculate-width! button))

(define-method set-button-label! ((button <button>)
                                  (value <string>))
  (call-next-method button value)
  (button-recalculate-width! button))

(define-class (<textbox>
               (constructor make-textbox (name text)
                            (attribs)))
  (<widget>)
  (text initial-value ""
        define standard))

(define-method initialize-instance ((textbox <textbox>) attribs)
  (set-widget-preferred-height! textbox 30)
  (set-widget-preferred-width! textbox 200)
  (set-widget-can-grow?! textbox #t))

;;
;; High-level constructors
;;

(define (make-convenience-constructor constructor)
  (lambda (first . rest)
    (let ((args (cons first rest))
          (arity (procedure-arity-min
                  (procedure-arity constructor))))
      (let loop ((constructor-args '())
                 (attribs '())
                 (pending args))
        (if (null? pending)
            (if (> (length constructor-args) (- arity 1))
                ;; XXX: this message isn't entirely informative
                (error:wrong-number-of-arguments 'button
                                                 (make-procedure-arity
                                                  (- arity 1)
                                                  arity)
                                                 args)
                (apply constructor (append (reverse constructor-args)
                                           (list attribs))))
            (let ((arg (car pending)))
              (if (alist? arg)
                  (loop constructor-args arg (cdr pending))
                  (loop (cons arg constructor-args)
                        attribs (cdr pending)))))))))

(define (make-container-convenience-constructor constructor required-args)
  (lambda (first . rest)
    (let ((args (cons first rest)))
      (let loop ((constructor-args '())
                 (attribs '())
                 (contents '())
                 (pending args))
        (if (null? pending)
            (let ((constructor-args
                   ;; they might have left off the container's name
                   (if (= (length constructor-args)
                          required-args)
                       (append constructor-args
                               (list (generate-uninterned-symbol 'anonymous-container)))
                       constructor-args)))
              (apply constructor (append (reverse constructor-args)
                                         (list (reverse contents))
                                         (list attribs))))
            (let ((arg (car pending)))
              (cond ((widget? arg)
                     (loop constructor-args attribs (cons arg contents) (cdr pending)))
                    ((alist? arg)
                     (loop constructor-args arg contents (cdr pending)))
                    (else
                     (loop (cons arg constructor-args) attribs contents (cdr pending))))))))))

(define frame (make-container-convenience-constructor make-frame 1))
(define button (make-convenience-constructor make-button))
(define textbox (make-convenience-constructor make-textbox))

;;
;; Utility methods
;;

;; search for a widget named name starting at widget
(define-generic find-widget-named (widget name))

(define-method find-widget-named ((widget <widget>)
                                  (name <symbol>))
  (if (eq? (widget-name widget) name)
      widget
      #f))

;; simple depth-first search
(define-method find-widget-named ((container <container>)
                                  (name <symbol>))
  (let ((this-widget? (call-next-method container name)))
    (if this-widget?
        this-widget?
        (let loop ((children (container-contents container)))
          (if (not (null? children))
              (let ((res (find-widget-named (car children) name)))
                (if res
                    res
                    (loop (cdr children))))
              #f)))))

;; fetch all widget names in the subtree starting at widget
(define-generic all-widget-names (widget))

(define-method all-widget-names ((widget <widget>))
  (list (widget-name widget)))

(define-method all-widget-names ((container <container>))
  (cons (widget-name container)
        (append-map (lambda (widget)
                      (all-widget-names widget))
                    (container-contents container))))

;; fetch all widgets in the subtree starting at widget
(define-generic all-widgets (widget))

(define-method all-widgets ((widget <widget>))
  (list widget))

(define-method all-widgets ((container <container>))
  (cons container
        (append-map (lambda (widget)
                      (all-widgets widget))
                    (container-contents container))))