{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Swarm.Util (
(?),
sortPair,
maxOn,
maximum0,
cycleEnum,
listEnums,
listEnumsNonempty,
showEnum,
indexWrapNonEmpty,
uniq,
binTuples,
histogram,
findDup,
both,
allEqual,
surfaceEmpty,
applyWhen,
hoistMaybe,
unsnocNE,
readFileMay,
readFileMayT,
acquireAllWithExt,
isIdentChar,
replaceLast,
failT,
showT,
showLowT,
reflow,
quote,
squote,
bquote,
parens,
brackets,
commaList,
indefinite,
indefiniteQ,
singularSubjectVerb,
plural,
number,
holdsOr,
isJustOr,
isRightOr,
isSuccessOr,
liftText,
(%%=),
(<%=),
(<+=),
(<<.=),
(<>=),
_NonEmpty,
removeSupersets,
smallHittingSet,
) where
import Control.Applicative (Alternative)
import Control.Carrier.Throw.Either
import Control.Effect.State (State, modify, state)
import Control.Lens (ASetter', Lens', LensLike, LensLike', Over, lens, (<&>), (<>~))
import Control.Monad (filterM, guard, unless)
import Control.Monad.Trans.Maybe (MaybeT (..))
import Data.Bifunctor (Bifunctor (bimap), first)
import Data.Char (isAlphaNum, toLower)
import Data.Either.Validation
import Data.List (foldl', maximumBy, partition)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as NE
import Data.Map (Map)
import Data.Map qualified as M
import Data.Maybe (fromMaybe)
import Data.Ord (comparing)
import Data.Set (Set)
import Data.Set qualified as S
import Data.Text (Text, toUpper)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Tuple (swap)
import Data.Yaml
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (lift)
import NLP.Minimorph.English qualified as MM
import NLP.Minimorph.Util ((<+>))
import System.Clock (TimeSpec)
import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)
import System.FilePath (takeExtension, (</>))
import System.IO.Error (catchIOError)
import Witch (from)
infixr 1 ?
infix 4 %%=, <+=, <%=, <<.=, <>=
(?) :: Maybe a -> a -> a
? :: forall a. Maybe a -> a -> a
(?) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. a -> Maybe a -> a
fromMaybe
sortPair :: Ord b => (b, b) -> (b, b)
sortPair :: forall b. Ord b => (b, b) -> (b, b)
sortPair (b
x, b
y) = if b
x forall a. Ord a => a -> a -> Bool
<= b
y then (b
x, b
y) else (b
y, b
x)
maxOn :: Ord b => (a -> b) -> a -> a -> a
maxOn :: forall b a. Ord b => (a -> b) -> a -> a -> a
maxOn a -> b
f a
x a
y
| a -> b
f a
x forall a. Ord a => a -> a -> Bool
> a -> b
f a
y = a
x
| Bool
otherwise = a
y
maximum0 :: (Num a, Ord a) => [a] -> a
maximum0 :: forall a. (Num a, Ord a) => [a] -> a
maximum0 [] = a
0
maximum0 [a]
xs = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [a]
xs
cycleEnum :: (Eq e, Enum e, Bounded e) => e -> e
cycleEnum :: forall e. (Eq e, Enum e, Bounded e) => e -> e
cycleEnum e
e
| e
e forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
maxBound = forall a. Bounded a => a
minBound
| Bool
otherwise = forall a. Enum a => a -> a
succ e
e
listEnums :: (Enum e, Bounded e) => [e]
listEnums :: forall e. (Enum e, Bounded e) => [e]
listEnums = [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound]
listEnumsNonempty :: (Enum e, Bounded e) => NonEmpty e
listEnumsNonempty :: forall e. (Enum e, Bounded e) => NonEmpty e
listEnumsNonempty = forall a. [a] -> NonEmpty a
NE.fromList forall e. (Enum e, Bounded e) => [e]
listEnums
showEnum :: (Show e, Enum e) => e -> NonEmpty Char
showEnum :: forall e. (Show e, Enum e) => e -> NonEmpty Char
showEnum = forall a. [a] -> NonEmpty a
NE.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
indexWrapNonEmpty ::
Integral b =>
NonEmpty a ->
b ->
a
indexWrapNonEmpty :: forall b a. Integral b => NonEmpty a -> b -> a
indexWrapNonEmpty NonEmpty a
list b
idx =
forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
list forall a. [a] -> Int -> a
!! forall a b. (Integral a, Num b) => a -> b
fromIntegral b
wrappedIdx
where
wrappedIdx :: b
wrappedIdx = b
idx forall a. Integral a => a -> a -> a
`mod` forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. NonEmpty a -> Int
NE.length NonEmpty a
list)
uniq :: Eq a => [a] -> [a]
uniq :: forall a. Eq a => [a] -> [a]
uniq = \case
[] -> []
(a
x : [a]
xs) -> a
x forall a. a -> [a] -> [a]
: forall a. Eq a => [a] -> [a]
uniq (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== a
x) [a]
xs)
binTuples ::
(Foldable t, Ord a) =>
t (a, b) ->
Map a (NE.NonEmpty b)
binTuples :: forall (t :: * -> *) a b.
(Foldable t, Ord a) =>
t (a, b) -> Map a (NonEmpty b)
binTuples = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, b) -> Map a (NonEmpty b) -> Map a (NonEmpty b)
f forall a. Monoid a => a
mempty
where
f :: (a, b) -> Map a (NonEmpty b) -> Map a (NonEmpty b)
f = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Semigroup a => a -> a -> a
(<>)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Applicative f => a -> f a
pure
histogram ::
(Foldable t, Ord a) =>
t a ->
Map a Int
histogram :: forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> Map a Int
histogram = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map a Int
m a
k -> forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Num a => a -> a -> a
(+) a
k Int
1 Map a Int
m) forall k a. Map k a
M.empty
findDup :: Ord a => [a] -> Maybe a
findDup :: forall a. Ord a => [a] -> Maybe a
findDup = forall {a}. Ord a => Set a -> [a] -> Maybe a
go forall a. Set a
S.empty
where
go :: Set a -> [a] -> Maybe a
go Set a
_ [] = forall a. Maybe a
Nothing
go Set a
seen (a
a : [a]
as)
| a
a forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
seen = forall a. a -> Maybe a
Just a
a
| Bool
otherwise = Set a -> [a] -> Maybe a
go (forall a. Ord a => a -> Set a -> Set a
S.insert a
a Set a
seen) [a]
as
both :: Bifunctor p => (a -> d) -> p a a -> p d d
both :: forall (p :: * -> * -> *) a d.
Bifunctor p =>
(a -> d) -> p a a -> p d d
both a -> d
f = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> d
f a -> d
f
allEqual :: (Ord a) => [a] -> Bool
allEqual :: forall a. Ord a => [a] -> Bool
allEqual [] = Bool
True
allEqual (a
x : [a]
xs) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== a
x) [a]
xs
surfaceEmpty :: Alternative f => (a -> Bool) -> a -> f a
surfaceEmpty :: forall (f :: * -> *) a. Alternative f => (a -> Bool) -> a -> f a
surfaceEmpty a -> Bool
isEmpty a
t = a
t forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (a -> Bool
isEmpty a
t))
applyWhen :: Bool -> (a -> a) -> a -> a
applyWhen :: forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
True a -> a
f a
x = a -> a
f a
x
applyWhen Bool
False a -> a
_ a
x = a
x
hoistMaybe :: (Applicative m) => Maybe b -> MaybeT m b
hoistMaybe :: forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
unsnocNE :: NonEmpty a -> ([a], a)
unsnocNE :: forall a. NonEmpty a -> ([a], a)
unsnocNE (a
x :| [a]
xs) = forall {a}. a -> [a] -> ([a], a)
go a
x [a]
xs
where
go :: a -> [a] -> ([a], a)
go a
y [] = ([], a
y)
go a
y (a
z : [a]
zs) = let ~([a]
ws, a
w) = a -> [a] -> ([a], a)
go a
z [a]
zs in (a
y forall a. a -> [a] -> [a]
: [a]
ws, a
w)
readFileMay :: FilePath -> IO (Maybe String)
readFileMay :: String -> IO (Maybe String)
readFileMay = forall a. IO a -> IO (Maybe a)
catchIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
readFile
readFileMayT :: FilePath -> IO (Maybe Text)
readFileMayT :: String -> IO (Maybe Text)
readFileMayT = forall a. IO a -> IO (Maybe a)
catchIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Text
T.readFile
acquireAllWithExt :: FilePath -> String -> IO [(FilePath, String)]
acquireAllWithExt :: String -> String -> IO [(String, String)]
acquireAllWithExt String
dir String
ext = do
[String]
paths <- String -> IO [String]
listDirectory String
dir forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a b. (a -> b) -> [a] -> [b]
map (String
dir String -> String -> String
</>)
[String]
filePaths <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\String
path -> String -> IO Bool
doesFileExist String
path forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Bool -> Bool
(&&) (String -> Bool
hasExt String
path)) [String]
paths
[(String, String)]
children <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\String
path -> (,) String
path forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
path) [String]
filePaths
[String]
sub <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesDirectoryExist [String]
paths
[(String, String)]
transChildren <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> String -> IO [(String, String)]
`acquireAllWithExt` String
ext) [String]
sub
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(String, String)]
children forall a. Semigroup a => a -> a -> a
<> [(String, String)]
transChildren
where
hasExt :: String -> Bool
hasExt String
path = String -> String
takeExtension String
path forall a. Eq a => a -> a -> Bool
== (String
"." forall a. [a] -> [a] -> [a]
++ String
ext)
catchIO :: IO a -> IO (Maybe a)
catchIO :: forall a. IO a -> IO (Maybe a)
catchIO IO a
act = (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
act) forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\IOError
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
isIdentChar :: Char -> Bool
isIdentChar :: Char -> Bool
isIdentChar Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\''
replaceLast :: Text -> Text -> Text
replaceLast :: Text -> Text -> Text
replaceLast Text
r Text
t = Text -> Text -> Text
T.append ((Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
isIdentChar Text
t) Text
r
failT :: MonadFail m => [Text] -> m a
failT :: forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall source target. From source target => source -> target
from @Text forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unwords
showT :: Show a => a -> Text
showT :: forall a. Show a => a -> Text
showT = forall source target. From source target => source -> target
from @String forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
showLowT :: Show a => a -> Text
showLowT :: forall a. Show a => a -> Text
showLowT = forall source target. From source target => source -> target
from @String forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
reflow :: Text -> Text
reflow :: Text -> Text
reflow = [Text] -> Text
T.unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words
indefinite :: Text -> Text
indefinite :: Text -> Text
indefinite Text
w = Text -> Text
MM.indefiniteDet Text
w Text -> Text -> Text
<+> Text
w
indefiniteQ :: Text -> Text
indefiniteQ :: Text -> Text
indefiniteQ Text
w = Text -> Text
MM.indefiniteDet Text
w Text -> Text -> Text
<+> Text -> Text
squote Text
w
singularSubjectVerb :: Text -> Text -> Text
singularSubjectVerb :: Text -> Text -> Text
singularSubjectVerb Text
sub Text
verb
| Text
verb forall a. Eq a => a -> a -> Bool
== Text
"be" = case Text -> Text
toUpper Text
sub of
Text
"I" -> Text
"I am"
Text
"YOU" -> Text
sub Text -> Text -> Text
<+> Text
"are"
Text
_ -> Text
sub Text -> Text -> Text
<+> Text
"is"
| Bool
otherwise = Text
sub Text -> Text -> Text
<+> (if Bool
is3rdPerson then Text
verb3rd else Text
verb)
where
is3rdPerson :: Bool
is3rdPerson = Text -> Text
toUpper Text
sub forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
"I", Text
"YOU"]
verb3rd :: Text
verb3rd
| Text
verb forall a. Eq a => a -> a -> Bool
== Text
"have" = Text
"has"
| Text
verb forall a. Eq a => a -> a -> Bool
== Text
"can" = Text
"can"
| Bool
otherwise = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Text -> (Text, Text)
MM.defaultVerbStuff Text
verb
plural :: Text -> Text
plural :: Text -> Text
plural = Text -> Text
MM.defaultNounPlural
number :: Int -> Text -> Text
number :: Int -> Text -> Text
number Int
1 = forall a. a -> a
id
number Int
_ = Text -> Text
plural
squote :: Text -> Text
squote :: Text -> Text
squote Text
t = [Text] -> Text
T.concat [Text
"'", Text
t, Text
"'"]
quote :: Text -> Text
quote :: Text -> Text
quote Text
t = [Text] -> Text
T.concat [Text
"\"", Text
t, Text
"\""]
bquote :: Text -> Text
bquote :: Text -> Text
bquote Text
t = [Text] -> Text
T.concat [Text
"`", Text
t, Text
"`"]
parens :: Text -> Text
parens :: Text -> Text
parens Text
t = [Text] -> Text
T.concat [Text
"(", Text
t, Text
")"]
brackets :: Text -> Text
brackets :: Text -> Text
brackets Text
t = [Text] -> Text
T.concat [Text
"[", Text
t, Text
"]"]
commaList :: [Text] -> Text
commaList :: [Text] -> Text
commaList [] = Text
""
commaList [Text
t] = Text
t
commaList [Text
s, Text
t] = [Text] -> Text
T.unwords [Text
s, Text
"and", Text
t]
commaList [Text]
ts = [Text] -> Text
T.unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Text
`T.append` Text
",") (forall a. [a] -> [a]
init [Text]
ts) forall a. [a] -> [a] -> [a]
++ [Text
"and", forall a. [a] -> a
last [Text]
ts]
deriving instance FromJSON TimeSpec
deriving instance ToJSON TimeSpec
holdsOr :: Has (Throw e) sig m => Bool -> e -> m ()
holdsOr :: forall e (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw e) sig m =>
Bool -> e -> m ()
holdsOr Bool
b e
e = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b forall a b. (a -> b) -> a -> b
$ forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError e
e
isJustOr :: Has (Throw e) sig m => Maybe a -> e -> m a
Just a
a isJustOr :: forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
Maybe a -> e -> m a
`isJustOr` e
_ = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
Maybe a
Nothing `isJustOr` e
e = forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError e
e
isRightOr :: Has (Throw e) sig m => Either b a -> (b -> e) -> m a
Right a
a isRightOr :: forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) b a.
Has (Throw e) sig m =>
Either b a -> (b -> e) -> m a
`isRightOr` b -> e
_ = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
Left b
b `isRightOr` b -> e
f = forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError (b -> e
f b
b)
isSuccessOr :: Has (Throw e) sig m => Validation b a -> (b -> e) -> m a
Success a
a isSuccessOr :: forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) b a.
Has (Throw e) sig m =>
Validation b a -> (b -> e) -> m a
`isSuccessOr` b -> e
_ = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
Failure b
b `isSuccessOr` b -> e
f = forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError (b -> e
f b
b)
liftText :: T.Text -> Q Exp
liftText :: Text -> Q Exp
liftText Text
txt = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'T.pack) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift (Text -> String
T.unpack Text
txt)
(<+=) :: (Has (State s) sig m, Num a) => LensLike' ((,) a) s a -> a -> m a
LensLike' ((,) a) s a
l <+= :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State s) sig m, Num a) =>
LensLike' ((,) a) s a -> a -> m a
<+= a
a = LensLike' ((,) a) s a
l forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State s) sig m =>
LensLike' ((,) a) s a -> (a -> a) -> m a
<%= (forall a. Num a => a -> a -> a
+ a
a)
{-# INLINE (<+=) #-}
(<%=) :: (Has (State s) sig m) => LensLike' ((,) a) s a -> (a -> a) -> m a
LensLike' ((,) a) s a
l <%= :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State s) sig m =>
LensLike' ((,) a) s a -> (a -> a) -> m a
<%= a -> a
f = LensLike' ((,) a) s a
l forall s (sig :: (* -> *) -> * -> *) (m :: * -> *)
(p :: * -> * -> *) r a b.
Has (State s) sig m =>
Over p ((,) r) s s a b -> p a (r, b) -> m r
%%= (\a
b -> (a
b, a
b)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f
{-# INLINE (<%=) #-}
(%%=) :: (Has (State s) sig m) => Over p ((,) r) s s a b -> p a (r, b) -> m r
Over p ((,) r) s s a b
l %%= :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *)
(p :: * -> * -> *) r a b.
Has (State s) sig m =>
Over p ((,) r) s s a b -> p a (r, b) -> m r
%%= p a (r, b)
f = forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State s) sig m =>
(s -> (s, a)) -> m a
state (forall a b. (a, b) -> (b, a)
swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. Over p ((,) r) s s a b
l p a (r, b)
f)
{-# INLINE (%%=) #-}
(<<.=) :: (Has (State s) sig m) => LensLike ((,) a) s s a b -> b -> m a
LensLike ((,) a) s s a b
l <<.= :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b.
Has (State s) sig m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= b
b = LensLike ((,) a) s s a b
l forall s (sig :: (* -> *) -> * -> *) (m :: * -> *)
(p :: * -> * -> *) r a b.
Has (State s) sig m =>
Over p ((,) r) s s a b -> p a (r, b) -> m r
%%= (,b
b)
{-# INLINE (<<.=) #-}
(<>=) :: (Has (State s) sig m, Semigroup a) => ASetter' s a -> a -> m ()
ASetter' s a
l <>= :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State s) sig m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= a
a = forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
(s -> s) -> m ()
modify (ASetter' s a
l forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ a
a)
{-# INLINE (<>=) #-}
_NonEmpty :: Lens' (NonEmpty a) (a, [a])
_NonEmpty :: forall a. Lens' (NonEmpty a) (a, [a])
_NonEmpty = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(a
x :| [a]
xs) -> (a
x, [a]
xs)) (forall a b. a -> b -> a
const (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. a -> [a] -> NonEmpty a
(:|)))
removeSupersets :: Ord a => Set (Set a) -> Set (Set a)
removeSupersets :: forall a. Ord a => Set (Set a) -> Set (Set a)
removeSupersets Set (Set a)
ss = forall a. (a -> Bool) -> Set a -> Set a
S.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> Bool
isSuperset) Set (Set a)
ss
where
isSuperset :: Set a -> Bool
isSuperset Set a
s = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => Set a -> Set a -> Bool
`S.isSubsetOf` Set a
s) (forall a. Ord a => a -> Set a -> Set a
S.delete Set a
s Set (Set a)
ss)
smallHittingSet :: Ord a => [Set a] -> Set a
smallHittingSet :: forall a. Ord a => [Set a] -> Set a
smallHittingSet [Set a]
ss = forall {a}. Ord a => Set a -> [Set a] -> Set a
go Set a
fixed (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Set a -> Bool
S.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => Set a -> Set a -> Set a
S.intersection Set a
fixed) [Set a]
choices)
where
(Set a
fixed, [Set a]
choices) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((forall a. Eq a => a -> a -> Bool
== Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Int
S.size) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
S.null) forall a b. (a -> b) -> a -> b
$ [Set a]
ss
go :: Set a -> [Set a] -> Set a
go !Set a
soFar [] = Set a
soFar
go !Set a
soFar [Set a]
cs = Set a -> [Set a] -> Set a
go (forall a. Ord a => a -> Set a -> Set a
S.insert a
best Set a
soFar) (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
best forall a. Ord a => a -> Set a -> Bool
`S.member`)) [Set a]
cs)
where
best :: a
best = forall a. Ord a => [Set a] -> a
mostCommon [Set a]
cs
mostCommon :: Ord a => [Set a] -> a
mostCommon :: forall a. Ord a => [Set a] -> a
mostCommon = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.assocs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. Num a => a -> a -> a
(+) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (,Int
1 :: Int) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Set a -> [a]
S.toList