{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE KindSignatures #-}
module Brassica.SoundChange.Category
(
Category(..)
, CategoryState(..)
, categorise
, Categories
, Brassica.SoundChange.Category.lookup
, mapCategories
, expand
, bake
, values
) where
import Data.Coerce
import Data.List (intersect)
import Data.Maybe (fromMaybe)
import qualified Data.Map.Strict as M
import Data.Containers.ListUtils (nubOrd)
data CategoryState = Unexpanded | Expanded
data Category (s :: CategoryState) a
= Empty
| Node a
| UnionOf [Category s a]
| Intersect (Category s a) (Category s a)
| Subtract (Category s a) (Category s a)
deriving (Int -> Category s a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: CategoryState) a.
Show a =>
Int -> Category s a -> ShowS
forall (s :: CategoryState) a. Show a => [Category s a] -> ShowS
forall (s :: CategoryState) a. Show a => Category s a -> String
showList :: [Category s a] -> ShowS
$cshowList :: forall (s :: CategoryState) a. Show a => [Category s a] -> ShowS
show :: Category s a -> String
$cshow :: forall (s :: CategoryState) a. Show a => Category s a -> String
showsPrec :: Int -> Category s a -> ShowS
$cshowsPrec :: forall (s :: CategoryState) a.
Show a =>
Int -> Category s a -> ShowS
Show, Category s a -> Category s a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (s :: CategoryState) a.
Eq a =>
Category s a -> Category s a -> Bool
/= :: Category s a -> Category s a -> Bool
$c/= :: forall (s :: CategoryState) a.
Eq a =>
Category s a -> Category s a -> Bool
== :: Category s a -> Category s a -> Bool
$c== :: forall (s :: CategoryState) a.
Eq a =>
Category s a -> Category s a -> Bool
Eq, Category s a -> Category s a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {s :: CategoryState} {a}. Ord a => Eq (Category s a)
forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Bool
forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Ordering
forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Category s a
min :: Category s a -> Category s a -> Category s a
$cmin :: forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Category s a
max :: Category s a -> Category s a -> Category s a
$cmax :: forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Category s a
>= :: Category s a -> Category s a -> Bool
$c>= :: forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Bool
> :: Category s a -> Category s a -> Bool
$c> :: forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Bool
<= :: Category s a -> Category s a -> Bool
$c<= :: forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Bool
< :: Category s a -> Category s a -> Bool
$c< :: forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Bool
compare :: Category s a -> Category s a -> Ordering
$ccompare :: forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Ordering
Ord, forall a b. a -> Category s b -> Category s a
forall a b. (a -> b) -> Category s a -> Category s b
forall (s :: CategoryState) a b. a -> Category s b -> Category s a
forall (s :: CategoryState) a b.
(a -> b) -> Category s a -> Category s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Category s b -> Category s a
$c<$ :: forall (s :: CategoryState) a b. a -> Category s b -> Category s a
fmap :: forall a b. (a -> b) -> Category s a -> Category s b
$cfmap :: forall (s :: CategoryState) a b.
(a -> b) -> Category s a -> Category s b
Functor)
type Categories a = M.Map a (Category 'Expanded a)
lookup :: Ord a => a -> Categories a -> Maybe (Category 'Expanded a)
lookup :: forall a.
Ord a =>
a -> Categories a -> Maybe (Category 'Expanded a)
lookup = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup
mapCategories :: Ord b => (a -> b) -> Categories a -> Categories b
mapCategories :: forall b a. Ord b => (a -> b) -> Categories a -> Categories b
mapCategories a -> b
f = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys a -> b
f
categorise :: Ord a => [a] -> Category 'Expanded a
categorise :: forall a. Ord a => [a] -> Category 'Expanded a
categorise = forall (s :: CategoryState) a. [Category s a] -> Category s a
UnionOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (s :: CategoryState) a. a -> Category s a
Node
expand :: Ord a => Categories a -> Category 'Unexpanded a -> Category 'Expanded a
expand :: forall a.
Ord a =>
Categories a -> Category 'Unexpanded a -> Category 'Expanded a
expand Categories a
_ Category 'Unexpanded a
Empty = forall (s :: CategoryState) a. Category s a
Empty
expand Categories a
cs n :: Category 'Unexpanded a
n@(Node a
a) = forall a. a -> Maybe a -> a
fromMaybe (coerce :: forall a b. Coercible a b => a -> b
coerce Category 'Unexpanded a
n) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup a
a Categories a
cs
expand Categories a
cs (UnionOf [Category 'Unexpanded a]
u) = forall (s :: CategoryState) a. [Category s a] -> Category s a
UnionOf forall a b. (a -> b) -> a -> b
$ forall a.
Ord a =>
Categories a -> Category 'Unexpanded a -> Category 'Expanded a
expand Categories a
cs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Category 'Unexpanded a]
u
expand Categories a
cs (Intersect Category 'Unexpanded a
a Category 'Unexpanded a
b) = forall (s :: CategoryState) a.
Category s a -> Category s a -> Category s a
Intersect (forall a.
Ord a =>
Categories a -> Category 'Unexpanded a -> Category 'Expanded a
expand Categories a
cs Category 'Unexpanded a
a) (forall a.
Ord a =>
Categories a -> Category 'Unexpanded a -> Category 'Expanded a
expand Categories a
cs Category 'Unexpanded a
b)
expand Categories a
cs (Subtract Category 'Unexpanded a
a Category 'Unexpanded a
b) = forall (s :: CategoryState) a.
Category s a -> Category s a -> Category s a
Subtract (forall a.
Ord a =>
Categories a -> Category 'Unexpanded a -> Category 'Expanded a
expand Categories a
cs Category 'Unexpanded a
a) (forall a.
Ord a =>
Categories a -> Category 'Unexpanded a -> Category 'Expanded a
expand Categories a
cs Category 'Unexpanded a
b)
bake :: Eq a => Category 'Expanded a -> [a]
bake :: forall a. Eq a => Category 'Expanded a -> [a]
bake Category 'Expanded a
Empty = []
bake (Node a
a) = [a
a]
bake (UnionOf [Category 'Expanded a]
u) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Eq a => Category 'Expanded a -> [a]
bake [Category 'Expanded a]
u
bake (Intersect Category 'Expanded a
a Category 'Expanded a
b) = forall a. Eq a => Category 'Expanded a -> [a]
bake Category 'Expanded a
a forall a. Eq a => [a] -> [a] -> [a]
`intersect` forall a. Eq a => Category 'Expanded a -> [a]
bake Category 'Expanded a
b
bake (Subtract Category 'Expanded a
a Category 'Expanded a
b) = forall a. Eq a => Category 'Expanded a -> [a]
bake Category 'Expanded a
a forall {t :: * -> *} {a}. (Foldable t, Eq a) => [a] -> t a -> [a]
`difference` forall a. Eq a => Category 'Expanded a -> [a]
bake Category 'Expanded a
b
where
difference :: [a] -> t a -> [a]
difference [a]
l t a
m = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
m)) [a]
l
values :: Ord a => Categories a -> [a]
values :: forall a. Ord a => Categories a -> [a]
values = forall a. Ord a => [a] -> [a]
nubOrd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {s :: CategoryState} {a}. Category s a -> [a]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
M.elems
where
go :: Category s a -> [a]
go Category s a
Empty = []
go (Node a
a) = [a
a]
go (UnionOf [Category s a]
u) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Category s a -> [a]
go [Category s a]
u
go (Intersect Category s a
a Category s a
b) = Category s a -> [a]
go Category s a
a forall a. [a] -> [a] -> [a]
++ Category s a -> [a]
go Category s a
b
go (Subtract Category s a
a Category s a
b) = Category s a -> [a]
go Category s a
a forall a. [a] -> [a] -> [a]
++ Category s a -> [a]
go Category s a
b