(use goo)
(use goo/system)
(use goo/boot)

(use samurui/gtk.swig)
(use samurui/treegoo.h)
(use samurui/treegoo.c)

(use samurui/gtkcallbacks)

(use samurui/core/metadata)
(use samurui/core/macros)
(use samurui/core/geom)
(use samurui/core/gtkwrapping)
(use samurui/core/util)
(use samurui/core/graphics)
(use samurui/core/masterslave)

(use samurui/core/renderize)

(use samurui/core/constraints)

(use samurui/core/menus)
(use samurui/core/visicol)

(use samurui/core/visiwrapcol)
(use samurui/core/treeview)

(use/include /usr/include/gtk-2.0)
(use/include /usr/lib/gtk-2.0/include)
(use/include /usr/include/atk-1.0)
(use/include /usr/include/pango-1.0)
(use/include /usr/X11R6/include)
(use/include /usr/include/freetyp2)
(use/include /usr/include/glib-2.0)
(use/include /usr/lig/glib-2.0/include)

;; Todo:
;;  Allow sizing hints for canvases.


; ----

; --
; --- Present (like presentation, not gift or here)
; --

(dm rebind-interface-model ((updaters <col>) (obj <any>))
  (do (fun ((updater-tup <tup>))
        ((1st updater-tup) obj))
      updaters
      )
  )

(dm update-interface-model ((updaters <col>))
  (do (fun ((updater-tup <tup>))
        ((2nd updater-tup))
        )
      updaters
      )
  )

; Presentation constructs a top-level window to display the object.
(df kill-gtk (x)
  (gtk_main_quit)
)

(dv *samurui-inited* #f)

(df samurui-init ()
  (unless *samurui-inited*
    (gtk_init_easy)
    (set *samurui-inited* #t)
    )
  )

(df samurui-go ()
  (samurui-init)
  (gtk_main)
  )

(dm present (obj)
  (samurui-init)
  (let ((window (gui-window))
        (kill-gtk-cb (goo_safeCreateCallback kill-gtk 0))
        (class (class-of obj))
        (model (find-interface-model class root-interface (vec)))
        (updaters (fab <vec> 0))
        )
    ; set up the window for death on destroy
    (gtk_signal_connect (handle window) "destroy" (gtk_getGtkCallback) kill-gtk-cb)
    (msg out "About to add-all\n")
    (ad! window (renderize-model model root-interface class updaters (fab <str-tab> 0)))
    (msg out "About to rebind\n")
    (rebind-interface-model updaters obj)
    (msg out "About to update\n")
    (update-interface-model updaters)
    (msg out "About to show\n")
    (show window)
    )
  )

;; ;;;;;;;;;; ;;
;; Rectangles ;;
;; ;;;;;;;;;; ;;


; -event hooks-
; Provide default event hooks for widgets

(df hook-configure-event (data widget event)
  (reconfigure data widget)
  #t
  )

(df hook-expose-event (data widget event)
    (let ((area (_GdkEventExpose_area_get event))
          (r-area (new <gdk-rect>)))
      (set (handle r-area) area)
      (repaint data r-area)
      )
    #t
    )

(dg mouse-press (widget x|<int> y|<int> button|<int> time|<int>))

(dg mouse-release (widget x|<int> y|<int> button|<int> time|<int>))

(dg mouse-move (widget x|<int> y|<int> state|<int>))

(df hook-mouse-press (data widget event)
  (mouse-press data ; data is our widget... widget is their widget!               
               (round (_GdkEventButton_x_get event))
               (round (_GdkEventButton_y_get event))
               (_GdkEventButton_button_get event)
               (_GdkEventButton_time_get event)
               )
  #t
  )

(df hook-mouse-release (data widget event)
  (mouse-release data ; data is our widget... widget is their widget!               
                 (round (_GdkEventButton_x_get event))
                 (round (_GdkEventButton_y_get event))
                 (_GdkEventButton_button_get event)
                 (_GdkEventButton_time_get event)
                 )
  #t
  )

(df hook-mouse-move (data widget event)
  (let ((vRet (gdk_window_get_pointer (_GdkEventMotion_window_get event)))
        (x (elt vRet 1))
        (y (elt vRet 2))
        (state (elt vRet 3)))
    (mouse-move data
                (round x)
                (round y)
                state)
    )
  #t
  )
              
(dm hookify ((imagebox <gui-imagebox>))
  (let ((hWidget (handle (paintbox imagebox)))
        (cb-mouse-press (goo_safeCreateCallback hook-mouse-press imagebox))
        (cb-mouse-release (goo_safeCreateCallback hook-mouse-release imagebox))
        (cb-mouse-move (goo_safeCreateCallback hook-mouse-move imagebox))
        (cb-expose-event (goo_safeCreateCallback hook-expose-event imagebox))
        (cb-configure-event (goo_safeCreateCallback hook-configure-event imagebox)))
    (g_signal_connect hWidget "button_press_event" (gtk_getBoolEventCallback) cb-mouse-press)
    (g_signal_connect hWidget "button_release_event" (gtk_getBoolEventCallback) cb-mouse-release)
    (g_signal_connect hWidget "motion_notify_event" (gtk_getBoolEventCallback) cb-mouse-move)
    (g_signal_connect hWidget "expose_event" (gtk_getBoolEventCallback) cb-expose-event)
    (g_signal_connect hWidget "configure_event" (gtk_getBoolEventCallback) cb-configure-event)
    
    ;; ask to receive events the drawing area doesn't normally subscribe to
    (gtk_widget_set_events hWidget (| (| (| (| (| (| (gtk_widget_get_events hWidget)
                                                     GDK_BUTTON_PRESS_MASK)
                                                  GDK_BUTTON_RELEASE_MASK)
                                               GDK_POINTER_MOTION_MASK)
                                            GDK_POINTER_MOTION_HINT_MASK)
                                         GDK_EXPOSURE_MASK)
                                      GDK_STRUCTURE_MASK))
    )
  )

(dm mouse-click ((widget <any>) (x <int>) (y <int>) (button <int>))
  #f)

(dm mouse-move ((widget <any>) (x <int>) (y <int>) (state <int>))
  #f)


; -bindings-
;
; The task of a binding can be thought of to be similar to an enzyme.  For it to
;  be useful it must lock onto both the GUI object in question and the object 
;  that is supposed to be represented.
;
; We want:
; * The GUI state to be initialized to conform with the state of the object
; * Updates to the GUI to be reflected in the object
; * Updates to the object to be reflected in the GUI.
;
; Given that the lifetime of the enzyme and GUI object should outlive the attachment
;  to the object, we want to be able to de-couple and re-couple easily and without
;  creating horrible memory and resource leaks.
;
; As such, we want a binding to provide three functions once initial setup has been done
; 1: Re-bind to a new object, so that GUI actions are triggered on the right objects.
; 2: Refresh the GUI state to be in-sync with the object.
; 3: De-bind
;
; Given the design of everything, it makes sense for bindings to exist on a property-level
;  granularity. 

(dg drawmodel-model (widget|<any> => <any>))
(dg drawmodel-model-setter (obj|<any> widget|<any>))

(dm bind (widget|<interface-drawing-area> info|<interface-info> => (tup <fun> <fun> <fun>))
  (tup
   (fun (new-obj) (set (drawmodel-model widget) ((getter info) new-obj)))
   (fun ())
   (fun ())
   )
  )

; Constructs a binding
(dm bind ((textbox <gui-textbox>) (info <interface-info>) => (tup <fun> <fun> <fun>))
  (let ((cur-obj #f)
        (callback (fun (data widget)
                    ;(msg out "Callback!\n")
                    ((setter info) (gtk_entry_get_text (handle textbox))
                            cur-obj)
                    )))

    ; Establish our hooks into the gui object
    (g_signal_connect (handle textbox)
                      "activate"
                      (gtk_getGtkCallback)
                      (goo_safeCreateCallback callback 0))

    ; Construct the helper functions
    (tup 
                                        ; Establish re-binder
     (fun (new-obj)
       ;(msg out "Rebinding!\n")
       (set cur-obj new-obj)
       )
                                        ; Establish refresher
     (fun ()
       ;(msg out "Refreshing!\n")
       (gtk_entry_set_text (handle textbox) (as <str> ((getter info)cur-obj)))
       )

                                        ; This is where we would de-bind if memory 
                                        ; weren't so cheap that we don't need to 
                                        ; worry about memory leaks.
                                        ; (ha ha ha, I'm funny.)
                          ; But really, it would be a good idea to free stuff here.
     (fun ()
       ; free your mind!
       )
     )
    )
  )

; Constructs a binding
(dm bind ((spin <gui-spinbutton>) (info <interface-info>) => (tup <fun> <fun> <fun>))
  (let ((cur-obj #f)
        (relevant-gtk-getter (if (= (type info) <int>)
                                 gtk_spin_button_get_value_as_int
                                 gtk_spin_button_get_value))
        (callback (fun (data widget)
                    ((setter info) (relevant-gtk-getter (handle spin))
                     cur-obj)
                    )))

    ; Establish our hooks into the gui object
    (g_signal_connect (handle spin)
                      "value-changed"
                      (gtk_getGtkCallback)
                      (goo_safeCreateCallback callback 0))

    ; Construct the helper functions
    (tup 
                                        ; Establish re-binder
     (fun (new-obj)
       ;(msg out "Rebinding!\n")
       (set cur-obj new-obj)
       )
                                        ; Establish refresher
     (fun ()
       ;(msg out "Refreshing!\n")
       (gtk_spin_button_set_value (handle spin) (as <flo> ((getter info) cur-obj)))
       )

                                        ; This is where we would de-bind if memory 
                                        ; weren't so cheap that we don't need to 
                                        ; worry about memory leaks.
                                        ; (ha ha ha, I'm funny.)
                          ; But really, it would be a good idea to free stuff here.
     (fun ()
       ; free your mind!
       )
     )
    )
  )

; Constructs a binding
(dm bind ((toggle <gui-toggle-button>) (info <interface-info>) => (tup <fun> <fun> <fun>))
  (let ((cur-obj #f)
        (callback (fun (data widget)
                    ;(msg out "Callback!\n")
                    ((setter info) (gtk-to-log (gtk_toggle_button_get_active (handle toggle)))
                     cur-obj)
                    ;;(msg out "Callback done!\n")
                    )))

    ; Establish our hooks into the gui object
    (g_signal_connect (handle toggle)
                      "toggled"
                      (gtk_getGtkCallback)
                      (goo_safeCreateCallback callback 0))

    ; Construct the helper functions
    (tup 
                                        ; Establish re-binder
     (fun (new-obj)
       ;(msg out "Rebinding!\n")
       (set cur-obj new-obj)
       )
                                        ; Establish refresher
     (fun ()
       ;(msg out "Refreshing!\n")
       (gtk_toggle_button_set_active (handle toggle) (log-to-gtk ((getter info) cur-obj)))
       )

                                        ; This is where we would de-bind if memory 
                                        ; weren't so cheap that we don't need to 
                                        ; worry about memory leaks.
                                        ; (ha ha ha, I'm funny.)
                          ; But really, it would be a good idea to free stuff here.
     (fun ()
       ; free your mind!
       )
     )
    )
  )

(dm bind-master (container|<gui-container> master|<gui-master> => <log>)
  (esc found-it
    (do (fun (child)
          (when (bind-master child master)
            (found-it #t)
            )
          )
        (children container)
        )
    )
  )

(register-interface-model <str> (interface-model 
                                 (fun (item attribs) 1)
                                 (fun (info class updaters)
                                   (let ((textbox (gui-textbox))
                                         (textbox-updater (bind textbox info)))
                                     (ad! updaters textbox-updater)
                                     textbox
                                     )
                                   )
                                 )
                          )


(register-interface-model <num> (interface-model 
                                 (fun (item attribs) 1)
                                 (fun (info class updaters)
                                   (let ((spinbox (gui-spinbutton (to-adjustment (constraint info))))
                                         (spinbox-updater (bind spinbox info)))
                                     (ad! updaters spinbox-updater)
                                     spinbox
                                     )
                                   )
                                 )
                          )


(register-interface-model <log> (interface-model 
                                 (fun (item attribs) 1)
                                 (fun (info class updaters)
                                   (let ((checkbox (gui-check-button (description info)))
                                         (checkbox-updater (bind checkbox info)))
                                     (ad! updaters checkbox-updater)
                                     checkbox
                                     )
                                   )
                                 )
                          )

;;;;;;; EXPORTS
(export
  *default-samurui-font*
  get-default-samurui-font
  )

;; Classes
(export
  <interface-info>
  <interface-action>
  <interface-property>
  <interface-class-info>
  <interface-model>
  
  <gui>
  <gui-widget>
  
  <gui-container>
  <gui-window>
  <gui-box>
  <gui-vbox>
  <gui-hbox>

  <gui-button>
  <gui-toggle-button>
  <gui-check-button>
  
  <gui-label>
  <gui-textbox>

  <gui-menu>
  <gui-menu-item>
  <gui-menu-item-label>

  <rectangle>
  <gdk-rect>
  <gui-rect>

  <point>
  <gui-point>
  <gui-point-flo>
  <gdk-point>

  <gui-circle-flo>
  <gui-line-flo>

  <gui-drawable>
  <gdk-colormap>
  <gdk-gc>
  <gui-paintbox>
  <gui-canvas>
  <gui-color>
  <gui-font>
  <gui-imagebox>
  
  <interface-drawing-area>

  <visi-col>
  <visi-wrap-col>
  <visi-reversablize>

  <gui-treeview-model>
  <gui-treeview>
  
  <gui-master>
  <gui-slave>
  )

;; Glorious functions
(export
  interface-action
  interface-property
  interface-class-info
  interface-model
  imodel-eval
  imodel-payload
  register-interface-model
  has-interface-model?
  get-interface-model
  get-interface-models
  find-interface-model
  
  add-all!
  add-all-opt!
  
  find-first-class
  get-class-info
  add-property
  add-action
  get-class-actions
  get-all-actions
  find-action
  get-class-properties
  get-all-properties
  find-property
  rebind-interface-model
  update-interface-model
  kill-gtk
  present
  
  log-to-gtk
  gtk-to-log
  free

  gui-width
  gui-height

  gui-window
  gui-vbox
  gui-hbox
  ad!
  ad-opt!
  show
  show-all
  gui-button
  connect
  gui-check-button
  gui-label
  gui-textbox
  gui-menu
  popup
  gui-menu-item-label
  gdk-rect
  rect-x
  rect-y
  rect-w
  rect-h
  grow!
  free
  rect
  rect-around
  rect-to-gdk
  shrink!
  point
  point-in-rect
;;  point-to-gdk
;;  gdk-point
  point-x
  point-x-setter
  point-y
  point-y-setter
  circle
  circle-p
  circle-p-setter
  circle-r
  circle-r-setter
  line
  line-p1
  line-p1-setter
  line-p2
  line-p2-setter
  dist
  sqdist
  intersect
  line-point-by-param
  gui-paintbox
  gui-canvas
  gui-canvas-ext
  gdk-gc
  gdk-colormap
  color
  color-hsb
  realize
  fg-setter
  bg-setter
  font
  gui-imagebox
  reconfigure
  blank
  drawable
  get-gc
  hookify
  repaint
  repaint-widget
  mouse-click
  mouse-move
  drawable-handle
  draw-blit
  draw-rect
  draw-arc
  draw-ellipse
  draw-polygon
  draw-line
  draw-string
  draw-string-ul
  draw-string-center
  string-width
  string-height
  font-ascent
  font-height
  invalidate-all
  invalidate
  bind
  visi-wrap-col
  visi-reversablize
  get-start-node
  node-label
  node-weight
  node-browsable
  register-node-add-notification
  remove-node-add-notification
  register-edge-add-notification
  remove-edge-add-notification
  node-axes
  node-out-edges
  node-in-edges

  axis-to-str
  
  gui-treeview

  gimme-menu
  renderize-model
  renderize

  mouse-press
  mouse-release
  mouse-move
  )

(export
  name
  name-setter
  method
  method-setter
  description
  description-setter
  type
  type-setter
  getter
  getter-setter
  setter
  setter-setter
  constraint
  constraint-setter
  properties
  properties-setter
  actions
  actions-setter
  handle
  handle-setter
  attrs
  attrs-setter
  children
  children-setter
  colormap
  colormap-setter
  gc
  gc-setter
  realized-into
  realized-into-setter
  paintbox
  paintbox-setter
  canvas
  canvas-setter
;;  wrapped
;;  wrapped-setter
;;  parent-hash
;;  parent-hash-setter
;;  collection
;;  collection-setter
;;  axis
;;  axis-setter
;;  prop-axes
;;  prop-axes-setter
;;  model
;;  model-setter
;;  children
;;  children-setter
  bind-master
  master-update-slaves
  )

(export 
  samurui-init
  samurui-go
  iprop
  ipropc
  iaction
  imodel
  iview
  idrawmodel
  idrawmodel-ext
  )

(export
  font-lucida
  )


(export
  drawmodel-model
  drawmodel-model-setter
  )

(export
  <interface-constraint>

  <numeric-constraint>
  <int-constraint>
  <flo-constraint>
  lbound
  lbound-setter
  ubound
  ubound-setter
  small-increment
  small-increment-setter
  large-increment
  large-increment-setter
  
  num-constraint

  <string-constraint>
  
  <gui-adjustment>
  to-adjustment
  )