Haskell slow performance compared to Perl

Question

I am making a Hackercup 2015 Facebook issue with Haskell and am stuck on this issue .

Input: starts with an integer T, the number of questions. For each question, there is one line containing 3 integers, separated by spaces: A, B and K.

Output: for the i-th question, print a line containing "Case #i:", followed by the number of integers in the inclusive range [A, B] with K.

The privilege of the number X is the number of its simple factors. For example, Primarity 12 is 2 (since it is divisible by primes 2 and 3), seizure 550 is 3 (since it is divisible by primes 2, 5 and 11), and Primariness 7 is 1 (as soon as a prime divisible by 7).

1 ≤ T ≤ 100 2 ≤ A ≤ B ≤ 10 ^ 7 1 ≤ K ≤ 10 ^ 9

Here is my Haskell solution:

import System.IO
import Data.List
import Control.Monad

incEvery :: Int -> [(Int -> Int)]
incEvery n = (cycle ((replicate (n-1) id) ++ [(+ 1)]))

primes2 :: [Int]
primes2 = sieve 2 (replicate (10^7) 0)
  where
    sieve _ [] = []
    sieve n (a:xs) = (a + (if a == 0 then 1 else 0))
      : if a == 0 then
          sieve (n+1) (zipWith ($) (incEvery n) xs)
        else
          sieve (n+1) xs

process :: (Int, Int, Int) -> Int
process (lo, hi, k) =
  length . filter (\(a, b) -> a >= lo && a <= hi && b == k) . zip [2,3..] $ primes2

readIn :: [String] -> (Int, Int, Int)
readIn =
  (\[x, y, z] -> (x, y, z)) . fmap (read::String->Int) . take 3

lib :: String -> String
lib xs = unlines . fmap (\(i, x) -> "Case #" ++ (show i) ++ ": " ++ x) . zip [1,2..]
  . fmap parse . tail . lines $ xs
  where
    parse = (show . process . readIn . words)

main :: IO ()
main = interact lib

Here is my solution for Perl:

use strict;
use warnings;

my $max = 10000010;

my @f = (0) x $max;

for my $i (2 .. $max) {
    if($f[$i] == 0) {
        $f[$i] = 1;
        # print $i . "\n";
        for my $j (2 .. ($max / $i)) {
            $f[$i * $j] ++;
        }
    }
}

my $k =  <STDIN>;
for my $i (1 .. $k) {
    my $line = <STDIN>;
    if($line) {
        chomp $line;
        my ($a, $b, $t) = split(' ', $line);
        my $ans = 0;
        for my $j ($a .. $b) {
            if($f[$j] == $t) {
                $ans ++;
            }
        }
        print "Case #$i: " . $ans . "\n";
    }    
}

Although I use the same sifting algorithm for both languages, the Haskell version is significantly slower than the Perl version on a 10 ^ 7 scale. Basically, the following Haskell function is slower than its Perl copy:

incEvery :: Int -> [(Int -> Int)]
incEvery n = (cycle ((replicate (n-1) id) ++ [(+ 1)]))

primes2 :: [Int]
primes2 = sieve 2 (replicate (10^7) 0)
  where
   sieve _ [] = []
   sieve n (a:xs) = (a + (if a == 0 then 1 else 0))
   : if a == 0 then
      sieve (n+1) (zipWith ($) (incEvery n) xs)
     else
      sieve (n+1) xs

I think that both recursion and (zipWith ($) (incEvery n) xs)cause a problem. Any ideas?

Answer 1

There is absolutely no reason why you need to resort to imperative programming to improve performance. The unique thing about Haskell is that you need to learn to think differently if you want to program purely functionally. Use laziness to speed things up a bit:

{-# LANGUAGE ScopedTypeVariables #-}

import Control.Applicative ( pure, (<$>) )
import Data.List           ( nub )
import Data.Monoid         ( (<>) )

isPrime :: (Integral i) => i -> Bool
isPrime n = isPrime_ n primes
  where isPrime_ n (p:ps)
          | p * p > n      = True
          | n `mod` p == 0 = False
          | otherwise      = isPrime_ n ps

primes :: (Integral i) => [i]
primes = 2 : filter isPrime [3,5..]

primeFactors :: (Integral i) => i -> [i]
primeFactors n = factors n primes
  where factors n (x:xs)
          | x * x > n      = [n]
          | n `mod` x == 0 = x : factors (n `div` x) (x:xs)
          | otherwise      = factors n xs

primacity :: (Integral i) => i -> Int
primacity = length . nub . primeFactors

user :: IO Int
user = do
  xs <- getLine
  let a :: Int = read . takeWhile (/=' ') . dropN 0 $ xs
  let b :: Int = read . takeWhile (/=' ') . dropN 1 $ xs
  let k :: Int = read . takeWhile (/=' ') . dropN 2 $ xs
  let n = length . filter (== k) . fmap primacity $ [a..b]
  pure n
    where
      dropN 0 = id
      dropN n = dropN (pred n) . drop 1 . dropWhile (/= ' ')

printNTimes :: Int -> Int -> IO ()
printNTimes 0 _ = pure ()
printNTimes n total = do
  ans <- user
  putStr $ "Case #" <> show (total - n + 1) <> ": "
  putStrLn $ show ans
  printNTimes (pred n) total

main :: IO ()
main = do
  n :: Int <- read <$> getLine
  printNTimes n n

, . , , , .

Answer 2

, . . Haskell zipWith ($) (incEvery n) xs , Perl for my $j (2 .. ($max / $i)) { $f[$i * $j] ++; } , , $i . , : , Haskell STUArray.