uni-graphs-2.2.0.0: Graphs/Graph.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}

-- | Graph defines the Graph class, which defines the basic things a
-- graph must do.  Peculiarities:
-- (1) Graphs are directed with labelled nodes and
--     arcs.  These nodes and arcs have types.
-- (2) The nodes and arcs are identified by values of type Node and Arc.
--     These values are essentially strings.  The strings are provided by
--     the user; there is no mechanism for generating new unique strings.
--     (This is because this is easy in the applications I have in mind.)
-- (3) A necessary feature of these graphs is that it is supposed to
--     be easy generate copies, both on the same system and on others.
module Graphs.Graph(
   Graph(..), -- the Graph class
   -- Instances are parameterised on
   -- nodeLabel, nodeTypeLabel, arcLabel, arcTypeLabel.

   -- Nodes, Arc, NodeTypes, Arc
   Node, Arc, NodeType, ArcType,
   -- These are all instances of AtomString.StringClass (and so Read & Show).
   -- This means that they are essentially strings; the different types
   -- are just there to add a little abstraction.
   -- They are also all instances of Eq and Ord.  However there
   -- is no guarantee that the ordering will be the same as for the
   -- corresponding strings.
   firstNode,
   -- :: Node
   -- first Node in the node ordering.

   -- They are also instances of Typeable.

   -- Updates
   Update(..),
   -- datatype encoding update to shared graph
   -- Like instances of Graph, parameterised on
   -- nodeLabel, nodeTypeLabel, arcLabel, arcTypeLabel.
   -- Derives Read and Show.

   CannedGraph(..),
   -- contains complete immutable contents of a Graph at some time
   -- Like instances of Graph, parameterised on
   -- nodeLabel, nodeTypeLabel, arcLabel, arcTypeLabel.
   -- Derives Read and Show.

   GraphConnection,
   GraphConnectionData(..),
   -- A GraphConnection contains the information generated by one
   -- instance of Graph, which can be used to construct another,
   -- including a CannedGraph.
   -- Like instances of Graph, parameterised on
   -- nodeLabel, nodeTypeLabel, arcLabel, arcTypeLabel.

   PartialShow(..),
      -- newtype alias for showing updates.
      -- NB.  This type might get moved into ExtendedPrelude if it proves
      -- useful elsewhere.

   ) where

import Util.AtomString
import Util.QuickReadShow
import Util.Dynamics
import Graphs.NewNames

class Graph graph where
   -- access functions
   getNodes :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> IO [Node]
   getArcs :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> IO [Arc]
   getNodeTypes :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> IO [NodeType]
   getArcTypes :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> IO [ArcType]

   getArcsOut :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> Node -> IO [Arc]
   getArcsIn :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> Node -> IO [Arc]
   getNodeLabel :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> Node -> IO nodeLabel
   getNodeType :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> Node -> IO NodeType
   getNodeTypeLabel :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> NodeType -> IO nodeTypeLabel

   getSource :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> Arc -> IO Node
   getTarget :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> Arc -> IO Node
   getArcLabel :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> Arc -> IO arcLabel
   getArcType :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> Arc -> IO ArcType
   getArcTypeLabel :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> ArcType -> IO arcTypeLabel

   shareGraph :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel
   newGraph :: GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> IO (graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)

   -- Functions for changing the state.
   newNodeType :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> nodeTypeLabel -> IO NodeType
   newNode :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> NodeType -> nodeLabel -> IO Node
   newArcType :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> arcTypeLabel -> IO ArcType
   newArc :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> ArcType -> arcLabel -> Node -> Node -> IO Arc

   -- Other updates, such as deletions should be done with the update
   -- function.  It is also possible to add nodes, arcs, arctypes and
   -- nodetypes using update; however in this case the caller is responsible
   -- for providing a globally new label.
   update :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ()

   newEmptyGraph :: IO (graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
   -- Actually newEmptyGraph can be synthesised from the above functions
   -- by synthesising a null GraphConnection and passing it to newGraph.

------------------------------------------------------------------------
-- GraphConnection
------------------------------------------------------------------------

type GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel =
   (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ())
   -> IO (GraphConnectionData nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
   -- The first argument is passed back to the parent graph and
   -- indicates where to put changes to the parent graph since the
   -- canned graph was made.

data GraphConnectionData nodeLabel nodeTypeLabel arcLabel arcTypeLabel =
      GraphConnectionData {
   graphState :: CannedGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel,
      -- current state of graph
   deRegister :: IO (),
      -- disables graphUpdates
   graphUpdate :: Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -> IO(),
      -- Similar to update (in class definition) except that
      -- it doesn't get echoed on graphUpdates.
   nameSourceBranch :: NameSourceBranch
      -- A source of new names.  Each graph should contain a NameSource
      -- to generate new node strings.
   }

------------------------------------------------------------------------
-- Nodes, Arcs, NodeTypes, ArcTypes.
------------------------------------------------------------------------

newtype Node = Node AtomString deriving (Eq,Ord,Typeable)

instance StringClass Node where
   toString (Node atomString) = toString atomString
   fromString atomString = Node (fromString atomString)

instance Show Node where
   showsPrec = qShow

instance Read Node where
   readsPrec = qRead

firstNode :: Node
firstNode = Node firstAtomString

newtype NodeType = NodeType AtomString deriving (Eq,Ord,Typeable)

instance StringClass NodeType where
   toString (NodeType atomString) = toString atomString
   fromString atomString = NodeType (fromString atomString)

instance Show NodeType where
   showsPrec = qShow

instance Read NodeType where
   readsPrec = qRead

newtype Arc = Arc AtomString deriving (Eq,Ord,Typeable)

instance StringClass Arc where
   toString (Arc atomString) = toString atomString
   fromString atomString = Arc (fromString atomString)

instance Show Arc where
   showsPrec = qShow

instance Read Arc where
   readsPrec = qRead

newtype ArcType = ArcType AtomString deriving (Eq,Ord,Typeable)

instance StringClass ArcType where
   toString (ArcType atomString) = toString atomString
   fromString atomString = ArcType (fromString atomString)

instance Show ArcType where
   showsPrec = qShow

instance Read ArcType where
   readsPrec = qRead

------------------------------------------------------------------------
-- Update
------------------------------------------------------------------------

data Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel =
   -- NB.  For various reasons, we decree that DeleteNode and DeleteArc should
   -- return normally, doing nothing, should the node already be deleted.
      NewNodeType NodeType nodeTypeLabel
   |  SetNodeTypeLabel NodeType nodeTypeLabel
   |  NewNode Node NodeType nodeLabel
   |  DeleteNode Node
   |  SetNodeLabel Node nodeLabel
   |  SetNodeType Node NodeType
   |  NewArcType ArcType arcTypeLabel
   |  SetArcTypeLabel ArcType arcTypeLabel
   |  NewArc Arc ArcType arcLabel Node Node
   |  DeleteArc Arc
   |  SetArcLabel Arc arcLabel
   |  SetArcType Arc ArcType
   |  MultiUpdate [Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel]
      -- can be used to present unnecessary redrawing when making big
      -- updates.
   deriving (Read,Show)

-- ---------------------------------------------------------------------
-- Show instance which does not require argument types to be showable
-- ---------------------------------------------------------------------

newtype PartialShow a = PartialShow a

instance Show (PartialShow a) => Show (PartialShow [a]) where
   show (PartialShow as) = show (map PartialShow as)

instance Show (PartialShow (
      Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)) where
   show (PartialShow update) = case update of
      NewNodeType nodeType nodeTypeLabel ->
         "NewNodeType " ++ show nodeType
      SetNodeTypeLabel nodeType nodeTypeLabel ->
         "SetNodeTypeLabel " ++ show nodeType
      NewNode node nodeType nodeLabel ->
         "NewNode " ++ show node ++ "::" ++ show nodeType
      DeleteNode node ->
         "DeleteNode " ++ show node
      SetNodeLabel node nodeLabel ->
         "SetNodeLabel " ++ show node
      SetNodeType node nodeType ->
         "SetNodeType " ++ show node ++ "::" ++ show nodeType
      NewArcType arcType arcTypeLabel ->
         "NewArcType " ++ show arcType
      SetArcTypeLabel arcType arcTypeLabel ->
         "SetArcTypeLabel " ++ show arcType
      NewArc arc arcType arcLabel node1 node2 ->
         "NewArc " ++ show arc ++ "::" ++ show arcType ++ " " ++ show node1
             ++ "->" ++ show node2
      DeleteArc arc ->
         "DeleteArc " ++ show arc
      SetArcLabel arc arcLabel ->
         "SetArcLabel " ++ show arc
      SetArcType arc arcType ->
         "SetArcType " ++ show arc ++ "::" ++ show arcType
      MultiUpdate updates -> "MultiUpdate " ++ show (PartialShow updates)

instance Show (PartialShow (
      CannedGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)) where
   show (PartialShow (CannedGraph {updates = updates})) =
      "CannedGraph " ++ show (PartialShow updates)


------------------------------------------------------------------------
-- CannedGraph
------------------------------------------------------------------------

data CannedGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel =
   CannedGraph {
      updates :: [Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel]
      -- This list may only contain NewNodeType, NewNode, NewArcType and
      -- NewArc definitions.  The updates are processed in list order, so
      -- for example the endpoints of an Arc should be created before the Arc.
      } deriving (Read,Show)