(require 'stdlib)
(require 'gtk)

;; TODO rewrite to compiled-net form, or to macro

(define (define-screen args)
  (let ((widgets ())                    ; '((name type widget) ...)
        (window (gtk-window-new 'toplevel)))
    (define (name->widget name)
      (third (assoc name widgets)))
    (define (name->type name)
      (second (assoc name widgets)))

    (define (callback name event)
      (printf "event: %s on %s\n" event name)
      (and (eq 'ok-button (name->type name))
           (eq event 'clicked)
           (gtk-exit)))

    (define (make-component spec)
      (let ((name (first spec))
            (type (second spec)))
        (printf "item %s, type %s\n" name type)
        (case type
          ((ok-button cancel-button)
           (let ((button (gtk-button-new-with-label (symbol-name name))))
             (gtk-signal-connect button "clicked"
                                 (lambda ()
                                   (callback name 'clicked)))
             (push (list name type button) widgets)))
          ((text-field password-field)
           (let ((label (gtk-label-new (symbol-name name)))
                 (entry (gtk-entry-new))
                 (hbox (gtk-hbox-new nil 0)))
             (gtk-box-pack-start hbox label nil t 4)
             (gtk-box-pack-end hbox entry nil nil)
             (gtk-signal-connect entry "focus_out_event"
                                 (lambda ()
                                   (callback name 'focus-out-event)))
             (push (list name type hbox) widgets)))
          ((combo)
           (let ((label (gtk-label-new (symbol-name name)))
                 (combo (gtk-combo-new))
                 (hbox (gtk-hbox-new nil 0)))
             (gtk-box-pack-start hbox label nil t 4)
             (gtk-box-pack-end hbox combo nil nil)
             (puts (third spec))
             (gtk-combo-set-popdown-strings combo (third spec))
             (push (list name type hbox) widgets))))))

    (define (layout-items ordering)
      (let ((vbox (gtk-vbox-new nil 2)))
        (gtk-container-add window vbox)
        (puts "layout:")
        (dolist (name ordering)
          (puts name)
          (cond ((symbolp name)
                 (gtk-box-pack-start vbox (name->widget name)))
                ((listp name)
                 (when (eq (first name) 'horizontal)
                   (let ((hbox (gtk-hbox-new t 2)))
                     (gtk-box-pack-start vbox hbox)
                     (dolist (item (rest name))
                       (gtk-box-pack-start hbox (name->widget item) t t)))))
                (t (printf "unknown layout spec `%s'" name))))))

    (dolist (spec (rest args))
      (case (first spec)
        ((components)
         (dolist (item (rest spec))
           (make-component item))
         (puts widgets))
        ((layout)
         (layout-items (rest spec)))
        ((constraints)
         (puts "NYI: constraints"))
        (t
         (printf "unknown specification item: %s\n" (first arg)))))

    (gtk-signal-connect window "delete_event" (lambda (w) (gtk-exit)))
    (gtk-window-set-title window (symbol-name (first args)))
    (gtk-container-border-width window 4)
    (gtk-widget-show-all window)
    (when (gtk-standalone-p)
      (gtk-main))))

(define-screen
  '(password-dialogue
    (components
     (username text-field)
     (domain combo ("aap" "noot" "mies"))
     (password password-field)
     (password-verify password-field)
     (ok ok-button)
     (cancel cancel-button))

    (layout
     username domain
     password
     password-verify
     (horizontal ok cancel))

    (constraints
     (username (valid-when not-blank))
     (password (valid-when (and not-blank
                                (eq? (value-of password)
                                     (value-of password-verify)))))
     (ok (enabled-when (and (valid? username)
                            (valid? password)))))))

;;; -----------------------------------------------------------------
;;; Declaration of a username/password entry dialog.

;; Initialise the components. `password' and `password-verify' are the
;; usual sort of "enter same password in both fields for confirmation"
;; arrangement.
;; (make-components
;;  (username        text-field)
;;  (password	   password-field)
;;  (password-verify password-field)
;;  (ok	           ok-button)
;;  (cancel          cancel-button))

;; Layout the components. username, password, and password-verify get
;; their own rows, but the buttons are laid out horizontally on the
;; same row.
;; (layout username
;;         password
;;         password-verify
;;         (horizontal ok cancel))

;; The username is valid when it's non-blank. The password is valid when
;; it's both non-blank and equal in value to the password-verify field.
;; (constraints
;;  (username (valid-when not-blank))
;;  (password (valid-when (and not-blank
;;                             (eq? (value-of password)
;;                                  (value-of password-verify)))))

;; the OK button is only enabled (unshaded, clickable) when the
;; username and password are valid.
;;  (ok (enabled-when (and (valid? username)
;;                         (valid? password)))))

;;----------------------------------------------------------------------
;;WyCash used a declarative definition for the numerous data entry
;;screens in the product. The minimal format was easy to enter, store
;;and interpret.

;;  #(('Customer Information')
;;  ('Name' 20 firstName lastName)
;;  ('Addr' address)
;;  ('City' city)
;;  ('State' 10 state 'Zip' zip))


;;This is a Smalltalk literal array with elements of four different
;;types that are used as follows.

;;    * Array -- the inner ( ) -- a complete line of the form
;;    * String -- label text

;;    * Symbol -- from which getters, setters and format info is
;;                retrieved by reflection
;;    * Integer -- temporarily overrides the default field width

;;We had previously used well factored code to create all of our
;;screens, much like is now the convention with Swing. We found the
;;declarative form to be a huge improvement, mostly because we didn't
;;have to think up and remember so many names. We converted all of our
;;source code to the new form through an elegant refactoring
;;(WardsRefactoring?) where we executed the code and asked the resulting
;;object structure to report the decleration that would reproduce it. We
;;started this development one moring and were finished before lunch. --
;;WardCunningham