hamming.hs

gistfile1.txt

{-# LANGUAGE BangPatterns #-}
module Main where

import qualified Data.Text as Text
import Data.Text (Text, pack)
import Criterion.Main
import Test.QuickCheck.Arbitrary
import Test.QuickCheck
import Data.List

highLevel :: Text.Text -> Text.Text -> Int
highLevel a !b =
	foldl'
    (\distance (cha, chb) ->
        if cha /= chb then
            distance + 1
        else
            distance
    ) 0 (Text.zip a b)

highLevel2 :: String -> String -> Int
highLevel2 a b =
	foldl'
    (\distance (cha, chb) ->
        if cha /= chb then
            distance + 1
        else
            distance
    ) 0 (zip a b)



naiveRec :: Text.Text -> Text.Text -> Int
naiveRec a !b =
    if Text.null a then
        0
    else if Text.head a /= Text.head b then
        naiveRec (Text.tail a) (Text.tail b) + 1
    else
        naiveRec (Text.tail a) (Text.tail b)

rec2 :: Text.Text -> Text.Text -> Int
rec2 a b =
  let
    go !a !b !distance =
      if Text.null a then
              distance
          else if Text.head a /= Text.head b then
              go (Text.tail a) (Text.tail b) (distance + 1)
          else
              go (Text.tail a) (Text.tail b) distance
  in
      go a b 0

data TextPairs = TextPairs !Int !Text !Text deriving Show

data StringPairs = StringPairs !Int !String !String deriving Show

instance Arbitrary TextPairs where
    arbitrary = sized $ \size -> do
        ta <- vectorOf size (elements ['a'..'f'])
        tb <- shuffle ta
        pure (TextPairs size (pack ta) (pack tb))

instance Arbitrary StringPairs where
    arbitrary = sized $ \size -> do
        ta <- vectorOf size (elements ['a'..'f'])
        tb <- shuffle ta
        pure (StringPairs size ta tb)

implementations = [("naive", naiveRec), ("tail", rec2), ("highLevel", highLevel)]

main = do
    texts <- mapM (generate . flip resize arbitrary) [5, 10, 20, 40, 80, 160, 10000]
    strings <- mapM (generate . flip resize arbitrary) [5, 10, 20, 40, 80, 160, 10000]

    defaultMain $
        [ bgroup name
            [ bench (show size) (whnf (fn ta) tb)
            | TextPairs size ta tb <- texts
            ]
        | (name, fn) <- implementations
        ] ++
        [ bgroup "string"
            [ bench (show size) (whnf (highLevel2 ta) tb)
            | StringPairs size ta tb <- strings] ]