I'm trying to solve this problem https://codeforces.com/contest/285/problem/C?locale=en. On test #7 I have got TIME_LIMIT_EXCEEDED (the limit is 1000ms). How can I optimize my solution?
import Data.List
import Data.Int
(|>) a b = b a
main = do
s1 <- getLine
s2 <- getLine
let n = s1 |> (read :: String -> Int64)
a = s2 |> words |> map (read :: String -> Int64)
r = sort a |> zipWith (\x y -> abs (x - y)) [1 .. n] |> sum
print r
Test output:
Test: #7, time: 1000 ms., memory: 98516 KB, exit code: -1, checker exit code: 0, verdict: TIME_LIMIT_EXCEEDED
Input
300000
299996 65 64 63 62 61 60 59 58 70 53 79 88 97 106 115 124 133 142 45 151 160 169 178 187 196 ...
The solution was to switch to ByteString based I/O as suggested by Dogbert.
import Data.Maybe
import Data.List
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
-- NOTE: This will throw an error if parsing fails.
readInt :: B.ByteString -> Integer
readInt = fst . fromJust . C.readInteger
(|>) a b = b a
main = do
s1 <- B.getLine
s2 <- B.getLine
let n = s1 |> readInt
a = s2 |> C.words |> map readInt
r = sort a |> zipWith (\x y -> abs (x - y)) [1 .. n] |> sum
print r
Related
I told about that problem: https://www.hackerrank.com/contests/projecteuler/challenges/euler003
I am trying to solve this problem as follows:
open System
let isPrime n =
match n with
| _ when n > 3L && (n % 2L = 0L || n % 3L = 0L) -> false
| _ ->
let maxDiv = int64(System.Math.Sqrt(float n)) + 1L
let rec f d i =
if d > maxDiv then
true
else
if n % d = 0L then
false
else
f (d + i) (6L - i)
f 5L 2L
let primeFactors n =
let rec getFactor num proposed acc =
match proposed with
| _ when proposed = num -> proposed::acc
| _ when num % proposed = 0L -> getFactor (num / proposed) proposed (proposed::acc)
| _ when isPrime num -> num::acc
| _ -> getFactor num (proposed + 1L) acc
getFactor n 2L []
let pe3() =
for i = 1 to Console.ReadLine() |> int do
let num = Console.ReadLine() |> int64
let start = DateTime.Now
primeFactors num
|> List.max
|> printfn "%i"
let elapsed = DateTime.Now - start
printfn "elapsed: %A" elapsed
pe3()
There are results of my testing:
Input: 10 Output: 5 Elapsed time: 00:00:00.0562321
Input: 123456789 Output: 3803 Elapsed time: 00:00:00.0979232
Input: 12345678999 Output: 1371742111 Elapsed time: 00:00:00.0520280
Input: 987654321852 Output: 680202701 Elapsed time: 00:00:00.0564059
Input: 13652478965478 Output: 2275413160913 Elapsed time:
00:00:00.0593369
Input: 99999999999999 Output: 909091 Elapsed time: 00:00:00.1260673
But I anyway get Terminated due to timeout in Test Case 5. What can I do?
There is a solution:
open System
let primeFactors n =
let rec getFactor num proposed acc =
match proposed with
| _ when proposed*proposed > num -> num::acc
| _ when num % proposed = 0L -> getFactor (num / proposed) proposed (proposed::acc)
| _ -> getFactor num (proposed + 1L) acc
getFactor n 2L []
let pe3() =
for i = 1 to Console.ReadLine() |> int do
printfn "%i" (primeFactors (Console.ReadLine() |> int64)).Head
pe3()
Thanks Will Ness and rici.
There is no need to write super sophisticated code for this challenge. A simple algorithm to enumerate a number's prime factors will do the trick. My code creates a seq of the prime factors, then finds the maximum, and prints it. The rest of the code shows a nice functional way of handling processing of lines read from standard input.
module Auxiliaries =
let isNull (x : 'a when 'a : not struct) =
match box x with
| null -> true
| _ -> false
let refAsOption x =
if isNull x then None else Some x
let readLinesFromTextReader r =
let tryRdLn (r : System.IO.TextReader) =
try refAsOption (r.ReadLine ()) with _ -> None
let gen r =
tryRdLn r |> Option.map (fun s -> (s, r))
Seq.unfold gen r
module Contest =
let factors num =
let next n =
if n = 2L then 3L
elif n % 6L = 1L then n + 4L
else n + 2L
let rec loop nn ct lf =
seq {
if ct * ct > nn then
if nn > lf then yield nn
elif nn % ct = 0L then
yield ct
yield! loop (nn / ct) ct ct
else
yield! loop nn (next ct) lf
}
loop num 2L 0L
let euler003 n = factors n |> Seq.max
let () =
Auxiliaries.readLinesFromTextReader stdin
|> Seq.skip 1
|> Seq.map (int64 >> euler003)
|> Seq.iter stdout.WriteLine
I've used the pseudocode from Wikipedia in an attempt to write a KMP algorithm in Haskell.
It's giving "index out of bounds" when I try to search beyond the length of the pattern and I can't seem to find the issue; my "fixes" have only ruined the result.
import Control.Monad
import Control.Lens
import qualified Data.ByteString.Char8 as C
import qualified Data.Vector.Unboxed as V
(!) :: C.ByteString -> Int -> Char
(!) = C.index
-- Make the table for the KMP. Directly from Wikipedia. Works as expected for inputs from Wikipedia article.
mkTable :: C.ByteString -> V.Vector Int
mkTable pat = make 2 0 (ix 0 .~ (negate 1) $ V.replicate l 0)
where
l = C.length pat
make :: Int -> Int -> V.Vector Int -> V.Vector Int
make p c t
| p >= l = t
| otherwise = proc
where
proc | pat ! (p-1) == pat ! c
= make (p+1) (c+1) (ix p .~ (c+1) $ t)
| c > 0 = make p (t V.! c) t
| otherwise = make (p+1) c (ix p .~ 0 $ t)
kmp :: C.ByteString -> C.ByteString -> V.Vector Int -> Int
kmp text pat tbl = search 0 0
where
l = C.length text
search m i
| m + i >= l = l
| otherwise = cond
where
-- The conditions for the loop, given in the wiki article
cond | pat ! i == text ! (m+i)
= if i == C.length pat - 1
then m
else search m (i+1)
| tbl V.! i > (-1)
= search (m + i - (tbl V.! i)) (tbl V.! i)
| otherwise
= search 0 (m+1)
main :: IO()
main = do
t <- readLn
replicateM_ t $ do
text <- C.getLine
pat <- C.getLine
putStrLn $ kmp text pat (mkTable pat)
Simple solution: I mixed up m and i in the last condition of kmp.
| otherwise = search 0 (m+1)
Becomes
| otherwise = search (m+1) 0
And the issue is resolved.
Aside from that, it's necessary to use unboxed arrays in the ST monad or the table generation takes an absurd amount of time.
I was playing around with Project Euler #34, and I wrote these functions:
import Data.Time.Clock.POSIX
import Data.Char
digits :: (Integral a) => a -> [Int]
digits x
| x < 10 = [fromIntegral x]
| otherwise = let (q, r) = x `quotRem` 10 in (fromIntegral r) : (digits q)
digitsByShow :: (Integral a, Show a) => a -> [Int]
digitsByShow = map (\x -> ord x - ord '0') . show
I thought that for sure digits has to be the faster one, as we don't convert to a String. I could not have been more wrong. I ran the two versions via pe034:
pe034 digitFunc = sum $ filter sumFactDigit [3..2540160]
where
sumFactDigit :: Int -> Bool
sumFactDigit n = n == (sum $ map sFact $ digitFunc n)
sFact :: Int -> Int
sFact n
| n == 0 = 1
| n == 1 = 1
| n == 2 = 2
| n == 3 = 6
| n == 4 = 24
| n == 5 = 120
| n == 6 = 720
| n == 7 = 5040
| n == 8 = 40320
| n == 9 = 362880
main = do
begin <- getPOSIXTime
print $ pe034 digitsByShow -- or digits
end <- getPOSIXTime
print $ end - begin
After compiling with ghc -O, digits consistently takes .5 seconds, while digitsByShow consistently takes .3 seconds. Why is this so? Why is the function which stays within Integer arithmetic slower, whereas the function which goes into string comparison is faster?
I ask this because I come from programming in Java and similar languages, where the % 10 trick of generating digits is way faster than the "convert to String" method. I haven't been able to wrap my head around the fact that converting to a string could be faster.
This is the best I can come up with.
digitsV2 :: (Integral a) => a -> [Int]
digitsV2 n = go n []
where
go x xs
| x < 10 = fromIntegral x : xs
| otherwise = case quotRem x 10 of
(q,r) -> go q (fromIntegral r : xs)
when compiled with -O2 and tested with Criterion
digits runs in 470.4 ms
digitsByShow runs in 421.8 ms
digitsV2 runs in 258.0 ms
results may vary
edit:
I am not sure why building the list like this helps so much.
But you can improve your codes speed by strictly evaluating quotRem x 10
You can do this with BangPatterns
| otherwise = let !(q, r) = x `quotRem` 10 in (fromIntegral r) : (digits q)
or with case
| otherwise = case quotRem x 10 of
(q,r) -> fromIntegral r : digits q
Doing this drops digits down to 323.5 ms
edit: time without using Criterion
digits = 464.3 ms
digitsStrict = 328.2 ms
digitsByShow = 259.2 ms
digitV2 = 252.5 ms
note: The criterion package measures software performance.
Let's investigate why #No_signal's solution is faster.
I made three runs of ghc:
ghc -O2 -ddump-simpl digits.hs >digits.txt
ghc -O2 -ddump-simpl digitsV2.hs >digitsV2.txt
ghc -O2 -ddump-simpl show.hs >show.txt
digits.hs
digits :: (Integral a) => a -> [Int]
digits x
| x < 10 = [fromIntegral x]
| otherwise = let (q, r) = x `quotRem` 10 in (fromIntegral r) : (digits q)
main = return $ digits 1
digitsV2.hs
digitsV2 :: (Integral a) => a -> [Int]
digitsV2 n = go n []
where
go x xs
| x < 10 = fromIntegral x : xs
| otherwise = let (q, r) = x `quotRem` 10 in go q (fromIntegral r : xs)
main = return $ digits 1
show.hs
import Data.Char
digitsByShow :: (Integral a, Show a) => a -> [Int]
digitsByShow = map (\x -> ord x - ord '0') . show
main = return $ digitsByShow 1
If you'd like to view the complete txt files, I placed them on ideone (rather than paste a 10000 char dump here):
digits.txt
digitsV2.txt
show.txt
If we carefully look through digits.txt, it appears that this is the relevant section:
lvl_r1qU = __integer 10
Rec {
Main.$w$sdigits [InlPrag=[0], Occ=LoopBreaker]
:: Integer -> (# Int, [Int] #)
[GblId, Arity=1, Str=DmdType <S,U>]
Main.$w$sdigits =
\ (w_s1pI :: Integer) ->
case integer-gmp-1.0.0.0:GHC.Integer.Type.ltInteger#
w_s1pI lvl_r1qU
of wild_a17q { __DEFAULT ->
case GHC.Prim.tagToEnum# # Bool wild_a17q of _ [Occ=Dead] {
False ->
let {
ds_s16Q [Dmd=<L,U(U,U)>] :: (Integer, Integer)
[LclId, Str=DmdType]
ds_s16Q =
case integer-gmp-1.0.0.0:GHC.Integer.Type.quotRemInteger
w_s1pI lvl_r1qU
of _ [Occ=Dead] { (# ipv_a17D, ipv1_a17E #) ->
(ipv_a17D, ipv1_a17E)
} } in
(# case ds_s16Q of _ [Occ=Dead] { (q_a11V, r_X12h) ->
case integer-gmp-1.0.0.0:GHC.Integer.Type.integerToInt r_X12h
of wild3_a17c { __DEFAULT ->
GHC.Types.I# wild3_a17c
}
},
case ds_s16Q of _ [Occ=Dead] { (q_X12h, r_X129) ->
case Main.$w$sdigits q_X12h
of _ [Occ=Dead] { (# ww1_s1pO, ww2_s1pP #) ->
GHC.Types.: # Int ww1_s1pO ww2_s1pP
}
} #);
True ->
(# GHC.Num.$fNumInt_$cfromInteger w_s1pI, GHC.Types.[] # Int #)
}
}
end Rec }
digitsV2.txt:
lvl_r1xl = __integer 10
Rec {
Main.$wgo [InlPrag=[0], Occ=LoopBreaker]
:: Integer -> [Int] -> (# Int, [Int] #)
[GblId, Arity=2, Str=DmdType <S,U><L,U>]
Main.$wgo =
\ (w_s1wh :: Integer) (w1_s1wi :: [Int]) ->
case integer-gmp-1.0.0.0:GHC.Integer.Type.ltInteger#
w_s1wh lvl_r1xl
of wild_a1dp { __DEFAULT ->
case GHC.Prim.tagToEnum# # Bool wild_a1dp of _ [Occ=Dead] {
False ->
case integer-gmp-1.0.0.0:GHC.Integer.Type.quotRemInteger
w_s1wh lvl_r1xl
of _ [Occ=Dead] { (# ipv_a1dB, ipv1_a1dC #) ->
Main.$wgo
ipv_a1dB
(GHC.Types.:
# Int
(case integer-gmp-1.0.0.0:GHC.Integer.Type.integerToInt ipv1_a1dC
of wild2_a1ea { __DEFAULT ->
GHC.Types.I# wild2_a1ea
})
w1_s1wi)
};
True -> (# GHC.Num.$fNumInt_$cfromInteger w_s1wh, w1_s1wi #)
}
}
end Rec }
I actually couldn't find the relevant section for show.txt. I'll work on that later.
Right off the bat, digitsV2.hs produces shorter code. That's probably a good sign for it.
digits.hs seems to be following this psuedocode:
def digits(w_s1pI):
if w_s1pI < 10: return [fromInteger(w_s1pI)]
else:
ds_s16Q = quotRem(w_s1pI, 10)
q_X12h = ds_s16Q[0]
r_X12h = ds_s16Q[1]
wild3_a17c = integerToInt(r_X12h)
ww1_s1pO = r_X12h
ww2_s1pP = digits(q_X12h)
ww2_s1pP.pushFront(ww1_s1pO)
return ww2_s1pP
digitsV2.hs seems to be following this psuedocode:
def digitsV2(w_s1wh, w1_s1wi=[]): # actually disguised as go(), as #No_signal wrote
if w_s1wh < 10:
w1_s1wi.pushFront(fromInteger(w_s1wh))
return w1_s1wi
else:
ipv_a1dB, ipv1_a1dC = quotRem(w_s1wh, 10)
w1_s1wi.pushFront(integerToIn(ipv1a1dC))
return digitsV2(ipv1_a1dC, w1_s1wi)
It might not be that these functions mutate lists like my psuedocode suggests, but this immediately suggests something: it looks as if digitsV2 is fully tail-recursive, whereas digits is actually not (may have to use some Haskell trampoline or something). It appears as if Haskell needs to store all the remainders in digits before pushing them all to the front of the list, whereas it can just push them and forget about them in digitsV2. This is purely speculation, but it is well-founded speculation.
I'm writting a parogram in Haskell that creates a fractal and writes to a PNG file. I have a function
f:: Int->Int->PixelRGB8
which calcualtes color of the pixel with given image coordinates. (The output color format, PixelRGB8, is not important, I can easilly change it to, say, RGB tuple or anything).
Using Codec.Picture, I can write
writePng "test.png" $ generateImage f width height
which indeed writes the desired image file. However, it works very slowly and I can see that my CPU load is low. I want to use parallel computations, since the computation of each pixel value does not depend on its neighbors. As far as I can see, Codec.Picture does not provide any means to do it. I understand how parMap works, but I can't see a way to apply it here. I think one possible solution is to use repa.DevIL, but I'm kinda lost in its multidimusional arrays notation which looks like an overkill in my case. So, the question is: how to construct an image file from given function using parallel?
UPDATE. Here's a complete code (function 'extract' is ommited because it's long and called only one time):
import Data.Complex
import System.IO
import Data.List.Split
import Codec.Picture
eval:: (Floating a) => [a] -> a -> a
eval [p] _ = p
eval (p:ps) z = p * z ** (fromIntegral (length ps) ) + (eval ps z)
type Comp = Complex Double
-- func, der, z, iter
convergesOrNot:: (Comp -> Comp) -> (Comp -> Comp) -> Comp->Int -> Int
convergesOrNot _ _ _ 0 = 0
convergesOrNot f d z iter | realPart (abs (f z) ) < 1e-6 = 1
| otherwise = convergesOrNot f d (z - (f z)/(d z)) (iter-1)
-- x, y, f,d, xMin, xMin, stepX, stepY
getPixel:: Int->Int->(Comp->Comp)->(Comp->Comp)->Double->Double->Double->Double->PixelRGB8
getPixel x y f d xMin yMin stepX stepY | convergesOrNot f d z 16 == 1 = PixelRGB8 255 255 255
| otherwise = PixelRGB8 0 0 0
where
real = xMin + (fromIntegral x)*stepX
imag = yMin + (fromIntegral y)*stepY
z = real :+ imag;
data Params = Params{f :: [Comp],
d :: [Comp],
xMin::Double,
yMin::Double,
stepX::Double,
stepY::Double,
width::Int,
height::Int
} deriving (Show)
getPixelParams:: Int->Int->Params->PixelRGB8
getPixelParams x y params = getPixel x y func derv (xMin params) (yMin params) (stepX params) (stepY params)
where
func = \z -> eval (f params) z
derv = \z -> eval (d params) z
main = do
handle <- openFile "config.txt" ReadMode
config <- hGetContents handle
let params = extract config
writePng "test.png" $ generateImage (\x y -> getPixelParams x y params) (width params) (height params)
hClose handle
The profiling shows that most of the time is spent in eval function. Result (the .prof file ) is as follows (it's only the top part of file, the rest is bunch of zeroes):
COST CENTRE MODULE no. entries %time %alloc %time %alloc
MAIN MAIN 91 0 0.0 0.0 100.0 100.0
main Main 183 0 0.0 0.0 99.9 100.0
main.\ Main 244 0 0.0 0.0 0.0 0.0
getPixelParams Main 245 0 0.0 0.0 0.0 0.0
getPixelParams.derv Main 269 1 0.0 0.0 0.0 0.0
getPixelParams.func Main 246 1 0.0 0.0 0.0 0.0
generateImage Codec.Picture.Types 199 1 0.0 0.0 99.8 99.9
generateImage.generated Codec.Picture.Types 234 1 0.0 0.0 99.8 99.9
generateImage.generated.lineGenerator Codec.Picture.Types 238 257 0.0 0.0 99.8 99.9
generateImage.generated.lineGenerator.column Codec.Picture.Types 239 65792 0.5 0.8 99.8 99.9
unsafeWritePixel Codec.Picture.Types 275 65536 0.0 0.0 0.0 0.0
main.\ Main 240 65536 0.1 0.0 99.2 99.1
getPixelParams Main 241 65536 0.7 0.0 99.1 99.1
getPixelParams.derv Main 270 0 0.2 0.0 19.3 18.5
getPixelParams.derv.\ Main 271 463922 0.2 0.0 19.2 18.5
eval Main 272 1391766 18.9 18.5 18.9 18.5
getPixelParams.func Main 247 0 0.5 0.0 62.3 59.0
getPixelParams.func.\ Main 248 993380 0.4 0.0 61.8 59.0
eval Main 249 3973520 61.4 59.0 61.4 59.0
getPixel Main 242 65536 0.2 0.0 16.7 21.5
getPixel.imag Main 262 256 0.0 0.0 0.0 0.0
getPixel.z Main 261 65536 0.1 0.1 0.1 0.1
getPixel.real Main 251 65536 0.2 0.1 0.2 0.1
convergesOrNot Main 243 531889 16.3 21.3 16.3 21.3
UPDATE 2 After a number of changes from #Cirdec and #Jedai, the code looks like this:
import Data.Complex
import System.IO
import Data.List.Split
import qualified Data.List as DL
import Codec.Picture
import Codec.Picture.Types
import Control.Parallel
import Data.Array
import Control.Parallel.Strategies
import GHC.Conc (numCapabilities)
class Ix a => Partitionable a where
partition :: Int -> (a, a) -> [(a, a)]
default partition :: (Num a) => Int -> (a, a) -> [(a, a)]
partition n r#(l,_) = zipWith (\x y -> (x, x+y-1)) starts steps
where
(span, longerSpans) = rangeSize r `quotRem` n
steps = zipWith (+) (replicate (min (rangeSize r) n) (fromIntegral span)) (replicate longerSpans 1 ++ repeat 0)
starts = scanl (+) l steps
instance Partitionable Int
instance (Partitionable a, Partitionable b) => Partitionable (a, b) where
partition n ((x0,y0), (x1, y1)) = do
xr'#(x0', x1') <- partition n (x0, x1)
let n' = n * rangeSize xr' `div` rangeSize (x0, x1)
(y0', y1') <- partition n' (y0, y1)
return ((x0', y0'), (x1', y1'))
mkArrayPar :: (Partitionable i) => Int -> Strategy e -> (i, i) -> (i -> e) -> Array i e
mkArrayPar n s bounds f = listArray bounds (concat workUnits)
where
partitions = partition n bounds
workUnits = parMap (evalList s) (map f . range) partitions
generateImagePar :: forall a . Pixel a => (Int -> Int -> a) -> Int -> Int -> Image a
generateImagePar f w h = generateImage f' w h
where
bounds = ((0, 0), (w-1,h-1))
pixels = mkArrayPar numCapabilities rseq bounds (uncurry f)
f' = curry (pixels !)
--
-- Newton
--
eval:: (Floating a) => [a] -> a -> a
eval cs z = DL.foldl1' (\acc c -> acc * z + c) cs
diff:: (Floating a) => [a] -> [a]
diff [p] = []
diff (p:ps) = [(fromIntegral (length ps) )*p] ++ diff ps
type Comp = Complex Double
convergesOrNot:: (Comp -> Comp) -> (Comp -> Comp) -> Comp->Int -> Int
convergesOrNot _ _ _ 0 = 0
convergesOrNot f d z iter | realPart (abs (f z) ) < 1e-6 = 1
| otherwise = convergesOrNot f d (z - (f z)/(d z)) (iter-1)
-- x, y, f,d, xMin, xMin, stepX, stepY
getPixel:: Int->Int->(Comp->Comp)->(Comp->Comp)->Double->Double->Double->Double->PixelRGB8
getPixel x y f d xMin yMin stepX stepY | convergesOrNot f d z 16 == 1 = PixelRGB8 255 255 255
| otherwise = PixelRGB8 0 0 0
where
real = xMin + (fromIntegral x)*stepX
imag = yMin + (fromIntegral y)*stepY
z = real :+ imag;
data Params = Params{f :: [Comp],
d :: [Comp],
xMin::Double,
yMin::Double,
stepX::Double,
stepY::Double,
width::Int,
height::Int
} deriving (Show)
extract:: String -> Params
extract config = Params poly deriv xMin yMin stepX stepY width height
where
lines = splitOn "\n" config
wh = splitOn " " (lines !! 0)
width = read (wh !! 0) :: Int
height = read (wh !! 1) :: Int
bottomLeft = splitOn " " (lines !! 1)
upperRight = splitOn " " (lines !! 2)
xMin = read $ (bottomLeft !! 0) :: Double
yMin = read $ (bottomLeft !! 1) :: Double
xMax = read $ (upperRight !! 0) :: Double
yMax = read $ (upperRight !! 1) :: Double
stepX = (xMax - xMin)/(fromIntegral width)
stepY = (yMax - yMin)/(fromIntegral height)
poly = map (\x -> (read x :: Double) :+ 0) (splitOn " " (lines !! 3))
deriv = diff poly
getPixelParams:: Int->Int->Params->PixelRGB8
getPixelParams x y params = getPixel x y func derv (xMin params) (yMin params) (stepX params) (stepY params)
where
func = \z -> eval (f params) z
derv = \z -> eval (d params) z
main = do
handle <- openFile "config.txt" ReadMode
config <- hGetContents handle
let params = extract config
writePng "test.png" $ generateImagePar (\x y -> getPixelParams x y params) (width params) (height params)
hClose handle
I compile it with
ghc O2 -threaded -rtsopts -XDefaultSignatures -XExistentialQuantification partNewton.hs -o newton
and I run it with ./newton +RTS -N. But when I run it on config
2048 2048
-1 -1
1 1
1 0 0 1
it results in error
Stack space overflow: current size 8388608 bytes.
You can calculate the pixels in parallel before generating the image. To make the pixel lookup for generateImage simple, we'll stuff all of the pixels into an Array.
{-# LANGUAGE RankNTypes #-}
import Data.Array
import Control.Parallel.Strategies
To generate the image in parallel, we'll calculate the pixels in parallel for each boint within the range of the bounds of the image. We'll build a temporary Array to hold all the pixels. The array's lookup function, ! will provide an efficient lookup function to pass to generateImage.
generateImagePar :: forall a . Pixel a => (Int -> Int -> a) -> Int -> Int -> Image a
generateImagePar f w h = generateImage f' w h
where
bounds = ((0, 0), (w-1,h-1))
pixels = parMap rseq (uncurry f) (range bounds)
pixelArray = listArray bounds pixels
f' = curry (pixelArray !)
We can then write your example in terms of generateImagePar.
writePng "test.png" $ generateImagePar f width height
This may be no faster and may in fact be slower than using generateImage. It's important to profile your code to understand why it is slow before attempting to improve its performance. For example, if your program is memory starved or is thrashing resources, using generateImagePar will certainly be slower than using generateImage.
Partitioning the work
We can partition the work into chunks to reduce the number of sparks without resorting to any sort of mutable data structure. First we'll define the class of indexes whose ranges can be divided into partitions. We'll define a default for dividing up numeric ranges.
class Ix a => Partitionable a where
partition :: Int -> (a, a) -> [(a, a)]
default partition :: (Num a) => Int -> (a, a) -> [(a, a)]
partition n r#(l,_) = zipWith (\x y -> (x, x+y-1)) starts steps
where
(span, longerSpans) = rangeSize r `quotRem` n
steps = zipWith (+) (replicate (min (rangeSize r) n) (fromIntegral span)) (replicate longerSpans 1 ++ repeat 0)
starts = scanl (+) l steps
Ints (and any other Num) can be made Partitionable using the default implementation.
instance Partitionable Int
Index products can be partitioned by first partitioning the first dimension, and then partitioning the second dimension if there aren't enough possible divisions in the first dimension.
instance (Partitionable a, Partitionable b) => Partitionable (a, b) where
partition n ((x0,y0), (x1, y1)) = do
xr'#(x0', x1') <- partition n (x0, x1)
let n' = n * rangeSize xr' `div` rangeSize (x0, x1)
(y0', y1') <- partition n' (y0, y1)
return ((x0', y0'), (x1', y1'))
We can build an array in parallel by partitioning the work into units and sparking each work unit.
mkArrayPar :: (Partitionable i) => Int -> Strategy e -> (i, i) -> (i -> e) -> Array i e
mkArrayPar n s bounds f = listArray bounds (concat workUnits)
where
partitions = partition n bounds
workUnits = parMap (evalList s) (map f . range) partitions
Now we can define generateImagePar in terms of making an array in parallel. A good number of partitions is a small multiple of the number of actual processors, numCapabilities; we'll start up to 1 partition per processor.
import GHC.Conc (numCapabilities)
generateImagePar :: forall a . Pixel a => (Int -> Int -> a) -> Int -> Int -> Image a
generateImagePar f w h = generateImage f' w h
where
bounds = ((0, 0), (w-1,h-1))
pixels = mkArrayPar numCapabilities rseq bounds (uncurry f)
f' = curry (pixels !)
Profiling of some code showed that about 65% of the time I was inside the following code.
What it does is use the Data.Binary.Get monad to walk through a bytestring looking for the terminator. If it detects 0xff, it checks if the next byte is 0x00. If it is, it drops the 0x00 and continues. If it is not 0x00, then it drops both bytes and the resulting list of bytes is converted to a bytestring and returned.
Any obvious ways to optimize this? I can't see it.
parseECS = f [] False
where
f acc ff = do
b <- getWord8
if ff
then if b == 0x00
then f (0xff:acc) False
else return $ L.pack (reverse acc)
else if b == 0xff
then f acc True
else f (b:acc) False
Bug fix
It seems there may be a bug here. An exception gets raised if you reach the end of the byte stream before an 0xff, not 0x00 sequence is found. Here's a modified version of your function:
parseECS :: Get L.ByteString
parseECS = f [] False
where
f acc ff = do
noMore <- isEmpty
if noMore
then return $ L.pack (reverse acc)
else do
b <- getWord8
if ff
then
if b == 0x00
then f (0xff:acc) False
else return $ L.pack (reverse acc)
else
if b == 0xff
then f acc True
else f (b:acc) False
Optimization
I haven't done any profiling, but this function will probably be faster. Reversing long lists is expensive. I'm not sure how lazy getRemainingLazyByteString is. If it's too strict this probably won't work for you.
parseECS2 :: Get L.ByteString
parseECS2 = do
wx <- liftM L.unpack $ getRemainingLazyByteString
return . L.pack . go $ wx
where
go [] = []
go (0xff:0x00:wx) = 0xff : go wx
go (0xff:_) = []
go (w:wx) = w : go wx
If problem is in "reverse" you can use "lookAhead" to scan position and then go back and rebuild your new string
parseECS2 :: Get L.ByteString
parseECS2 = do
let nextWord8 = do
noMore <- isEmpty
if noMore then return Nothing
else liftM Just getWord8
let scanChunk !n = do
b <- nextWord8
case b of
Just 0xff -> return (Right (n+1))
Just _ -> scanChunk (n+1)
Nothing -> return (Left n)
let readChunks = do
c <- lookAhead (scanChunk 0)
case c of
Left n -> getLazyByteString n >>= \blk -> return [blk]
Right n -> do
blk <- getLazyByteString n
b <- lookAhead nextWord8
case b of
Just 0x00 -> skip 1 >> liftM (blk:) readChunks
_ -> return [L.init blk]
liftM (foldr L.append L.empty) readChunks