summaryrefslogtreecommitdiff
path: root/examples/monadic.hs
diff options
context:
space:
mode:
authorAlberto Ruiz <aruiz@um.es>2015-10-04 14:16:57 +0200
committerAlberto Ruiz <aruiz@um.es>2015-10-04 14:16:57 +0200
commit0500032a1d954058b94cf9a0fa2a662e5666a526 (patch)
treedad39582ff940d2043acf6042470ee63898c3185 /examples/monadic.hs
parent04ec1d6b547d6c48506d66298f7d09f7de22c96e (diff)
update examples
Diffstat (limited to 'examples/monadic.hs')
-rw-r--r--examples/monadic.hs31
1 files changed, 18 insertions, 13 deletions
diff --git a/examples/monadic.hs b/examples/monadic.hs
index 7c6e0f4..cf8aacc 100644
--- a/examples/monadic.hs
+++ b/examples/monadic.hs
@@ -1,35 +1,37 @@
1-- monadic computations 1-- monadic computations
2-- (contributed by Vivian McPhail) 2-- (contributed by Vivian McPhail)
3 3
4{-# LANGUAGE FlexibleContexts #-}
5
4import Numeric.LinearAlgebra 6import Numeric.LinearAlgebra
7import Numeric.LinearAlgebra.Devel
5import Control.Monad.State.Strict 8import Control.Monad.State.Strict
6import Control.Monad.Maybe 9import Control.Monad.Trans.Maybe
7import Foreign.Storable(Storable) 10import Foreign.Storable(Storable)
8import System.Random(randomIO) 11import System.Random(randomIO)
9 12
10------------------------------------------- 13-------------------------------------------
11 14
12-- an instance of MonadIO, a monad transformer 15-- an instance of MonadIO, a monad transformer
13type VectorMonadT = StateT Int IO 16type VectorMonadT = StateT I IO
14 17
15test1 :: Vector Int -> IO (Vector Int) 18test1 :: Vector I -> IO (Vector I)
16test1 = mapVectorM $ \x -> do 19test1 = mapVectorM $ \x -> do
17 putStr $ (show x) ++ " " 20 putStr $ (show x) ++ " "
18 return (x + 1) 21 return (x + 1)
19 22
20-- we can have an arbitrary monad AND do IO 23-- we can have an arbitrary monad AND do IO
21addInitialM :: Vector Int -> VectorMonadT () 24addInitialM :: Vector I -> VectorMonadT ()
22addInitialM = mapVectorM_ $ \x -> do 25addInitialM = mapVectorM_ $ \x -> do
23 i <- get 26 i <- get
24 liftIO $ putStr $ (show $ x + i) ++ " " 27 liftIO $ putStr $ (show $ x + i) ++ " "
25 put $ x + i 28 put $ x + i
26 29
27-- sum the values of the even indiced elements 30-- sum the values of the even indiced elements
28sumEvens :: Vector Int -> Int 31sumEvens :: Vector I -> I
29sumEvens = foldVectorWithIndex (\x a b -> if x `mod` 2 == 0 then a + b else b) 0 32sumEvens = foldVectorWithIndex (\x a b -> if x `mod` 2 == 0 then a + b else b) 0
30 33
31-- sum and print running total of evens 34-- sum and print running total of evens
32sumEvensAndPrint :: Vector Int -> VectorMonadT ()
33sumEvensAndPrint = mapVectorWithIndexM_ $ \ i x -> do 35sumEvensAndPrint = mapVectorWithIndexM_ $ \ i x -> do
34 when (i `mod` 2 == 0) $ do 36 when (i `mod` 2 == 0) $ do
35 v <- get 37 v <- get
@@ -38,7 +40,7 @@ sumEvensAndPrint = mapVectorWithIndexM_ $ \ i x -> do
38 liftIO $ putStr $ (show v') ++ " " 40 liftIO $ putStr $ (show v') ++ " "
39 41
40 42
41indexPlusSum :: Vector Int -> VectorMonadT () 43--indexPlusSum :: Vector I -> VectorMonadT ()
42indexPlusSum v' = do 44indexPlusSum v' = do
43 let f i x = do 45 let f i x = do
44 s <- get 46 s <- get
@@ -63,7 +65,7 @@ monoStep d = do
63 65
64isMonotoneIncreasing :: Vector Double -> Bool 66isMonotoneIncreasing :: Vector Double -> Bool
65isMonotoneIncreasing v = 67isMonotoneIncreasing v =
66 let res = evalState (runMaybeT $ (mapVectorM_ monoStep v)) (v @> 0) 68 let res = evalState (runMaybeT $ (mapVectorM_ monoStep v)) (v ! 0)
67 in case res of 69 in case res of
68 Nothing -> False 70 Nothing -> False
69 Just _ -> True 71 Just _ -> True
@@ -72,8 +74,8 @@ isMonotoneIncreasing v =
72------------------------------------------- 74-------------------------------------------
73 75
74-- | apply a test to successive elements of a vector, evaluates to true iff test passes for all pairs 76-- | apply a test to successive elements of a vector, evaluates to true iff test passes for all pairs
75successive_ :: Storable a => (a -> a -> Bool) -> Vector a -> Bool 77successive_ :: (Container Vector a, Indexable (Vector a) a) => (a -> a -> Bool) -> Vector a -> Bool
76successive_ t v = maybe False (\_ -> True) $ evalState (runMaybeT (mapVectorM_ step (subVector 1 (dim v - 1) v))) (v @> 0) 78successive_ t v = maybe False (\_ -> True) $ evalState (runMaybeT (mapVectorM_ step (subVector 1 (size v - 1) v))) (v ! 0)
77 where step e = do 79 where step e = do
78 ep <- lift $ get 80 ep <- lift $ get
79 if t e ep 81 if t e ep
@@ -81,8 +83,10 @@ successive_ t v = maybe False (\_ -> True) $ evalState (runMaybeT (mapVectorM_ s
81 else (fail "successive_ test failed") 83 else (fail "successive_ test failed")
82 84
83-- | operate on successive elements of a vector and return the resulting vector, whose length 1 less than that of the input 85-- | operate on successive elements of a vector and return the resulting vector, whose length 1 less than that of the input
84successive :: (Storable a, Storable b) => (a -> a -> b) -> Vector a -> Vector b 86successive
85successive f v = evalState (mapVectorM step (subVector 1 (dim v - 1) v)) (v @> 0) 87 :: (Storable b, Container Vector s, Indexable (Vector s) s)
88 => (s -> s -> b) -> Vector s -> Vector b
89successive f v = evalState (mapVectorM step (subVector 1 (size v - 1) v)) (v ! 0)
86 where step e = do 90 where step e = do
87 ep <- get 91 ep <- get
88 put e 92 put e
@@ -90,7 +94,7 @@ successive f v = evalState (mapVectorM step (subVector 1 (dim v - 1) v)) (v @> 0
90 94
91------------------------------------------- 95-------------------------------------------
92 96
93v :: Vector Int 97v :: Vector I
94v = 10 |> [0..] 98v = 10 |> [0..]
95 99
96w = fromList ([1..10]++[10,9..1]) :: Vector Double 100w = fromList ([1..10]++[10,9..1]) :: Vector Double
@@ -116,3 +120,4 @@ main = do
116 print $ successive_ (>) v 120 print $ successive_ (>) v
117 print $ successive_ (>) w 121 print $ successive_ (>) w
118 print $ successive (+) v 122 print $ successive (+) v
123