blob: b933de99474f096bd6eff480b8623bb7a9438b66 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
|
-- monadic computations
-- (contributed by Vivian McPhail)
import Numeric.Container
import Control.Monad.State
import Control.Monad.Maybe
-------------------------------------------
-- an instance of MonadIO, a monad transformer
type VectorMonadT = StateT Int IO
v :: Vector Int
v = 10 |> [0..]
test1 :: Vector Int -> IO (Vector Int)
test1 = mapVectorM $ \x -> do
putStr $ (show x) ++ " "
return (x + 1)
-- we can have an arbitrary monad AND do IO
addInitialM :: Vector Int -> VectorMonadT ()
addInitialM = mapVectorM_ $ \x -> do
i <- get
liftIO $ putStr $ (show $ x + i) ++ " "
put $ x + i
-- sum the values of the even indiced elements
sumEvens :: Vector Int -> Int
sumEvens = foldVectorWithIndex (\x a b -> if x `mod` 2 == 0 then a + b else b) 0
-- sum and print running total of evens
sumEvensAndPrint :: Vector Int -> VectorMonadT ()
sumEvensAndPrint = mapVectorWithIndexM_ $ \ i x -> do
when (i `mod` 2 == 0) $ do
v <- get
put $ v + x
v' <- get
liftIO $ putStr $ (show v') ++ " "
indexPlusSum :: Vector Int -> VectorMonadT ()
indexPlusSum v' = do
let f i x = do
s <- get
let inc = x+s
liftIO $ putStr $ show (i,inc) ++ " "
put inc
return inc
v <- mapVectorWithIndexM f v'
liftIO $ do
putStrLn ""
putStrLn $ show v
-------------------------------------------
-- short circuit
monoStep :: Double -> MaybeT (State Double) ()
monoStep d = do
dp <- get
when (d < dp) (fail "negative difference")
put d
{-# INLINE monoStep #-}
isMonotoneIncreasing :: Vector Double -> Bool
isMonotoneIncreasing v =
let res = evalState (runMaybeT $ (mapVectorM_ monoStep v)) (v @> 0)
in case res of
Nothing -> False
Just _ -> True
w = fromList ([1..10]++[10,9..1]) :: Vector Double
-------------------------------------------
main = do
v' <- test1 v
putStrLn ""
putStrLn $ show v'
evalStateT (addInitialM v) 0
putStrLn ""
putStrLn $ show (sumEvens v)
evalStateT (sumEvensAndPrint v) 0
putStrLn ""
evalStateT (indexPlusSum v) 0
putStrLn "-----------------------"
print $ isMonotoneIncreasing w
print $ isMonotoneIncreasing (subVector 0 7 w)
print $ successive_ (>) v
print $ successive_ (>) w
|
