Programming Contest - Snuke Festival

Question

Problem Statement

The season for Snuke Festival has come again this year. First of all, Ringo will perform a ritual to summon Snuke. For the ritual, he needs an altar, which consists of three parts, one in each of the three categories: upper, middle and lower.

He has \$N\$ parts for each of the three categories. The size of the \$i\$-th upper part is \$A_i\$, the size of the \$i\$-th middle part is \$B_i\$, and the size of the \$i\$-th lower part is \$C_i\$.

To build an altar, the size of the middle part must be strictly greater than that of the upper part, and the size of the lower part must be strictly greater than that of the middle part. On the other hand, any three parts that satisfy these conditions can be combined to form an altar.

How many different altars can Ringo build? Here, two altars are considered different when at least one of the three parts used is different.

Constraints

• \$1 ≤ N ≤ 10^5\$
• \$1 ≤ A_i ≤ 10^9 (1 ≤ i ≤ N)\$
• \$1 ≤ B_i ≤ 10^9 (1 ≤ i ≤ N)\$
• \$1 ≤ C_i ≤ 10^9 (1 ≤ i ≤ N)\$

All input values are integers.

Time limit: 2 sec / Memory limit: 256 MB

Input

Input is given from Standard Input in the following format:

N
A1 … AN
B1 … BN
C1 … CN

Output

Print the number of different altars that Ringo can build.

Sample Input1

2
1 5
2 4
3 6

Sample Output1

3

Sample Input2

3
1 1 1
2 2 2
3 3 3

Sample Output2

27

Sample Input3

6
3 14 159 2 6 53
58 9 79 323 84 6
2643 383 2 79 50 288

Sample Output3

87

My solution - classified as Time Limit Exceeded:

import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Maybe as Maybe
import qualified Text.Printf as Printf
import qualified Control.Monad as Monad
import qualified Data.Array as Array

bisectLeft :: (Ord a) => a -> (Array.Array Int a) -> Int
bisectLeft n xs = bisectLeft' 0 (length xs) n xs

bisectLeft' :: (Ord a) => Int -> Int -> a -> (Array.Array Int a) -> Int
bisectLeft' lo hi n xs = if lo >= hi then lo else
                    if n <= (xs Array.! mid) then bisectLeft' lo mid n xs
                      else bisectLeft' (mid + 1) hi n xs
                    where mid = (lo + hi) `div` 2

bisectRight :: (Ord a) => a -> (Array.Array Int a) -> Int
bisectRight n xs = bisectRight' 0 (length xs) n xs

bisectRight' :: (Ord a) => Int -> Int -> a -> (Array.Array Int a) -> Int
bisectRight' lo hi n xs = if lo >= hi then hi else
                    if n < (xs Array.! mid) then bisectRight' lo mid n xs
                      else bisectRight' (mid + 1) hi n xs
                    where mid = (lo + hi) `div` 2

main :: IO ()
main = do
  n <- (read :: String -> Int) <$> getLine
  as <- (Array.listArray (0,n-1)) . List.sort . map (read :: String -> Int) . words <$> getLine
  bs <- map (read :: String -> Int) . words <$> getLine
  cs <- (Array.listArray (0,n-1)) . List.sort . map (read :: String -> Int) . words <$> getLine
  print $ foldl (+) 0 $ map (\ b -> (bisectLeft b as) * (n - bisectRight b cs)) bs

I think it takes too much time to make the array, but I cannot think of any way to make it more efficient...
How can I this code more efficiently?

Question Link

Answer 1

It's a good idea to profile your code (which is easy if you use stack – instead of stack build, just type stack build --profile, and run your program with the options +RTS -p) to find out exactly where the bottle-necks are. See the GHC profiling guide for more information.

If you do that, you'll find that a significant amount of your program's time is spent splitting up strings into words, and parsing them into Ints. Remember that a Haskell string is a linked list of characters, and thus not particularly efficient – I found that using the Text type from the text package results in the revised program taking only 40% of the time of your version. (Contrary to the other comment here, the binary search you've implemented seems fairly efficient, that's not where the slow-down is.)

Instead of getLine from the standard Prelude, use the version of getLine from Data.Text; instead of parsing a line of text using read . word, I'd suggest something like the following:

import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Read as T
import Data.Text (Text)

-- ...

forceEither :: Either a b -> b
forceEither (Right r) = r 

parseLine :: Text -> [Int]
parseLine txt =
  map (fst . forceEither . T.decimal) $ T.splitOn (T.pack " ") txt

(Possibly a hand-coded loop might be even faster than T.splitOn, but I didn't check that.)

I'd also suggest splitting out the parsing of input from the actual solving of the problem - no advantage is gained by putting everything into main. I'd further suggest that writing sum makes your intent clearer than foldl (+) 0; and that you use Vectors instead of Arrays, since this will (a) get rid of extra bits of cruft in the code and (b) allow you to use the vector-algorithms package, which already contains a binary search function. It's usually far better to use someone else's de-bugged search routine than write your own. However, if you are submitting for an online competition, that package may not be available. Nevertheless, it provides useful inspiration on how the search may be sped up.

This gives code along the following lines:

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}

import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Read as T
import Data.Text (Text)
import qualified Data.List as L

import qualified Data.Vector.Unboxed as V
import Data.Vector.Unboxed (Vector)
import qualified Data.Vector.Unboxed.Mutable as VMut

import Control.Monad  ( replicateM )

import System.IO.Unsafe
import Data.Bits (shiftR)

-- adapted from "vector-algorithms" package:

{-# INLINE binarySearchPBounds #-}
binarySearchPBounds p vec = loop
 where
 loop !l !u
   | u <= l    = return l
   | otherwise = VMut.unsafeRead vec k >>= \e -> if p e then loop l k else loop (k+1) u
  where k = (u + l) `shiftR` 1

{-# INLINE binarySearchL #-}
binarySearchL vec e = binarySearchPBounds (>= e) vec 0 (VMut.length vec)

{-# INLINE binarySearchR #-}
binarySearchR vec e = binarySearchPBounds (> e) vec 0 (VMut.length vec)



forceEither :: Either a b -> b
forceEither (Right r) = r 

parseLine :: Text -> [Int]
parseLine txt =
  map (fst . forceEither . T.decimal) $ T.splitOn (T.pack " ") txt

bisectLeft :: Int -> Vector Int -> Int
bisectLeft n xs = unsafePerformIO $ do 
  xs' <- V.unsafeThaw xs
  binarySearchL xs' n

bisectRight :: Int -> Vector Int -> Int
bisectRight n xs = unsafePerformIO $ do 
  xs' <- V.unsafeThaw xs
  binarySearchR xs' n

getInput :: IO [Text]  
getInput = do
  res@[n, as, bs, cs] <- replicateM 4 T.getLine
  return res

sortedVec :: t -> Text -> Vector Int
sortedVec n txt = 
  V.fromList $ L.sort $ parseLine txt


parseProblemInput
  :: [Text] -> (Int, Vector Int, [Int], Vector Int)
parseProblemInput [nStr, asStr, bsStr, csStr] = 
  let [n] = parseLine nStr
      as =  sortedVec n asStr
      bs =  parseLine  bsStr
      cs = sortedVec n csStr
  in (n, as, bs, cs)

solve :: (Int, Vector Int, [Int], Vector Int) -> Int
solve (n, as, bs, cs) = 
  sum $ map (\ b -> bisectLeft b as * (n - bisectRight b cs)) bs


main = do
  ls <- getInput 
  print $ solve $ parseProblemInput ls

This may not be as concise as your code, but should be much easier to follow and to modify - and importantly, for your purposes, it runs in less than half the time.

Other notes - the Unboxed versions of Vectors will normally be faster than the boxed versions, if you can use them; if you're submitting code for review, then I'd think a few more comments in your code wouldn't go astray. I hope that helps.