diff options
Diffstat (limited to 'examples/monadic.hs')
-rw-r--r-- | examples/monadic.hs | 31 |
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 | |||
4 | import Numeric.LinearAlgebra | 6 | import Numeric.LinearAlgebra |
7 | import Numeric.LinearAlgebra.Devel | ||
5 | import Control.Monad.State.Strict | 8 | import Control.Monad.State.Strict |
6 | import Control.Monad.Maybe | 9 | import Control.Monad.Trans.Maybe |
7 | import Foreign.Storable(Storable) | 10 | import Foreign.Storable(Storable) |
8 | import System.Random(randomIO) | 11 | import 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 |
13 | type VectorMonadT = StateT Int IO | 16 | type VectorMonadT = StateT I IO |
14 | 17 | ||
15 | test1 :: Vector Int -> IO (Vector Int) | 18 | test1 :: Vector I -> IO (Vector I) |
16 | test1 = mapVectorM $ \x -> do | 19 | test1 = 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 |
21 | addInitialM :: Vector Int -> VectorMonadT () | 24 | addInitialM :: Vector I -> VectorMonadT () |
22 | addInitialM = mapVectorM_ $ \x -> do | 25 | addInitialM = 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 |
28 | sumEvens :: Vector Int -> Int | 31 | sumEvens :: Vector I -> I |
29 | sumEvens = foldVectorWithIndex (\x a b -> if x `mod` 2 == 0 then a + b else b) 0 | 32 | sumEvens = 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 |
32 | sumEvensAndPrint :: Vector Int -> VectorMonadT () | ||
33 | sumEvensAndPrint = mapVectorWithIndexM_ $ \ i x -> do | 35 | sumEvensAndPrint = 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 | ||
41 | indexPlusSum :: Vector Int -> VectorMonadT () | 43 | --indexPlusSum :: Vector I -> VectorMonadT () |
42 | indexPlusSum v' = do | 44 | indexPlusSum 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 | ||
64 | isMonotoneIncreasing :: Vector Double -> Bool | 66 | isMonotoneIncreasing :: Vector Double -> Bool |
65 | isMonotoneIncreasing v = | 67 | isMonotoneIncreasing 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 |
75 | successive_ :: Storable a => (a -> a -> Bool) -> Vector a -> Bool | 77 | successive_ :: (Container Vector a, Indexable (Vector a) a) => (a -> a -> Bool) -> Vector a -> Bool |
76 | successive_ t v = maybe False (\_ -> True) $ evalState (runMaybeT (mapVectorM_ step (subVector 1 (dim v - 1) v))) (v @> 0) | 78 | successive_ 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 |
84 | successive :: (Storable a, Storable b) => (a -> a -> b) -> Vector a -> Vector b | 86 | successive |
85 | successive 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 | ||
89 | successive 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 | ||
93 | v :: Vector Int | 97 | v :: Vector I |
94 | v = 10 |> [0..] | 98 | v = 10 |> [0..] |
95 | 99 | ||
96 | w = fromList ([1..10]++[10,9..1]) :: Vector Double | 100 | w = 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 | |||