summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Data/Packed/Vector.hs54
-rw-r--r--lib/Numeric/LinearAlgebra/Tests.hs58
2 files changed, 56 insertions, 56 deletions
diff --git a/lib/Data/Packed/Vector.hs b/lib/Data/Packed/Vector.hs
index e79e237..8b1e813 100644
--- a/lib/Data/Packed/Vector.hs
+++ b/lib/Data/Packed/Vector.hs
@@ -22,8 +22,7 @@ module Data.Packed.Vector (
22 subVector, takesV, join, 22 subVector, takesV, join,
23 mapVector, zipVector, zipVectorWith, unzipVector, unzipVectorWith, 23 mapVector, zipVector, zipVectorWith, unzipVector, unzipVectorWith,
24 mapVectorM, mapVectorM_, mapVectorWithIndexM, mapVectorWithIndexM_, 24 mapVectorM, mapVectorM_, mapVectorWithIndexM, mapVectorWithIndexM_,
25 foldLoop, foldVector, foldVectorG, foldVectorWithIndex, 25 foldLoop, foldVector, foldVectorG, foldVectorWithIndex
26 successive_, successive
27) where 26) where
28 27
29import Data.Packed.Internal.Vector 28import Data.Packed.Internal.Vector
@@ -84,54 +83,3 @@ unzipVector :: (Storable a, Storable b, Storable (a,b)) => Vector (a,b) -> (Vect
84unzipVector = unzipVectorWith id 83unzipVector = unzipVectorWith id
85 84
86------------------------------------------------------------------- 85-------------------------------------------------------------------
87
88newtype State s a = State { runState :: s -> (a,s) }
89
90instance Monad (State s) where
91 return a = State $ \s -> (a,s)
92 m >>= f = State $ \s -> let (a,s') = runState m s
93 in runState (f a) s'
94
95state_get :: State s s
96state_get = State $ \s -> (s,s)
97
98state_put :: s -> State s ()
99state_put s = State $ \_ -> ((),s)
100
101evalState :: State s a -> s -> a
102evalState m s = let (a,s') = runState m s
103 in seq s' a
104
105newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }
106
107instance Monad m => Monad (MaybeT m) where
108 return a = MaybeT $ return $ Just a
109 m >>= f = MaybeT $ do
110 res <- runMaybeT m
111 case res of
112 Nothing -> return Nothing
113 Just r -> runMaybeT (f r)
114 fail _ = MaybeT $ return Nothing
115
116lift_maybe m = MaybeT $ do
117 res <- m
118 return $ Just res
119
120-- | apply a test to successive elements of a vector, evaluates to true iff test passes for all pairs
121successive_ :: Storable a => (a -> a -> Bool) -> Vector a -> Bool
122successive_ t v = maybe False (\_ -> True) $ evalState (runMaybeT (mapVectorM_ step (subVector 1 (dim v - 1) v))) (v @> 0)
123 where step e = do
124 ep <- lift_maybe $ state_get
125 if t e ep
126 then lift_maybe $ state_put e
127 else (fail "successive_ test failed")
128
129-- | operate on successive elements of a vector and return the resulting vector, whose length 1 less than that of the input
130successive :: (Storable a, Storable b) => (a -> a -> b) -> Vector a -> Vector b
131successive f v = evalState (mapVectorM step (subVector 1 (dim v - 1) v)) (v @> 0)
132 where step e = do
133 ep <- state_get
134 state_put e
135 return $ f ep e
136
137-------------------------------------------------------------------
diff --git a/lib/Numeric/LinearAlgebra/Tests.hs b/lib/Numeric/LinearAlgebra/Tests.hs
index 630ba91..093e4ef 100644
--- a/lib/Numeric/LinearAlgebra/Tests.hs
+++ b/lib/Numeric/LinearAlgebra/Tests.hs
@@ -26,7 +26,7 @@ import Numeric.LinearAlgebra
26import Numeric.LinearAlgebra.LAPACK 26import Numeric.LinearAlgebra.LAPACK
27import Numeric.LinearAlgebra.Tests.Instances 27import Numeric.LinearAlgebra.Tests.Instances
28import Numeric.LinearAlgebra.Tests.Properties 28import Numeric.LinearAlgebra.Tests.Properties
29import Test.HUnit hiding ((~:),test,Testable) 29import Test.HUnit hiding ((~:),test,Testable,State)
30import System.Info 30import System.Info
31import Data.List(foldl1') 31import Data.List(foldl1')
32import Numeric.GSL 32import Numeric.GSL
@@ -300,8 +300,60 @@ conjuTest m = mapVector conjugate (flatten (trans m)) == flatten (ctrans m)
300 300
301--------------------------------------------------------------------- 301---------------------------------------------------------------------
302 302
303succTest = utest "successive" $ successive_ (>) (fromList [1 :: Double,2,3,4]) == True 303newtype State s a = State { runState :: s -> (a,s) }
304 && successive_ (<) (fromList [1 :: Double,3,2,4]) == False 304
305instance Monad (State s) where
306 return a = State $ \s -> (a,s)
307 m >>= f = State $ \s -> let (a,s') = runState m s
308 in runState (f a) s'
309
310state_get :: State s s
311state_get = State $ \s -> (s,s)
312
313state_put :: s -> State s ()
314state_put s = State $ \_ -> ((),s)
315
316evalState :: State s a -> s -> a
317evalState m s = let (a,s') = runState m s
318 in seq s' a
319
320newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }
321
322instance Monad m => Monad (MaybeT m) where
323 return a = MaybeT $ return $ Just a
324 m >>= f = MaybeT $ do
325 res <- runMaybeT m
326 case res of
327 Nothing -> return Nothing
328 Just r -> runMaybeT (f r)
329 fail _ = MaybeT $ return Nothing
330
331lift_maybe m = MaybeT $ do
332 res <- m
333 return $ Just res
334
335-- | apply a test to successive elements of a vector, evaluates to true iff test passes for all pairs
336--successive_ :: Storable a => (a -> a -> Bool) -> Vector a -> Bool
337successive_ t v = maybe False (\_ -> True) $ evalState (runMaybeT (mapVectorM_ step (subVector 1 (dim v - 1) v))) (v @> 0)
338 where step e = do
339 ep <- lift_maybe $ state_get
340 if t e ep
341 then lift_maybe $ state_put e
342 else (fail "successive_ test failed")
343
344-- | operate on successive elements of a vector and return the resulting vector, whose length 1 less than that of the input
345--successive :: (Storable a, Storable b) => (a -> a -> b) -> Vector a -> Vector b
346successive f v = evalState (mapVectorM step (subVector 1 (dim v - 1) v)) (v @> 0)
347 where step e = do
348 ep <- state_get
349 state_put e
350 return $ f ep e
351
352
353succTest = utest "successive" $
354 successive_ (>) (fromList [1 :: Double,2,3,4]) == True
355 && successive_ (>) (fromList [1 :: Double,3,2,4]) == False
356 && successive (+) (fromList [1..10 :: Double]) == 9 |> [3,5,7,9,11,13,15,17,19]
305 357
306--------------------------------------------------------------------- 358---------------------------------------------------------------------
307 359