{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-}
-- | Extra list functions
--
-- In separate module to aid testing.
module Data.HashMap.List
    ( isPermutationBy
    , deleteBy
    , unorderedCompare
    ) where

import Data.Maybe (fromMaybe)
import Data.List (sortBy)
import Data.Monoid
import Prelude

-- Note: previous implemenation isPermutation = null (as // bs)
-- was O(n^2) too.
--
-- This assumes lists are of equal length
isPermutationBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool
isPermutationBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool
isPermutationBy a -> b -> Bool
f = [a] -> [b] -> Bool
go
  where
    f' :: b -> a -> Bool
f' = (a -> b -> Bool) -> b -> a -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> b -> Bool
f

    go :: [a] -> [b] -> Bool
go [] [] = Bool
True
    go (a
x : [a]
xs) (b
y : [b]
ys)
        | a -> b -> Bool
f a
x b
y         = [a] -> [b] -> Bool
go [a]
xs [b]
ys
        | Bool
otherwise     = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
            [a]
xs' <- (b -> a -> Bool) -> b -> [a] -> Maybe [a]
forall a b. (a -> b -> Bool) -> a -> [b] -> Maybe [b]
deleteBy b -> a -> Bool
f' b
y [a]
xs
            [b]
ys' <- (a -> b -> Bool) -> a -> [b] -> Maybe [b]
forall a b. (a -> b -> Bool) -> a -> [b] -> Maybe [b]
deleteBy a -> b -> Bool
f a
x [b]
ys
            Bool -> Maybe Bool
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> [b] -> Bool
go [a]
xs' [b]
ys')
    go [] (b
_ : [b]
_) = Bool
False
    go (a
_ : [a]
_) [] = Bool
False

-- The idea:
--
-- Homogeonous version
--
-- uc :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
-- uc c as bs = compare (sortBy c as) (sortBy c bs)
--
-- But as we have only (a -> b -> Ordering), we cannot directly compare
-- elements from the same list.
--
-- So when comparing elements from the list, we count how many elements are
-- "less and greater" in the other list, and use the count as a metric.
--
unorderedCompare :: (a -> b -> Ordering) -> [a] -> [b] -> Ordering
unorderedCompare :: (a -> b -> Ordering) -> [a] -> [b] -> Ordering
unorderedCompare a -> b -> Ordering
c [a]
as [b]
bs = [a] -> [b] -> Ordering
go ((a -> a -> Ordering) -> [a] -> [a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy a -> a -> Ordering
cmpA [a]
as) ((b -> b -> Ordering) -> [b] -> [b]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy b -> b -> Ordering
cmpB [b]
bs)
  where
    go :: [a] -> [b] -> Ordering
go [] [] = Ordering
EQ
    go [] (b
_ : [b]
_) = Ordering
LT
    go (a
_ : [a]
_) [] = Ordering
GT
    go (a
x : [a]
xs) (b
y : [b]
ys) = a -> b -> Ordering
c a
x b
y Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` [a] -> [b] -> Ordering
go [a]
xs [b]
ys

    cmpA :: a -> a -> Ordering
cmpA a
a a
a' = (Int, Int) -> (Int, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> (Int, Int)
inB a
a) (a -> (Int, Int)
inB a
a')
    cmpB :: b -> b -> Ordering
cmpB b
b b
b' = (Int, Int) -> (Int, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (b -> (Int, Int)
inA b
b) (b -> (Int, Int)
inA b
b')

    inB :: a -> (Int, Int)
inB a
a = ([b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([b] -> Int) -> [b] -> Int
forall a b. (a -> b) -> a -> b
$ (b -> Bool) -> [b] -> [b]
forall a. (a -> Bool) -> [a] -> [a]
filter (\b
b -> a -> b -> Ordering
c a
a b
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT) [b]
bs, Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([b] -> Int) -> [b] -> Int
forall a b. (a -> b) -> a -> b
$ (b -> Bool) -> [b] -> [b]
forall a. (a -> Bool) -> [a] -> [a]
filter (\b
b -> a -> b -> Ordering
c a
a b
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT) [b]
bs)
    inA :: b -> (Int, Int)
inA b
b = ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int) -> [a] -> Int
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\a
a -> a -> b -> Ordering
c a
a b
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT) [a]
as, Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int) -> [a] -> Int
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\a
a -> a -> b -> Ordering
c a
a b
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT) [a]
as)

-- Returns Nothing is nothing deleted
deleteBy              :: (a -> b -> Bool) -> a -> [b] -> Maybe [b]
deleteBy :: (a -> b -> Bool) -> a -> [b] -> Maybe [b]
deleteBy a -> b -> Bool
_  a
_ []      = Maybe [b]
forall a. Maybe a
Nothing
deleteBy a -> b -> Bool
eq a
x (b
y:[b]
ys)  = if a
x a -> b -> Bool
`eq` b
y then [b] -> Maybe [b]
forall a. a -> Maybe a
Just [b]
ys else ([b] -> [b]) -> Maybe [b] -> Maybe [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b
y b -> [b] -> [b]
forall a. a -> [a] -> [a]
:) ((a -> b -> Bool) -> a -> [b] -> Maybe [b]
forall a b. (a -> b -> Bool) -> a -> [b] -> Maybe [b]
deleteBy a -> b -> Bool
eq a
x [b]
ys)