I'm testing the speed of various memoizing methods. The code below compares two implementation of memoizing with an array. I tested this on a recursive function. The complete code is below
Running the program with stack test for memoweird 1000, memoweird 5000 etc, shows that IOArray is consistently faster than STArray by a couple seconds, and the difference seems to be O(1). However, running the same program with stack test --profile reverses the result, and STArray becomes consistently faster by about one second.
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Data.Array
import Data.Array.ST
import Control.Monad.ST
import Data.Array.IO
import GHC.IO
import Control.Monad
import Data.Time
memoST :: forall a b. (Ix a)
=> (a, a) -- range of the argument memoized
-> ((a -> b) -- a recursive function, but uses it's first argument for recursive calls instead
-> a -> b)
-> (a -> b) -- memoized function
memoST r f = (runSTArray compute !)
where
compute :: ST s (STArray s a b)
compute= do
arr <- newArray_ r
forM_ (range r) (\i -> do
writeArray arr i $ f (memoST r f) i)
return arr
memoArray :: forall a b. (Ix a)
=> (a, a)
-> ((a -> b) -> a -> b)
-> a -> b
memoArray r f = (unsafePerformIO compute !) -- safe!
where
compute :: IO (Array a b)
compute = do
arr <- newArray_ r :: IO (IOArray a b)
forM_ (range r) (\i -> do
writeArray arr i$ f (memoArray r f) i)
freeze arr
weird :: (Int -> Int) -> Int -> Int
weird _ 0 = 0
weird _ 1 = 0
weird f i = f (i `div` 2) + f (i - 1) + 1
stweird :: Int -> Int
stweird n = memoST (0,n) weird n
arrayweird :: Int -> Int
arrayweird n = memoArray (0,n) weird n
main :: IO()
main = do
t0 <- getCurrentTime
print (stweird 5000)
t1 <- getCurrentTime
print (arrayweird 5000)
t2 <- getCurrentTime
let sttime = diffUTCTime t0 t1
let artime = diffUTCTime t1 t2
print (sttime - artime)
Is there a reason why the profiling overhead is so different (albeit small) on the two array types?
I'm using Stack Version 2.7.3, GHC version 8.10.4 on OS X.
Some data on my computer.
Running this a couple times:
Without Profiling:
-0.222663s -0.116007s -0.202765s -0.205319s -0.130202s
Avg -0.1754s
Std 0.0486s
With Profiling:
0.608895s -0.755541s -0.61222s -0.83613s 0.450045s
1.879662s -0.181789s 3.251379s 0.359211s 0.122721s
Avg 0.4286s
Std 1.2764s
Apparently, the random fluctuations of the profiler covers the difference up. The data here is not sufficient to confirm a difference.
You really should use criterion for benchmarking.
benchmarking stweird
time 3.116 s (3.109 s .. 3.119 s)
1.000 R² (1.000 R² .. 1.000 R²)
mean 3.112 s (3.110 s .. 3.113 s)
std dev 2.220 ms (953.8 μs .. 2.807 ms)
variance introduced by outliers: 19% (moderately inflated)
benchmarking marrayweird
time 3.170 s (2.684 s .. 3.602 s)
0.997 R² (0.989 R² .. 1.000 R²)
mean 3.204 s (3.148 s .. 3.280 s)
std dev 72.66 ms (1.810 ms .. 88.94 ms)
variance introduced by outliers: 19% (moderately inflated)
My system is noisy, but it does appear that the standard deviations don't overlap. I don't actually care much about figuring out why, though, because the code is exceptionally slow. 3 seconds for memoizing 5000 operations? Something has gone horribly wrong.
The code as written is a super-exponential algorithm - there's no sharing of memoized functions in the memoization code. Each sub-evaluation could create an entirely new array and populate it. You're being saved from that situation by two things. First is laziness - most values are never evaluated. The upshot here is that the algorithm will actually terminate, instead of eagerly evaluating array entries forever. Second, and more importantly, GHC does some constant-lifting, lifting the expression (memoST r f) (or the arrayST version) out of the loop body. This creates sharing within each loop body so that the two sub-calls actually share memoization. It's not great, but it's actually doing some speedup. But it's mostly accidental.
The traditional approach to this sort of memoization is to just let laziness do the necessary mutation:
memoArray
:: forall a b. (Ix a)
=> (a, a)
-> ((a -> b) -> a -> b)
-> a -> b
memoArray r f = fetch
where
fetch n = arr ! n
arr = listArray r $ map (f fetch) (range r)
Note the knot-tying between fetch and arr internally. This ensures that the same array is used in every calculation. It benchmarks a bit better:
benchmarking arrayweird
time 212.0 μs (211.5 μs .. 212.6 μs)
1.000 R² (0.999 R² .. 1.000 R²)
mean 213.3 μs (212.4 μs .. 215.0 μs)
std dev 4.104 μs (2.469 μs .. 6.194 μs)
variance introduced by outliers: 12% (moderately inflated)
213 microseconds is much more what I'd expect from only 5000 iterations. Still, one might be curious whether doing explicit sharing could work with the other variants. And it can:
memoST'
:: forall a b. (Ix a)
=> (a, a)
-> ((a -> b) -> a -> b)
-> a -> b
memoST' r f = fetch
where
fetch n = arr ! n
arr = runSTArray compute
compute :: ST s (STArray s a b)
compute = do
a <- newArray_ r
forM_ (range r) $ \i -> do
writeArray a i $ f fetch i
return a
memoMArray'
:: forall a b. (Ix a)
=> (a, a)
-> ((a -> b) -> a -> b)
-> a -> b
memoMArray' r f = fetch
where
fetch n = arr ! n
arr = unsafePerformIO compute
compute :: IO (Array a b)
compute = do
a <- newArray_ r :: IO (IOArray a b)
forM_ (range r) $ \i -> do
writeArray a i $ f fetch i
freeze a
Those use explicit sharing to introduce the same sort of knot-tying, though significantly more indirectly.
benchmarking stweird'
time 168.1 μs (167.1 μs .. 169.9 μs)
1.000 R² (0.999 R² .. 1.000 R²)
mean 167.1 μs (166.7 μs .. 167.8 μs)
std dev 1.636 μs (832.3 ns .. 3.007 μs)
benchmarking marrayweird'
time 171.1 μs (170.7 μs .. 171.7 μs)
1.000 R² (1.000 R² .. 1.000 R²)
mean 170.9 μs (170.5 μs .. 171.4 μs)
std dev 1.554 μs (1.076 μs .. 2.224 μs)
And those actually seem to beat the listArray variant. I really don't know what's up with that. listArray must be doing some surprising extra amount of work. Oh well.
In the end, I don't actually know what's leading to these small performance differences. But none of them are significant in comparison to actually using an efficient algorithm.
Full code, for your perusal:
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Data.Array
import Data.Array.ST
import Data.Array.Unsafe
import Control.Monad.ST
import Data.Array.IO
import GHC.IO.Unsafe
import Control.Monad
import Criterion.Main
memoST
:: forall a b. (Ix a)
=> (a, a)
-> ((a -> b) -> a -> b)
-> a -> b
memoST r f = (runSTArray compute !)
where
compute :: ST s (STArray s a b)
compute = do
arr <- newArray_ r
forM_ (range r) $ \i -> do
writeArray arr i $ f (memoST r f) i
return arr
memoMArray
:: forall a b. (Ix a)
=> (a, a)
-> ((a -> b) -> a -> b)
-> a -> b
memoMArray r f = (unsafePerformIO compute !)
where
compute :: IO (Array a b)
compute = do
arr <- newArray_ r :: IO (IOArray a b)
forM_ (range r) $ \i -> do
writeArray arr i $ f (memoMArray r f) i
freeze arr
memoArray
:: forall a b. (Ix a)
=> (a, a)
-> ((a -> b) -> a -> b)
-> a -> b
memoArray r f = fetch
where
fetch n = arr ! n
arr = listArray r $ map (f fetch) (range r)
memoST'
:: forall a b. (Ix a)
=> (a, a)
-> ((a -> b) -> a -> b)
-> a -> b
memoST' r f = fetch
where
fetch n = arr ! n
arr = runSTArray compute
compute :: ST s (STArray s a b)
compute = do
a <- newArray_ r
forM_ (range r) $ \i -> do
writeArray a i $ f fetch i
return a
memoMArray'
:: forall a b. (Ix a)
=> (a, a)
-> ((a -> b) -> a -> b)
-> a -> b
memoMArray' r f = fetch
where
fetch n = arr ! n
arr = unsafePerformIO compute
compute :: IO (Array a b)
compute = do
a <- newArray_ r :: IO (IOArray a b)
forM_ (range r) $ \i -> do
writeArray a i $ f fetch i
freeze a
weird :: (Int -> Int) -> Int -> Int
weird _ 0 = 0
weird _ 1 = 0
weird f i = f (i `div` 2) + f (i - 1) + 1
stweird :: Int -> Int
stweird n = memoST (0, n) weird n
marrayweird :: Int -> Int
marrayweird n = memoMArray (0, n) weird n
arrayweird :: Int -> Int
arrayweird n = memoArray (0, n) weird n
stweird' :: Int -> Int
stweird' n = memoST' (0, n) weird n
marrayweird' :: Int -> Int
marrayweird' n = memoMArray' (0, n) weird n
main :: IO()
main = do
let rounds = 5000
print $ stweird rounds
print $ marrayweird rounds
print $ arrayweird rounds
print $ stweird' rounds
print $ marrayweird' rounds
putStrLn ""
defaultMain
[ bench "stweird" $ whnf stweird rounds
, bench "marrayweird" $ whnf marrayweird rounds
, bench "arrayweird" $ whnf arrayweird rounds
, bench "stweird'" $ whnf stweird' rounds
, bench "marrayweird'" $ whnf marrayweird' rounds
]
Related
I'm trying to find a much more efficient way to code in R the following matrix:
Let A and C be two 3D array of dimension (n, n, m) and B a matrix of dimension (m, m), then M is an (n, n) matrix such that:
M_ij = SUM_kl A_ijk * B_kl * C_ijl
for (i in seq(n)) {
for (j in seq(n)) {
M[i, j] <- A[i,j,] %*% B %*% C[i,j,]
}
}
It is possible to write this with the TensorA package using i and j as parallel dimension, but I'd rather stay with base R object.
einstein.tensor(A %e% log(B), C, by = c("i", "j"))
Thanks!
I don't know if this would be faster, but it would avoid one level of looping:
for (i in seq(n))
M[i,] <- diag(A[i,,] %*% B %*% t(C[i,,]))
It gives the same answer as yours in this example:
n <- 2
m <- 3
A <- array(1:(n^2*m), c(n, n, m))
C <- A + 1
B <- matrix(1:(m^2), m, m)
M <- matrix(NA, n, n)
for (i in seq(n))
M[i,] <- diag(A[i,,] %*% B %*% t(C[i,,]))
M
# [,1] [,2]
# [1,] 1854 3216
# [2,] 2490 4032
Edited to add: Based on https://stackoverflow.com/a/42569902/2554330, here's a slightly faster version:
for (i in seq(n))
M[i,] <- rowSums((A[i,,] %*% B) * C[i,,])
I did some timing with n <- 200 and m <- 300, and this was the fastest at 3.1 sec, versus my original solution at 4.7 sec, and the one in the question at 17.4 sec.
I have a function like this:
jac :: Int -> Int -> [Int] -> [Int] -> IOArray (Int,Int) Double -> IO Double
jac m k mu nu arr
| nu!!0 == 0 = return 1
| length nu > m && nu!!m > 0 = return 0
| m == 1 = return $ x!!0^(nu!!0) * theproduct (nu!!0)
| k == 0 && CONDITION = XXX
| otherwise = YYY
The CONDITION must check that that element (1,1) of the array arr is different from 0. But to get this element, one must do
element <- readArray arr (1,1)
I don't see how to do. Except with unsafePerformIO. Is it safe to use it here ? I mean:
| k == 0 && unsafePerformIO (readArray arr (1,1)) /= 0 = XXX
Otherwise, how could I do ?
Let's make a simplified version of your question.
Let's say we want to make the following function. It tells us whether or not both of the Int values are equal to 0. Problem is, it contains an IO. Your current method is this:
-- THIS IS BAD CODE! This could easily cause unexpected behaviour.
areBothZero :: Int -> IO Int -> IO Bool
areBothZero a b
| a == 0 && unsafePerformIO b == 0 = return True
| otherwise = return False
This shows a misunderstanding of monads. In Haskell, unsafePerformIO as a general rule shouldn't be used, unless you want to achieve a certain effect that pure computation cannot achieve. However, this kind of situation is perfectly achievable using the monad operations, which are, unlike unsafePerformIO, perfectly safe.
This is how we achieve this. Firsly, write the logic outside the context of IO:
areBothZeroLogic :: Int -> Int -> Bool
areBothZeroLogic a b
| a == 0 && b == 0 = True
| otherwise = False
Then, we pipe that up to the IO logic we want:
areBothZeroIO :: Int -> IO Int -> IO Bool
areBothZeroIO a mb = do
b <- mb -- Use do-notation to work with the value 'inside' the IO:
return $ areBothZeroLogic a b
Immediately, this separates IO logic from pure logic. This is a fundamental design principle in Haskell that you should always try to follow.
Now, onto your problem.
Your problem is much more messy and has several other issues, which suggests to me that you haven't considered how best to split the problem up into smaller peices. However, a better solution may look something like this, maybe with better names:
-- Look here! vvvvvv vvvvvv
jacPure :: Int -> Int -> [Int] -> [Int] -> Double -> Double
jacPure m k mu nu arrVal
| nu!!0 == 0 = 1
| length nu > m && nu!!m > 0 = 0
| m == 1 = x!!0^(nu!!0) * theproduct (nu!!0)
| k == 0 && arrVal /= 0 = XXX
| otherwise = YYY
jac :: Int -> Int -> [Int] -> [Int] -> IOArray (Int,Int) Double -> IO Double
jac m k mu nu arr = do
arrVal <- readArray arr (1,1) -- Use do-notation to work with the value 'inside' the IO:
return $ jacPure m k mu nu arrVal
You should see immediately why this is much better. When implementing logic, who cares what's going on in the IO domain? Including an IO in what should be pure logic is like telling an author about the acidity of the paper their book will be printed on—it isn't relevant to what their job is. Always separate logic and IO!
There are of course other ways of doing this, and some could very well be better than the way I have suggested. However, it is not possible to know with the code you have provided which the best path would be. You should aim to learn more about monads and get better at using them, so you can make this judgement on your own.
I suspect this question is borne from a lack of understanding of Monads and monadic operations. If you are a beginner, I recommend reading the relevant LYAH chapter, which I found helpful as a beginner too.
One option is to combine the last two cases:
jac m k mu nu arr
...
| k == 0 = do
element <- readArray arr (1,1)
case element of
0 -> YYY
_ -> XXX
| otherwise -> YYY
Suppose we have
areBothZero :: Int -> IOArray Int Int -> IO Bool
areBothZero a b
| a == 0 && unsafePerformIO (readArray b 0) == 0 = return True
| otherwise = return False
I think it's worth thinking about what can go wrong. Suppose I write
do
x <- areBothZero a b
-- Change the value in b[0]
y <- areBothZero a b
Now there are two identical function calls, so the compiler is perfectly free to rewrite this:
do
let m = areBothZero a b
x <- m
-- change b
y <- m
The first time we run m, we perform the IO, reading b and getting an action return True or return False. We run that action and bind the result to x. The next time, we already have an action, so we run it, producing the same result. Any change to b is ignored.
This is only one of the ways things can go wrong with unsafePerformIO, so watch out!
I think there are one and a half ways it's reasonable to use unsafePerformIO or (in some cases) unsafeDupablePerformIO routinely. The entirely reasonable one is to wrap an "essentially pure" FFI call that just performs a mathematical calculation in another language. The less reasonable one is to create a global IORef or (more often) MVar. I think this is less reasonable because global variables have a certain tendency to turn out not to be as global as you thought once a year or two has passed. Most other uses of these unsafe IO operations require very careful thought to get right These tend to be in libraries like monad-par and reflex that introduce whole new styles of computation to Haskell. They also tend to be subtly buggy, sometimes for years, until someone figures out just what needs to happen to make them right. (Not to toot my own horn too much, but I think I'm probably one of the top handful of people in the world at reasoning about unsafe IO, and I very much prefer to avoid it when possible. This stuff has tripped up some of the best Haskell programmers and most important GHC developers.)
I've found a solution. I pass the value of the array element in addition.
jac :: Int -> Int -> [Int] -> [Int] -> IOArray (Int,Int) Double -> Double -> IO Double
jac m k mu nu arr elt
| nu!!0 == 0 || m == 0 = return 1
| length nu > m && nu!!m > 0 = return 0
| m == 1 = return $ x!!0^(nu!!0) * theproduct (nu!!0)
| k == 0 && elt /= 0 = XXX
| otherwise = do
e <- readArray arr (1, 1)
jck <- jac (m-1) 0 nu nu arr e
......
Maybe my question was not precise enough...
Not terribly elegant, but should do:
jac :: Int -> Int -> [Int] -> [Int] -> IOArray (Int,Int) Double -> IO Double
jac m k mu nu arr
| nu!!0 == 0 = return 1
| length nu > m && nu!!m > 0 = return 0
| m == 1 = return $ x!!0^(nu!!0) * theproduct (nu!!0)
| otherwise = do
v <- readArray arr (1,1)
case () of
_ | k == 0 && v /= 0 -> XXX
| otherwise -> YYY
Alternatively, read from the array at the very beginning:
jac :: Int -> Int -> [Int] -> [Int] -> IOArray (Int,Int) Double -> IO Double
jac m k mu nu arr = do
v <- readArray arr (1,1)
case () of
_ | nu!!0 == 0 = return 1
| length nu > m && nu!!m > 0 = return 0
| m == 1 = return $ x!!0^(nu!!0) * theproduct (nu!!0)
| k == 0 && v /= 0 -> XXX
| otherwise -> YYY
Let's say there is a grammar
S -> PQT
R -> T
U -> aU | bX
X -> Y
P -> bQ
Y -> SX | c | X
Q -> aRY
T -> U
There is a loop:
X -> Y
Y -> X
How to eliminate it when converting to CNF?
I don't think it's fine to add a rule to grammar (as in unit elimination)
X -> X, right, because it s basically another loop?
If X -> Y and Y -> X, the nonterminal symbols are interchangeable and you can safely replace all instances of either of the two with the other of the two, eliminating one of the two completely. As you also pointed out, rules of the form X -> X can be safely eliminated. So this grammar is equivalent to the one you give:
S -> PQT
R -> T
U -> aU | bX
P -> bQ
X -> SX | c
Q -> aRX
T -> U
And so is this one:
S -> PQT
R -> T
U -> aU | bY
P -> bQ
Y -> SY | c
Q -> aRY
T -> U
I'm new in Haskell.
I trying to parse a text file with two matrices. The insides of a text file:
m n
a11 a12 ...
a21 a22 ...
...
b11 b12 ...
b21 b22 ...
...
where m is number of rows of the 1st matrix, n is number of rows of the 2nd matrix.
For instance:
3 2
1 2 3
4 5 6
7 8 9
1 2
3 4
I know, looks stupid, but I have a task parse a text file with 2 matrices and I only came up with it.
There is the code:
readLine :: Read a => Handle -> IO [a]
readLine = fmap (map read . words) . hGetLine
parse :: Handle -> IO (Matrix a, Matrix a)
parse = do
[m, n] <- readLine
xss1 <- replicateM m readLine
xss2 <- replicateM n readLine
return (fromLists xss1, fromLists xss2)
main = do
[input, output] <- getArgs
h <- openFile input ReadMode
(m1, m2) <- parse h
print $ mult m1 m2
There is a log from console:
Prelude> :r
[1 of 1] Compiling Matrix ( lab.matrix.hs, interpreted )
lab.matrix.hs:156:5:
Couldn't match expected type `IO [a0]' with actual type `[t0]'
In the pattern: [m, n]
In a stmt of a 'do' block: [m, n] <- readLine
In the expression:
do { [m, n] <- readLine;
xss1 <- replicateM m readLine;
xss2 <- replicateM n readLine;
return (fromLists xss1, fromLists xss2) }
Failed, modules loaded: none.
Most likely, there are still a few bugs.
Help me please, I'm exhausted already...
You need to supply a Handle as an argument to every call of readLine, so parse could look like this:
parse h = do
[m, n] <- readLine h
xss1 <- replicateM n $ readLine h
xss2 <- replicateM m $ readLine h
return (fromLists xss1, fromLists xss2)
Another note - it's probably safer to check the number of arguments returned by getArgs, rather than just assuming there will be two. For example:
main = do
args <- getArgs
case args of
[input, output] -> do
h <- openFile input ReadMode
(m1, m2) <- parse h
hClose h
print $ show mult m1 m2
_ -> putStrLn "expected two arguments"
I already tried to prove that fun bubble_main is ordered but no approach seems to work. Could someone here help me to prove the lemma is_ordered (bubble_main L) please.
I just delete all my previous lemmas because none seems to help Isabelle find a proof.
Here is my code/theory:
text{*check if the list is ordered ascendant*}
fun is_sorted :: "nat list ⇒ bool" where
"is_sorted (x1 # x2 # xs) = (x1 < x2 ∧ is_sorted (x2 # xs))" |
"is_sorted x = True"
fun bubble_once :: "nat list ⇒ nat list" where
"bubble_once (x1 # x2 # xs) = (if x1 < x2
then x1 # bubble_once (x2 # xs)
else x2 # bubble_once (x1 # xs))" |
"bubble_once xs = xs"
text{*calls fun bubble_once *}
fun bubble_all where
"bubble_all 0 L = L"|
"bubble_all (Suc n) L = burbuja_all n (bubble_once L)"
text{*main function *}
fun bubble_main where
"bubble_main L = bubble_main (length L) L"
text{*-----prove by induction-----*}
lemma "is_sorted (bubble_main L)"
apply (induction L)
apply auto
quickcheck
oops
First of all, I would repair your definitions. E.g., using your version
of is_sorted is too strict in the sense, that [0,0] is not sorted. This
is also detected by quick check.
fun is_sorted :: "nat list ⇒ bool" where
"is_sorted (x1 # x2 # xs) = (x1 <= x2 ∧ is_sorted (x2 # xs))" |
"is_sorted x = True"
bubble_all has to call itself recursively.
fun bubble_all where
"bubble_all 0 L = L"|
"bubble_all (Suc n) L = bubble_all n (bubble_once L)"
and bubble_main has to invoke bubble_all.
fun bubble_main where
"bubble_main L = bubble_all (length L) L"
Then there are several auxiliary lemmas required to prove the result.
Some I listed here, others are visible in the sorry's.
lemma length_bubble_once[simp]: "length (bubble_once L) = length L"
by (induct rule: bubble_once.induct, auto)
lemma is_sorted_last: assumes "⋀ x. x ∈ set xs ⟹ x ≤ y"
and "is_sorted xs"
shows "is_sorted (xs # [y])" sorry
And of course, the main algorithm is bubble_all, so you should prove
the property for bubble_all, not for bubble_main inductively.
Moreover, an induction over the length of the list (or the number of iterations)
is advantageous here, since the list is changed by bubble_all in the recursive call.
lemma bubble_all_sorted: "n ≥ length L ⟹ is_sorted (bubble_all n L)"
proof (induct n arbitrary: L)
case (0 L) thus ?case by auto
next
case (Suc n L)
show ?case
proof (cases "L = []")
case True
from Suc(1)[of L] True
show ?thesis by auto
next
case False
let ?BL = "bubble_once L"
from False have "length ?BL ≠ 0" by auto
hence "?BL ≠ []" by (cases "?BL", auto)
hence "?BL = butlast ?BL # [last ?BL]" by auto
then obtain xs x where BL: "?BL = xs # [x]" ..
from BL have x_large: "⋀ y. y ∈ set xs ⟹ y ≤ x" sorry
from Suc(2) have "length ?BL ≤ Suc n" by auto
with BL have "length xs ≤ n" by auto
from Suc(1)[OF this] have sorted: "is_sorted (bubble_all n xs)" .
from x_large have id: "bubble_all n (xs # [x]) = bubble_all n xs # [x]" sorry
show ?thesis unfolding bubble_all.simps BL id
proof (rule is_sorted_last[OF x_large sorted])
fix x
assume "x ∈ set (bubble_all n xs)"
thus "x ∈ set xs" sorry
qed
qed
qed
The final theorem is then easily achieved.
lemma "is_sorted (bubble_main L)"
using bubble_all_sorted by simp
I hope, this helps a bit to see the direction what is required.