mcmc-samplers-0.1.1.0: MCMC/SemanticEditors.hs

-- | Semantic editor combinators
-- 
-- <http://conal.net/blog/posts/semantic-editor-combinator>

module MCMC.SemanticEditors ( first
                            , second
                            , car
                            , cdr
                            , nth
                            , nthM
                            , block
                            , blockM
                            , swapWith
                            , chopAt
                            ) where

first  :: (a -> a') -> ((a,b) -> (a',b))
second :: (b -> b') -> ((a,b) -> (a,b'))
 
first  f = \ (a,b) -> (f a, b)
second g = \ (a,b) -> (a, g b)

car :: (a -> a) -> ([a] -> [a])
cdr :: ([a] -> [a]) -> ([a] -> [a])

car f = \(x:xs) -> f x : xs
cdr f = \(x:xs) -> x : f xs

--  A sample is 1-indexed, i.e., dimensions go from 1 to n

nth :: Int -> (a -> a) -> ([a] -> [a])
nth 1 = car
nth n = cdr . nth (n-1)

carM :: Monad m => (a -> m a) -> ([a] -> m [a])
carM f (x:xs) = do x' <- f x 
                   return $ x' : xs

cdrM :: Monad m => ([a] -> m [a]) -> ([a] -> m [a])
cdrM f (x:xs) = do xs' <- f xs
                   return $ x : xs'

nthM :: Monad m => Int -> (a -> m a) -> ([a] -> m [a])
nthM 1 = carM
nthM n = cdrM . nthM (n-1)

block :: Int -> Int -> ([a] -> [a]) -> ([a] -> [a])
block begin end f ls
    | begin == end = nth begin (single f) ls
    | begin == 1 = f (take end ls) ++ drop end ls
    | otherwise = front ++ f mids ++ back
    where (front, mids, back) = chopAt begin end ls

blockM :: Monad m => Int -> Int -> ([a] -> m [a]) -> ([a] -> m [a])
blockM begin end f ls
    | begin == end = nthM begin (singleM f) ls
    | begin == 1 = f (take end ls) >>= return . flip (++) (drop end ls)
    | otherwise = do let (front, mids, rest) = chopAt begin end ls
                     fmids <- f mids
                     return $ front ++ fmids ++ rest

swapWith :: a -> (b -> a)
swapWith x _ = x

single :: ([a] -> [a]) -> a -> a
single f x = head $ f [x]

singleM :: Monad m => ([a] -> m [a]) -> a -> m a
singleM f x = f [x] >>= return.head

chopAt :: Int -> Int -> [a] -> ([a], [a], [a])
chopAt begin end ls = (front, mids, back)
    where (front, rest) = splitAt (begin-1) ls
          (mids, back) = splitAt (end + 1 - begin) rest