swish-0.2.1: Swish/HaskellRDF/GraphMem.hs
{-# OPTIONS -XFlexibleInstances #-}
{-# OPTIONS -XMultiParamTypeClasses #-}
--------------------------------------------------------------------------------
-- $Id: GraphMem.hs,v 1.16 2004/02/09 22:22:44 graham Exp $
--
-- Copyright (c) 2003, G. KLYNE. All rights reserved.
-- See end of this file for licence information.
--------------------------------------------------------------------------------
-- |
-- Module : GraphMem
-- Copyright : (c) 2003, Graham Klyne
-- License : GPL V2
--
-- Maintainer : Graham Klyne
-- Stability : provisional
-- Portability : H98
--
-- This module defines a simple memory-based graph instance.
--
--------------------------------------------------------------------------------
------------------------------------------------------------
-- Simple labelled directed graph value
------------------------------------------------------------
module Swish.HaskellRDF.GraphMem
( GraphMem(..)
, setArcs, getArcs, add, delete, extract, labels
, LabelMem(..)
, labelIsVar, labelHash
-- For debug/test:
, matchGraphMem
) where
import Swish.HaskellUtils.LookupMap
import Swish.HaskellRDF.GraphClass
import Swish.HaskellRDF.GraphMatch
import Swish.HaskellUtils.MiscHelpers
( hash )
import Swish.HaskellUtils.FunctorM
( FunctorM(..) )
import Data.List
( nub, union, (\\), group, sort, sortBy, any )
import Data.Maybe
( isJust )
-----------------------------------------------------
-- Memory-based graph type and graph class functions
-----------------------------------------------------
data GraphMem lb = GraphMem { arcs :: [Arc lb] }
instance (Label lb) => LDGraph GraphMem lb where
getArcs = arcs
setArcs as g = g { arcs=as }
-- gmap f g = g { arcs = (map $ fmap f) (arcs g) }
instance (Label lb) => Eq (GraphMem lb) where
(==) = graphEq
instance (Label lb) => Show (GraphMem lb) where
show = graphShow
instance Functor GraphMem where
fmap f g = GraphMem $ map (fmap f) (arcs g)
instance FunctorM GraphMem where
fmapM f g =
do { arcs <- mapM (fmapM f) (arcs g)
; return $ GraphMem arcs
}
graphShow :: (Label lb) => GraphMem lb -> String
graphShow g = "Graph:"++(foldr (++) "" (map ("\n "++) (map show (arcs g))))
toGraph :: (Label lb) => [Arc lb] -> GraphMem lb
toGraph as = GraphMem { arcs=(nub as) }
-----------
-- graphEq
-----------
--
-- Return Boolean graph equality
graphEq :: (Label lb) => GraphMem lb -> GraphMem lb -> Bool
graphEq g1 g2 = fst ( matchGraphMem g1 g2 )
-----------------
-- matchGraphMem
-----------------
--
-- GraphMem matching function accepting GraphMem value and returning
-- node map if successful
--
-- g1 is the first of two graphs to be compared
-- g2 is the second of two graphs to be compared
--
-- returns a label map that maps each label to an equivalence
-- class identifier, or Nothing if the graphs cannot be
-- matched.
matchGraphMem :: (Label lb) => GraphMem lb -> GraphMem lb
-> (Bool,LabelMap (ScopedLabel lb))
matchGraphMem g1 g2 =
let
gs1 = arcs g1
gs2 = arcs g2
matchable l1 l2
| (labelIsVar l1) && (labelIsVar l2) = True
| (labelIsVar l1) || (labelIsVar l2) = False
| otherwise = l1 == l2
in
graphMatch matchable gs1 gs2
---------------
-- graphBiject
---------------
--
-- Return bijection between two graphs, or empty list
{-
graphBiject :: (Label lb) => GraphMem lb -> GraphMem lb -> [(lb,lb)]
graphBiject g1 g2 = if null lmap then [] else zip (sortedls g1) (sortedls g2)
where
lmap = graphMatch g1 g2
sortedls g = map snd $
(sortBy indexComp) $
equivalenceClasses (graphLabels $ arcs g) lmap
classComp ec1 ec2 = indexComp (classIndexVal ec1) (classIndexVal ec2)
indexComp (g1,v1) (g2,v2)
| g1 == g2 = compare v1 v2
| otherwise = compare g1 g2
-}
------------------------------------------------------------
-- Minimal graph label value - for testing
------------------------------------------------------------
data LabelMem
= LF String
| LV String
instance Label LabelMem where
labelIsVar (LV _) = True
labelIsVar _ = False
getLocal (LV loc) = loc
getLocal lab = error "getLocal of non-variable label: "++(show lab)
makeLabel loc = LV loc
labelHash seed lb = hash seed (show lb)
instance Eq LabelMem where
(LF l1) == (LF l2) = l1 == l2
(LV l1) == (LV l2) = l1 == l2
_ == _ = False
instance Show LabelMem where
show (LF l1) = "!"++l1
show (LV l2) = "?"++l2
instance Ord LabelMem where
compare l1 l2 = compare (show l1) (show l2)
--------------------------------------------------------------------------------
--
-- Copyright (c) 2003, G. KLYNE. All rights reserved.
--
-- This file is part of Swish.
--
-- Swish is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2 of the License, or
-- (at your option) any later version.
--
-- Swish is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with Swish; if not, write to:
-- The Free Software Foundation, Inc.,
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
--
--------------------------------------------------------------------------------
-- $Source: /file/cvsdev/HaskellRDF/GraphMem.hs,v $
-- $Author: graham $
-- $Revision: 1.16 $
-- $Log: GraphMem.hs,v $
-- Revision 1.16 2004/02/09 22:22:44 graham
-- Graph matching updates: change return value to give some indication
-- of the extent match achieved in the case of no match.
-- Added new module GraphPartition and test cases.
-- Add VehicleCapcity demonstration script.
--
-- Revision 1.15 2003/09/24 18:50:52 graham
-- Revised module format to be Haddock compatible.
--
-- Revision 1.14 2003/06/10 17:38:34 graham
-- Remove some unneeded calss constraints from data type declarations
-- Reworked NSGraph to be an instance of Functor, replacing function
-- gmap with fmap. Graph formulae are still not handled well: the data types
-- will need re-working so that a "Formula lb" type constructor can be
-- introduced having the correct (* -> *) kind to be a Functor.
--
-- Revision 1.13 2003/06/03 19:24:13 graham
-- Updated all source modules to cite GNU Public Licence
--
-- Revision 1.12 2003/05/30 15:04:56 graham
-- Fix references to defunct GraphHelpers module
--
-- Revision 1.11 2003/05/26 22:30:36 graham
-- Working on graph merge.
-- Added methods to Graph class for manipulating variable node.
-- Need to get RDFGraph to compile. And test.
--
-- Revision 1.10 2003/05/23 16:29:20 graham
-- Partial code cleanup:
-- - Arc is an alebraic type
-- - Arc is an instance of Functor
-- - add gmap function to Graph interface
-- - remove some duplicate functions from GraphMatch
-- This in preparation for adding graph merge facility with
-- blank node renaming.
--
-- Revision 1.9 2003/05/14 02:01:59 graham
-- GraphMatch recoded and almost working, but
-- there are a couple of
-- obscure bugs that are proving rather stubborn to squash.
--
-- Revision 1.8 2003/05/08 18:55:36 graham
-- Updated graph matching module to deal consistently
-- with graphs containing formulae. All graph tests now
-- run OK, but the GraphMatch module is a mess and
-- desperately needs restructuring. Also, graph matching
-- performance needs to be improved.
--
-- Revision 1.7 2003/04/24 23:41:39 graham
-- Added Ord class membership to graph nodes
-- Added empty lookup table definition
-- Started on N3 formatter module
--
-- Revision 1.6 2003/04/11 18:04:49 graham
-- Rename GraphLookupMap to LookupMap:
-- GraphTest runs OK.
--
-- Revision 1.5 2003/04/10 13:41:22 graham
-- More graph code tidying
-- Graph test cases still run OK
--
-- Revision 1.4 2003/04/10 13:35:34 graham
-- Separated GraphMatch logic from GraphMem
--
-- Revision 1.3 2003/04/10 08:36:06 graham
-- Graph matching passes battery of new tests
-- Started work on RDF graph
--
-- Revision 1.2 2003/03/31 20:52:23 graham
-- Restructure graph matching to deal with same unbound node names in
-- different graphs. It shows signs that it might be working now.
-- More testing is needed.
--
-- Revision 1.1 2003/03/28 21:50:22 graham
-- Graph equality coded and nearly working
--