Initial Check in of Janis’ Code
authorJoachim Breitner <mail@joachim-breitner.de>
Mon, 6 Oct 2008 11:35:08 +0000 (11:35 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Mon, 6 Oct 2008 11:35:08 +0000 (11:35 +0000)
Bff.hs [new file with mode: 0644]
Data/IntMapEq.hs [new file with mode: 0644]
Data/IntMapOrd.hs [new file with mode: 0644]
Data/Zippable.hs [new file with mode: 0644]
Test.hs [new file with mode: 0644]

diff --git a/Bff.hs b/Bff.hs
new file mode 100644 (file)
index 0000000..193a68d
--- /dev/null
+++ b/Bff.hs
@@ -0,0 +1,125 @@
+{-# OPTIONS_GHC -XRank2Types #-}
+
+module Bff (bff, bff_Eq, bff_Ord) where
+
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap (fromAscList, union, lookup, empty, insert)
+import Data.IntMapEq (IntMapEq)
+import qualified Data.IntMapEq as IntMapEq (union, lookup, empty, lookupR, insert, checkInsert)
+import Data.IntMapOrd (IntMapOrd)
+import qualified Data.IntMapOrd as IntMapOrd (union, lookup, fromAscPairList, empty, checkInsert, lookupR)
+import Data.Set (Set)
+import qualified Data.Set as Set (toAscList, singleton)
+import Maybe (fromJust)
+import Control.Monad.State (State, runState)
+import qualified Control.Monad.State as State (get, put)
+import Control.Applicative 
+import Control.Functor.Combinators.Lift
+import Data.Traversable
+import Data.Foldable
+import Data.Zippable
+
+template :: Traversable k => k a -> (k Int, IntMap a)
+template s = 
+  case runState (go s) ([],0)
+  of   (s',(l,_)) -> (s',IntMap.fromAscList (reverse l))
+  where go = unwrapMonad
+               . traverse (WrapMonad . number)
+
+number :: a -> State ([(Int,a)], Int) Int
+number a  = do (l,i) <- State.get
+               State.put ((i,a):l, i+1)
+               return i
+
+assoc :: (Zippable k, Foldable k, Eq a)
+         => k Int -> k a -> Either String (IntMap a)
+assoc = makeAssoc checkInsert IntMap.empty
+
+makeAssoc :: (Zippable k, Foldable k) 
+             => (Int -> a -> b -> Either String b) -> b
+                -> k Int -> k a -> Either String b
+makeAssoc checkInsert empty s'' v =
+  either Left f (tryZip s'' v)
+    where f = Data.Foldable.foldr 
+                (either Left . uncurry checkInsert) 
+                (Right empty) 
+
+checkInsert :: Eq a => Int -> a -> IntMap a
+                       -> Either String (IntMap a)
+checkInsert i b m =
+  case IntMap.lookup i m of
+    Nothing -> Right (IntMap.insert i b m)
+    Just c  -> if b==c 
+                 then Right m 
+                 else Left "Update violates equality."
+
+bff :: (Traversable k, Zippable k', Foldable k') 
+       => (forall a. k a -> k' a) 
+          -> (forall a. Eq a => k a -> k' a -> k a)
+bff get = \s v ->
+  let (s',g) = template s
+      h      = either error id (assoc (get s') v)
+      h'     = IntMap.union h g
+  in  seq h (fmap (fromJust . flip IntMap.lookup h') s')
+
+
+template_Eq :: (Traversable k, Eq a) 
+               => k a -> (k Int, IntMapEq a)
+template_Eq s = case runState (go s) (IntMapEq.empty,0) 
+                of   (s',(g,_)) -> (s',g)
+  where go = unwrapMonad
+               . traverse (WrapMonad . number_Eq)
+
+number_Eq :: Eq a => a -> State (IntMapEq a, Int) Int
+number_Eq a = 
+  do (m,i) <- State.get
+     case IntMapEq.lookupR a m of
+       Just j  -> return j
+       Nothing -> do let m' = IntMapEq.insert i a m
+                     State.put (m',i+1)
+                     return i
+
+assoc_Eq :: (Zippable k, Foldable k, Eq a)
+            => k Int -> k a -> Either String (IntMapEq a)
+assoc_Eq = makeAssoc IntMapEq.checkInsert 
+                     IntMapEq.empty
+
+bff_Eq :: (Traversable k, Zippable k', Foldable k') 
+          => (forall a. Eq a => k a -> k' a) 
+             -> (forall a. Eq a => k a -> k' a -> k a)
+bff_Eq get = \s v -> 
+  let (s',g) = template_Eq s
+      h      = either error id (assoc_Eq (get s') v)
+      h'     = either error id (IntMapEq.union h g)
+  in  seq h' (fmap (fromJust . flip IntMapEq.lookup h') s')
+
+
+template_Ord :: (Traversable k, Ord a) 
+                => k a -> (k Int,IntMapOrd a)
+template_Ord s = 
+  case traverse number_Ord s of
+    Lift (Const as,f) -> let m = IntMapOrd.fromAscPairList 
+                                 (zip [0..] (Set.toAscList as))
+                         in  (f m,m)
+
+number_Ord :: Ord a => a -> Lift (,) (Const (Set a)) 
+                                     ((->) (IntMapOrd a)) Int
+number_Ord a = Lift (Const (Set.singleton a), 
+                     fromJust . IntMapOrd.lookupR a)
+
+assoc_Ord :: (Zippable k, Foldable k, Ord a)
+             => k Int -> k a -> Either String (IntMapOrd a)
+assoc_Ord = makeAssoc IntMapOrd.checkInsert 
+                      IntMapOrd.empty
+
+bff_Ord :: (Traversable k, Zippable k', Foldable k') 
+           => (forall a. Ord a => k a -> k' a) 
+              -> (forall a. Ord a => k a -> k' a -> k a)
+bff_Ord get = \s v ->
+  let (s',g) = template_Ord s
+      h      = either error id (assoc_Ord (get s') v)
+      h'     = either error id (IntMapOrd.union h g)
+  in  seq h' (fmap (fromJust . flip IntMapOrd.lookup h') s')
+
+
+
diff --git a/Data/IntMapEq.hs b/Data/IntMapEq.hs
new file mode 100644 (file)
index 0000000..76cb836
--- /dev/null
@@ -0,0 +1,53 @@
+module Data.IntMapEq 
+  ( IntMapEq,
+    empty,
+    insert,
+    checkInsert,
+    lookup,
+    lookupR,
+    union ) where
+
+import qualified Data.IntMap as IntMap
+import Prelude hiding (lookup)
+import qualified Prelude
+
+newtype IntMapEq a = IntMapEq (IntMap.IntMap a)
+
+instance Show a => Show (IntMapEq a) where
+  show (IntMapEq m) = show m
+
+empty :: IntMapEq a
+empty = IntMapEq IntMap.empty
+
+insert :: Int -> a -> IntMapEq a -> IntMapEq a
+insert k a (IntMapEq m) = IntMapEq (IntMap.insert k a m)
+
+checkInsert :: Eq a => Int -> a -> IntMapEq a -> Either String (IntMapEq a)
+checkInsert i b m = case lookup i m of
+                      Nothing -> if memberR b m 
+                                   then Left "Update violates unequality."
+                                   else Right (insert i b m)
+                      Just c  -> if b==c 
+                                   then Right m 
+                                   else Left "Update violates equality."
+
+member :: Int -> IntMapEq a -> Bool
+member k (IntMapEq m) = IntMap.member k m
+
+memberR :: Eq a => a -> IntMapEq a -> Bool
+memberR a (IntMapEq m) = elem a (IntMap.elems m)
+
+lookup :: Int -> IntMapEq a -> Maybe a
+lookup k (IntMapEq m) = IntMap.lookup k m
+
+lookupR :: Eq a => a -> IntMapEq a -> Maybe Int
+lookupR a (IntMapEq m) = Prelude.lookup a (map (\(k,a) -> (a,k)) (IntMap.toList m))
+
+union :: Eq a => IntMapEq a -> IntMapEq a -> Either String (IntMapEq a)
+union h (IntMapEq m) = IntMap.foldWithKey f (Right h) m
+  where f j a (Right h) = if member j h 
+                            then Right h 
+                            else if memberR a h
+                                   then Left "Update violates unequality."
+                                   else Right (insert j a h)
+        f j a l         = l
diff --git a/Data/IntMapOrd.hs b/Data/IntMapOrd.hs
new file mode 100644 (file)
index 0000000..5e3eb55
--- /dev/null
@@ -0,0 +1,60 @@
+module Data.IntMapOrd 
+  ( IntMapOrd,
+    lookupR,
+    lookup,
+    union,
+    empty,
+    checkInsert,
+    fromAscPairList ) where
+
+import qualified Data.Map as Map
+import qualified Data.Bimap as Bimap
+import Prelude hiding (lookup)
+
+newtype IntMapOrd a = IntMapOrd (Bimap.Bimap Int a) 
+
+instance Show a => Show (IntMapOrd a) where
+  show (IntMapOrd m) = show m
+
+lookupR :: Ord a => a -> IntMapOrd a -> Maybe Int
+lookupR a (IntMapOrd m) = Bimap.lookupR a m
+
+member :: Ord a => Int -> IntMapOrd a -> Bool
+member k (IntMapOrd m) = Bimap.member k m
+
+memberR :: Ord a => a -> IntMapOrd a -> Bool
+memberR a (IntMapOrd m) = Bimap.memberR a m
+
+fromAscPairList :: Ord a => [(Int,a)] -> IntMapOrd a
+fromAscPairList l = IntMapOrd (Bimap.fromAscPairListUnchecked l)
+
+empty :: IntMapOrd a
+empty = IntMapOrd Bimap.empty
+
+lookup :: Ord a => Int -> IntMapOrd a -> Maybe a
+lookup k (IntMapOrd m) = Bimap.lookup k m
+
+insert :: Ord a => Int -> a -> IntMapOrd a -> Either String (IntMapOrd a)
+insert k a (IntMapOrd m) = let (m1,m2) = Map.split k (Bimap.toMap m)
+                           in  if (Map.null m1 || snd (Map.findMax m1) < a) 
+                                  && (Map.null m2 || snd (Map.findMin m2) > a) 
+                               then Right (IntMapOrd (Bimap.insert k a m)) 
+                               else Left "Update violates relative order."
+
+checkInsert :: Ord a => Int -> a -> IntMapOrd a -> Either String (IntMapOrd a)
+checkInsert i b m = case lookup i m of
+                      Nothing -> if memberR b m
+                                   then Left "Update violates unequality."
+                                   else insert i b m
+                      Just c  -> if b==c 
+                                   then Right m 
+                                   else Left "Update violates equality."
+
+union :: Ord a => IntMapOrd a -> IntMapOrd a -> Either String (IntMapOrd a)
+union h (IntMapOrd m) = Bimap.fold f (Right h) m
+  where f k a (Right h) = if member k h 
+                            then Right h 
+                            else if memberR a h
+                                   then Left "Update violates unequality."
+                                   else insert k a h
+        f k a l         = l
diff --git a/Data/Zippable.hs b/Data/Zippable.hs
new file mode 100644 (file)
index 0000000..9855352
--- /dev/null
@@ -0,0 +1,5 @@
+module Data.Zippable where
+
+class Zippable k where
+  tryZip :: k Int -> k a -> Either String (k (Int,a))
+
diff --git a/Test.hs b/Test.hs
new file mode 100644 (file)
index 0000000..66d2132
--- /dev/null
+++ b/Test.hs
@@ -0,0 +1,56 @@
+{-# OPTIONS_GHC  -XTemplateHaskell -XFlexibleInstances -XFlexibleContexts #-}
+
+module Test where
+
+import Control.Applicative 
+import Control.Functor.Combinators.Lift
+import Control.Monad.Either
+import Data.Traversable
+import Data.Foldable
+import Data.Zippable
+import Data.DeriveTH
+import Data.Derive.Traversable
+
+data Tree a = Leaf a | Node (Tree a) (Tree a) deriving Show
+
+$( derive makeTraversable ''Tree )
+
+instance Foldable Tree where
+  foldMap = foldMapDefault
+
+instance Functor Tree where
+  fmap = fmapDefault
+
+instance Zippable [] where
+  tryZip []     []     = Right []
+  tryZip (i:is) (b:bs) = Right (:) <*> Right (i,b)
+                                   <*> tryZip is bs
+  tryZip _      _      = Left "Update changes the length."
+
+instance Zippable Tree where
+  tryZip (Leaf i)     (Leaf b)     = Right (Leaf (i,b))
+  tryZip (Node t1 t2) (Node v1 v2) = Right Node 
+                                     <*> tryZip t1 v1 
+                                     <*> tryZip t2 v2
+  tryZip _ _ = Left "Update changes the shape."
+
+
+instance (Traversable k1, Traversable k2) 
+         => Traversable (Lift (,) k1 k2) where
+  traverse f (Lift (k1,k2)) = pure (curry Lift) 
+                              <*> traverse f k1
+                              <*> traverse f k2
+
+instance (Traversable k1, Traversable k2) 
+         => Foldable (Lift (,) k1 k2) where
+  foldMap = foldMapDefault
+
+instance (Zippable k1, Zippable k2) 
+         => Zippable (Lift (,) k1 k2) where
+  tryZip (Lift (k1,k2)) (Lift (k1',k2')) = Right (curry Lift) 
+                                           <*> tryZip k1 k1' 
+                                           <*> tryZip k2 k2'
+
+instance (Show (k1 a), Show (k2 a)) 
+         => Show (Lift (,) k1 k2 a) where
+  show (Lift p) = "Lift " ++ show p