(use gtk)

(define (destroy w)
  (format #t "destroying ~s\n" w)
  (gtk-main-quit))

(define (test-window args)
  (gtk-init args)
  (let ((window (gtk-window-new GTK_WINDOW_TOPLEVEL))
        (vbox (gtk-vbox-new #f 4))
        (label (gtk-label-new "multi-line label\nabcdefghijklmnopqrstuvwxyz"))
        (swin (gtk-scrolled-window-new #f #f))
        (lbox (gtk-list-new))
        (hbox (gtk-hbox-new #t 4))
        (button1 (gtk-button-new-with-label "Apply"))
        (button2 (gtk-button-new-with-label "Close")))
    (gtk-window-set-title window "GTK-2.x test")
    (gtk-container-set-border-width window 4)
    ;;(gtk-container-set-border-width vbox 4)
    (g-signal-connect window "destroy" destroy)
    (gtk-container-add window vbox)
    (gtk-container-add vbox label)
    (gtk-container-add vbox swin)
    (gtk-widget-set-size-request swin 300 200)
    (gtk-scrolled-window-set-policy swin
                                    GTK_POLICY_AUTOMATIC
                                    GTK_POLICY_AUTOMATIC)
    (gtk-scrolled-window-add-with-viewport swin lbox)
    (dotimes (i 100)
      (let ((item (gtk-list-item-new-with-label #`"item #,i\t,(* i i)")))
        (gtk-container-add lbox item)))
    (gtk-container-add vbox hbox)
    (gtk-container-add hbox button1)
    (gtk-container-add hbox button2)
    (g-signal-connect button2 "clicked" destroy)
    ;;(gtk-widget-show label)
    (gtk-widget-show-all window))
  (gtk-main))

(test-window '("gtk.scm"))

;; -----------------------------------------------------------------
;; snarfed from declarative-gui.jl
(define first car)
(define second cadr)
(define third caddr)
(define rest cdr)

;; TODO rewrite to compiled-net form, or to macro
(define (define-screen args)
  (gtk-init '(""))
  (let ((widgets ())                    ; '((name type widget) ...)
        (window (gtk-window-new GTK_WINDOW_TOPLEVEL)))
    (define (name->widget name)
      (third (assoc name widgets)))
    (define (name->type name)
      (second (assoc name widgets)))

    (define (callback name event)
      (format #t "event: ~s on ~s\n" event name)
      (and (eq? 'ok-button (name->type name))
           (eq? event 'clicked)
           (gtk-main-quit)))

    (define (make-component spec)
      (let ((name (first spec))
            (type (second spec)))
        (format #t "item ~s, type ~s\n" name type)
        (case type
          ((ok-button cancel-button)
           (let ((button (gtk-button-new-with-label (symbol->string name))))
             (g-signal-connect button "clicked"
                               (lambda (w)
                                 (callback name 'clicked)))
             (push! widgets (list name type button))))
          ((text-field password-field)
           (let ((label (gtk-label-new (symbol->string name)))
                 (entry (gtk-entry-new))
                 (hbox (gtk-hbox-new #f 0)))
             (gtk-box-pack-start hbox label #f #t 2)
             (gtk-box-pack-end hbox entry #f #f 2)
             '(g-signal-connect entry "focus_out_event"
                               (lambda (w)
                                 (callback name 'focus-out-event)))
             (push! widgets (list name type hbox))))
          ((combo)
           (let ((label (gtk-label-new (symbol->string name)))
                 (combo (gtk-combo-new))
                 (hbox (gtk-hbox-new #f 0)))
             (gtk-box-pack-start hbox label #f #t 2)
             (gtk-box-pack-end hbox combo #f #f 2)
             (print (third spec))
             (gtk-combo-set-popdown-strings combo (third spec))
             (push! widgets (list name type hbox)))))))

    (define (layout-items ordering)
      (let ((vbox (gtk-vbox-new #f 2)))
        (gtk-container-add window vbox)
        (print "layout:")
        (dolist (name ordering)
          (print name)
          (cond ((symbol? name)
                 (gtk-box-pack-start vbox (name->widget name) #t #t 2))
                ((list? name)
                 (when (eq? (first name) 'horizontal)
                   (let ((hbox (gtk-hbox-new #t 2)))
                     (gtk-box-pack-start vbox hbox #t #t 2)
                     (dolist (item (rest name))
                       (gtk-box-pack-start hbox
                                           (name->widget item) #t #t 2)))))
                (else (format #t "unknown layout spec `~s'" name))))))

    (dolist (spec (rest args))
      (case (first spec)
        ((components)
         (dolist (item (rest spec))
           (make-component item))
         (print widgets))
        ((layout)
         (layout-items (rest spec)))
        ((constraints)
         (print "NYI: constraints"))
        (else
         (format #t "unknown specification item: ~s\n" (first arg)))))

    (g-signal-connect window "delete_event" (lambda (w) (gtk-main-quit)))
    (gtk-window-set-title window (symbol->string (first args)))
    (gtk-container-set-border-width window 4)
    (gtk-widget-show-all window)
    (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)))))))

;; -----------------------------------------------------------------
;; no good:
;; (define (simple-drawing)
;;   (gtk-init "")
;;   (let ((window (gtk-window-new GTK_WINDOW_TOPLEVEL))
;;         (drawingarea #f)
;;         (gc #f))
;;     (g-signal-connect window "delete_event"
;;                       (lambda (w)
;;                         (gtk-main-quit)))
;;     (g-signal-connect window "expose_event"
;;                       (lambda (w)
;;                         (gdk-draw-line window gc 0 100 100)))
;;
;;     (set! drawingarea (gtk-drawing-area-new))
;;     (gtk-container-add window drawingarea)
;;     (set! gc (gdk-gc-new (ref drawingarea 'window)))
;;     (gtk-window-set-title window "gtk-test")
;;     (gtk-widget-show-all window)
;;     (gtk-main)))

(define (animation args)
  (let ((angle 0))
    (define (draw drawable fg bg)
      ;; clear
      (gdk-draw-rectangle drawable bg #t 0 0 100 100)
      ;; draw line
      (let ((x (inexact->exact (round (+ 50 (* (cos angle) 50)))))
            (y (inexact->exact (round (+ 50 (* (sin angle) 50))))))
        (gdk-draw-line drawable fg 50 50 x y)
        #t))

    (gtk-init args)
    (let ((w (gtk-window-new GTK_WINDOW_TOPLEVEL)))
      (g-signal-connect w "destroy" (lambda _ (gtk-main-quit)))
      (let* ((area (gtk-drawing-area-new))
             (drawable #f) ;; initialized by realize callback
             (fg-gc #f) ;; initialized by realize callback
             (bg-gc #f)) ;; initialized by realize callback
        (gtk-widget-set-size-request area 100 100)
        (gtk-container-add w area)
        (g-signal-connect area "realize"
                          (lambda _
                            (set! drawable (ref area 'window))
                            (set! fg-gc (gdk-gc-new drawable))
                            (set! bg-gc (gdk-gc-new drawable))
                            (gdk-gc-set-foreground
                             bg-gc
                             (ref (ref (ref area 'style) 'bg) 0))))
        (g-signal-connect area "expose_event"
                          (lambda (w event) (draw drawable fg-gc bg-gc)))
        (gtk-timeout-add 100
                         (lambda ()
                           (inc! angle (* (acos -1) 0.02))
                           (when drawable (draw drawable fg-gc bg-gc))))
        (gtk-widget-show area))
      (gtk-widget-show w))
    (gtk-main)))

;;(animation '())

(define (drawing)
  (define (draw drawable fg bg)
    (dotimes (i 512)
      (gdk-draw-point
       drawable fg
       i
       (inexact->exact
        (- 256 (* 256 (sin (* i (/ (* 2 (acos -1)) 512.0)))))))))

  (gtk-init '("drawing"))
  (let ((w (gtk-window-new GTK_WINDOW_TOPLEVEL)))
    (g-signal-connect w "destroy" (lambda _ (gtk-main-quit)))
    (let* ((area (gtk-drawing-area-new))
           (drawable #f)
           (fg-gc #f)
           (bg-gc #f))
      (gtk-widget-set-size-request area 512 512)
      (gtk-container-add w area)
      (g-signal-connect area "realize"
                        (lambda _
                          (set! drawable (ref area 'window))
                          (set! fg-gc (gdk-gc-new drawable))
                          (set! bg-gc (gdk-gc-new drawable))
                          (gdk-gc-set-foreground
                           bg-gc
                           (ref (ref (ref area 'style) 'bg) 0))))
      (g-signal-connect area "expose_event"
                        (lambda (w event) (draw drawable fg-gc bg-gc))))
    (gtk-widget-show-all w))
  (gtk-main))

;;(drawing)