1{-# LANGUAGE ScopedTypeVariables #-}
2{-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-}
3{-# OPTIONS_HADDOCK not-home #-}
4
5-- | = WARNING
6--
7-- This module is considered __internal__.
8--
9-- The Package Versioning Policy __does not apply__.
10--
11-- The contents of this module may change __in any way whatsoever__
12-- and __without any warning__ between minor versions of this package.
13--
14-- Authors importing this module are expected to track development
15-- closely.
16--
17-- = Description
18--
19-- Extra list functions
20--
21-- In separate module to aid testing.
22module Data.HashMap.Internal.List
23    ( isPermutationBy
24    , deleteBy
25    , unorderedCompare
26    ) where
27
28import Data.Maybe (fromMaybe)
29import Data.List (sortBy)
30import Data.Monoid
31import Prelude
32
33-- Note: previous implemenation isPermutation = null (as // bs)
34-- was O(n^2) too.
35--
36-- This assumes lists are of equal length
37isPermutationBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool
38isPermutationBy f = go
39  where
40    f' = flip f
41
42    go [] [] = True
43    go (x : xs) (y : ys)
44        | f x y         = go xs ys
45        | otherwise     = fromMaybe False $ do
46            xs' <- deleteBy f' y xs
47            ys' <- deleteBy f x ys
48            return (go xs' ys')
49    go [] (_ : _) = False
50    go (_ : _) [] = False
51
52-- The idea:
53--
54-- Homogeonous version
55--
56-- uc :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
57-- uc c as bs = compare (sortBy c as) (sortBy c bs)
58--
59-- But as we have only (a -> b -> Ordering), we cannot directly compare
60-- elements from the same list.
61--
62-- So when comparing elements from the list, we count how many elements are
63-- "less and greater" in the other list, and use the count as a metric.
64--
65unorderedCompare :: (a -> b -> Ordering) -> [a] -> [b] -> Ordering
66unorderedCompare c as bs = go (sortBy cmpA as) (sortBy cmpB bs)
67  where
68    go [] [] = EQ
69    go [] (_ : _) = LT
70    go (_ : _) [] = GT
71    go (x : xs) (y : ys) = c x y `mappend` go xs ys
72
73    cmpA a a' = compare (inB a) (inB a')
74    cmpB b b' = compare (inA b) (inA b')
75
76    inB a = (length $ filter (\b -> c a b == GT) bs, negate $ length $ filter (\b -> c a b == LT) bs)
77    inA b = (length $ filter (\a -> c a b == LT) as, negate $ length $ filter (\a -> c a b == GT) as)
78
79-- Returns Nothing is nothing deleted
80deleteBy              :: (a -> b -> Bool) -> a -> [b] -> Maybe [b]
81deleteBy _  _ []      = Nothing
82deleteBy eq x (y:ys)  = if x `eq` y then Just ys else fmap (y :) (deleteBy eq x ys)
83