{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Swarm.Util (
(?),
maxOn,
maximum0,
cycleEnum,
uniq,
getElemsInArea,
manhattan,
readFileMay,
readFileMayT,
getSwarmDataPath,
getSwarmSavePath,
getSwarmHistoryPath,
readAppData,
isIdentChar,
replaceLast,
reflow,
quote,
squote,
commaList,
indefinite,
indefiniteQ,
singularSubjectVerb,
plural,
number,
holdsOr,
isJustOr,
isRightOr,
isSuccessOr,
liftText,
(%%=),
(<%=),
(<+=),
(<<.=),
(<>=),
_NonEmpty,
smallHittingSet,
getDataDirSafe,
getDataFileNameSafe,
dataNotFound,
) where
import Control.Algebra (Has)
import Control.Effect.State (State, modify, state)
import Control.Effect.Throw (Throw, throwError)
import Control.Exception (catch)
import Control.Exception.Base (IOException)
import Control.Lens (ASetter', Lens', LensLike, LensLike', Over, lens, (<>~))
import Control.Lens.Lens ((&))
import Control.Monad (forM, unless, when)
import Data.Aeson (FromJSONKey, ToJSONKey)
import Data.Bifunctor (first)
import Data.Char (isAlphaNum)
import Data.Either.Validation
import Data.Int (Int64)
import Data.List (maximumBy, partition)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map (Map)
import Data.Map qualified as M
import Data.Maybe (fromMaybe, mapMaybe)
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 Linear (V2 (V2))
import NLP.Minimorph.English qualified as MM
import NLP.Minimorph.Util ((<+>))
import Paths_swarm (getDataDir)
import System.Clock (TimeSpec)
import System.Directory (
XdgDirectory (XdgData),
createDirectoryIfMissing,
doesDirectoryExist,
doesFileExist,
getXdgDirectory,
listDirectory,
)
import System.FilePath
import System.IO
import System.IO.Error (catchIOError)
import Witch
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
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
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)
manhattan :: V2 Int64 -> V2 Int64 -> Int64
manhattan :: V2 Int64 -> V2 Int64 -> Int64
manhattan (V2 Int64
x1 Int64
y1) (V2 Int64
x2 Int64
y2) = forall a. Num a => a -> a
abs (Int64
x1 forall a. Num a => a -> a -> a
- Int64
x2) forall a. Num a => a -> a -> a
+ forall a. Num a => a -> a
abs (Int64
y1 forall a. Num a => a -> a -> a
- Int64
y2)
getElemsInArea :: V2 Int64 -> Int64 -> Map (V2 Int64) e -> [e]
getElemsInArea :: forall e. V2 Int64 -> Int64 -> Map (V2 Int64) e -> [e]
getElemsInArea o :: V2 Int64
o@(V2 Int64
x Int64
y) Int64
d Map (V2 Int64) e
m = forall k a. Map k a -> [a]
M.elems Map (V2 Int64) e
sm'
where
sm :: Map (V2 Int64) e
sm =
Map (V2 Int64) e
m
forall a b. a -> (a -> b) -> b
& forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
M.split (forall a. a -> a -> V2 a
V2 (Int64
x forall a. Num a => a -> a -> a
- Int64
d) (Int64
y forall a. Num a => a -> a -> a
- Int64
1))
forall a b. a -> (a -> b) -> b
& forall a b. (a, b) -> b
snd
forall a b. a -> (a -> b) -> b
& forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
M.split (forall a. a -> a -> V2 a
V2 (Int64
x forall a. Num a => a -> a -> a
+ Int64
d) (Int64
y forall a. Num a => a -> a -> a
+ Int64
1))
forall a b. a -> (a -> b) -> b
& forall a b. (a, b) -> a
fst
sm' :: Map (V2 Int64) e
sm' = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Ord a => a -> a -> Bool
<= Int64
d) forall b c a. (b -> c) -> (a -> b) -> a -> c
. V2 Int64 -> V2 Int64 -> Int64
manhattan V2 Int64
o) Map (V2 Int64) e
sm
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
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 -> (IOException -> IO a) -> IO a
`catchIOError` (\IOException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
getDataDirSafe :: FilePath -> IO (Maybe FilePath)
getDataDirSafe :: String -> IO (Maybe String)
getDataDirSafe String
p = do
String
d <- String -> String
mySubdir forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getDataDir
Bool
de <- String -> IO Bool
doesDirectoryExist String
d
if Bool
de
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just String
d
else do
String
xd <- String -> String
mySubdir forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
</> String
"data") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> IO String
getSwarmDataPath Bool
False
Bool
xde <- String -> IO Bool
doesDirectoryExist String
xd
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
xde then forall a. a -> Maybe a
Just String
xd else forall a. Maybe a
Nothing
where
mySubdir :: String -> String
mySubdir String
d = String
d String -> String -> String
`appDir` String
p
appDir :: String -> String -> String
appDir String
r = \case
String
"" -> String
r
String
"." -> String
r
String
d -> String
r String -> String -> String
</> String
d
getDataFileNameSafe :: FilePath -> IO (Maybe FilePath)
getDataFileNameSafe :: String -> IO (Maybe String)
getDataFileNameSafe String
name = do
Maybe String
dir <- String -> IO (Maybe String)
getDataDirSafe String
"."
case Maybe String
dir of
Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just String
d -> do
let fp :: String
fp = String
d String -> String -> String
</> String
name
Bool
fe <- String -> IO Bool
doesFileExist String
fp
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
fe then forall a. a -> Maybe a
Just String
fp else forall a. Maybe a
Nothing
dataNotFound :: FilePath -> IO Text
dataNotFound :: String -> IO Text
dataNotFound String
f = do
String
d <- Bool -> IO String
getSwarmDataPath Bool
False
let squotes :: String -> Text
squotes = Text -> Text
squote forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
[Text] -> Text
T.unlines
[ Text
"Could not find the data: " forall a. Semigroup a => a -> a -> a
<> String -> Text
squotes String
f
, Text
"Try downloading the Swarm 'data' directory to: " forall a. Semigroup a => a -> a -> a
<> String -> Text
squotes String
d
]
getSwarmDataPath :: Bool -> IO FilePath
getSwarmDataPath :: Bool -> IO String
getSwarmDataPath Bool
createDirs = do
String
swarmData <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgData String
"swarm"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
createDirs (Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
swarmData)
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
swarmData
getSwarmSavePath :: Bool -> IO FilePath
getSwarmSavePath :: Bool -> IO String
getSwarmSavePath Bool
createDirs = do
String
swarmSave <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgData (String
"swarm" String -> String -> String
</> String
"saves")
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
createDirs (Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
swarmSave)
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
swarmSave
getSwarmHistoryPath :: Bool -> IO FilePath
getSwarmHistoryPath :: Bool -> IO String
getSwarmHistoryPath Bool
createDirs =
(String -> String -> String
</> String
"history") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> IO String
getSwarmDataPath Bool
createDirs
readAppData :: IO (Map Text Text)
readAppData :: IO (Map Text Text)
readAppData = do
Maybe String
md <- String -> IO (Maybe String)
getDataDirSafe String
"."
case Maybe String
md of
Maybe String
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO Text
dataNotFound String
"<the data directory itself>"
Just String
d -> do
[String]
fs <-
forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== String
".txt") forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( String -> IO [String]
listDirectory String
d forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOException
e ->
Handle -> String -> IO ()
hPutStr Handle
stderr (forall a. Show a => a -> String
show (IOException
e :: IOException)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
fs (\String
f -> (forall target source. From source target => source -> target
into @Text (String -> String
dropExtension String
f),) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe Text)
readFileMayT (String
d String -> String -> String
</> String
f))
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
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
"\""]
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 ToJSON (V2 Int64)
deriving instance FromJSON (V2 Int64)
deriving instance FromJSONKey (V2 Int64)
deriving instance ToJSONKey (V2 Int64)
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
(:|)))
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