 import DaVinciTypes hiding (Edge(..) , Node(..))
 import qualified DaVinciTypes (Edge(..) , Node(..))

--

 toDV :: NodeMap -> IO ()
 toDV nodes
  = writeFile "out.daVinci" (show $ map g2n nodes)


--

 show_gsymbol (HappyTok x) = show x
 show_gsymbol t            = show t

 g2n (n@(s,e,x), [])
  = mk_rhombus id (show_gsymbol x ++ show (s,e)) []
  where
   id = show n

 g2n (n@(s,e,x), [Branch _ bs])
  = mk_box id (show_gsymbol x ++ show (s,e)) 
  $ [ DaVinciTypes.R (NodeId $ show j) | j <- bs ]
  where
   id = show n

 g2n (n@(s,e,x), bss)
  = mk_circle id (show_gsymbol x ++ show (s,e)) 
  $ [ mk_box (id ++ "." ++ show i) (show_gsymbol x ++ show (s,e))
                [ DaVinciTypes.R (NodeId $ show j)
                | j <- js ]
    | (i,Branch _ js) <- zip [0..] bss ]
  where
   id = show n

---

 mk_box = mk_node box_t
 mk_circle = mk_node circle_t
 mk_plain = mk_node text_t
 mk_rhombus = mk_node rhombus_t

 mk_node :: Attribute -> String -> String -> [DaVinciTypes.Node] 
					   -> DaVinciTypes.Node
 mk_node a id nm ts
  = DaVinciTypes.N (NodeId id) (Type "") [a,text nm]
  $ [ (mk_edge id n) t | (n,t) <- zip [1..] ts ]

 mk_edge id child_no t@(DaVinciTypes.R (NodeId id2))
  = DaVinciTypes.E (EdgeId eId) (Type "") [] t
  where
   eId = concat [id,":",id2,"(",show child_no,")"]
 
 mk_edge id child_no t@(DaVinciTypes.N (NodeId id2) _ _ _)
  = DaVinciTypes.E (EdgeId eId) (Type "") [] t
  where
   eId = concat [id,":",id2,"(",show child_no,")"]

---

 nodeStyle = A "_GO"

 box_t, circle_t, ellipse_t, rhombus_t, text_t, icon_t :: Attribute
 box_t = nodeStyle "box"
 circle_t = nodeStyle "circle"
 ellipse_t = nodeStyle "ellipse"
 rhombus_t = nodeStyle "rhombus"
 text_t = nodeStyle "text"
 icon_t = nodeStyle "icon"

 text :: String -> Attribute
 text = A "OBJECT"



