-- 2009.01.08
-- 2009.01.08
--
-- Given a graph following this type
--
-- data DS = A [DS] String | B String,
--
-- the problem is to detect sharing so
-- that shared nodes are used only once
-- (for instance to output the name of
-- the node or to malloc it, ...).
--
-- Here, the goal is to clone the graph
-- into the following type
--
-- type NDS = [(Int,N)]
-- data N = NA [Int] String | B String
--
-- that is, each child of A is an Int in
-- a association list (N means 'named').
--
-- I see two possibility based on a Map
-- mapping already processed node to their
-- name :
-- - Map DS Int
-- - Map Int Int
--
-- The key in the first possibility is the
-- processed node itself. This mean it should be
-- an instance of Ord and the graph should be
-- acyclic.
--
-- The key in the second possibility is given
-- as the hash of the StableName of the node.
-- This need to be done in the IO monad.
-- This FAILS to detect the sharing.
--
-- Another possibility, which doesn't respect
-- exactly the problem as given above, is to
-- produce the graph directly in a monad that
-- holds the book-keeping of the name.
-- (Not implemented here.)
-- 

module Graph where

import Data.Map
import System.Mem.StableName

data DS = A [DS] String | B String
  deriving (Eq, Ord, Show) -- Ord for Data.Map.insert

type NDS = [(Int,N)]
data N = NA [Int] String | NB String
  deriving Show

ex1 = A [b,b] "arthur" where b = B "belzebuth"

-- This one will not terminate if show'd or namePure'd.
ex2 = let a = A [a] "arthur" in a

namePure :: DS -> NDS
namePure node = nds
  where (_,_,nds,_) = namePure1 node empty [1..] []

-- node : the node to name and add to the graph (i.e. the NDS).
-- dict : the map to remember which node has already been added
-- (it is a bit redundant with the NDS).
-- names : available names to name the nodes.
-- nds : the graph in construction.
namePure1 node dict names nds =
  if node `member` dict
  then (dict,names,nds,dict ! node)
  else case node of
         A children info ->
           let (dict',names',nds',children') =
                 namePureMany children dict names nds []
           in (insert node (head names') dict', tail names',
               (head names',NA children' info):nds', head names)
         B info          ->
           (insert node (head names) dict, tail names,
            (head names,NB info):nds, head names)

-- nodes : the nodes to name and add to the graph.
-- dict : see above.
-- names : see above.
-- nds : see above.
-- rnames : the names used in the graph, they are accumulated
-- while traversing the DS, then returned.
namePureMany [] dict names nds rnames = (dict,names,nds,rnames)
namePureMany nodes dict names nds rnames =
  let (dict',names',nds',name) = namePure1 (head nodes) dict names nds
  in namePureMany (tail nodes) dict' names' nds' (name:rnames)

nameIO :: DS -> IO NDS
nameIO node = do
  (_,_,nds,_) <- nameIO1 node empty [1..] []
  return nds

nameIO1 node dict names nds = do
  sname <- makeStableName node
  let key = hashStableName sname
  if key `member` dict
   then return (dict,names,nds,dict ! key)
   else case node of
         A children info -> do
           (dict',names',nds',children') <-
             nameIOMany children dict names nds []
           return (insert key (head names') dict', tail names',
                   (head names',NA children' info):nds', head names)
         B info          -> do
           return (insert key (head names) dict, tail names,
                   (head names,NB info):nds, head names)

nameIOMany [] dict names nds rnames = return (dict,names,nds,rnames)
nameIOMany nodes dict names nds rnames = do
  (dict',names',nds',name) <- nameIO1 (head nodes) dict names nds
  nameIOMany (tail nodes) dict' names' nds' (name:rnames)