{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Agda.Utils.Favorites where
import Prelude hiding ( null )
import Data.Foldable (Foldable)
import Data.Functor
import Data.Semigroup
import qualified Data.List as List
import qualified Data.Set as Set
import Agda.Utils.Null
import Agda.Utils.PartialOrd
import Agda.Utils.Singleton
import Agda.Utils.Tuple
newtype Favorites a = Favorites { toList :: [a] }
deriving (Foldable, Show, Null, Singleton a)
instance Ord a => Eq (Favorites a) where
as == bs = Set.fromList (toList as) == Set.fromList (toList bs)
data CompareResult a
= Dominates { dominated :: [a], notDominated :: [a] }
| IsDominated { dominator :: a }
compareWithFavorites :: PartialOrd a => a -> Favorites a -> CompareResult a
compareWithFavorites a favs = loop $ toList favs where
loop [] = Dominates [] []
loop as@(b : bs) = case comparable a b of
POLT -> dominates b $ loop bs
POLE -> dominates b $ loop bs
POEQ -> IsDominated b
POGE -> IsDominated b
POGT -> IsDominated b
POAny -> doesnotd b $ loop bs
dominates b (Dominates bs as) = Dominates (b : bs) as
dominates b r@IsDominated{} = r
doesnotd b (Dominates as bs) = Dominates as (b : bs)
doesnotd b r@IsDominated{} = r
compareFavorites :: PartialOrd a => Favorites a -> Favorites a ->
(Favorites a, Favorites a)
compareFavorites new old = mapFst Favorites $ loop (toList new) old where
loop [] old = ([], old)
loop (a : new) old = case compareWithFavorites a old of
Dominates _ old -> mapFst (a:) $ loop new (Favorites old)
IsDominated{} -> loop new old
unionCompared :: (Favorites a, Favorites a) -> Favorites a
unionCompared (Favorites new, Favorites old) = Favorites $ new ++ old
insertCompared :: a -> Favorites a -> CompareResult a -> Favorites a
insertCompared a _ (Dominates _ as) = Favorites (a : as)
insertCompared _ l IsDominated{} = l
insert :: PartialOrd a => a -> Favorites a -> Favorites a
insert a l = insertCompared a l (compareWithFavorites a l)
union :: PartialOrd a => Favorites a -> Favorites a -> Favorites a
union (Favorites as) bs = List.foldr insert bs as
fromList :: PartialOrd a => [a] -> Favorites a
fromList = List.foldl' (flip insert) empty
instance PartialOrd a => Semigroup (Favorites a) where
(<>) = union
instance PartialOrd a => Monoid (Favorites a) where
mempty = empty
mappend = (<>)