hamming.hs

{-# 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
import qualified Data.Vector.Unboxed as U

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

vect :: U.Vector Char -> U.Vector Char -> Int
vect a b =
    U.foldl'
    (\distance (cha, chb) ->
        if cha /= chb then
            distance + 1
        else
            distance
    ) 0 (U.zip a b)

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

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

data VectorPairs = VectorPairs !Int !(U.Vector Char) !(U.Vector Char) 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)

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

implementations :: [([Char], Text -> Text -> Int)]
implementations = [("naive", naiveRec), ("tail", rec2), ("highLevel", highLevel)]

main :: IO ()
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]
    vects   <- 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] ]
        ++
        [ bgroup "vector"
            [ bench (show size) (whnf (vect ta) tb)
            | VectorPairs size ta tb <- vects] ]

{-
benchmarking naive/5
time                 54.21 ns   (54.10 ns .. 54.32 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 54.14 ns   (54.05 ns .. 54.24 ns)
std dev              304.9 ps   (256.1 ps .. 365.1 ps)

benchmarking naive/10
time                 96.31 ns   (96.13 ns .. 96.54 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 96.47 ns   (96.30 ns .. 96.70 ns)
std dev              671.7 ps   (552.1 ps .. 873.4 ps)

benchmarking naive/20
time                 210.1 ns   (209.7 ns .. 210.5 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 209.9 ns   (209.7 ns .. 210.3 ns)
std dev              1.018 ns   (808.3 ps .. 1.471 ns)

benchmarking naive/40
time                 381.8 ns   (381.2 ns .. 382.5 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 382.5 ns   (381.7 ns .. 383.4 ns)
std dev              2.673 ns   (2.158 ns .. 3.345 ns)

benchmarking naive/80
time                 708.3 ns   (706.1 ns .. 710.5 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 707.5 ns   (706.2 ns .. 709.2 ns)
std dev              5.034 ns   (3.793 ns .. 6.809 ns)

benchmarking naive/160
time                 1.433 us   (1.427 us .. 1.439 us)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 1.430 us   (1.427 us .. 1.434 us)
std dev              12.26 ns   (9.548 ns .. 16.19 ns)

benchmarking naive/10000
time                 142.1 us   (141.6 us .. 142.6 us)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 141.7 us   (141.4 us .. 142.1 us)
std dev              1.080 us   (836.1 ns .. 1.423 us)

benchmarking tail/5
time                 59.24 ns   (59.05 ns .. 59.40 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 59.09 ns   (59.00 ns .. 59.21 ns)
std dev              363.8 ps   (312.5 ps .. 431.0 ps)

benchmarking tail/10
time                 94.26 ns   (94.08 ns .. 94.42 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 94.21 ns   (94.06 ns .. 94.38 ns)
std dev              531.3 ps   (438.9 ps .. 725.4 ps)

benchmarking tail/20
time                 162.3 ns   (162.0 ns .. 162.6 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 162.3 ns   (162.1 ns .. 162.6 ns)
std dev              796.1 ps   (678.2 ps .. 952.7 ps)

benchmarking tail/40
time                 310.8 ns   (310.1 ns .. 311.5 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 310.5 ns   (310.0 ns .. 311.0 ns)
std dev              1.552 ns   (1.275 ns .. 2.013 ns)

benchmarking tail/80
time                 593.8 ns   (592.2 ns .. 595.8 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 594.4 ns   (593.1 ns .. 596.0 ns)
std dev              4.951 ns   (4.020 ns .. 6.862 ns)

benchmarking tail/160
time                 1.152 us   (1.138 us .. 1.167 us)
                     0.999 R²   (0.999 R² .. 1.000 R²)
mean                 1.141 us   (1.137 us .. 1.148 us)
std dev              16.59 ns   (10.07 ns .. 29.66 ns)
variance introduced by outliers: 14% (moderately inflated)

benchmarking tail/10000
time                 79.00 us   (78.89 us .. 79.14 us)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 79.15 us   (79.02 us .. 79.33 us)
std dev              513.8 ns   (365.4 ns .. 730.4 ns)

benchmarking highLevel/5
time                 139.6 ns   (139.2 ns .. 139.9 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 139.3 ns   (139.0 ns .. 139.6 ns)
std dev              1.021 ns   (823.7 ps .. 1.296 ns)

benchmarking highLevel/10
time                 249.5 ns   (248.8 ns .. 250.3 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 249.2 ns   (248.8 ns .. 249.9 ns)
std dev              1.795 ns   (1.436 ns .. 2.344 ns)

benchmarking highLevel/20
time                 481.8 ns   (480.4 ns .. 483.7 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 482.7 ns   (481.5 ns .. 484.0 ns)
std dev              4.177 ns   (3.500 ns .. 4.967 ns)

benchmarking highLevel/40
time                 950.4 ns   (948.0 ns .. 952.5 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 951.5 ns   (949.1 ns .. 955.0 ns)
std dev              9.398 ns   (5.945 ns .. 14.77 ns)

benchmarking highLevel/80
time                 1.894 us   (1.889 us .. 1.899 us)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 1.891 us   (1.887 us .. 1.896 us)
std dev              14.45 ns   (12.37 ns .. 17.66 ns)

benchmarking highLevel/160
time                 3.805 us   (3.795 us .. 3.817 us)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 3.812 us   (3.804 us .. 3.821 us)
std dev              30.18 ns   (23.54 ns .. 40.12 ns)

benchmarking highLevel/10000
time                 234.2 us   (233.8 us .. 234.7 us)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 234.2 us   (233.8 us .. 234.5 us)
std dev              1.122 us   (908.7 ns .. 1.381 us)

benchmarking string/5
time                 42.68 ns   (42.58 ns .. 42.81 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 42.79 ns   (42.68 ns .. 42.97 ns)
std dev              436.8 ps   (317.9 ps .. 679.3 ps)

benchmarking string/10
time                 76.49 ns   (76.36 ns .. 76.60 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 76.47 ns   (76.37 ns .. 76.77 ns)
std dev              503.5 ps   (266.4 ps .. 904.7 ps)

benchmarking string/20
time                 139.9 ns   (139.7 ns .. 140.1 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 140.1 ns   (139.8 ns .. 140.3 ns)
std dev              943.6 ps   (774.7 ps .. 1.133 ns)

benchmarking string/40
time                 283.4 ns   (282.8 ns .. 283.8 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 283.0 ns   (282.6 ns .. 283.4 ns)
std dev              1.360 ns   (1.037 ns .. 1.826 ns)

benchmarking string/80
time                 568.0 ns   (567.0 ns .. 569.0 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 568.4 ns   (567.5 ns .. 569.3 ns)
std dev              3.051 ns   (2.493 ns .. 3.940 ns)

benchmarking string/160
time                 1.150 us   (1.147 us .. 1.153 us)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 1.151 us   (1.149 us .. 1.154 us)
std dev              8.114 ns   (6.375 ns .. 10.56 ns)

benchmarking string/10000
time                 83.13 us   (82.93 us .. 83.32 us)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 83.10 us   (82.94 us .. 83.30 us)
std dev              627.9 ns   (517.3 ns .. 804.0 ns)

benchmarking vector/5
time                 22.70 ns   (22.63 ns .. 22.80 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 22.70 ns   (22.63 ns .. 22.79 ns)
std dev              250.6 ps   (188.5 ps .. 375.6 ps)
variance introduced by outliers: 11% (moderately inflated)

benchmarking vector/10
time                 33.47 ns   (33.36 ns .. 33.57 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 33.43 ns   (33.38 ns .. 33.50 ns)
std dev              209.5 ps   (164.1 ps .. 276.6 ps)

benchmarking vector/20
time                 47.79 ns   (47.72 ns .. 47.88 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 47.81 ns   (47.73 ns .. 47.91 ns)
std dev              297.8 ps   (232.2 ps .. 406.8 ps)

benchmarking vector/40
time                 98.14 ns   (97.96 ns .. 98.32 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 98.13 ns   (98.00 ns .. 98.30 ns)
std dev              493.1 ps   (382.2 ps .. 753.9 ps)

benchmarking vector/80
time                 162.3 ns   (161.9 ns .. 162.8 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 162.8 ns   (162.5 ns .. 163.0 ns)
std dev              906.3 ps   (761.9 ps .. 1.086 ns)

benchmarking vector/160
time                 318.9 ns   (318.1 ns .. 319.8 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 318.6 ns   (318.0 ns .. 319.3 ns)
std dev              2.176 ns   (1.637 ns .. 3.321 ns)

benchmarking vector/10000
time                 30.57 us   (30.49 us .. 30.64 us)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 30.49 us   (30.45 us .. 30.55 us)
std dev              165.5 ns   (130.0 ns .. 227.0 ns)


-}