diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,8 @@ +4.8 +----- +* Added a `MonadFree` instance for `EitherT` (frrom the `either` package). +* Support for `transformers` 0.4 + 4.7.1 ----- * Added more versions of `cutoff`. diff --git a/examples/MandelbrotIter.lhs b/examples/MandelbrotIter.lhs new file mode 100644 --- /dev/null +++ b/examples/MandelbrotIter.lhs @@ -0,0 +1,138 @@ +Compiling to an executable file with the @-O2@ optimization level is recomended. + +For example: @ghc -o 'mandelbrot_iter' -O2 MandelbrotIter.lhs ; ./mandelbrot_iter@ + +> {-# LANGUAGE PackageImports #-} + +> import Control.Arrow +> import Control.Monad.Trans.Iter +> import "mtl" Control.Monad.Reader +> import "mtl" Control.Monad.List +> import "mtl" Control.Monad.Identity +> import Control.Monad.IO.Class +> import Data.Complex +> import Graphics.HGL (runGraphics, Window, withPen, +> line, RGB (RGB), RedrawMode (Unbuffered, DoubleBuffered), openWindowEx, +> drawInWindow, mkPen, Style (Solid)) + +Some fractals can be defined by infinite sequences of complex numbers. For example, +to render the , +the following sequence is generated for each point @c@ in the complex plane: + +@ +z₀ = c + +z₁ = z₀² + c + +z₂ = z₁² + c + +… +@ + +If, after some iterations, |z_i| ≥ 2, the point is not in the set. We +can compute if a point is not in the Mandelbrot set this way: + +@ + escaped :: Complex Double -> Int + escaped c = loop 0 0 where + loop z n = if (magnitude z) >= 2 then n + else loop (z*z + c) (n+1) +@ + +If @c@ is not in the Mandelbrot set, we get the number of iterations required to +prove that fact. But, if @c@ is in the mandelbrot set, 'escaped' will +run forever. + +We can use the 'Iter' monad to delimit this effect. By applying +'delay' before the recursive call, we decompose the computation into +terminating steps. + +> escaped :: Complex Double -> Iter Int +> escaped c = loop 0 0 where +> loop z n = if (magnitude z) >= 2 then return n +> else delay $ loop (z*z + c) (n+1) +> + +If we draw each point on a canvas after it escapes, we can get a _negative_ +image of the Mandelbrot set. Drawing pixels is a side-effect, so it +should happen inside the IO monad. Also, we want to have an +environment to store the size of the canvas, and the target window. + +By using 'IterT', we can add all these behaviours to our non-terminating +computation. + +> data Canvas = Canvas { width :: Int, height :: Int, window :: Window } +> +> type FractalM a = IterT (ReaderT Canvas IO) a + +Any simple, non-terminating computation can be lifted into a richer environment. + +> escaped' :: Complex Double -> IterT (ReaderT Canvas IO) Int +> escaped' = liftIter . escaped + +Then, to draw a point, we can just retrieve the number of iterations until it +finishes, and draw it. The color will depend on the number of iterations. + +> mandelbrotPoint :: (Int, Int) -> FractalM () +> mandelbrotPoint p = do +> c <- scale p +> n <- escaped' c +> let color = if (even n) then RGB 0 0 255 -- Blue +> else RGB 0 0 127 -- Darker blue +> drawPoint color p + +The pixels on the screen don't match the region in the complex plane where the +fractal is; we need to map them first. The region we are interested in is +Im z = [-1,1], Re z = [-2,1]. + +> scale :: (Int, Int) -> FractalM (Complex Double) +> scale (xi,yi) = do +> (w,h) <- asks $ (fromIntegral . width) &&& (fromIntegral . height) +> let (x,y) = (fromIntegral xi, fromIntegral yi) +> let im = (-y + h / 2 ) / (h/2) +> let re = ( x - w * 2 / 3 ) / (h/2) +> return $ re :+ im + +Drawing a point is equivalent to drawing a line of length one. + +> drawPoint :: RGB -> (Int,Int) -> FractalM () +> drawPoint color p@(x,y) = do +> w <- asks window +> let point = line (x,y) (x+1, y+1) +> liftIO $ drawInWindow w $ mkPen Solid 1 color (flip withPen point) + +We may want to draw more than one point. However, if we just sequence the computations +monadically, the first point that is not a member of the set will block the whole +process. We need advance all the points at the same pace, by interleaving the +computations. + +> drawMandelbrot :: FractalM () +> drawMandelbrot = do +> (w,h) <- asks $ width &&& height +> let ps = [mandelbrotPoint (x,y) | x <- [0 .. (w-1)], y <- [0 .. (h-1)]] +> interleave_ ps + +To run this computation, we can just use @retract@, which will run indefinitely: + +> runFractalM :: Canvas -> FractalM a -> IO a +> runFractalM canvas = flip runReaderT canvas . retract + +Or, we can trade non-termination for getting an incomplete result, +by cutting off after a certain number of steps. + +> runFractalM' :: Integer -> Canvas -> FractalM a -> IO (Maybe a) +> runFractalM' n canvas = flip runReaderT canvas . retract . cutoff n + +Thanks to the 'IterT' transformer, we can separate timeout concerns from +computational concerns. + +> main :: IO () +> main = do +> let windowWidth = 800 +> let windowHeight = 480 +> runGraphics $ do +> w <- openWindowEx "Mandelbrot" Nothing (windowWidth, windowHeight) DoubleBuffered (Just 1) +> let canvas = Canvas windowWidth windowHeight w +> runFractalM' 100 canvas drawMandelbrot +> putStrLn $ "Fin" + diff --git a/examples/NewtonCoiter.lhs b/examples/NewtonCoiter.lhs new file mode 100644 --- /dev/null +++ b/examples/NewtonCoiter.lhs @@ -0,0 +1,99 @@ +Many numerical approximation methods compute infinite sequences of results; each, +hopefully, more accurate than the previous one. + + +to find zeroes of a function is one such algorithm. + +> {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} + +> import Control.Comonad.Trans.Coiter +> import Control.Comonad.Env +> import Control.Applicative +> import Data.Foldable (toList, find) + +> data Function = Function { +> -- Function to find zeroes of +> function :: Double -> Double, +> -- Derivative of the function +> derivative :: Double -> Double +> } +> +> data Result = Result { +> -- Estimated zero of the function +> value :: Double, +> -- Estimated distance to the actual zero +> xerror :: Double, +> -- How far is value from being an actual zero; that is, +> -- the difference between @0@ and @f value@ +> ferror :: Double +> } deriving (Show) +> +> data Outlook = Outlook { result :: Result, +> -- Whether the result improves in future steps +> progress :: Bool } deriving (Show) + +To make our lives easier, we will store the problem at hand using the Env +environment comonad. + +> type Solution a = CoiterT (Env Function) a + +Problems consist of a function and its derivative as the environment, and +an initial value. + +> type Problem = Env Function Double + +We can express an iterative algorithm using unfold over an initial environment. + +> newton :: Problem -> Solution Double +> newton = unfold (\wd -> +> let f = asks function wd in +> let df = asks derivative wd in +> let x = extract wd in +> x - f x / df x) +> +> + +To estimate the error, we look forward one position in the stream. The next value +will be much more precise than the current one, so we can consider it as the +actual result. + +We know that the exact value of a function at one of it's zeroes is 0. So, +@ferror@ can be computed exactly as @abs (f a - f 0) == abs (f a)@ + +> estimateError :: Solution Double -> Result +> estimateError s = +> let a:a':_ = toList s in +> let f = asks function s in +> Result { value = a, +> xerror = abs $ a - a', +> ferror = abs $ f a +> } + +To get a sense of when the algorithm is making any progress, we can sample the +future and check if the result improves at all. + +> estimateOutlook :: Int -> Solution Result -> Outlook +> estimateOutlook sampleSize solution = +> let sample = map ferror $ take sampleSize $ tail $ toList solution in +> let result = extract solution in +> Outlook { result = result, +> progress = ferror result > minimum sample } + +To compute the square root of @c@, we solve the equation @x*x - c = 0@. We will +stop whenever the accuracy of the result doesn't improve in the next 5 steps. + +The starting value for our algorithm is @c@ itself. One could compute a better +estimate, but the algorithm converges fast enough that it's not really worth it. + +> squareRoot :: Double -> Maybe Result +> squareRoot c = let problem = flip env c (Function { function = (\x -> x*x - c), +> derivative = (\x -> 2*x) }) +> in +> fmap result $ find (not . progress) $ +> newton problem =>> estimateError =>> estimateOutlook 5 + +This program will output the result together with the error. + +> main :: IO () +> main = putStrLn $ show $ squareRoot 3 + diff --git a/examples/RetryTH.hs b/examples/RetryTH.hs new file mode 100644 --- /dev/null +++ b/examples/RetryTH.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +module Main where + +import Control.Monad +import Control.Monad.Free +import Control.Monad.Free.TH +import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe +import qualified Data.Foldable as F +import Text.Read (readMaybe) + +-- | A data type representing basic commands for a retriable eDSL. +data RetryF next where + -- | Simple output command. + Output :: String -> next -> RetryF next + -- | Get anything readable from input. + Input :: Read a => (a -> next) -> RetryF next + -- | Declare a retriable block. + WithRetry :: Retry a -> (a -> next) -> RetryF next + -- | Force retry command (retries innermost retriable block). + Retry :: RetryF next + +-- | Unfortunately this Functor instance cannot yet be derived +-- automatically by GHC. +instance Functor RetryF where + fmap f (Output s x) = Output s (f x) + fmap f (Input g) = Input (f . g) + fmap f (WithRetry block g) = WithRetry block (f . g) + fmap _ Retry = Retry + +-- | The monad for a retriable eDSL. +type Retry = Free RetryF + +-- automacally generate convenience functions +makeFree ''RetryF + +-- The following functions have been made available: +-- +-- output :: MonadFree RetryF m => String -> m () +-- input :: (MonadFree RetryF m, Read a) => m a +-- withRetry :: MonadFree RetryF m => Retry a -> m a +-- retry :: MonadFree RetryF m => m a + +-- | We can run a retriable program in any MonadIO. +runRetry :: MonadIO m => Retry a -> m a +runRetry = iterM run + where + run :: MonadIO m => RetryF (m a) -> m a + + run (Output s next) = do + liftIO $ putStrLn s + next + + run (Input next) = do + s <- liftIO getLine + case readMaybe s of + Just x -> next x + Nothing -> fail "invalid input" + + run (WithRetry block next) = do + -- Here we use + -- runRetry :: MonadIO m => Retry a -> MaybeT (m a) + -- to control failure with MaybeT. + -- We repeatedly run retriable block until we get it to work. + Just x <- runMaybeT . F.msum $ repeat (runRetry block) + next x + + run Retry = fail "forced retry" + +-- | Sample program. +test :: Retry () +test = do + n <- withRetry $ do + output "Enter any positive number: " + n <- input + when (n <= 0) $ do + output "The number should be positive." + retry + return n + output $ "You've just entered " ++ show (n :: Int) + +main :: IO () +main = runRetry test + diff --git a/examples/Teletype.lhs b/examples/Teletype.lhs new file mode 100644 --- /dev/null +++ b/examples/Teletype.lhs @@ -0,0 +1,104 @@ +> {-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-} -- + +> import Control.Monad (mfilter) +> import Control.Monad.Loops (unfoldM) +> import Control.Monad.Free (liftF, Free, iterM, MonadFree) +> import Control.Monad.Free.TH (makeFree) +> import Control.Applicative ((<$>)) +> import System.IO (isEOF) +> import Control.Exception (catch) +> import System.IO.Error (ioeGetErrorString) +> import System.Exit (exitSuccess) + +First, we define a data type with the primitive actions of a teleprinter. The +@param@ will stand for the next action to execute. + +> type Error = String +> +> data Teletype param = Halt -- Abort (ignore all following instructions) +> | NL param -- Newline +> | Read (Char -> param) -- Get a character from the terminal +> | ReadOrEOF { onEOF :: param, +> onChar :: Char -> param } -- GetChar if not end of file +> | ReadOrError (Error -> param) +> (Char -> param) -- GetChar with error code +> | param :\^^ String -- Write a message to the terminal +> | (:%) param String [String] -- String interpolation +> deriving (Functor) + +By including a 'makeFree' declaration: + +> makeFree ''Teletype + +the following functions have been made available: + +@ + halt :: (MonadFree Teletype m) => m a + nL :: (MonadFree Teletype m) => m () + read :: (MonadFree Teletype m) => m Char + readOrEOF :: (MonadFree Teletype m) => m (Maybe Char) + readOrError :: (MonadFree Teletype m) => m (Either Error Char) + (\\^^) :: (MonadFree Teletype m) => String -> m () + (%) :: (MonadFree Teletype m) => String -> [String] -> m () +@ + +To make use of them, we need an instance of 'MonadFree Teletype'. Since 'Teletype' is a +'Functor', we can use the one provided in the 'Control.Monad.Free' package. + +> type TeletypeM = Free Teletype + +Programs can be run in different ways. For example, we can use the +system terminal through the @IO@ monad. + +> runTeletypeIO :: TeletypeM a -> IO a +> runTeletypeIO = iterM run where +> run :: Teletype (IO a) -> IO a +> run Halt = do +> putStrLn "This conversation can serve no purpose anymore. Goodbye." +> exitSuccess +> +> run (Read f) = getChar >>= f +> run (ReadOrEOF eof f) = isEOF >>= \b -> if b then eof +> else getChar >>= f +> +> run (ReadOrError ferror f) = catch (getChar >>= f) (ferror . ioeGetErrorString) +> run (NL rest) = putChar '\n' >> rest +> run (rest :\^^ str) = putStr str >> rest +> run ((:%) rest format tokens) = ttFormat format tokens >> rest +> +> ttFormat :: String -> [String] -> IO () +> ttFormat [] _ = return () +> ttFormat ('\\':'%':cs) tokens = putChar '%' >> ttFormat cs tokens +> ttFormat ('%':cs) (t:tokens) = putStr t >> ttFormat cs tokens +> ttFormat (c:cs) tokens = putChar c >> ttFormat cs tokens + +Now, we can write some helper functions: + +> readLine :: TeletypeM String +> readLine = unfoldM $ mfilter (/= '\n') <$> readOrEOF + +And use them to interact with the user: + +> hello :: TeletypeM () +> hello = do +> (\^^) "Hello! What's your name?"; nL +> name <- readLine +> "Nice to meet you, %." % [name]; nL +> halt + +We can transform any @TeletypeM@ into an @IO@ action, and run it: + +> main :: IO () +> main = runTeletypeIO hello + +@ + Hello! What's your name? + $ Dave + Nice to meet you, Dave. + This conversation can serve no purpose anymore. Goodbye. +@ + +When specifying DSLs in this way, we only need to define the semantics +for each of the actions; the plumbing of values is taken care of by +the generated monad instance. + diff --git a/examples/ValidationForm.hs b/examples/ValidationForm.hs new file mode 100644 --- /dev/null +++ b/examples/ValidationForm.hs @@ -0,0 +1,112 @@ +module Main where + +import Control.Applicative +import Control.Applicative.Free +import Control.Monad.State + +import Data.Monoid + +import Text.Read (readEither) +import Text.Printf + +import System.IO + +-- | Field reader tries to read value or generates error message. +type FieldReader a = String -> Either String a + +-- | Convenient synonym for field name. +type Name = String + +-- | Convenient synonym for field help message. +type Help = String + +-- | A single field of a form. +data Field a = Field + { fName :: Name -- ^ Name. + , fValidate :: FieldReader a -- ^ Pure validation function. + , fHelp :: Help -- ^ Help message. + } + +-- | Validation form is just a free applicative over Field. +type Form = Ap Field + +-- | Build a form with a single field. +field :: Name -> FieldReader a -> Help -> Form a +field n f h = liftAp $ Field n f h + +-- | Singleton form accepting any input. +string :: Name -> Help -> Form String +string n h = field n Right h + +-- | Singleton form accepting anything but mentioned values. +available :: [String] -> Name -> Help -> Form String +available xs n h = field n check h + where + check x | x `elem` xs = Left "the value is not available" + | otherwise = Right x + +-- | Singleton integer field form. +int :: Name -> Form Int +int name = field name readEither "an integer value" + +-- | Generate help message for a form. +help :: Form a -> String +help = unlines . runAp_ (\f -> [fieldHelp f]) + +-- | Get help message for a field. +fieldHelp :: Field a -> String +fieldHelp (Field name _ msg) = printf " %-15s - %s" name msg + +-- | Count fields in a form. +count :: Form a -> Int +count = getSum . runAp_ (\_ -> Sum 1) + +-- | Interactive input of a form. +-- Shows progress on each field. +-- Repeats field input until it passes validation. +-- Show help message on empty input. +input :: Form a -> IO a +input m = evalStateT (runAp inputField m) (1 :: Integer) + where + inputField f@(Field n g h) = do + i <- get + -- get field input with prompt + x <- liftIO $ do + putStr $ printf "[%d/%d] %s: " i (count m) n + hFlush stdout + getLine + case words x of + -- display help message for empty input + [] -> do + liftIO . putStrLn $ "help: " ++ h + inputField f + -- validate otherwise + _ -> case g x of + Right y -> do + modify (+ 1) + return y + Left e -> do + liftIO . putStrLn $ "error: " ++ e + inputField f + +-- | User datatype. +data User = User + { userName :: String + , userFullName :: String + , userAge :: Int } + deriving (Show) + +-- | Form for User. +form :: [String] -> Form User +form us = User + <$> available us "Username" "any vacant username" + <*> string "Full name" "your full name (e.g. John Smith)" + <*> int "Age" + +main :: IO () +main = do + putStrLn "Creating a new user." + putStrLn "Please, fill the form:" + user <- input (form ["bob", "alice"]) + putStrLn $ "Successfully created user \"" ++ userName user ++ "\"!" + diff --git a/free.cabal b/free.cabal --- a/free.cabal +++ b/free.cabal @@ -1,6 +1,6 @@ name: free category: Control, Monads -version: 4.7.1 +version: 4.8 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE @@ -42,6 +42,11 @@ HLint.hs doc/proof/Control/Comonad/Cofree/*.md doc/proof/Control/Comonad/Trans/Cofree/*.md + examples/*.hs + examples/*.lhs +extra-doc-files: + examples/*.hs + examples/*.lhs source-repository head type: git @@ -65,16 +70,18 @@ bifunctors == 4.*, comonad == 4.*, distributive >= 0.2.1, - mtl >= 2.0.1.0 && < 2.2, + either >= 4.1.1, + mtl >= 2.0.1.0 && < 2.3, prelude-extras >= 0.4 && < 1, profunctors == 4.*, semigroupoids == 4.*, semigroups >= 0.8.3.1 && < 1, - transformers >= 0.2.0 && < 0.4, + transformers >= 0.2.0 && < 0.5, template-haskell >= 2.7.0.0 && < 3 exposed-modules: Control.Applicative.Free + Control.Applicative.Trans.Free Control.Alternative.Free Control.Comonad.Cofree Control.Comonad.Cofree.Class diff --git a/src/Control/Applicative/Free.hs b/src/Control/Applicative/Free.hs --- a/src/Control/Applicative/Free.hs +++ b/src/Control/Applicative/Free.hs @@ -28,14 +28,19 @@ Ap(..) , runAp + , runAp_ , liftAp , hoistAp , retractAp + + -- * Examples + -- $examples ) where import Control.Applicative import Data.Functor.Apply import Data.Typeable +import Data.Monoid -- | The free 'Applicative' for a 'Functor' @f@. data Ap f a where @@ -52,6 +57,17 @@ runAp _ (Pure x) = pure x runAp u (Ap f x) = flip id <$> u f <*> runAp u x +-- | Perform a monoidal analysis over free applicative value. +-- +-- Example: +-- +-- @ +-- count :: Ap f a -> Int +-- count = getSum . runAp_ (\\_ -> Sum 1) +-- @ +runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f b -> m +runAp_ f = getConst . runAp (Const . f) + instance Functor (Ap f) where fmap f (Pure a) = Pure (f a) fmap f (Ap x y) = Ap x ((f .) <$> y) @@ -98,3 +114,9 @@ {-# NOINLINE apTyCon #-} #endif + +{- $examples + + + +-} diff --git a/src/Control/Applicative/Trans/Free.hs b/src/Control/Applicative/Trans/Free.hs new file mode 100644 --- /dev/null +++ b/src/Control/Applicative/Trans/Free.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs #-} +#if __GLASGOW_HASKELL__ >= 707 +{-# LANGUAGE DeriveDataTypeable #-} +#endif +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Applicative.Trans.Free +-- Copyright : (C) 2012-2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : GADTs, Rank2Types +-- +-- 'Applicative' functor transformers for free +---------------------------------------------------------------------------- +module Control.Applicative.Trans.Free + ( + -- | Compared to the free monad transformers, they are less expressive. However, they are also more + -- flexible to inspect and interpret, as the number of ways in which + -- the values can be nested is more limited. + -- + -- See , + -- by Paolo Capriotti and Ambrus Kaposi, for some applications. + ApT(..) + , ApF(..) + , liftApT + , liftApO + , runApT + , runApF + , runApT_ + , hoistApT + , hoistApF + , transApT + , transApF + -- * Free Applicative + , Ap + , runAp + , runAp_ + , retractAp + -- * Free Alternative + , Alt + , runAlt + ) where + +import Control.Applicative +import Data.Functor.Apply +import Data.Functor.Identity +import Data.Typeable +import Data.Monoid +import qualified Data.Foldable as F + +-- | The free 'Applicative' for a 'Functor' @f@. +data ApF f g a where + Pure :: a -> ApF f g a + Ap :: f a -> ApT f g (a -> b) -> ApF f g b +#if __GLASGOW_HASKELL__ >= 707 + deriving Typeable +#endif + +-- | The free 'Applicative' transformer for a 'Functor' @f@ over +-- 'Applicative' @g@. +newtype ApT f g a = ApT { getApT :: g (ApF f g a) } +#if __GLASGOW_HASKELL__ >= 707 + deriving Typeable +#endif + +instance Functor g => Functor (ApF f g) where + fmap f (Pure a) = Pure (f a) + fmap f (Ap x g) = x `Ap` fmap (f .) g + +instance Functor g => Functor (ApT f g) where + fmap f (ApT g) = ApT (fmap f <$> g) + +instance Applicative g => Applicative (ApF f g) where + pure = Pure + {-# INLINE pure #-} + Pure f <*> y = fmap f y -- fmap + y <*> Pure a = fmap ($ a) y -- interchange + Ap a f <*> b = a `Ap` (flip <$> f <*> ApT (pure b)) + {-# INLINE (<*>) #-} + +instance Applicative g => Applicative (ApT f g) where + pure = ApT . pure . pure + {-# INLINE pure #-} + ApT xs <*> ApT ys = ApT ((<*>) <$> xs <*> ys) + {-# INLINE (<*>) #-} + +instance Applicative g => Apply (ApF f g) where + (<.>) = (<*>) + {-# INLINE (<.>) #-} + +instance Applicative g => Apply (ApT f g) where + (<.>) = (<*>) + {-# INLINE (<.>) #-} + +instance Alternative g => Alternative (ApT f g) where + empty = ApT empty + {-# INLINE empty #-} + ApT g <|> ApT h = ApT (g <|> h) + {-# INLINE (<|>) #-} + +-- | A version of 'lift' that can be used with no constraint for @f@. +liftApT :: Applicative g => f a -> ApT f g a +liftApT x = ApT (pure (Ap x (pure id))) + +-- | Lift an action of the \"outer\" 'Functor' @g a@ to @'ApT' f g a@. +liftApO :: Functor g => g a -> ApT f g a +liftApO g = ApT (Pure <$> g) + +-- | Given natural transformations @f ~> h@ and @g . h ~> h@ this gives +-- a natural transformation @ApF f g ~> h@. +runApF :: (Applicative h, Functor g) => (forall a. f a -> h a) -> (forall a. g (h a) -> h a) -> ApF f g b -> h b +runApF _ _ (Pure x) = pure x +runApF f g (Ap x y) = f x <**> runApT f g y + +-- | Given natural transformations @f ~> h@ and @g . h ~> h@ this gives +-- a natural transformation @ApT f g ~> h@. +runApT :: (Applicative h, Functor g) => (forall a. f a -> h a) -> (forall a. g (h a) -> h a) -> ApT f g b -> h b +runApT f g (ApT a) = g (runApF f g <$> a) + +-- | Perform a monoidal analysis over @'ApT' f g b@ value. +-- +-- Examples: +-- +-- @ +-- height :: ('Functor' g, 'F.Foldable' g) => 'ApT' f g a -> 'Int' +-- height = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'F.maximum' +-- @ +-- +-- @ +-- size :: ('Functor' g, 'F.Foldable' g) => 'ApT' f g a -> 'Int' +-- size = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'F.fold' +-- @ +runApT_ :: (Functor g, Monoid m) => (forall a. f a -> m) -> (g m -> m) -> ApT f g b -> m +runApT_ f g = getConst . runApT (Const . f) (Const . g . fmap getConst) + +-- | Given a natural transformation from @f@ to @f'@ this gives a monoidal natural transformation from @ApF f g@ to @ApF f' g@. +hoistApF :: Functor g => (forall a. f a -> f' a) -> ApF f g b -> ApF f' g b +hoistApF _ (Pure x) = Pure x +hoistApF f (Ap x y) = f x `Ap` hoistApT f y + +-- | Given a natural transformation from @f@ to @f'@ this gives a monoidal natural transformation from @ApT f g@ to @ApT f' g@. +hoistApT :: Functor g => (forall a. f a -> f' a) -> ApT f g b -> ApT f' g b +hoistApT f (ApT g) = ApT (hoistApF f <$> g) + +-- | Given a natural transformation from @g@ to @g'@ this gives a monoidal natural transformation from @ApF f g@ to @ApF f g'@. +transApF :: Functor g => (forall a. g a -> g' a) -> ApF f g b -> ApF f g' b +transApF _ (Pure x) = Pure x +transApF f (Ap x y) = x `Ap` transApT f y + +-- | Given a natural transformation from @g@ to @g'@ this gives a monoidal natural transformation from @ApT f g@ to @ApT f g'@. +transApT :: Functor g => (forall a. g a -> g' a) -> ApT f g b -> ApT f g' b +transApT f (ApT g) = ApT $ f (transApF f <$> g) + +-- | The free 'Applicative' for a 'Functor' @f@. +type Ap f = ApT f Identity + +-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@. +-- +-- prop> runAp t == retractApp . hoistApp t +runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a +runAp f = runApT f runIdentity + +-- | Perform a monoidal analysis over free applicative value. +-- +-- Example: +-- +-- @ +-- count :: 'Ap' f a -> 'Int' +-- count = 'getSum' . runAp_ (\\_ -> 'Sum' 1) +-- @ +runAp_ :: Monoid m => (forall x. f x -> m) -> Ap f a -> m +runAp_ f = runApT_ f runIdentity + +-- | Interprets the free applicative functor over f using the semantics for +-- `pure` and `<*>` given by the Applicative instance for f. +-- +-- prop> retractApp == runAp id +retractAp :: Applicative f => Ap f a -> f a +retractAp = runAp id + +-- | The free 'Alternative' for a 'Functor' @f@. +type Alt f = ApT f [] + +-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Alt' f@ to @g@. +runAlt :: (Alternative g, F.Foldable t) => (forall x. f x -> g x) -> ApT f t a -> g a +runAlt f (ApT xs) = F.foldr (\x acc -> h x <|> acc) empty xs + where + h (Pure x) = pure x + h (Ap x g) = f x <**> runAlt f g + +#if __GLASGOW_HASKELL__ < 707 +instance (Typeable1 f, Typeable1 g) => Typeable1 (ApT f g) where + typeOf1 t = mkTyConApp apTTyCon [typeOf1 (f t)] where + f :: ApT f g a -> g (f a) + f = undefined + +instance (Typeable1 f, Typeable1 g) => Typeable1 (ApF f g) where + typeOf1 t = mkTyConApp apFTyCon [typeOf1 (f t)] where + f :: ApF f g a -> g (f a) + f = undefined + +apTTyCon, apFTyCon :: TyCon +#if __GLASGOW_HASKELL__ < 704 +apTTyCon = mkTyCon "Control.Applicative.Trans.Free.ApT" +apFTyCon = mkTyCon "Control.Applicative.Trans.Free.ApF" +#else +apTTyCon = mkTyCon3 "free" "Control.Applicative.Trans.Free" "ApT" +apFTyCon = mkTyCon3 "free" "Control.Applicative.Trans.Free" "ApF" +#endif +{-# NOINLINE apTTyCon #-} +{-# NOINLINE apFTyCon #-} +#endif diff --git a/src/Control/Comonad/Trans/Coiter.hs b/src/Control/Comonad/Trans/Coiter.hs --- a/src/Control/Comonad/Trans/Coiter.hs +++ b/src/Control/Comonad/Trans/Coiter.hs @@ -40,7 +40,7 @@ , unfold -- * Cofree comonads , ComonadCofree(..) - -- * Example + -- * Examples -- $example ) where @@ -207,111 +207,8 @@ coiterTDataType = mkDataType "Control.Comonad.Trans.Coiter.CoiterT" [coiterTConstr] {-# NOINLINE coiterTDataType #-} --- BEGIN Coiter.lhs {- $example -This is literate Haskell! To run the example, open the source and copy -this comment block into a new file with '.lhs' extension. -Many numerical approximation methods compute infinite sequences of results; each, -hopefully, more accurate than the previous one. - - -to find zeroes of a function is one such algorithm. - -@ \{\-\# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances \#\-\} @ - -> {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} - -> import Control.Comonad.Trans.Coiter -> import Control.Comonad.Env -> import Control.Applicative -> import Data.Foldable (toList, find) - -> data Function = Function { -> -- Function to find zeroes of -> function :: Double -> Double, -> -- Derivative of the function -> derivative :: Double -> Double -> } -> -> data Result = Result { -> -- Estimated zero of the function -> value :: Double, -> -- Estimated distance to the actual zero -> xerror :: Double, -> -- How far is value from being an actual zero; that is, -> -- the difference between @0@ and @f value@ -> ferror :: Double -> } deriving (Show) -> -> data Outlook = Outlook { result :: Result, -> -- Whether the result improves in future steps -> progress :: Bool } deriving (Show) - -To make our lives easier, we will store the problem at hand using the Env -environment comonad. - -> type Solution a = CoiterT (Env Function) a - -Problems consist of a function and its derivative as the environment, and -an initial value. - -> type Problem = Env Function Double - -We can express an iterative algorithm using unfold over an initial environment. - -> newton :: Problem -> Solution Double -> newton = unfold (\wd -> -> let f = asks function wd in -> let df = asks derivative wd in -> let x = extract wd in -> x - f x / df x) -> -> - -To estimate the error, we look forward one position in the stream. The next value -will be much more precise than the current one, so we can consider it as the -actual result. - -We know that the exact value of a function at one of it's zeroes is 0. So, -@ferror@ can be computed exactly as @abs (f a - f 0) == abs (f a)@ - -> estimateError :: Solution Double -> Result -> estimateError s = -> let a:a':_ = toList s in -> let f = asks function s in -> Result { value = a, -> xerror = abs $ a - a', -> ferror = abs $ f a -> } - -To get a sense of when the algorithm is making any progress, we can sample the -future and check if the result improves at all. - -> estimateOutlook :: Int -> Solution Result -> Outlook -> estimateOutlook sampleSize solution = -> let sample = map ferror $ take sampleSize $ tail $ toList solution in -> let result = extract solution in -> Outlook { result = result, -> progress = ferror result > minimum sample } - -To compute the square root of @c@, we solve the equation @x*x - c = 0@. We will -stop whenever the accuracy of the result doesn't improve in the next 5 steps. - -The starting value for our algorithm is @c@ itself. One could compute a better -estimate, but the algorithm converges fast enough that it's not really worth it. - -> squareRoot :: Double -> Maybe Result -> squareRoot c = let problem = flip env c (Function { function = (\x -> x*x - c), -> derivative = (\x -> 2*x) }) -> in -> fmap result $ find (not . progress) $ -> newton problem =>> estimateError =>> estimateOutlook 5 - -This program will output the result together with the error. - -> main :: IO () -> main = putStrLn $ show $ squareRoot 4 + -} --- END Coiter.lhs diff --git a/src/Control/Monad/Free.hs b/src/Control/Monad/Free.hs --- a/src/Control/Monad/Free.hs +++ b/src/Control/Monad/Free.hs @@ -50,6 +50,7 @@ import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Data +import Prelude hiding (foldr) import Prelude.Extras -- | The 'Free' 'Monad' for a 'Functor' @f@. @@ -210,6 +211,20 @@ go (Pure a) = f a go (Free fa) = foldMap go fa {-# INLINE foldMap #-} + + foldr f = go where + go r free = + case free of + Pure a -> f a r + Free fa -> foldr (flip go) r fa + {-# INLINE foldr #-} + + foldl' f = go where + go r free = + case free of + Pure a -> f r a + Free fa -> foldl' go r fa + {-# INLINE foldl' #-} instance Foldable1 f => Foldable1 (Free f) where foldMap1 f = go where diff --git a/src/Control/Monad/Free/Church.hs b/src/Control/Monad/Free/Church.hs --- a/src/Control/Monad/Free/Church.hs +++ b/src/Control/Monad/Free/Church.hs @@ -68,7 +68,9 @@ import Control.Monad.Cont.Class import Control.Monad.Trans.Class import Control.Monad.State.Class +import Data.Foldable import Data.Functor.Bind +import Prelude hiding (foldr) -- | The Church-encoded free monad for a functor @f@. -- @@ -106,6 +108,14 @@ mfix f = a where a = f (impure a) impure (F x) = x id (error "MonadFix (F f): wrap") + +instance (Foldable f, Functor f) => Foldable (F f) where + foldr f r xs = runF xs f (foldr (.) id) r + {-# INLINE foldr #-} + + foldl' f r xs = runF xs (flip f) (foldr (!>>>) id) r + where (!>>>) f g = \r -> g $! f r + {-# INLINE foldl' #-} instance MonadPlus f => MonadPlus (F f) where mzero = F (\_ kf -> kf mzero) diff --git a/src/Control/Monad/Free/Class.hs b/src/Control/Monad/Free/Class.hs --- a/src/Control/Monad/Free/Class.hs +++ b/src/Control/Monad/Free/Class.hs @@ -39,6 +39,7 @@ import Control.Monad.Trans.List import Control.Monad.Trans.Error import Control.Monad.Trans.Identity +import Control.Monad.Trans.Either import Data.Monoid -- | @@ -134,6 +135,9 @@ instance (Functor f, MonadFree f m, Error e) => MonadFree f (ErrorT e m) where wrap = ErrorT . wrap . fmap runErrorT + +instance (Functor f, MonadFree f m) => MonadFree f (EitherT e m) where + wrap = EitherT . wrap . fmap runEitherT -- | A version of lift that can be used with just a Functor for f. liftF :: (Functor f, MonadFree f m) => f a -> m a diff --git a/src/Control/Monad/Free/TH.hs b/src/Control/Monad/Free/TH.hs --- a/src/Control/Monad/Free/TH.hs +++ b/src/Control/Monad/Free/TH.hs @@ -17,8 +17,8 @@ makeFree -- $doc - -- ** Example - -- $example + -- ** Examples + -- $examples ) where import Control.Arrow @@ -132,8 +132,8 @@ unifyCaptured _ [x, y] = unifyT x y unifyCaptured _ _ = fail "can't unify more than 2 arguments that use type parameter" -liftCon' :: Type -> Name -> [Name] -> Name -> [Type] -> Q [Dec] -liftCon' f n ns cn ts = do +liftCon' :: [TyVarBndr] -> Cxt -> Type -> Name -> [Name] -> Name -> [Type] -> Q [Dec] +liftCon' tvbs cx f n ns cn ts = do -- prepare some names opName <- mkName <$> mkOpName (nameBase cn) m <- newName "m" @@ -154,31 +154,31 @@ let pat = map VarP xs -- this is LHS exprs = zipExprs (map VarE xs) es args -- this is what ctor would be applied to fval = foldl AppE (ConE cn) exprs -- this is RHS without liftF - q = map PlainTV $ qa ++ m : ns + q = tvbs ++ map PlainTV (qa ++ m : ns) qa = case retType of VarT b | a == b -> [a]; _ -> [] f' = foldl AppT f (map VarT ns) return #if MIN_VERSION_template_haskell(2,10,0) - [ SigD opName (ForallT q [ConT monadFree `AppT` f' `AppT` VarT m] opType) + [ SigD opName (ForallT q (cx ++ [ConT monadFree `AppT` f' `AppT` VarT m]) opType) #else - [ SigD opName (ForallT q [ClassP monadFree [f', VarT m]] opType) + [ SigD opName (ForallT q (cx ++ [ClassP monadFree [f', VarT m]]) opType) #endif , FunD opName [ Clause pat (NormalB $ AppE (VarE liftF) fval) [] ] ] -- | Provide free monadic actions for a single value constructor. -liftCon :: Type -> Name -> [Name] -> Con -> Q [Dec] -liftCon f n ns con = +liftCon :: [TyVarBndr] -> Cxt -> Type -> Name -> [Name] -> Con -> Q [Dec] +liftCon ts cx f n ns con = case con of - NormalC cName fields -> liftCon' f n ns cName $ map snd fields - RecC cName fields -> liftCon' f n ns cName $ map (\(_, _, ty) -> ty) fields - InfixC (_,t1) cName (_,t2) -> liftCon' f n ns cName [t1, t2] - _ -> fail $ "liftCon: Don't know how to lift " ++ show con + NormalC cName fields -> liftCon' ts cx f n ns cName $ map snd fields + RecC cName fields -> liftCon' ts cx f n ns cName $ map (\(_, _, ty) -> ty) fields + InfixC (_,t1) cName (_,t2) -> liftCon' ts cx f n ns cName [t1, t2] + ForallC ts' cx' con' -> liftCon (ts ++ ts') (cx ++ cx') f n ns con' -- | Provide free monadic actions for a type declaration. liftDec :: Dec -> Q [Dec] liftDec (DataD _ tyName tyVarBndrs cons _) | null tyVarBndrs = fail $ "Type " ++ show tyName ++ " needs at least one free variable" - | otherwise = concat <$> mapM (liftCon con nextTyName (init tyNames)) cons + | otherwise = concat <$> mapM (liftCon [] [] con nextTyName (init tyNames)) cons where tyNames = map tyVarBndrName tyVarBndrs nextTyName = last tyNames @@ -196,7 +196,7 @@ {- $doc To generate free monadic actions from a @Type@, it must be a @data@ - declaration with at least one free variable. For each constructor of the type, a + declaration (maybe GADT) with at least one free variable. For each constructor of the type, a new function will be declared. Consider the following generalized definitions: @@ -207,6 +207,7 @@ > | t1 :* t2 > | t1 `Bar` t2 > | Baz { x :: t1, y :: t2, …, z :: tJ } + > | forall b1 b2 … bN. cxt => Qux t1 t2 … tJ > | … where each of the constructor arguments @t1, …, tJ@ is either: @@ -231,7 +232,9 @@ > … > fooBar :: (MonadFree Type m) => t1' -> … -> tK' -> m ret > (+) :: (MonadFree Type m) => t1' -> … -> tK' -> m ret + > bar :: (MonadFree Type m) => t1 -> … -> tK' -> m ret > baz :: (MonadFree Type m) => t1' -> … -> tK' -> m ret + > qux :: (MonadFree Type m, cxt) => t1' -> … -> tK' -> m ret > … The @t1', …, tK'@ are those @t1@ … @tJ@ that only depend on the @@ -259,118 +262,10 @@ -} --- BEGIN Teletype.lhs -{- $example - -This is literate Haskell! To run this example, open the source of this -module and copy the whole comment block into a file with '.lhs' -extension. For example, @Teletype.lhs@. - -@\{\-\# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts \#\-\}@ - -> {-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-} -- - -> import Control.Monad (mfilter) -> import Control.Monad.Loops (unfoldM) -> import Control.Monad.Free (liftF, Free, iterM, MonadFree) -> import Control.Monad.Free.TH (makeFree) -> import Control.Applicative ((<$>)) -> import System.IO (isEOF) -> import Control.Exception (catch) -> import System.IO.Error (ioeGetErrorString) -> import System.Exit (exitSuccess) - -First, we define a data type with the primitive actions of a teleprinter. The -@param@ will stand for the next action to execute. - -> type Error = String -> -> data Teletype param = Halt -- Abort (ignore all following instructions) -> | NL param -- Newline -> | Read (Char -> param) -- Get a character from the terminal -> | ReadOrEOF { onEOF :: param, -> onChar :: Char -> param } -- GetChar if not end of file -> | ReadOrError (Error -> param) -> (Char -> param) -- GetChar with error code -> | param :\^^ String -- Write a message to the terminal -> | (:%) param String [String] -- String interpolation -> deriving (Functor) - -By including a 'makeFree' declaration: - -> makeFree ''Teletype - -the following functions have been made available: - -@ - halt :: (MonadFree Teletype m) => m a - nL :: (MonadFree Teletype m) => m () - read :: (MonadFree Teletype m) => m Char - readOrEOF :: (MonadFree Teletype m) => m (Maybe Char) - readOrError :: (MonadFree Teletype m) => m (Either Error Char) - (\\^^) :: (MonadFree Teletype m) => String -> m () - (%) :: (MonadFree Teletype m) => String -> [String] -> m () -@ - -To make use of them, we need an instance of 'MonadFree Teletype'. Since 'Teletype' is a -'Functor', we can use the one provided in the 'Control.Monad.Free' package. - -> type TeletypeM = Free Teletype - -Programs can be run in different ways. For example, we can use the -system terminal through the @IO@ monad. - -> runTeletypeIO :: TeletypeM a -> IO a -> runTeletypeIO = iterM run where -> run :: Teletype (IO a) -> IO a -> run Halt = do -> putStrLn "This conversation can serve no purpose anymore. Goodbye." -> exitSuccess -> -> run (Read f) = getChar >>= f -> run (ReadOrEOF eof f) = isEOF >>= \b -> if b then eof -> else getChar >>= f -> -> run (ReadOrError ferror f) = catch (getChar >>= f) (ferror . ioeGetErrorString) -> run (NL rest) = putChar '\n' >> rest -> run (rest :\^^ str) = putStr str >> rest -> run ((:%) rest format tokens) = ttFormat format tokens >> rest -> -> ttFormat :: String -> [String] -> IO () -> ttFormat [] _ = return () -> ttFormat ('\\':'%':cs) tokens = putChar '%' >> ttFormat cs tokens -> ttFormat ('%':cs) (t:tokens) = putStr t >> ttFormat cs tokens -> ttFormat (c:cs) tokens = putChar c >> ttFormat cs tokens - -Now, we can write some helper functions: - -> readLine :: TeletypeM String -> readLine = unfoldM $ mfilter (/= '\n') <$> readOrEOF - -And use them to interact with the user: - -> hello :: TeletypeM () -> hello = do -> (\^^) "Hello! What's your name?"; nL -> name <- readLine -> "Nice to meet you, %." % [name]; nL -> halt - -We can transform any @TeletypeM@ into an @IO@ action, and run it: - -> main :: IO () -> main = runTeletypeIO hello +{- $examples -@ - Hello! What's your name? - $ Dave - Nice to meet you, Dave. - This conversation can serve no purpose anymore. Goodbye. -@ + (regular data type declaration) -When specifying DSLs in this way, we only need to define the semantics -for each of the actions; the plumbing of values is taken care of by -the generated monad instance. + (GADT declaration) -} --- END Teletype.lhs diff --git a/src/Control/Monad/Trans/Iter.hs b/src/Control/Monad/Trans/Iter.hs --- a/src/Control/Monad/Trans/Iter.hs +++ b/src/Control/Monad/Trans/Iter.hs @@ -58,8 +58,8 @@ , foldM -- * IterT ~ FreeT Identity , MonadFree(..) - -- * Example - -- $example + -- * Examples + -- $examples ) where import Control.Applicative @@ -414,149 +414,8 @@ iterDataType = mkDataType "Control.Monad.Iter.IterT" [iterConstr] {-# NOINLINE iterDataType #-} --- BEGIN MandelbrotIter.lhs -{- $example -This is literate Haskell! To run the example, open the source and copy -this comment block into a new file with '.lhs' extension. Compiling to an executable -file with the @-O2@ optimization level is recomended. - -For example: @ghc -o 'mandelbrot_iter' -O2 MandelbrotIter.lhs ; ./mandelbrot_iter@ - -@ \{\-\# LANGUAGE PackageImports \#\-\} @ - -> {-# LANGUAGE PackageImports #-} - -> import Control.Arrow -> import Control.Monad.Trans.Iter -> import "mtl" Control.Monad.Reader -> import "mtl" Control.Monad.List -> import "mtl" Control.Monad.Identity -> import Control.Monad.IO.Class -> import Data.Complex -> import Graphics.HGL (runGraphics, Window, withPen, -> line, RGB (RGB), RedrawMode (Unbuffered, DoubleBuffered), openWindowEx, -> drawInWindow, mkPen, Style (Solid)) - -Some fractals can be defined by infinite sequences of complex numbers. For example, -to render the , -the following sequence is generated for each point @c@ in the complex plane: - -@ -z₀ = c - -z₁ = z₀² + c - -z₂ = z₁² + c - -… -@ - -If, after some iterations, |z_i| ≥ 2, the point is not in the set. We -can compute if a point is not in the Mandelbrot set this way: - -@ - escaped :: Complex Double -> Int - escaped c = loop 0 0 where - loop z n = if (magnitude z) >= 2 then n - else loop (z*z + c) (n+1) -@ - -If @c@ is not in the Mandelbrot set, we get the number of iterations required to -prove that fact. But, if @c@ is in the mandelbrot set, 'escaped' will -run forever. - -We can use the 'Iter' monad to delimit this effect. By applying -'delay' before the recursive call, we decompose the computation into -terminating steps. - -> escaped :: Complex Double -> Iter Int -> escaped c = loop 0 0 where -> loop z n = if (magnitude z) >= 2 then return n -> else delay $ loop (z*z + c) (n+1) -> - -If we draw each point on a canvas after it escapes, we can get a _negative_ -image of the Mandelbrot set. Drawing pixels is a side-effect, so it -should happen inside the IO monad. Also, we want to have an -environment to store the size of the canvas, and the target window. - -By using 'IterT', we can add all these behaviours to our non-terminating -computation. - -> data Canvas = Canvas { width :: Int, height :: Int, window :: Window } -> -> type FractalM a = IterT (ReaderT Canvas IO) a - -Any simple, non-terminating computation can be lifted into a richer environment. - -> escaped' :: Complex Double -> IterT (ReaderT Canvas IO) Int -> escaped' = liftIter . escaped - -Then, to draw a point, we can just retrieve the number of iterations until it -finishes, and draw it. The color will depend on the number of iterations. - -> mandelbrotPoint :: (Int, Int) -> FractalM () -> mandelbrotPoint p = do -> c <- scale p -> n <- escaped' c -> let color = if (even n) then RGB 0 0 255 -- Blue -> else RGB 0 0 127 -- Darker blue -> drawPoint color p - -The pixels on the screen don't match the region in the complex plane where the -fractal is; we need to map them first. The region we are interested in is -Im z = [-1,1], Re z = [-2,1]. - -> scale :: (Int, Int) -> FractalM (Complex Double) -> scale (xi,yi) = do -> (w,h) <- asks $ (fromIntegral . width) &&& (fromIntegral . height) -> let (x,y) = (fromIntegral xi, fromIntegral yi) -> let im = (-y + h / 2 ) / (h/2) -> let re = ( x - w * 2 / 3 ) / (h/2) -> return $ re :+ im - -Drawing a point is equivalent to drawing a line of length one. - -> drawPoint :: RGB -> (Int,Int) -> FractalM () -> drawPoint color p@(x,y) = do -> w <- asks window -> let point = line (x,y) (x+1, y+1) -> liftIO $ drawInWindow w $ mkPen Solid 1 color (flip withPen point) - -We may want to draw more than one point. However, if we just sequence the computations -monadically, the first point that is not a member of the set will block the whole -process. We need advance all the points at the same pace, by interleaving the -computations. - -> drawMandelbrot :: FractalM () -> drawMandelbrot = do -> (w,h) <- asks $ width &&& height -> let ps = [mandelbrotPoint (x,y) | x <- [0 .. (w-1)], y <- [0 .. (h-1)]] -> interleave_ ps - -To run this computation, we can just use @retract@, which will run indefinitely: - -> runFractalM :: Canvas -> FractalM a -> IO a -> runFractalM canvas = flip runReaderT canvas . retract - -Or, we can trade non-termination for getting an incomplete result, -by cutting off after a certain number of steps. - -> runFractalM' :: Integer -> Canvas -> FractalM a -> IO (Maybe a) -> runFractalM' n canvas = flip runReaderT canvas . retract . cutoff n - -Thanks to the 'IterT' transformer, we can separate timeout concerns from -computational concerns. +{- $examples -> main :: IO () -> main = do -> let windowWidth = 800 -> let windowHeight = 480 -> runGraphics $ do -> w <- openWindowEx "Mandelbrot" Nothing (windowWidth, windowHeight) DoubleBuffered (Just 1) -> let canvas = Canvas windowWidth windowHeight w -> runFractalM' 100 canvas drawMandelbrot -> putStrLn $ "Fin" + -} --- END MandelbrotIter.lhs