{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Swarm.Util (
(?),
maxOn,
maximum0,
cycleEnum,
listEnums,
uniq,
getElemsInArea,
manhattan,
binTuples,
readFileMay,
readFileMayT,
getSwarmXdgDataSubdir,
getSwarmXdgDataFile,
getSwarmSavePath,
getSwarmHistoryPath,
readAppData,
getDataDirSafe,
getDataFileNameSafe,
dataNotFound,
isIdentChar,
replaceLast,
reflow,
quote,
squote,
bquote,
commaList,
indefinite,
indefiniteQ,
singularSubjectVerb,
plural,
number,
holdsOr,
isJustOr,
isRightOr,
isSuccessOr,
liftText,
(%%=),
(<%=),
(<+=),
(<<.=),
(<>=),
_NonEmpty,
smallHittingSet,
) 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.Bifunctor (first)
import Data.Char (isAlphaNum)
import Data.Either.Validation
import Data.Int (Int32)
import Data.List (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, 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 NLP.Minimorph.English qualified as MM
import NLP.Minimorph.Util ((<+>))
import Paths_swarm (getDataDir)
import Swarm.Util.Location
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
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]
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 :: Location -> Location -> Int32
manhattan :: Location -> Location -> Int32
manhattan (Location Int32
x1 Int32
y1) (Location Int32
x2 Int32
y2) = forall a. Num a => a -> a
abs (Int32
x1 forall a. Num a => a -> a -> a
- Int32
x2) forall a. Num a => a -> a -> a
+ forall a. Num a => a -> a
abs (Int32
y1 forall a. Num a => a -> a -> a
- Int32
y2)
getElemsInArea :: Location -> Int32 -> Map Location e -> [e]
getElemsInArea :: forall e. Location -> Int32 -> Map Location e -> [e]
getElemsInArea o :: Location
o@(Location Int32
x Int32
y) Int32
d Map Location e
m = forall k a. Map k a -> [a]
M.elems Map Location e
sm'
where
sm :: Map Location e
sm =
Map Location 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 (Int32 -> Int32 -> Location
Location (Int32
x forall a. Num a => a -> a -> a
- Int32
d) (Int32
y forall a. Num a => a -> a -> a
- Int32
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 (Int32 -> Int32 -> Location
Location (Int32
x forall a. Num a => a -> a -> a
+ Int32
d) (Int32
y forall a. Num a => a -> a -> a
+ Int32
1))
forall a b. a -> (a -> b) -> b
& forall a b. (a, b) -> a
fst
sm' :: Map Location 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
<= Int32
d) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> Location -> Int32
manhattan Location
o) Map Location e
sm
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
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 -> String
`appDir` String
p) 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 -> String
`appDir` String
p) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> String -> IO String
getSwarmXdgDataSubdir Bool
False String
"data"
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
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 -> String -> IO String
getSwarmXdgDataSubdir Bool
False String
""
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 String -> String -> String
</> String
"data")
]
getSwarmXdgDataSubdir :: Bool -> FilePath -> IO FilePath
getSwarmXdgDataSubdir :: Bool -> String -> IO String
getSwarmXdgDataSubdir Bool
createDirs String
subDir = do
String
swarmData <- (String -> String -> String
</> String
subDir) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
getSwarmXdgDataFile :: Bool -> FilePath -> IO FilePath
getSwarmXdgDataFile :: Bool -> String -> IO String
getSwarmXdgDataFile Bool
createDirs String
filepath = do
let (String
subDir, String
file) = String -> (String, String)
splitFileName String
filepath
String
d <- Bool -> String -> IO String
getSwarmXdgDataSubdir Bool
createDirs String
subDir
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
d String -> String -> String
</> String
file
getSwarmSavePath :: Bool -> IO FilePath
getSwarmSavePath :: Bool -> IO String
getSwarmSavePath Bool
createDirs = Bool -> String -> IO String
getSwarmXdgDataSubdir Bool
createDirs String
"saves"
getSwarmHistoryPath :: Bool -> IO FilePath
getSwarmHistoryPath :: Bool -> IO String
getSwarmHistoryPath Bool
createDirs = Bool -> String -> IO String
getSwarmXdgDataFile Bool
createDirs String
"history"
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
"\""]
bquote :: Text -> Text
bquote :: Text -> Text
bquote 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
(:|)))
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