Haskell solution for InterviewStreet String Similarity challenge - string

Question

This is my best attempt to solve the String Similarity challenge for InterviewStreet.
import Control.Monad
import Data.Text as T
import qualified Data.Text.IO as TIO
sumSimilarities s = (T.length s) + (sum $ Prelude.map (similarity s) (Prelude.tail $ tails s))
similarity :: Text -> Text -> Int
similarity a b = case commonPrefixes a b of
Just (x,_,_) -> T.length x
Nothing -> 0
main = do
cases <- fmap read getLine
inputs <- replicateM cases TIO.getLine
forM_ inputs $ print . sumSimilarities
It only passes 7/10 of the test cases. Test cases 7, 8, and 9 fail because they exceed the allotted execution time.
I'm half trying to verify that this is indeed possible to solve in Haskell and half looking for what an optimized Haskell program looks like.
Thanks!
Tyler

Answer 1

Like user5402, I'd be curious whether an equivalent (for certain values of equivalent) C programme would finish within the time limit or also time out. If it would, it would be interesting to see whether an equivalent programme using ByteStrings could finish in time. - Not that ByteStrings are per se faster than Text, but since the input must be converted to the internal representation of Text while ByteString takes it as is, that might make a difference. Another possible reason that ByteStrings might be faster - if the testing machines have 32-bit GHCs - would be that text's fusion at least used to need more registers than generally available on 32 bit architectures to get full profit [a long time ago, in the days of text-0.5 to text-0.7, on my 32-bit box, bytestring used to be quite a bit faster, no idea whether that still holds for newer text versions].
Okay, since user5402 has verified that the naïve algorithm is fast enough in C, I've gone ahead and wrote an implementation of the naïve algorithm using ByteStrings
{-# LANGUAGE BangPatterns #-}
module Main (main) where
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Unsafe as U
import Control.Monad
import Data.Word
main :: IO ()
main = do
cl <- C.getLine
case C.readInt cl of
Just (cases,_) -> replicateM_ cases (C.getLine >>= print . similarity)
Nothing -> return ()
-- Just to keep the condition readable.
(?) :: B.ByteString -> Int -> Word8
(?) = U.unsafeIndex
similarity :: B.ByteString -> Int
similarity bs
| len == 0 = 0
| otherwise = go len 1
where
!len = B.length bs
go !acc i
| i < len = go (acc + prf 0 i) (i+1)
| otherwise = acc
prf !k j
| j < len && bs ? k == bs ? j = prf (k+1) (j+1)
| otherwise = k
and compared it to the OP's Text version on some bad cases. On my box, that is more than four times faster than the Text version, so it'd be interesting whether that's fast enough (the C version is another 4.5 times faster, so it may well not be).
However, I consider it more likely that the time limit is exceeded due to using the naïve algorithm that has quadratic worst-case behaviour. Probably there are test cases that evoke the worst-case for the naïve algorithm.
So the solution would be to use an algorithm that scales better, optimally linear. One linear algorithm to compute the similarity of a string is the Z-algorithm.
The idea is simple (but, like most good ideas, not easy to have). Let us call a (non-empty) substring that is also a prefix of the string a prefix-substring. To avoid recomputation, the algorithm uses a window of the prefix-substring starting before the currently considered index that extends farthest to the right (initially, the window is empty).
Variables used and invariants of the algorithm:
i, the index under consideration, starts at 1 (for 0-based indexing; the entire string is not considered) and is incremented to length - 1
left and right, the first and last index of the prefix-substring window; invariants:
left < i, left <= right < length(S), either left > 0 or right < 1,
if left > 0, then S[left .. right] is the maximal common prefix of S and S[left .. ],
if 1 <= j < i and S[j .. k] is a prefix of S, then k <= right
An array Z, invariant: for 1 <= k < i, Z[k] contains the length of the longest common prefix of S[k .. ] and S.
The algorithm:
Set i = 1, left = right = 0 (any values with left <= right < 1 are allowed), and set Z[j] = 0 for all indices 1 <= j < length(S).
If i == length(S), stop.
If i > right, find the length l of the longest common prefix of S and S[i .. ], store it in Z[i]. If l > 0 we have found a window extending farther right than the previous, then set left = i and right = i+l-1, otherwise leave them unchanged. Increment i and go to 2.
Here left < i <= right, so the substring S[i .. right] is known - since S[left .. right] is a prefix of S, it is equal to S[i-left .. right-left].
Now consider the longest common prefix of S with the substring starting at index i - left.
Its length is Z[i-left], hence S[k] = S[i-left + k] for 0 <= k < Z[i-left] and
S[Z[i-left]] ≠ S[i-left+Z[i-left]]. Now, if Z[i-left] <= right-i, then i + Z[i-left] is inside the known window, therefore
S[i + Z[i-left]] = S[i-left + Z[i-left]] ≠ S[Z[i-left]]
S[i + k] = S[i-left + k] = S[k] for 0 <= k < Z[i-left]
and we see that the length of the longest common prefix of S and S[i .. ] has length Z[i-left].
Then set Z[i] = Z[i-left], increment i, and go to 2.
Otherwise, S[i .. right] is a prefix of S and we check how far it extends, starting the comparison of characters at the indices right+1 and right+1 - i. Let the length be l. Set Z[i] = l, left = i, right = i + l - 1, increment i, and go to 2.
Since the window never moves left, and the comparisons always start after the end of the window, each character in the string is compared at most once successfully to an earlier character in the string, and for each starting index, there is at most one unsuccessful comparison, therefore the algorithm is linear.
The code (using ByteString out of habit, ought to be trivially portable to Text):
{-# LANGUAGE BangPatterns #-}
module Main (main) where
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Unsafe as U
import Data.Array.ST
import Data.Array.Base
import Control.Monad.ST
import Control.Monad
import Data.Word
main :: IO ()
main = do
cl <- C.getLine
case C.readInt cl of
Just (cases,_) -> replicateM_ cases (C.getLine >>= print . similarity)
Nothing -> return ()
-- Just to keep the condition readable.
(?) :: B.ByteString -> Int -> Word8
(?) = U.unsafeIndex
-- Calculate the similarity of a string using the Z-algorithm
similarity :: B.ByteString -> Int
similarity bs
| len == 0 = 0
| otherwise = runST getSim
where
!len = B.length bs
getSim = do
za <- newArray (0,len-1) 0 :: ST s (STUArray s Int Int)
-- The common prefix of the string with itself is entire string.
unsafeWrite za 0 len
let -- Find the length of the common prefix.
go !k j
| j < len && (bs ? j == bs ? k) = go (k+1) (j+1)
| otherwise = return k
-- The window with indices in [left .. right] is the prefix-substring
-- starting before i that extends farthest.
loop !left !right i
| i >= len = count 0 0 -- when done, sum
| i > right = do
-- We're outside the window, simply
-- find the length of the common prefix
-- and store it in the Z-array.
w <- go 0 i
unsafeWrite za i w
if w > 0
-- We got a non-empty common prefix and a new window.
then loop i (i+w-1) (i+1)
-- No new window, same procedure at next index.
else loop left right (i+1)
| otherwise = do
-- We're inside the window, so the substring starting at
-- (i - left) has a common prefix with the substring
-- starting at i of length at least (right - i + 1)
-- (since the [left .. right] window is a prefix of bs).
-- But we already know how long the common prefix
-- starting at (i - left) is.
z <- unsafeRead za (i-left)
let !s = right-i+1 -- length of known prefix starting at i
if z < s
-- If the common prefix of the substring starting at
-- (i - left) is shorter than the rest of the window,
-- the common prefix of the substring starting at i
-- is the same. Store it and move on with the same window.
then do
unsafeWrite za i z
loop left right (i+1)
else do
-- Otherwise, find out how far the common prefix
-- extends, starting at (right + 1) == s + i.
w <- go s (s+i)
unsafeWrite za i w
loop i (i+w-1) (i+1)
count !acc i
| i == len = return acc
| otherwise = do
n <- unsafeRead za i
count (acc+n) (i+1)
loop 0 0 1