module Util.NameMonad(NameMonad(..),GenName(..),NameMT,runNameMT,runNameMT',freeNames,mixInt,mixInt3,hashInt) where
import Control.Monad.State
import Data.Bits
import Data.Word
import qualified Data.Set as Set
class Monad m => NameMonad n m | m -> n where
addNames :: [n] -> m ()
addBoundNames :: [n] -> m ()
newName :: m n
newNameFrom :: [n] -> m n
uniqueName :: n -> m n
addNames = addBoundNames
class GenName n where
genNames :: Int -> [n]
instance GenName Int where
genNames i = [st, st + 2 ..] where
st = abs i + 2 + abs i `mod` 2
freeNames :: (Ord n,GenName n) => Set.Set n -> [n]
freeNames s = filter (not . (`Set.member` s)) (genNames (Set.size s))
instance (Monad m, Monad (t m), MonadTrans t, NameMonad n m) => NameMonad n (t m) where
addNames n = lift $ addNames n
addBoundNames n = lift $ addBoundNames n
newName = lift newName
newNameFrom y = lift $ newNameFrom y
uniqueName y = lift $ uniqueName y
newtype NameMT n m a = NameMT (StateT (Set.Set n, Set.Set n) m a)
deriving(Monad, MonadTrans, Functor, MonadFix, MonadPlus, MonadIO)
runNameMT :: (Monad m) => NameMT a1 m a -> m a
runNameMT (NameMT x) = liftM fst $ runStateT x (Set.empty,Set.empty)
runNameMT' :: (Monad m) => NameMT a1 m a -> m (a,Set.Set a1)
runNameMT' (NameMT x) = do
(r,(used,bound)) <- runStateT x (Set.empty,Set.empty)
return (r,bound)
fromNameMT :: NameMT n m a -> StateT (Set.Set n, Set.Set n) m a
fromNameMT (NameMT x) = x
instance (GenName n,Ord n,Monad m) => NameMonad n (NameMT n m) where
addNames ns = NameMT $ do
modify (\ (used,bound) -> (Set.fromList ns `Set.union` used, bound) )
addBoundNames ns = NameMT $ do
let nset = Set.fromList ns
modify (\ (used,bound) -> (nset `Set.union` used, nset `Set.union` bound) )
uniqueName n = NameMT $ do
(used,bound) <- get
if n `Set.member` bound then fromNameMT newName else put (Set.insert n used,Set.insert n bound) >> return n
newNameFrom vs = NameMT $ do
(used,bound) <- get
let f (x:xs)
| x `Set.member` used = f xs
| otherwise = x
f [] = error "newNameFrom: finite list!"
nn = f vs
put (Set.insert nn used, Set.insert nn bound)
return nn
newName = NameMT $ do
(used,bound) <- get
fromNameMT $ newNameFrom (genNames (Set.size used `mixInt` Set.size bound))
hashInt :: Int -> Int
hashInt x = fromIntegral $ f (fromIntegral x) where
f :: Word -> Word
f a = a''''' where
!a' = (a `xor` 61) `xor` (a `shiftR` 16)
!a'' = a' + (a' `shiftL` 3)
!a''' = a'' `xor` (a'' `shiftR` 4)
!a'''' = a''' * 0x27d4eb2d
!a''''' = a'''' `xor` (a'''' `shiftR` 15)
mixInt :: Int -> Int -> Int
mixInt x y = hashInt x hashInt y
mixInt3 :: Int -> Int -> Int -> Int
mixInt3 x y z = (hashInt x hashInt y) `xor` hashInt z