-- This file is part of Goatee.
--
-- Copyright 2014-2021 Bryan Gardiner
--
-- Goatee is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- Goatee is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.

-- | Common utilities used throughout the project.
module Game.Goatee.Common (
  listDeleteAt,
  listInsertAt,
  listReplace,
  listUpdate,
  andEithers,
  for,
  mapTuple,
  mapInvert,
  whenMaybe,
  cond,
  if',
  andM,
  forIndexM_,
  whileM,
  whileM',
  whileM'',
  doWhileM,
  ) where

import Control.Arrow ((***))
import Control.Monad (forM_, join, when)
import Data.Either (partitionEithers)
import qualified Data.Map as Map
import Data.Map (Map)

-- | Drops the element at an index from a list.  If the index is out of bounds
-- then the list is returned unmodified.
listDeleteAt :: Int -> [a] -> [a]
listDeleteAt :: Int -> [a] -> [a]
listDeleteAt Int
index [a]
list = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
index [a]
list [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [a]
list

-- | Inserts the element into the list before the given position.  If the
-- position is less than 0 or greater than the length of the list, then the
-- index is clamped to this range.
listInsertAt :: Int -> a -> [a] -> [a]
listInsertAt :: Int -> a -> [a] -> [a]
listInsertAt Int
index a
x [a]
xs =
  let ([a]
before, [a]
after) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
index [a]
xs
  in [a]
before [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
after

-- | @listReplace old new list@ replaces all occurrences of @old@ with @new@ in
-- @list@.
listReplace :: Eq a => a -> a -> [a] -> [a]
listReplace :: a -> a -> [a] -> [a]
listReplace a
from a
to = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> a) -> [a] -> [a]) -> (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ a -> a -> a -> a
forall p. Eq p => p -> p -> p -> p
replace a
from a
to
  where replace :: p -> p -> p -> p
replace p
from p
to p
x = if p
x p -> p -> Bool
forall a. Eq a => a -> a -> Bool
== p
from then p
to else p
x

-- | Modifies the element at a specific index in a list.
listUpdate :: Show a => (a -> a) -> Int -> [a] -> [a]
listUpdate :: (a -> a) -> Int -> [a] -> [a]
listUpdate a -> a
fn Int
ix [a]
xs = Int -> [a] -> [a]
forall t. (Eq t, Num t) => t -> [a] -> [a]
listSet' Int
ix [a]
xs
  where listSet' :: t -> [a] -> [a]
listSet' t
0 (a
x':[a]
xs') = a -> a
fn a
x'a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs'
        listSet' t
ix' (a
x':[a]
xs') = a
x'a -> [a] -> [a]
forall a. a -> [a] -> [a]
:t -> [a] -> [a]
listSet' (t
ix' t -> t -> t
forall a. Num a => a -> a -> a
- t
1) [a]
xs'
        listSet' t
_ [a]
_ = [Char] -> [a]
forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot update index " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
ix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                              [Char]
" of list " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [a] -> [Char]
forall a. Show a => a -> [Char]
show [a]
xs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".")

-- | If any item is a 'Left', then the list of 'Left's is returned, otherwise
-- the list of 'Right's is returned.
andEithers :: [Either a b] -> Either [a] [b]
andEithers :: [Either a b] -> Either [a] [b]
andEithers [Either a b]
xs = let ([a]
as, [b]
bs) = [Either a b] -> ([a], [b])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either a b]
xs
                in if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
as then [a] -> Either [a] [b]
forall a b. a -> Either a b
Left [a]
as else [b] -> Either [a] [b]
forall a b. b -> Either a b
Right [b]
bs

-- | @for@ is @flip map@.
for :: [a] -> (a -> b) -> [b]
for :: [a] -> (a -> b) -> [b]
for = ((a -> b) -> [a] -> [b]) -> [a] -> (a -> b) -> [b]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map

-- | Transforms both values in a homogeneous tuple.
mapTuple :: (a -> b) -> (a, a) -> (b, b)
mapTuple :: (a -> b) -> (a, a) -> (b, b)
mapTuple = ((a -> b) -> (a -> b) -> (a, a) -> (b, b))
-> (a -> b) -> (a, a) -> (b, b)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (a -> b) -> (a -> b) -> (a, a) -> (b, b)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
(***)

-- | Inverts a map, collecting all of the keys that map to a single value in one
-- list in the result map.  No guarantees are made on the order of the keys in
-- each value's list.  If you want the results in ascending order, apply
-- @'Data.Map.map' 'Data.List.sort'@ to the result.
mapInvert :: Ord v => Map k v -> Map v [k]
mapInvert :: Map k v -> Map v [k]
mapInvert = ([k] -> [k] -> [k]) -> [(v, [k])] -> Map v [k]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [k] -> [k] -> [k]
forall a. [a] -> [a] -> [a]
(++) ([(v, [k])] -> Map v [k])
-> (Map k v -> [(v, [k])]) -> Map k v -> Map v [k]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, v) -> (v, [k])) -> [(k, v)] -> [(v, [k])]
forall a b. (a -> b) -> [a] -> [b]
map (\(k
k, v
v) -> (v
v, [k
k])) ([(k, v)] -> [(v, [k])])
-> (Map k v -> [(k, v)]) -> Map k v -> [(v, [k])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
Map.assocs

-- | Executes the monadic function if a 'Maybe' contains a value.
whenMaybe :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenMaybe :: Maybe a -> (a -> m ()) -> m ()
whenMaybe = ((a -> m ()) -> Maybe a -> m ()) -> Maybe a -> (a -> m ()) -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((a -> m ()) -> Maybe a -> m ())
 -> Maybe a -> (a -> m ()) -> m ())
-> ((a -> m ()) -> Maybe a -> m ())
-> Maybe a
-> (a -> m ())
-> m ()
forall a b. (a -> b) -> a -> b
$ m () -> (a -> m ()) -> Maybe a -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Finds the first tuple whose first element is true, and returns its second
-- element.  If all of the first values are false, then the first argument to
-- @cond@ is returned instead.
cond :: a -> [(Bool, a)] -> a
cond :: a -> [(Bool, a)] -> a
cond a
fallback ((Bool
test, a
body):[(Bool, a)]
rest) = if Bool
test then a
body else a -> [(Bool, a)] -> a
forall a. a -> [(Bool, a)] -> a
cond a
fallback [(Bool, a)]
rest
cond a
fallback [(Bool, a)]
_ = a
fallback

-- | A function form of @if@ that takes its test last.
if' :: a -> a -> Bool -> a
if' :: a -> a -> Bool -> a
if' a
true a
false Bool
test = if Bool
test then a
true else a
false

-- | 'and' in a monad.  Executes the actions in the list in order.  If any
-- action returns false then the remaining actions are skipped and the result is
-- false.  Otherwise all actions returned true, and the result is true.  An
-- empty list returns true.
andM :: Monad m => [m Bool] -> m Bool
andM :: [m Bool] -> m Bool
andM (m Bool
x:[m Bool]
xs) = m Bool
x m Bool -> (Bool -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m Bool -> m Bool -> Bool -> m Bool
forall a. a -> a -> Bool -> a
if' ([m Bool] -> m Bool
forall (m :: * -> *). Monad m => [m Bool] -> m Bool
andM [m Bool]
xs) (Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
andM [m Bool]
_ = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- | 'forM_' that also passes in the index of each element.
forIndexM_ :: Monad m => [a] -> (Int -> a -> m ()) -> m ()
forIndexM_ :: [a] -> (Int -> a -> m ()) -> m ()
forIndexM_ [a]
list = [(Int, a)] -> ((Int, a) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [a]
list) (((Int, a) -> m ()) -> m ())
-> ((Int -> a -> m ()) -> (Int, a) -> m ())
-> (Int -> a -> m ())
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> a -> m ()) -> (Int, a) -> m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry

-- | @whileM test body@ repeatedly evaluates @test@ until it returns false.
-- Every time @test@ returns true, @body@ is executed once.
whileM :: Monad m => m Bool -> m () -> m ()
whileM :: m Bool -> m () -> m ()
whileM m Bool
test m ()
body = do Bool
x <- m Bool
test
                      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
x (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m ()
body m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whileM m Bool
test m ()
body

-- | @whileM' test body@ repeatedly evaluates @test@ until it returns 'Nothing'.
-- Every time it returns a 'Just', that value is passed to @body@ and the result
-- is executed.
whileM' :: Monad m => m (Maybe a) -> (a -> m ()) -> m ()
whileM' :: m (Maybe a) -> (a -> m ()) -> m ()
whileM' m (Maybe a)
test a -> m ()
body = do Maybe a
x <- m (Maybe a)
test
                       case Maybe a
x of
                         Maybe a
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                         Just a
y -> a -> m ()
body a
y m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m (Maybe a) -> (a -> m ()) -> m ()
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whileM' m (Maybe a)
test a -> m ()
body

-- | A while loop that supports returning a value, and also exiting early from
-- the body.
--
-- @whileM'' test body@ repeatedly evaluates @test@.  If the test produces a
-- @Right a@, then @body a@ is evaluated, and the loop will either repeat (if
-- @body@ returns @Nothing@) or exit (if @body@ returns a @Just r@).  If @test@
-- produces a @Left r@ at any point, then the loop immediately exits with that
-- @r@ value.
whileM'' :: Monad m => m (Either r a) -> (a -> m (Maybe r)) -> m r
whileM'' :: m (Either r a) -> (a -> m (Maybe r)) -> m r
whileM'' m (Either r a)
test a -> m (Maybe r)
body =
  m (Either r a)
test m (Either r a) -> (Either r a -> m r) -> m r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left r
r -> r -> m r
forall (m :: * -> *) a. Monad m => a -> m a
return r
r
    Right a
a -> a -> m (Maybe r)
body a
a m (Maybe r) -> (Maybe r -> m r) -> m r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just r
r -> r -> m r
forall (m :: * -> *) a. Monad m => a -> m a
return r
r
      Maybe r
Nothing -> m (Either r a) -> (a -> m (Maybe r)) -> m r
forall (m :: * -> *) r a.
Monad m =>
m (Either r a) -> (a -> m (Maybe r)) -> m r
whileM'' m (Either r a)
test a -> m (Maybe r)
body

-- | @doWhileM init body@ repeatedly calls @body@ with @init@.  As long as
-- @body@ returns a @Right@ value, it is re-executed with the returned value.
-- When it returns a @Left@ value, the loop stops and the value is returned.
doWhileM :: Monad m => a -> (a -> m (Either b a)) -> m b
doWhileM :: a -> (a -> m (Either b a)) -> m b
doWhileM a
init a -> m (Either b a)
body = do
  Either b a
value <- a -> m (Either b a)
body a
init
  case Either b a
value of
    Right a
next -> a -> (a -> m (Either b a)) -> m b
forall (m :: * -> *) a b.
Monad m =>
a -> (a -> m (Either b a)) -> m b
doWhileM a
next a -> m (Either b a)
body
    Left b
end -> b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
end