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