; (load "/home/ai2/sombrero/cvs/goo/src/samurui/graph.goo" 'goo/user)

(use goo)
(use samurui/samurui)
(use samurui/gtk.swig)
(use samurui/badge)
(use samurui/gtkcallbacks)

(use goo/random)

;; All of the code currently in this file is basically a direct conversion
;;  of the relevant touchgraph code into goo, with minimal idiom conversions.
;;  Eg, the conversion is much like a naive robot would do, except in a few cases
;;  where rampant laziness dictated that it was much easier to do it closer to the
;;  right way.  But still, don't be surprised if things seem to side-effect based
;;  when there's no good reason to do it that way...

(dc <layout-engine> (<any>))

(dc <graph-node> (<any>))
 (dp! node-x (<graph-node> => <flo>) 0.0)
 (dp! node-y (<graph-node> => <flo>) 0.0)
 (dp! node-dx (<graph-node> => <flo>) 0.0)
 (dp! node-dy (<graph-node> => <flo>) 0.0)
 (dp! node-drawx (<graph-node> => <flo>) 0.0)
 (dp! node-drawy (<graph-node> => <flo>) 0.0)
 (dp! node-width (<graph-node> => <int>) 0) ;; cached when drawn
 (dp! node-height (<graph-node> => <int>) 0) ;; cached when drawn
 (dp! node-fixed (<graph-node> => <log>) #f)
 (dp! node-just-made-local (<graph-node> => <log>) #f)
 (dp! node-repulsion (<graph-node> => <flo>) 100.0)
 (dp! node-obj (<graph-node> => <any>))

(dm node-rect (node|<graph-node> => <gui-rect>)
  (rect-around (floor (node-drawx node))
               (floor (node-drawy node))
               (+ 2 (1st (trunc/ (node-width node) 2)))
               (+ 2 (node-height node)))
  )

(dc <graph-edge> (<any>))
 (dp! edge-to (<graph-edge> => <graph-node>))
 (dp! edge-from (<graph-edge> => <graph-node>))
 (dp! edge-length (<graph-edge> => <flo>) 40.0)

(dc <touchgraph-layout> (<layout-engine>))
 (dp! damper (<touchgraph-layout> => <flo>) 1.0)
 (dp! damping (<touchgraph-layout> => <log>) #f)
 (dp! drag-node (<touchgraph-layout> => (t? <graph-node>)) #f)
 (dp! max-motion (<touchgraph-layout> => <flo>) 0.0)
 (dp! motion-ratio (<touchgraph-layout> => <flo>) 0.0)
 (dp! rigidity (<touchgraph-layout> => <flo>) 1.0)

(dm relax-edges (tgl|<touchgraph-layout> vis-edges)
  (do (fun (edge)
        (def vx (- (node-x (edge-to edge))
                   (node-x (edge-from edge))))
        (def vy (- (node-y (edge-to edge))
                   (node-y (edge-from edge))))
        (def len (sqrt (+ (* vx vx)
                          (* vy vy))))

        (def dx (* vx (rigidity tgl)))
        (def dy (* vy (rigidity tgl)))

        (set dx (/ dx (* (edge-length edge) 100.0)))
        (set dy (/ dy (* (edge-length edge) 100.0)))

        (if (or (node-just-made-local (edge-to edge))               
                 (not (node-just-made-local (edge-from edge))))
            (seq
              (set (node-dx (edge-to edge))
                   (- (node-dx (edge-to edge))
                      (* dx len)))
              (set (node-dy (edge-to edge))
                   (- (node-dy (edge-to edge))
                      (* dy len)))
              )
            (seq
              (set (node-dx (edge-to edge))
                   (- (node-dx (edge-to edge))
                      (* dx (/ len 10.0))))
              (set (node-dy (edge-to edge))
                   (- (node-dy (edge-to edge))
                      (* dy (/ len 10.0))))
              )
            )

       (if (or (node-just-made-local (edge-from edge))               
                 (not (node-just-made-local (edge-to edge))))
            (seq
              (set (node-dx (edge-from edge))
                   (+ (node-dx (edge-from edge))
                      (* dx len)))
              (set (node-dy (edge-from edge))
                   (+ (node-dy (edge-from edge))
                      (* dy len)))
              )
            (seq
              (set (node-dx (edge-from edge))
                   (+ (node-dx (edge-from edge))
                      (* dx (/ len 10.0))))
              (set (node-dy (edge-from edge))
                   (+ (node-dy (edge-from edge))
                      (* dy (/ len 10.0))))
              )
            )

        )
      vis-edges)
  )

(dm for-each-pair (func nodes)
  (do (fun (node1)
        (do (fun (node2)
              (unless (== node1 node2)
                (func node1 node2)
                )
              )
            nodes)
        )
      nodes)
  )

(dm avoid-labels (tgl|<touchgraph-layout> vis-nodes)
  (for-each-pair 
   (fun (node1 node2)
     (def dx 0.0)
     (def dy 0.0)

     (def vx (- (node-x node1)
                (node-x node2)))
     (def vy (- (node-y node1)
                (node-y node2)))
     
     (def len (+ (* vx vx)
                 (* vy vy)))

     (if (== len 0.0)
         (seq
           (set dx (random-unit)) ;; 0.0 -> 1.0
           (set dy (random-unit)) ;; 0.0 -> 1.0
           )
         (seq
           (set dx (/ vx len))
           (set dy (/ vy len))
           )
         )
     
     (def repSum (* (node-repulsion node1) 
                    (/ (node-repulsion node2)
                       100.0)))

     (if (or (node-just-made-local node1)
             (not (node-just-made-local node2)))
         (seq
           (set (node-dx node1)
                (+ (node-dx node1)
                   (* (* dx repSum) (rigidity tgl))))
           (set (node-dy node1)
                (+ (node-dy node1)
                   (* (* dy repSum) (rigidity tgl))))
           )
         (seq
           (set (node-dx node1)
                (+ (node-dx node1)
                   (* (* dx repSum) (/ (rigidity tgl)
                                       10.0))))
           (set (node-dy node1)
                (+ (node-dy node1)
                   (* (* dy repSum) (/ (rigidity tgl)
                                       10.0))))
           )
         )

     (if (or (node-just-made-local node2)
             (not (node-just-made-local node1)))
         (seq
           (set (node-dx node2)
                (- (node-dx node2)
                   (* (* dx repSum) (rigidity tgl))))
           (set (node-dy node2)
                (- (node-dy node2)
                   (* (* dy repSum) (rigidity tgl))))
           )
         (seq
           (set (node-dx node2)
                (- (node-dx node2)
                   (* (* dx repSum) (/ (rigidity tgl)
                                       10.0))))
           (set (node-dy node2)
                (- (node-dy node2)
                   (* (* dy repSum) (/ (rigidity tgl)
                                       10.0))))
           )
         )
     )
   vis-nodes)
  )

(dm move-nodes (tgl|<touchgraph-layout> vis-nodes)
  (def maxMotion 0.0)
  (def lastMaxMotion (max-motion tgl))

  (do (fun (node)
        (def dx (node-dx node))
        (def dy (node-dy node))
        
        (set dx (* dx (damper tgl)))
        (set dy (* dy (damper tgl)))
        
        (set (node-dx node) (/ dx 2.0))
        (set (node-dy node) (/ dy 2.0))

        (def dist-moved (sqrt (+ (* dx dx)
                                 (* dy dy))))
        
        (when (and (not (node-fixed node))
                   (not (== node (drag-node tgl))))
          (set (node-x node) (+ (node-x node)
                                (max -30.0 (min 30.0 dx))))
          (set (node-y node) (+ (node-y node)
                                (max -30.0 (min 30.0 dy))))
          )

        (set maxMotion (max dist-moved maxMotion))
        )
      vis-nodes)
  
  (if (< 0.0 maxMotion)
      (set (motion-ratio tgl) (/ lastMaxMotion (- maxMotion 1.0)))
      (set (motion-ratio tgl) 0.0))

  (set (max-motion tgl) maxMotion)

  (damp tgl vis-nodes)
  )

(dm damp (tgl|<touchgraph-layout> vis-nodes)
  (when (and (damping tgl)
             (<= (motion-ratio tgl) 0.001))
    (cond ((and (or (< (max-motion tgl) 0.2)
                    (and (> (max-motion tgl) 1.0)
                         (< (damper tgl) 0.9)))
                (> (damper tgl) 0.01))
           (set (damper tgl) (- (damper tgl) 0.01)))
          ((and (< (max-motion tgl) 0.4)
                (> (damper tgl) 0.003))
           (set (damper tgl) (- (damper tgl) 0.003)))
          ((> (damper tgl) 0.0001)
           (set (damper tgl) (- (damper tgl) 0.001)))
          )
    )
  
  (when (and (< (max-motion tgl) 0.001)
             (damping tgl))
    (set (damper tgl) 0.0)
    )
  )

(dm relax (tgl|<touchgraph-layout> vis-nodes vis-edges)
  (rep loop ((i 0))
             (when (< i 10)

               (relax-edges tgl vis-edges)
               (avoid-labels tgl vis-nodes)
               (move-nodes tgl vis-nodes)

               (loop (+ i 1))
               )
             )
  
  ; repaint
  )

(df tick-fdg (fdg)
  (when (enable-anim fdg)
    (relax (layout fdg) (graph-nodes fdg) (graph-edges fdg))
    )
  (repaint-graph fdg)
  )

(idrawmodel <visi-col> <visi-fdg>
;;            (gtk_timeout_add 500
;;                             (gtk_getGtkFunctionCallback)
;;                             (goo_safeCreateCallback tick-fdg imagebox))
            (gtk_idle_add (gtk_getGtkFunctionCallback)
                          (goo_safeCreateCallback tick-fdg imagebox))
            )
 (dp! wrapped (<visi-fdg> => (t? <visi-col>)) #f)
 (dp! graph-nodes (<visi-fdg> => <col>) (vec))
 (dp! graph-edges (<visi-fdg> => <col>) (vec))
 (dp! lenses (<visi-fdg> => <col>) (vec))
 (dp! unlenses (<visi-fdg> => <col>) (vec))
 (dp! layout (<visi-fdg> => <touchgraph-layout>) (new <touchgraph-layout>))
 (dp! drag-node-off-x (<visi-fdg> => <int>) 0)
 (dp! drag-node-off-y (<visi-fdg> => <int>) 0)
 (dp! selected-node (<visi-fdg> => (t? <graph-node>)) #f)
 (dp! graph-badge (<visi-fdg> => (t? <badge>)) #f)
 (dp! post-node-renderers (<visi-fdg> => <col>) (vec))
 (dp! enable-anim (<visi-fdg> => <log>) #t)
 (dp! fdg-master (<visi-fdg> => (t? <gui-master>)) #f)

(dm bind-master (fdg|<visi-fdg> master|<gui-master> => <log>)
  (set (fdg-master fdg) master)
  #t
  )

(dm find-graph-node (fdg|<visi-fdg> node)
  (esc found-it
    (do (fun (gn)
          (when (== (node-obj gn) node)
            (found-it gn)))
        (graph-nodes fdg))
    (msg out "Unable to locate graph node %=\n" node)
    )
  )

(dm graph-control-add-post-draw (fdg|<visi-fdg> func)
  (add! (post-node-renderers fdg) func)
  )

(dm graph-control-remove-post-draw (fdg|<visi-fdg> func)
  (del! (post-node-renderers fdg) func)
  )

(dm graph-control-enable-anim (fdg|<visi-fdg> should-enable)
  (set (enable-anim fdg) should-enable)
  )

(dm graph-control-clear-graph (fdg|<visi-fdg>)
  (set (graph-nodes fdg) (vec))
  (set (graph-edges fdg) (vec))
  )


(dm graph-control-clear-edges (fdg|<visi-fdg>)
  (set (graph-edges fdg) (vec))
  )

(dm graph-control-fix-node (fdg|<visi-fdg> unode)
  (def gnode (find-graph-node fdg unode))
  (set (node-fixed gnode) #t)
  )

(dm graph-control-get-node-pos (fdg|<visi-fdg> unode => <gui-point-flo>)
  (def gnode (find-graph-node fdg unode))
  (point (node-x gnode)
         (node-y gnode))
  )

(dm graph-control-draw-line (fdg|<visi-fdg> l|<gui-line-flo> c|<gui-color>)
  (def p1 (point-to-draw-space fdg (line-p1 l)))
  (def p2 (point-to-draw-space fdg (line-p2 l)))
  (draw-line fdg
             (round (point-x p1))
             (round (point-y p1)) 
             (round (point-x p2)) 
             (round (point-y p2))
             c)
  )

(dm bind (fdg|<visi-fdg> info|<interface-info> => (tup <fun> <fun> <fun>))
  (tup
   ;; -- Rebinder --
   (fun (new-obj)
     ;; Detach from current if applicable
     (when (wrapped fdg)
       ;; um... nop for now
       )
     
     ;; 
     (set (wrapped fdg) ((getter info) new-obj))
     (register-node-add-notification (wrapped fdg) 
                                     (fun (node)
                                       (def gn (new <graph-node>))
                                       (set (node-obj gn) node)
                                       (add! (graph-nodes fdg) gn)
                                       ))
     (register-edge-add-notification (wrapped fdg)
                                     (fun (from to axis)
                                       (def ge (new <graph-edge>))
                                       (set (edge-from ge) (find-graph-node fdg from))
                                       (set (edge-to ge)   (find-graph-node fdg to))
                                       ;; Only add it if both nodes are valid
                                       (when (and (edge-from ge)
                                                  (edge-to ge))
                                         (add! (graph-edges fdg) ge))
                                       ))

     (add! (lenses fdg)
           (fun (p)
             (point (+ (point-x p) (1st (trunc/ (gui-width fdg) 2)))
                    (+ (point-y p) (1st (trunc/ (gui-height fdg) 2))))
             )
           )

     (add! (unlenses fdg)
           (fun (p)
             (point (- (point-x p) (1st (trunc/ (gui-width fdg) 2)))
                    (- (point-y p) (1st (trunc/ (gui-height fdg) 2))))
             )
           )

     (set (graph-badge fdg) (suggest-badge (wrapped fdg)))

     ;; Set up the graph-control handle thing
     (graph-control-is (wrapped fdg) fdg)
     
     ;; At some point we should traverse the existing collection...
     (populate-graph fdg (get-start-node (wrapped fdg)))
     )

   ;; -- Refresher --
   (fun ()
     ;; When we update the rebinder code... update this too by using a common method or something...
     )

   ;; -- Free / Cleanup --
   (fun ()
     )
   )
  )

(dm find-or-create-node (fdg|<visi-fdg> node|<any> => <graph-node>)
  (or (find-graph-node fdg node)
      (let ((gnode (new <graph-node>)))
        (set (node-obj gnode) node)
        (add! (graph-nodes fdg) gnode)
        gnode))
  )

(dm populate-graph (fdg|<visi-fdg> start-node|<any>)
  ;; Add the current node if it's not there yet
  (def start-graph-node (find-or-create-node fdg start-node))

  ;; Iterate over its edges
  (do (fun (new-node)
        ;; Recurse
        (populate-graph fdg new-node)

        ;; Add the edge
        (def ge (new <graph-edge>))
        (set (edge-from ge) start-graph-node)
        (set (edge-to ge)   (find-graph-node fdg new-node))
        ;; Only add it if both nodes are valid
        (when (and (edge-from ge)
                   (edge-to ge))
          (add! (graph-edges fdg) ge))        
        )
      (node-out-edges (wrapped fdg) "implicit" start-node)
      )
  )

(dv c_background (color 255 255 255))
(dv c_node (color 192 64 64))
(dv c_label (color 255 192 255))
(dv c_edge (color 64 192 64))

(dm method-fold (methods initial-data)
  (def cur-val initial-data)
  (do (fun (method)
        (set cur-val (method cur-val))
        )
      methods)
  cur-val
  )

(dm point-to-draw-space (fdg|<visi-fdg> p|<point> => <point>)
  (method-fold (lenses fdg)
               p)
  )

(dm update-draw-positions (fdg|<visi-fdg>)
  (do (fun (node)
        (def draw-point (method-fold (lenses fdg)
                                     (point (node-x node)
                                            (node-y node))))
        (set (node-drawx node) (point-x draw-point))
        (set (node-drawy node) (point-y draw-point))
        )
      (graph-nodes fdg)
      )
  )

(dm update-pos-from-draw (fdg|<visi-fdg> node|<graph-node>)
  (def draw-point (point (node-drawx node) (node-drawy node)))
  (def true-point (method-fold (unlenses fdg)
                               draw-point))
  (set (node-x node) (point-x true-point))
  (set (node-y node) (point-y true-point))
  )

(dm find-node (fdg|<visi-fdg> x|<int> y|<int> => (t? <graph-node>))
  ;; Don't use an 'esc' because we want them to get the one they can see in case of
  ;;  overlap, which would be the last one painted.
  (def da-node #f)
  (def p (point x y))
  (do (fun (node)
        (if (point-in-rect p (node-rect node))
            (set da-node node))
         )
        (graph-nodes fdg)
        )
  da-node
  )

(dm repaint-graph (fdg|<visi-fdg>)
  (update-draw-positions fdg)

  ;; Clear background
  (draw-rect fdg (rect 0 0 (gui-width fdg) (gui-height fdg)) #t c_background)

  ;; Pre-Paint
;;  (do (fun (node)
;;        (pre-paint-node node fdg)
;;        )
;;      (graph-nodes fdg)
;;      )

  (when (graph-badge fdg)
    (do (fun (node)
          (when node
            (render-badge fdg
                          (graph-badge fdg)
                          (wrapped fdg)
                          (node-obj node)
                          (round (node-drawx node))
                          (round (node-drawy node)))))
        (graph-nodes fdg))
    )

  ;; Edges
  (do (fun (edge)
        (paint-edge edge fdg)
        )
      (graph-edges fdg)
      )

  ;; Nodes
  (do (fun (node)
        (paint-node node fdg)
        )
      (graph-nodes fdg)
      )

  ;; Post-Paint

  (unless (empty? (post-node-renderers fdg))
    ;; hard-code for 1 post node renderer for the time being
    (set render-func (1st (post-node-renderers fdg)))
    (do (fun (node)
          (render-func fdg (node-obj node)))
        (graph-nodes fdg))
    )

  (invalidate-all fdg)
  )

(dm pre-paint-node (node widget)
  )

(dm paint-node (node widget)
  ;; Intentional naivete : this should be rectified once things are working.
  ;; (def my-font (font font-lucida))
  (def my-font (get-default-samurui-font))

  (def label (node-label (wrapped widget) (node-obj node))) ;; widget is an fdg
  (def s-w (string-width my-font label))
  (def s-h (string-height my-font label))

  (set (node-width node) s-w)
  (set (node-height node) s-h)

  (def node-rect (rect-around (floor (node-drawx node))
                              (floor (node-drawy node))
                              (+ 2 (1st (trunc/ s-w 2)))
                              (+ 2 s-h)))
  (draw-rect widget node-rect #t c_node)
  (draw-string widget my-font 
               (+ 2 (rect-x node-rect))
               (+ (+ 2 (rect-y node-rect))
                  (font-ascent my-font))
               label c_label)

  ;; (free my-font)
  )

(dm post-paint-node (gnode widget)
  )

(dm paint-edge (edge widget)
  (def tx (floor (node-drawx (edge-to edge))))
  (def ty (floor (node-drawy (edge-to edge))))
  (def fx (floor (node-drawx (edge-from edge))))
  (def fy (floor (node-drawy (edge-from edge))))
  (def dx (abs (- tx fx)))
  (def dy (abs (- ty fy)))
  (if (> dx dy)
      (seq
        (draw-line widget
                   fx
                   (- fy 3)
                   tx
                   ty
                   c_edge)
        (draw-line widget
                   fx
                   (+ fy 3)
                   tx
                   ty
                   c_edge)
        )
      (seq
        (draw-line widget
                   (- fx 3)
                   fy
                   tx
                   ty
                   c_edge)
        (draw-line widget
                   (+ fx 3)
                   fy
                   tx
                   ty
                   c_edge)
        )
      )
  )

(dm node-clicked (node widget)
  )

(dm mouse-press ((widget <visi-fdg>) (x <int>) (y <int>) (button <int>) (time <int>))
  (case button
    ((1)
     (def da-node (find-node widget x y))
     (set (drag-node (layout widget)) da-node)   
     (when da-node   
       (set (drag-node-off-x widget) (- (floor (node-drawx da-node)) x))
       (set (drag-node-off-y widget) (- (floor (node-drawy da-node)) y))


       (when (and (and (fdg-master widget)
                       da-node)
                  (node-browsable (wrapped widget) (node-obj da-node)))
         (master-update-slaves (fdg-master widget) (node-obj da-node))
         )
       )
     )
    ((2)
     )
    ((3)
     (def da-node (find-node widget x y))
     (when da-node
       (def da-menu (gimme-menu (node-obj da-node)))
       (popup da-menu button 0)
       )
     )
    )
  )

(dm mouse-release ((widget <visi-fdg>) (x <int>) (y <int>) (button <int>) (time <int>))
  (case button
    ((1)
     (when (drag-node (layout widget))
       (set (selected-node widget) (drag-node (layout widget)))
       (set (drag-node (layout widget)) #f)
       )
     (repaint-graph widget)
     )
    ((2)
     )
    ((3)
     )
    )
  )

(dm mouse-move ((widget <visi-fdg>) (x <int>) (y <int>) (state <int>))
  (when (drag-node (layout widget))
    (def da-node (drag-node (layout widget)))
    (set (node-drawx da-node) (as <flo> (+ x (drag-node-off-x widget))))
    (set (node-drawy da-node) (as <flo> (+ y (drag-node-off-y widget))))
    (update-pos-from-draw widget da-node)
    (repaint-graph widget)
    )
  )

(dm graph-control-is (vc|<visi-col> fdg)
  )

(export
  graph-control-is
  graph-control-add-post-draw
  graph-control-remove-post-draw
  graph-control-fix-node
  graph-control-get-node-pos
  graph-control-draw-line
  graph-control-clear-graph
  graph-control-clear-edges
  graph-control-enable-anim
  )