diff options
Diffstat (limited to 'packages/hmatrix/examples/monadic.hs')
-rw-r--r-- | packages/hmatrix/examples/monadic.hs | 118 |
1 files changed, 0 insertions, 118 deletions
diff --git a/packages/hmatrix/examples/monadic.hs b/packages/hmatrix/examples/monadic.hs deleted file mode 100644 index 7c6e0f4..0000000 --- a/packages/hmatrix/examples/monadic.hs +++ /dev/null | |||
@@ -1,118 +0,0 @@ | |||
1 | -- monadic computations | ||
2 | -- (contributed by Vivian McPhail) | ||
3 | |||
4 | import Numeric.LinearAlgebra | ||
5 | import Control.Monad.State.Strict | ||
6 | import Control.Monad.Maybe | ||
7 | import Foreign.Storable(Storable) | ||
8 | import System.Random(randomIO) | ||
9 | |||
10 | ------------------------------------------- | ||
11 | |||
12 | -- an instance of MonadIO, a monad transformer | ||
13 | type VectorMonadT = StateT Int IO | ||
14 | |||
15 | test1 :: Vector Int -> IO (Vector Int) | ||
16 | test1 = mapVectorM $ \x -> do | ||
17 | putStr $ (show x) ++ " " | ||
18 | return (x + 1) | ||
19 | |||
20 | -- we can have an arbitrary monad AND do IO | ||
21 | addInitialM :: Vector Int -> VectorMonadT () | ||
22 | addInitialM = mapVectorM_ $ \x -> do | ||
23 | i <- get | ||
24 | liftIO $ putStr $ (show $ x + i) ++ " " | ||
25 | put $ x + i | ||
26 | |||
27 | -- sum the values of the even indiced elements | ||
28 | sumEvens :: Vector Int -> Int | ||
29 | sumEvens = foldVectorWithIndex (\x a b -> if x `mod` 2 == 0 then a + b else b) 0 | ||
30 | |||
31 | -- sum and print running total of evens | ||
32 | sumEvensAndPrint :: Vector Int -> VectorMonadT () | ||
33 | sumEvensAndPrint = mapVectorWithIndexM_ $ \ i x -> do | ||
34 | when (i `mod` 2 == 0) $ do | ||
35 | v <- get | ||
36 | put $ v + x | ||
37 | v' <- get | ||
38 | liftIO $ putStr $ (show v') ++ " " | ||
39 | |||
40 | |||
41 | indexPlusSum :: Vector Int -> VectorMonadT () | ||
42 | indexPlusSum v' = do | ||
43 | let f i x = do | ||
44 | s <- get | ||
45 | let inc = x+s | ||
46 | liftIO $ putStr $ show (i,inc) ++ " " | ||
47 | put inc | ||
48 | return inc | ||
49 | v <- mapVectorWithIndexM f v' | ||
50 | liftIO $ do | ||
51 | putStrLn "" | ||
52 | putStrLn $ show v | ||
53 | |||
54 | ------------------------------------------- | ||
55 | |||
56 | -- short circuit | ||
57 | monoStep :: Double -> MaybeT (State Double) () | ||
58 | monoStep d = do | ||
59 | dp <- get | ||
60 | when (d < dp) (fail "negative difference") | ||
61 | put d | ||
62 | {-# INLINE monoStep #-} | ||
63 | |||
64 | isMonotoneIncreasing :: Vector Double -> Bool | ||
65 | isMonotoneIncreasing v = | ||
66 | let res = evalState (runMaybeT $ (mapVectorM_ monoStep v)) (v @> 0) | ||
67 | in case res of | ||
68 | Nothing -> False | ||
69 | Just _ -> True | ||
70 | |||
71 | |||
72 | ------------------------------------------- | ||
73 | |||
74 | -- | 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 | ||
76 | successive_ t v = maybe False (\_ -> True) $ evalState (runMaybeT (mapVectorM_ step (subVector 1 (dim v - 1) v))) (v @> 0) | ||
77 | where step e = do | ||
78 | ep <- lift $ get | ||
79 | if t e ep | ||
80 | then lift $ put e | ||
81 | else (fail "successive_ test failed") | ||
82 | |||
83 | -- | 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 | ||
85 | successive f v = evalState (mapVectorM step (subVector 1 (dim v - 1) v)) (v @> 0) | ||
86 | where step e = do | ||
87 | ep <- get | ||
88 | put e | ||
89 | return $ f ep e | ||
90 | |||
91 | ------------------------------------------- | ||
92 | |||
93 | v :: Vector Int | ||
94 | v = 10 |> [0..] | ||
95 | |||
96 | w = fromList ([1..10]++[10,9..1]) :: Vector Double | ||
97 | |||
98 | |||
99 | main = do | ||
100 | v' <- test1 v | ||
101 | putStrLn "" | ||
102 | putStrLn $ show v' | ||
103 | evalStateT (addInitialM v) 0 | ||
104 | putStrLn "" | ||
105 | putStrLn $ show (sumEvens v) | ||
106 | evalStateT (sumEvensAndPrint v) 0 | ||
107 | putStrLn "" | ||
108 | evalStateT (indexPlusSum v) 0 | ||
109 | putStrLn "-----------------------" | ||
110 | mapVectorM_ print v | ||
111 | print =<< (mapVectorM (const randomIO) v :: IO (Vector Double)) | ||
112 | print =<< (mapVectorM (\a -> fmap (+a) randomIO) (5|>[0,100..1000]) :: IO (Vector Double)) | ||
113 | putStrLn "-----------------------" | ||
114 | print $ isMonotoneIncreasing w | ||
115 | print $ isMonotoneIncreasing (subVector 0 7 w) | ||
116 | print $ successive_ (>) v | ||
117 | print $ successive_ (>) w | ||
118 | print $ successive (+) v | ||