Related
I have a list of pairs of views which represents list of content labels and their widths which I want to group in lines (if the next content label doesn't fit in line then put it into another line). So we have: viewList = [(View1, 45), (View2, 223.5), (View3, 14) (View4, 42)].
I want to write a function groupViews :: [a] -> [[a]] to group this list into a list of sublists where each sublist will contain only views with sum of widths less than the maximum specified width (let's say 250).
So for a sorted viewList this function will return : [[(View3, 14), (View4, 42), (View1, 45)],[(View2, 223.5)]]
It looks similar to groupBy. However, groupBy doesn't maintain an accumulator. I tried to use scanl + takeWhile(<250) combination but in this case I was able to receive only first valid sublist. Maybe use iterate + scanl + takeWhile somehow? But this looks very cumbersome and not functional at all. Any help will be much appreciated.
I would start with a recursive definition like this:
groupViews :: Double -> (a -> Double) -> [a] -> [[a]]
groupViews maxWidth width = go (0, [[]])
where
go (current, acc : accs) (view : views)
| current + width view <= maxWidth
= go (current + width view, (view : acc) : accs) views
| otherwise = go (width view, [view] : acc : accs) views
go (_, accs) []
= reverse $ map reverse accs
Invoked like groupViews 250 snd (sortOn snd viewList). The first thing I notice is that it can be represented as a left fold:
groupViews' maxWidth width
= reverse . map reverse . snd . foldl' go (0, [[]])
where
go (current, acc : accs) view
| current + width view <= maxWidth
= (current + width view, (view : acc) : accs)
| otherwise
= (width view, [view] : acc : accs)
I think this is fine, though you could factor it further if you like, into one scan to accumulate the widths modulo the max width, and another pass to group the elements into ascending runs. For example, here’s a version that works on integer widths:
groupViews'' maxWidth width views
= map fst
$ groupBy ((<) `on` snd)
$ zip views
$ drop 1
$ scanl (\ current view -> (current + width view) `mod` maxWidth) 0 views
And of course you can include the sort in these definitions instead of passing the sorted list from outside.
I don't know a clever way to do this just by combining functions from the standard library, but I do think you can do better than just implementing it from scratch.
This problem fits into a class of problems that I've seen before: "batch up items from this list somehow, and combine its items into batches according to some combination rule and some rule for deciding when a batch is too big". Years ago, when I was writing Clojure, I built a function that abstracted out this idea of batched combinations, just asking you to specify the rules for batching, and was able to use it in a surprising number of places.
Here's how I think it might be reimagined in Haskell:
glue :: Monoid a => (a -> Bool) -> [a] -> [a]
glue tooBig = go mempty
where go current [] = [current]
go current (x:xs) | tooBig x' = current : go x xs
| otherwise = go x' xs
where x' = current `mappend` x
If you had such a glue function already, you could build a simple data type with the appropriate Monoid instance (a list of objects and their cumulative sum), and then let glue do the heavy lifting:
import Data.Monoid (Sum(..))
data ViewGroup contents size = ViewGroup {totalSize :: size,
elements :: [(contents, size)]}
instance Monoid b => Monoid (ViewGroup a b) where
mempty = ViewGroup mempty []
mappend (ViewGroup lSize lElts) (ViewGroup rSize rElts) =
ViewGroup (lSize `mappend` rSize)
(lElts ++ rElts)
viewGroups = let views = [("a", 14), ("b", 42), ("c", 45), ("d", 223.5)]
in glue ((> 250) . totalSize) [ViewGroup (Sum width) [(x, Sum width)]
| (x, width) <- views]
main = print (viewGroups :: [ViewGroup String (Sum Double)])
[ViewGroup {totalSize = Sum {getSum = 101.0},
elements = [("a",Sum {getSum = 14.0}),
("b",Sum {getSum = 42.0}),
("c",Sum {getSum = 45.0})]},
ViewGroup {totalSize = Sum {getSum = 223.5},
elements = [("d",Sum {getSum = 223.5})]}]
On the one hand this looks like quite a bit of work for a simple function, but on the other it's rather nice to have a type that describes the cumulative summing you're doing, and Monoid instances are nice to have anyway...and after defining the type and the Monoid instance there's almost no work left to do in the calling of glue itself.
Well, I don't know, maybe it's still too much work, especially if you don't believe you can reuse that type. But I do think it's useful to recognize that this is a specific case of a more general problem, and try to solve the more general problem as well.
Given that groupBy and span themselves are defined by manual recursive functions, our modified functions will use the same mechanism.
Let us first define a general function groupAcc which takes an initial value for the accumulator, and then a function which takes an element in the list, the current accumulator state and potentially produces a new accumulated value (Nothing means the element is not accepted):
{-# LANGUAGE LambdaCase #-}
import Data.List (sortOn)
import Control.Arrow (first, second)
spanAcc :: z -> (a -> z -> Maybe z) -> [a] -> ((z, [a]), [a])
spanAcc z0 p = \case
xs#[] -> ((z0, xs), xs)
xs#(x:xs') -> case p x z0 of
Nothing -> ((z0, []), xs)
Just z1 -> first (\(z2, xt) -> (if null xt then z1 else z2, x : xt)) $
spanAcc z1 p xs'
groupAcc :: z -> (a -> z -> Maybe z) -> [a] -> [(z, [a])]
groupAcc z p = \case
[] -> [] ;
xs -> uncurry (:) $ second (groupAcc z p) $ spanAcc z p xs
For our specific problem, we define:
threshold :: (Num a, Ord a) => a -> a -> a -> Maybe a
threshold max a z0 = let z1 = a + z0 in if z1 < max then Just z1 else Nothing
groupViews :: (Ord z, Num z) => [(lab, z)] -> [[(lab, z)]]
groupViews = fmap snd . groupAcc 0 (threshold 250 . snd)
Which finally gives us:
groupFinal :: (Num a, Ord a) => [(lab, a)] -> [[(lab, a)]]
groupFinal = groupViews . sortOn snd
And ghci gives us:
> groupFinal [("a", 45), ("b", 223.5), ("c", 14), ("d", 42)]
[[("c",14.0),("d",42.0),("a",45.0)],[("b",223.5)]]
If we want to, we can simplify groupAcc by assuming that z is a Monoid wherefore mempty may be used, such that:
groupAcc2 :: Monoid z => (a -> z -> Maybe z) -> [a] -> [(z, [a])]
groupAcc2 p = \case
[] -> [] ;
xs -> let z = mempty in
uncurry (:) $ second (groupAcc z p) $ spanAcc z p xs
I tried to implement a simple reservoir sampling in haskell following http://jeremykun.com/2013/07/05/reservoir-sampling/ (note that the algorithm shown is possibly semantically incorrect)
According to this: Iterative or Lazy Reservoir Sampling lazy reservoir sampling is impossible unless you know the population size ahead of time.
Even so, I'm not understanding why (operationally speaking) the below sampleReservoir doesn't work on infinite lists. Just where exactly is laziness broken?
import System.Random (randomRIO)
-- equivalent to python's enumerate
enumerate :: (Num i, Enum i) => i -> [e] -> [(i, e)]
enumerate start = zip [start..]
sampleReservoir stream =
foldr
(\(i, e) reservoir -> do
r <- randomRIO (0.0, 1.0) :: IO Double
-- randomRIO gets confused about 0.0 and 1.0
if r < (1.0 / fromIntegral i) then
fmap (e:) reservoir
else
reservoir)
(return [])
(enumerate 1 stream)
The challenge and test is fmap (take 1) $ sampleReservoir [1..].
Furthermore, if reservoir sampling can't be lazy, what can take in a lazy list and produce a sampled lazy list?
I get the idea that there must be a way of making the above function lazy in the output as well, because I could change this:
if r < (1.0 / fromIntegral i) then
fmap (e:) reservoir
else
To:
if r < (1.0 / fromIntegral i) then
do
print e
fmap (e:) reservoir
This shows results as the function is iterating over the list. Using coroutine abstraction, perhaps instead of print e there can be a yield e, and the rest of the computation can be held as a continuation.
The problem is that the IO monad maintains a strict sequence between actions. Writing fmap (e:) reservoir will first execute all of the effects associated with reservoir, which will be infinite if the input list is infinite.
I was able to fix this with liberal use of unsafeInterleaveIO, which allows you to break the semantics of IO:
sampleReservoir2 :: [e] -> IO [e]
sampleReservoir2 stream =
foldr
(\(i, e) reservoir -> do
r <- unsafeInterleaveIO $ randomRIO (0.0, 1.0) :: IO Double -- randomRIO gets confused about 0.0 and 1.0
if r < (1.0 / fromIntegral i) then unsafeInterleaveIO $ do
rr <- reservoir
return (e:rr)
else
reservoir)
(return [])
(enumerate 1 stream)
Obviously, this will allow the interleaving of IO actions, but since all you're doing is generating random numbers it shouldn't matter. However, this solution isn't very satisfactory; the correct solution is to refactor your code somewhat. You should generate an infinite list of random numbers, then consume that infinite list (lazily) with foldr:
sampleReservoir3 :: MonadRandom m => [a] -> m [a]
sampleReservoir3 stream = do
ws <- getRandomRs (0, 1 :: Double)
return $ foldr
(\(w, (i, e)) reservoir ->
(if w < (1 / fromIntegral i) then (e:) else id) reservoir
)
[]
(zip ws $ enumerate 1 stream)
This can also (equivalently) be written as
sampleReservoir4 :: [a] -> IO [a]
sampleReservoir4 stream = do
seed <- newStdGen
let ws = randomRs (0, 1 :: Double) seed
return $ foldr
(\(w, (i, e)) reservoir ->
(if w < (1 / fromIntegral i) then (e:) else id) reservoir
)
[]
(zip ws $ enumerate 1 stream)
As an aside, I'm not sure as to the correctness of the algorithm, since it seems to always return the first element of the input list first. Not very random.
The Idea
Hello! I'm trying to implement in Haskell an image processing library based on dataflow ideology. I've got a problem connected to how I want to handle the flow of control.
The main idea is to introduce a time. The time is a Float, which could be accessed anywhere in the code (you can think of it like about State monad, but a little funnier). The funny thing about it, is that we can use timeShift operation on results, affecting the time corresponding operations would see.
An example would be best to explain this situation. Lets use following dataflow diagram:
-- timeShift(*2) --
-- / \
-- readImage -- addImages -> out
-- \ /
-- blur ----------
and its pseudocode (which deos not typecheck - its not important if we use do or let notation here, the idea should be clear):
test = do
f <- frame
a <- readImage $ "test" + show f + ".jpg"
aBlur <- blur a
a' <- a.timeShift(*2)
out <- addImage aBlur a'
main = print =<< runStateT test 5
The 5 is the time we want to run the test function with. The timeShift function affects all the operations on the left of it (in the dataflow diagram) - in this case the function readImage would be run twice - for both branches - the lower one would use frame 5 and the upper one frame 5*2 = 10.
The problem
I'm providing here a very simple implementation, that works great, but has some caveats I want to solve. The problem is, that I want to keep the order of all IO operations. Look at the bottom for example, which will clarify what I mean.
Sample implementation
Below is a sample implementation of the algorithm and a code, which constructs following dataflow graph:
-- A --- blur --- timeShift(*2) --
-- \
-- addImages -> out
-- /
-- B --- blur --------------------
the code:
import Control.Monad.State
-- for simplicity, lets assume an Image is just a String
type Image = String
imagesStr = ["a0","b1","c2","d3","e4","f5","g6","h7","i8","j9","k10","l11","m12","n13","o14","p15","q16","r17","s18","t19","u20","v21","w22","x23","y24","z25"]
images = "abcdefghjiklmnoprstuwxyz"
--------------------------------
-- Ordinary Image processing functions
blurImg' :: Image -> Image
blurImg' img = "(blur " ++ img ++ ")"
addImage' :: Image -> Image -> Image
addImage' img1 img2 = "(add " ++ img1 ++ " " ++ img2 ++ ")"
--------------------------------
-- Functions processing Images in States
readImage1 :: StateT Int IO Image
readImage1 = do
t <- get
liftIO . putStrLn $ "[1] reading image with time: " ++ show t
return $ imagesStr !! t
readImage2 :: StateT Int IO Image
readImage2 = do
t <- get
liftIO . putStrLn $ "[2] reading image with time: " ++ show t
return $ imagesStr !! t
blurImg :: StateT Int IO Image -> StateT Int IO Image
blurImg img = do
i <- img
liftIO $ putStrLn "blurring"
return $ blurImg' i
addImage :: StateT Int IO Image -> StateT Int IO Image -> StateT Int IO Image
addImage img1 img2 = do
i1 <- img1
i2 <- img2
liftIO $ putStrLn "adding images"
return $ addImage' i1 i2
timeShift :: StateT Int IO Image -> (Int -> Int) -> StateT Int IO Image
timeShift img f = do
t <- get
put (f t)
i <- img
put t
return i
test = out where
i1 = readImage1
j1 = readImage2
i2 = blurImg i1
j2 = blurImg j1
i3 = timeShift i2 (*2)
out = addImage i3 j2
main = do
print =<< runStateT test 5
print "end"
The output is:
[1] reading image with time: 10
blurring
[2] reading image with time: 5
blurring
adding images
("(add (blur k10) (blur f5))",5)
"end"
and should be:
[1] reading image with time: 10
[2] reading image with time: 5
blurring
blurring
adding images
("(add (blur k10) (blur f5))",5)
"end"
Please note that the correct output is ("(add (blur k10) (blur f5))",5) - which means, that we added image k10 to f5 - from respectively 10th and 5th frame.
Further requirements
I'm looking for a solution, which would allow users to write simple code (like in test function - it could of course be in a Monad), but I do not want them to handle the time-shifting logic by hand.
Conclusions
The only difference is the order of IO actions execution. I would love to preserve the order of the IO actions just like they are written in the test function. I was trying to implement the idea using Countinuations, Arrows and some funny states, but without success.
Dataflow and functional reactive programming libraries in Haskell are usually written in terms of Applicative or Arrow. These are abstractions for computations that are less general than Monads - the Applicative and Arrow typeclasses do not expose a way for the structure of computations to depend on the results of other computations. As a result, libraries exposing only these typeclasses can reason about the structure of computations in the library independently of performing those computations. We will solve your problem in terms of the Applicative typeclass
class Functor f => Applicative f where
-- | Lift a value.
pure :: a -> f a
-- | Sequential application.
(<*>) :: f (a -> b) -> f a -> f b
Applicative allows a library user to make new computations with pure, operate on existing computations with fmap (from Functor) and compose computations together with <*>, using the result of one computation as an input for another. It does not allow a library user to make a computation that makes another computation and then use the result of that computation directly; there's no way a user can write join :: f (f a) -> f a. This restriction will keep our library from running into the problem I described in my other answer.
Transformers, free, and the ApT transformer
Your example problem is quite involved, so we are going to pull out a bunch of high level Haskell tricks, and make a few new ones of our own. The first two tricks we are going to pull out are transformers and free data types. Transformers are types that take types with a kind like that of Functors, Applicatives or Monads and produce new types with the same kind.
Transformers typically look like the following Double example. Double can take any Functor or Applicative or Monad and make a version of it that always holds two values instead of one
newtype Double f a = Double {runDouble :: f (a, a)}
Free data types are transformers that do two things. First, given some simpler property of the underlying type the gain new exciting properties for the transformed type. The Free Monad provides a Monad given any Functor, and the free Applicative, Ap, makes an Applicative out of any Functor. The other thing "free" types do is they "free" the implementation of the interpreter as much as possible. Here are the types for the free Applicative, Ap, the free Monad, Free, and the free monad transfomer, FreeT. The free monad transformer provides a monad transformer for "free" given a Functor
-- Free Applicative
data Ap f a where
Pure :: a -> Ap f a
Ap :: f a -> Ap f (a -> b) -> Ap f b
-- Base functor of the free monad transformer
data FreeF f a b
= Pure a
| Free (f b)
-- Free monad transformer
newtype FreeT f m a = FreeT {runFreeT :: m (FreeF f a (FreeT f m a)}
-- The free monad is the free monad transformer applied to the Identity monad
type Free f = FreeT f Identity
Here's a sketch of our goal - we want to provide an Applicative interface for combining computations, which, at the bottom, allows Monadic computations. We want to "free" the interpreter as much as possible so that it can hopefully reorder computations. To do this, we will be combining both the free Applicative and the free monad transformer.
We want an Applicative interface, and the easiest one to make is the one we can get for "free", which aligns nicely with out goal of "freeing the interpeter" as much as possible. This suggests our type is going to look like
Ap f a
for some Functor f and any a. We'd like the underlying computation to be over some Monad, and Monads are functors, but we'd like to "free" the interpreter as much as posssible. We'll grab the free monad transformer as the underlying functor for Ap, giving us
Ap (FreeT f m) a
for some Functor f, some Monad m, and any a. We know the Monad m is probably going to be IO, but we'll leave our code as generic as possible. We just need to provide the Functor for FreeT. All Applicatives are Functors, so Ap itself could be used for f, we'd write something like
type ApT m a = Ap (FreeT (ApT m) m) a
This gives the compiler fits, so instead we'll mover the Ap inside and define
newtype ApT m a = ApT {unApT :: FreeT (Ap (ApT m)) m a}
We'll derive some instances for this and discuss its real motivation after an interlude.
Interlude
To run all of this code, you'll need the following. The Map and Control.Concurrent are only needed for sharing computations, more on that much later.
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Main where
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Control.Applicative
import Control.Applicative.Free hiding (Pure)
import qualified Control.Applicative.Free as Ap (Ap(Pure))
import Control.Monad.Trans.Free
import qualified Data.Map as Map
import Control.Concurrent
Stuffing it
I mislead you in the previous section, and pretended to discover ApT from resoning about the problem. I actually discovered ApT by trying anything and everything to try to stuff Monadic computations into an Applicative and be able to control their order when it came out. For a long time, I was trying to solve how to implement mapApM (below) in order to write flipImage (my replacement for your blur). Here's the ApT Monad transformer in all its glory. It's intended to be used as the Functor for an Ap, and, by using Ap as its own Functor for FreeT, can magically stuff values into an Applicative that shouldn't seem possible.
newtype ApT m a = ApT {unApT :: FreeT (Ap (ApT m)) m a}
deriving (Functor, Applicative, Monad, MonadIO)
It could derive even more instances from FreeT, these are just the ones we need. It can't derive MonadTrans, but we can do that ourselves:
instance MonadTrans ApT where
lift = ApT . lift
runApT :: ApT m a -> m (FreeF (Ap (ApT m)) a (FreeT (Ap (ApT m)) m a))
runApT = runFreeT . unApT
The real beauty of ApT is we can write some seemingly impossible code like
stuffM :: (Functor m, Monad m) => m (ApT m a) -> ApT m a
stuffMAp :: (Functor m, Monad m) => m (ApT m a) -> Ap (ApT m) a
The m on the outside disappeares, even into Ap that's merely Applicative.
This works because of the following cycle of functions, each of which can stuff the output from the function above it into the input of the function below it. The first function starts with an ApT m a, and the last one ends with one. (These definitions aren't part of the program)
liftAp' :: ApT m a ->
Ap (ApT m) a
liftAp' = liftAp
fmapReturn :: (Monad m) =>
Ap (ApT m) a ->
Ap (ApT m) (FreeT (Ap (ApT m)) m a)
fmapReturn = fmap return
free' :: Ap (ApT m) (FreeT (Ap (ApT m)) m a) ->
FreeF (Ap (ApT m)) a (FreeT (Ap (ApT m)) m a)
free' = Free
pure' :: a ->
FreeF (Ap (ApT m)) a (FreeT (Ap (ApT m)) m a)
pure' = Pure
return' :: (Monad m) =>
FreeF (Ap (ApT m)) a (FreeT (Ap (ApT m)) m a) ->
m (FreeF (Ap (ApT m)) a (FreeT (Ap (ApT m)) m a))
return' = return
freeT :: m (FreeF (Ap (ApT m)) a (FreeT (Ap (ApT m)) m a)) ->
FreeT (Ap (ApT m)) m a
freeT = FreeT
apT :: FreeT (Ap (ApT m)) m a ->
ApT m a
apT = ApT
This lets us write
-- Get rid of an Ap by stuffing it into an ApT.
stuffAp :: (Monad m) => Ap (ApT m) a -> ApT m a
stuffAp = ApT . FreeT . return . Free . fmap return
-- Stuff ApT into Free
stuffApTFree :: (Monad m) => ApT m a -> FreeF (Ap (ApT m)) a (FreeT (Ap (ApT m)) m a)
stuffApTFree = Free . fmap return . liftAp
-- Get rid of an m by stuffing it into an ApT
stuffM :: (Functor m, Monad m) => m (ApT m a) -> ApT m a
stuffM = ApT . FreeT . fmap stuffApTFree
-- Get rid of an m by stuffing it into an Ap
stuffMAp :: (Functor m, Monad m) => m (ApT m a) -> Ap (ApT m) a
stuffMAp = liftAp . stuffM
And some utility functions for working on a transformer stack
mapFreeT :: (Functor f, Functor m, Monad m) => (m a -> m b) -> FreeT f m a -> FreeT f m b
mapFreeT f fa = do
a <- fa
FreeT . fmap Pure . f . return $ a
mapApT :: (Functor m, Monad m) => (m a -> m b) -> ApT m a -> ApT m b
mapApT f = ApT . mapFreeT f . unApT
mapApM :: (Functor m, Monad m) => (m a -> m b) -> Ap (ApT m) a -> Ap (ApT m) b
mapApM f = liftAp . mapApT f . stuffAp
We'd like to start writing our example image processors, but first we need to take another diversion to address a hard requirement.
A hard requirement - input sharing
Your first example shows
-- timeShift(*2) --
-- / \
-- readImage -- addImages -> out
-- \ /
-- blur ----------
implying that the result of readImage should be shared between blur and timeShift(*2). I take this to mean that the results of readImage should only be computed once for each time.
Applicative isn't powerful enough to capture this. We'll make a new typeclass to represent computations whose output can be divided into multiple identical streams.
-- The class of things where input can be shared and divided among multiple parts
class Applicative f => Divisible f where
(<\>) :: (f a -> f b) -> f a -> f b
We'll make a transformer that adds this capability to existing Applicatives
-- A transformer that adds input sharing
data LetT f a where
NoLet :: f a -> LetT f a
Let :: LetT f b -> (LetT f b -> LetT f a) -> LetT f a
And provide some utility functions and instances for it
-- A transformer that adds input sharing
data LetT f a where
NoLet :: f a -> LetT f a
Let :: LetT f b -> (LetT f b -> LetT f a) -> LetT f a
liftLetT :: f a -> LetT f a
liftLetT = NoLet
mapLetT :: (f a -> f b) -> LetT f a -> LetT f b
mapLetT f = go
where
go (NoLet a) = NoLet (f a)
go (Let b g) = Let b (go . g)
instance (Applicative f) => Functor (LetT f) where
fmap f = mapLetT (fmap f)
-- I haven't checked that these obey the Applicative laws.
instance (Applicative f) => Applicative (LetT f) where
pure = NoLet . pure
NoLet f <*> a = mapLetT (f <*>) a
Let c h <*> a = Let c ((<*> a) . h)
instance (Applicative f) => Divisible (LetT f) where
(<\>) = flip Let
Image processors
With all of our transformers in place, we can start writing our image processors. At the bottom of our stack we have our ApT from an earlier section
Ap (ApT IO)
The computations need to be able to read the time from the environment, so we'll add a ReaderT for that
ReaderT Int (Ap (ApT IO))
Finally, we'd like to be able to share computations, so we'll add out LetT transformer on top, giving the entire type IP for our image processors
type Image = String
type IP = LetT (ReaderT Int (Ap (ApT IO)))
We'll read images from IO. getLine makes fun interactive examples.
readImage :: Int -> IP Image
readImage n = liftLetT $ ReaderT (\t -> liftAp . liftIO $ do
putStrLn $ "[" ++ show n ++ "] reading image for time: " ++ show t
--getLine
return $ "|image [" ++ show n ++ "] for time: " ++ show t ++ "|"
)
We can shift the time of inputs
timeShift :: (Int -> Int) -> IP a -> IP a
timeShift f = mapLetT shift
where
shift (ReaderT g) = ReaderT (g . f)
Add multiple images together
addImages :: Applicative f => [f Image] -> f Image
addImages = foldl (liftA2 (++)) (pure [])
And flip images pretending to use some library that's stuck in IO. I couldn't figure out how to blur a string...
inIO :: (IO a -> IO b) -> IP a -> IP b
inIO = mapLetT . mapReaderT . mapApM
flipImage :: IP [a] -> IP [a]
flipImage = inIO flip'
where
flip' ma = do
a <- ma
putStrLn "flipping"
return . reverse $ a
Interpreting LetT
Our LetT for sharing results is at the top of our transformer stack. We'll need to interpret it to get at the computations underneath it. To interpret LetT we will need a way to share results in IO, which memoize provides, and an interpeter that removes the LetT transformer from the top of the stack.
To share computations we need to store them somewhere, this memoizes an IO computation in IO, making sure it happens only once even across multiple threads.
memoize :: (Ord k) => (k -> IO a) -> IO (k -> IO a)
memoize definition = do
cache <- newMVar Map.empty
let populateCache k map = do
case Map.lookup k map of
Just a -> return (map, a)
Nothing -> do
a <- definition k
return (Map.insert k a map, a)
let fromCache k = do
map <- readMVar cache
case Map.lookup k map of
Just a -> return a
Nothing -> modifyMVar cache (populateCache k)
return fromCache
In order to interpret a Let, we need an evaluator for the underlying ApT IO to incorporate into the definitions for the Let bindings. Since the result of computations depends on the environment read from the ReaderT, we will incorporate dealing with the ReaderT into this step. A more sophisticated approach would use transformer classes, but transformer classes for Applicative is a topic for a different question.
compileIP :: (forall x. ApT IO x -> IO x) -> IP a -> IO (Int -> ApT IO a)
compileIP eval (NoLet (ReaderT f)) = return (stuffAp . f)
compileIP eval (Let b lf) = do
cb <- compileIP eval b
mb <- memoize (eval . cb)
compileIP eval . lf . NoLet $ ReaderT (liftAp . lift . mb)
Interpreting ApT
Our interpreter uses the following State to avoid needing to peek inside AsT, FreeT, and FreeF all the time.
data State m a where
InPure :: a -> State m a
InAp :: State m b -> State m (b -> State m a) -> State m a
InM :: m a -> State m a
instance Functor m => Functor (State m) where
fmap f (InPure a) = InPure (f a)
fmap f (InAp b sa) = InAp b (fmap (fmap (fmap f)) sa)
fmap f (InM m) = InM (fmap f m)
Interpereting Ap is harder than it looks. The goal is to take data that's in Ap.Pure and put it in InPure and data that's in Ap and put it in InAp. interpretAp actually needs to call itself with a larger type each time it goes into a deeper Ap; the function keeps picking up another argument. The first argument t provides a way to simplify these otherwise exploding types.
interpretAp :: (Functor m) => (a -> State m b) -> Ap m a -> State m b
interpretAp t (Ap.Pure a) = t a
interpretAp t (Ap mb ap) = InAp sb sf
where
sb = InM mb
sf = interpretAp (InPure . (t .)) $ ap
interperetApT gets data out of ApT, FreeT, and FreeF and into State m
interpretApT :: (Functor m, Monad m) => ApT m a -> m (State (ApT m) a)
interpretApT = (fmap inAp) . runApT
where
inAp (Pure a) = InPure a
inAp (Free ap) = interpretAp (InM . ApT) $ ap
With these simple interpreting pieces we can make strategies for interpreting results. Each strategy is a function from the interpreter's State to a new State, with possible side effect happening on the way. The order the strategy chooses to execute side effects in determines the order of the side effects. We'll make two example strategies.
The first strategy performs only one step on everything that's ready to be computed, and combines results when they are ready. This is probably the strategy that you want.
stepFB :: (Functor m, Monad m) => State (ApT m) a -> m (State (ApT m) a)
stepFB (InM ma) = interpretApT ma
stepFB (InPure a) = return (InPure a)
stepFB (InAp b f) = do
sf <- stepFB f
sb <- stepFB b
case (sf, sb) of
(InPure f, InPure b) -> return (f b)
otherwise -> return (InAp sb sf)
This other strategy performs all the calculations as soon as it knows about them. It performs them all in a single pass.
allFB :: (Functor m, Monad m) => State (ApT m) a -> m (State (ApT m) a)
allFB (InM ma) = interpretApT ma
allFB (InPure a) = return (InPure a)
allFB (InAp b f) = do
sf <- allFB f
sb <- allFB b
case (sf, sb) of
(InPure f, InPure b) -> return (f b)
otherwise -> allFB (InAp sb sf)
Many, many other strategies are possible.
We can evaluate a strategy by running it until it produces a single result.
untilPure :: (Monad m) => ((State f a) -> m (State f a)) -> State f a -> m a
untilPure s = go
where
go state =
case state of
(InPure a) -> return a
otherwise -> s state >>= go
Executing the intepreter
To execute the interpreter, we need some example data. Here are a few interesting examples.
example1 = (\i -> addImages [timeShift (*2) i, flipImage i]) <\> readImage 1
example1' = (\i -> addImages [timeShift (*2) i, flipImage i, flipImage . timeShift (*2) $ i]) <\> readImage 1
example1'' = (\i -> readImage 2) <\> readImage 1
example2 = addImages [timeShift (*2) . flipImage $ readImage 1, flipImage $ readImage 2]
The LetT interpreter needs to know what evaluator to use for bound values, so we'll define our evaluator only once. A single interpretApT kicks off the evaluation by finding the initial State of the interpreter.
evaluator :: ApT IO x -> IO x
evaluator = (>>= untilPure stepFB) . interpretApT
We'll compile example2, which is essentially your example, and run it for time 5.
main = do
f <- compileIP evaluator example2
a <- evaluator . f $ 5
print a
Which produces almost the desired result, with all reads happening before any flips.
[2] reading image for time: 5
[1] reading image for time: 10
flipping
flipping
"|01 :emit rof ]1[ egami||5 :emit rof ]2[ egami|"
A Monad can not reorder the component steps that make up img1 and img2 in
addImage :: (Monad m) => m [i] -> m [i] -> m [i]
addImage img1 img2 = do
i1 <- img1
i2 <- img2
return $ i1 ++ i2
if there exists any m [i] whose result depends on a side effect. Any MonadIO m has an m [i] whose result depends on a side effect, therefore you cannot reorder the component steps of img1 and img2.
The above desugars to
addImage :: (Monad m) => m [i] -> m [i] -> m [i]
addImage img1 img2 =
img1 >>=
(\i1 ->
img2 >>=
(\i2 ->
return (i1 ++ i2)
)
)
Let's focus on the first >>= (remembering that (>>=) :: forall a b. m a -> (a -> m b) -> m b). Specialized for our type, this is (>>=) :: m [i] -> ([i] -> m [i]) -> m [i]. If we are going to implement it, we'd have to write something like
(img1 :: m [i]) >>= (f :: [i] -> m [i]) = ...
In order to do anything with f, we need to pass it an [i]. The only correct [i] we have is stuck inside img1 :: m [i]. We need the result of img1 to do anything with f. There are now two possibilities. We either can or can not determine the result of img1 without executing its side effects. We will examine both cases, starting with when we can not.
can not
When we can not determine the result of img1 without executing its side effects, we have only one choice - we must execute img1 and all of its side effects. We now have an [i], but all of img1s side effects have already been executed. There's no way we can execute any of the side effects from img2 before some of the side effects of img1 because the side effects of img1 have already happened.
can
If we can determine the result of img1 without executing its side effects, we're in luck. We find the result of img1 and pass that to f, getting a new m [i] holding the result we want. We can now examine the side effects of both img1 and the new m [i] and reorder them (although there's a huge caveat here about the associative law for >>=).
the problem at hand
As this applies to our case, for any MonadIO, there exists the following, whose result can not be determined without executing its side effects, placing us firmly in the can not case where we can not re-order side effects.
counterExample :: (MonadIO m) => m String
counterExample = liftIO getLine
There are also many other counter examples, such as anything like readImage1 or readImage2 that must actually read the image from IO.
I'm running a number of times now into a similar pattern which is error-prone (typos can skip some caching) and simply doesn't look nice to me. Is there a better way of writing something like this?
sum_with_cache' result cache ((p1,p2,p3,p4):partitions) = let
(cache_p1, sol1) = count_noncrossing' cache p1
(cache_p2, sol2) = count_noncrossing' cache_p1 p2
(cache_p3, sol3) = count_noncrossing' cache_p2 p3
(cache_p4, sol4) = count_noncrossing' cache_p3 p4
in sum_with_cache' (result+(sol1*sol2*sol3*sol4)) cache_p4 partitions
So basically N operations which can update the cache?
I could write also something like:
process_with_cache' res cache _ [] = (cache, res)
process_with_cache' res cache f (x:xs) =
let (new_cache, r) = f cache x
in process_with_cache' (r:res) new_cache f xs
process_with_cache = process_with_cache' []
But that doesn't look really clean either. Is there a nicer way of writing this code?
Another similar pattern is when you request a series of named random numbers:
let (x, rng') = random rng''
(y, rng) = random rng'
in (x^2 + y^2, rng)
This is exactly when using a state monad is the right way to go:
import Control.Monad.State
For all random number generators of type (RandomGen g) => g there is a state monad State g, which threads the state implicitly:
do x <- state random
y <- state random
return (x^2 + y^2)
The state function simply takes a function of type s -> (a, s) and turns it into a computation of type State s a, in this case:
state :: (RandomGen g) => (g -> (a, g)) -> State g a
You can run a State computation by using runState, evalState or execState:
runState (liftA2 (\x y -> x^2 + y^2) (state random) (state random))
(mkStdGen 0)
Suppose someone makes a program to play chess, or solve sudoku. In this kind of program it makes sense to have a tree structure representing game states.
This tree would be very large, "practically infinite". Which isn't by itself a problem as Haskell supports infinite data structures.
An familiar example of an infinite data structure:
fibs = 0 : 1 : zipWith (+) fibs (tail fibs)
Nodes are only allocated when first used, so the list takes finite memory. One may also iterate over an infinite list if they don't keep references to its head, allowing the garbage collector to collect its parts which are not needed anymore.
Back to the tree example - suppose one does some iteration over the tree, the tree nodes iterated over may not be freed if the root of the tree is still needed (for example in an iterative deepening search, the tree would be iterated over several times and so the root needs to be kept).
One possible solution for this problem that I thought of is using an "unmemo-monad".
I'll try to demonstrate what this monad is supposed to do using monadic lists:
import Control.Monad.ListT (ListT) -- cabal install List
import Data.Copointed -- cabal install pointed
import Data.List.Class
import Prelude hiding (enumFromTo)
nums :: ListT Unmemo Int -- What is Unmemo?
nums = enumFromTo 0 1000000
main = print $ div (copoint (foldlL (+) 0 nums)) (copoint (lengthL nums))
Using nums :: [Int], the program would take a lot of memory as a reference to nums is needed by lengthL nums while it is being iterated over foldlL (+) 0 nums.
The purpose of Unmemo is to make the runtime not keep the nodes iterated over.
I attempted using ((->) ()) as Unmemo, but it yields the same results as nums :: [Int] does - the program uses a lot of memory, as evident by running it with +RTS -s.
Is there anyway to implement Unmemo that does what I want?
Same trick as with a stream -- don't capture the remainder directly, but instead capture a value and a function which yields a remainder. You can add memoization on top of this as necessary.
data UTree a = Leaf a | Branch a (a -> [UTree a])
I'm not in the mood to figure it out precisely at the moment, but this structure arises, I'm sure, naturally as the cofree comonad over a fairly straightforward functor.
Edit
Found it: http://hackage.haskell.org/packages/archive/comonad-transformers/1.6.3/doc/html/Control-Comonad-Trans-Stream.html
Or this is perhaps simpler to understand: http://hackage.haskell.org/packages/archive/streams/0.7.2/doc/html/Data-Stream-Branching.html
In either case, the trick is that your f can be chosen to be something like data N s a = N (s -> (s,[a])) for an appropriate s (s being the type of your state parameter of the stream -- the seed of your unfold, if you will). That might not be exactly correct, but something close should do...
But of course for real work, you can scrap all this and just write the datatype directly as above.
Edit 2
The below code illustrates how this can prevent sharing. Note that even in the version without sharing, there are humps in the profile indicating that the sum and length calls aren't running in constant space. I'd imagine that we'd need an explicit strict accumulation to knock those down.
{-# LANGUAGE DeriveFunctor #-}
import Data.Stream.Branching(Stream(..))
import qualified Data.Stream.Branching as S
import Control.Arrow
import Control.Applicative
import Data.List
data UM s a = UM (s -> Maybe a) deriving Functor
type UStream s a = Stream (UM s) a
runUM s (UM f) = f s
liftUM x = UM $ const (Just x)
nullUM = UM $ const Nothing
buildUStream :: Int -> Int -> Stream (UM ()) Int
buildUStream start end = S.unfold (\x -> (x, go x)) start
where go x
| x < end = liftUM (x + 1)
| otherwise = nullUM
sumUS :: Stream (UM ()) Int -> Int
sumUS x = S.head $ S.scanr (\x us -> maybe 0 id (runUM () us) + x) x
lengthUS :: Stream (UM ()) Int -> Int
lengthUS x = S.head $ S.scanr (\x us -> maybe 0 id (runUM () us) + 1) x
sumUS' :: Stream (UM ()) Int -> Int
sumUS' x = last $ usToList $ liftUM $ S.scanl (+) 0 x
lengthUS' :: Stream (UM ()) Int -> Int
lengthUS' x = last $ usToList $ liftUM $ S.scanl (\acc _ -> acc + 1) 0 x
usToList x = unfoldr (\um -> (S.head &&& S.tail) <$> runUM () um) x
maxNum = 1000000
nums = buildUStream 0 maxNum
numsL :: [Int]
numsL = [0..maxNum]
-- All these need to be run with increased stack to avoid an overflow.
-- This generates an hp file with two humps (i.e. the list is not shared)
main = print $ div (fromIntegral $ sumUS' nums) (fromIntegral $ lengthUS' nums)
-- This generates an hp file as above, and uses somewhat less memory, at the cost of
-- an increased number of GCs. -H helps a lot with that.
-- main = print $ div (fromIntegral $ sumUS nums) (fromIntegral $ lengthUS nums)
-- This generates an hp file with one hump (i.e. the list is shared)
-- main = print $ div (fromIntegral $ sum $ numsL) (fromIntegral $ length $ numsL)