------------------------------------------------------------------------
-- |
-- Module      :  ALife.Creatur.Util
-- Copyright   :  (c) 2011-2021 Amy de Buitléir
-- License     :  BSD-style
-- Maintainer  :  amy@nualeargais.ie
-- Stability   :  experimental
-- Portability :  portable
--
-- Utility functions that don't fit anywhere else.
--
------------------------------------------------------------------------
module ALife.Creatur.Util
  (
    -- * Integers
    ilogBase,
    isPowerOf,
    isqrt,
    perfectSquare,
    -- * Arrays
    cropRect,
    cropSquare,
    -- * Sequences
    replaceElement,
    reverseLookup,
    rotate,
    safeReplaceElement,
    shuffle,
    -- * Bits/Booleans
    boolsToBits,
    showBin,
    -- * Monads
    stateMap,
    fromEither,
    catEithers,
    modifyLift,
    getLift
--    constrain,
  ) where

import Control.Monad (forM_, liftM)
import Control.Monad.Random (Rand, RandomGen, getRandomRs)
import Control.Monad.State (StateT(..), get, lift, put)
import Data.Array.ST (runSTArray)
import Data.Char (intToDigit)
import Data.List.Split (chunksOf)
import GHC.Arr (elems, listArray, readSTArray, thawSTArray, writeSTArray)
import Numeric (showIntAtBase)

-- constrain :: Ord a => (a, a) -> a -> a
-- constrain (a,b) x | b < a     = error "Invalid range"
--                   | x < a     = a
--                   | x > b     = b
--                   | otherwise = x

-- | From <http://www.haskell.org/haskellwiki/Random_shuffle>
shuffle :: RandomGen g => [a] -> Rand g [a]
shuffle :: [a] -> Rand g [a]
shuffle [a]
xs = do
  let l :: Int
l = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
  [Int]
rands <- Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
l ([Int] -> [Int])
-> RandT g Identity [Int] -> RandT g Identity [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Int, Int) -> RandT g Identity [Int]
forall (m :: * -> *) a.
(MonadRandom m, Random a) =>
(a, a) -> m [a]
getRandomRs (Int
0, Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
  let ar :: Array Int a
ar = (forall s. ST s (STArray s Int a)) -> Array Int a
forall i e. (forall s. ST s (STArray s i e)) -> Array i e
runSTArray ((forall s. ST s (STArray s Int a)) -> Array Int a)
-> (forall s. ST s (STArray s Int a)) -> Array Int a
forall a b. (a -> b) -> a -> b
$ do
             STArray s Int a
ar' <- Array Int a -> ST s (STArray s Int a)
forall i e s. Array i e -> ST s (STArray s i e)
thawSTArray (Array Int a -> ST s (STArray s Int a))
-> Array Int a -> ST s (STArray s Int a)
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> [a] -> Array Int a
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [a]
xs
             [(Int, Int)] -> ((Int, Int) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..(Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)] [Int]
rands) (((Int, Int) -> ST s ()) -> ST s ())
-> ((Int, Int) -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, Int
j) -> do
               a
vi <- STArray s Int a -> Int -> ST s a
forall i s e. Ix i => STArray s i e -> i -> ST s e
readSTArray STArray s Int a
ar' Int
i
               a
vj <- STArray s Int a -> Int -> ST s a
forall i s e. Ix i => STArray s i e -> i -> ST s e
readSTArray STArray s Int a
ar' Int
j
               STArray s Int a -> Int -> a -> ST s ()
forall i s e. Ix i => STArray s i e -> i -> e -> ST s ()
writeSTArray STArray s Int a
ar' Int
j a
vi
               STArray s Int a -> Int -> a -> ST s ()
forall i s e. Ix i => STArray s i e -> i -> e -> ST s ()
writeSTArray STArray s Int a
ar' Int
i a
vj
             STArray s Int a -> ST s (STArray s Int a)
forall (m :: * -> *) a. Monad m => a -> m a
return STArray s Int a
ar'
  [a] -> Rand g [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Array Int a -> [a]
forall i e. Array i e -> [e]
elems Array Int a
ar)

-- | @'safeReplaceElement' xs n x@ returns a copy of @xs@ in which the @n@th
--   element (if it exists) has been replaced with @x@.
safeReplaceElement :: [a] -> Int -> a -> [a]
safeReplaceElement :: [a] -> Int -> a -> [a]
safeReplaceElement [a]
xs Int
i a
x =
  if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
    then [a] -> Int -> a -> [a]
forall a. [a] -> Int -> a -> [a]
replaceElement [a]
xs Int
i a
x
    else [a]
xs

-- | @'replaceElement' xs n x@ returns a copy of @xs@ in which the @n@th
--   element has been replaced with @x@. Causes an exception if @xs@ has
--   fewer than @n+1@ elements. Compare with @'safeReplaceElement'@.
replaceElement :: [a] -> Int -> a -> [a]
replaceElement :: [a] -> Int -> a -> [a]
replaceElement [a]
xs Int
i a
x =
  if Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs then [a]
fore [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
aft) else [a]
xs
  where fore :: [a]
fore = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
i [a]
xs
        aft :: [a]
aft = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [a]
xs

-- | Assuming @xs@ is a sequence containing the elements of a square matrix,
--   @'cropSquare' n xs@ returns the elements of the submatrix of size @n@x@n@,
--   centred within the original matrix @xs@.
--
--   Example: Suppose we have a /5/x/5/ matrix and we want to extract the
--   central /3/x/3/ submatrix, as illustrated below.
--
-- > a b c d e
-- > f g h i j            g h i
-- > k l m n o    --->    l m n
-- > p q r s t            q r s
-- > u v w x y
--
--   We can represent the elements of the original matrix as @[\'a\'..\'y\']@.
--   The elements of the submatrix are
--   @[\'g\', \'h\', \'i\', \'l\', \'m\', \'n\', \'q\', \'r\', \'s\']@,
--   or equivalently, @\"ghilmnqrs\"@. And that is what
--   @'cropSquare' 3 [\'a\'..\'y\']@ returns.
cropSquare :: Int -> [a] -> [a]
cropSquare :: Int -> [a] -> [a]
cropSquare Int
n [a]
xs | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0     = []
                | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
m     =
                    (Int, Int) -> (Int, Int) -> [a] -> Int -> [a]
forall a. (Int, Int) -> (Int, Int) -> [a] -> Int -> [a]
cropRect (Int
margin, Int
margin) (Int
marginInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, Int
marginInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [a]
xs Int
m
                | Bool
otherwise = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
m) [a]
xs
  where m :: Int
m = (Int -> Int
forall a b. (Integral a, Integral b) => a -> b
isqrt (Int -> Int) -> ([a] -> Int) -> [a] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [a]
xs
        margin :: Int
margin = (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2

-- | Assuming @xs@ is a sequence containing the elements of a matrix with @k@
--   columns, @'cropRect' (a,b) (c, d) k xs@ returns the elements of the
--   submatrix from @(a,b)@ in the upper left corner to @(c,d)@ in the lower
--   right corner).
--   Note: Matrix indices begin at @(0,0)@.
--
--   Example: Suppose we have a /4/x/6/ matrix and we want to extract the
--   submatrix from (1,2) to (2,4), as illustrated below.
--
-- > a b c d e f
-- > g h i j k l    --->   i j k
-- > m n o p q r           o p q
-- > s t u v w x
--
--   We can represent the elements of the original matrix as @[\'a\'..\'x\']@.
--   The elements of the submatrix are
--   @[\'i\', \'j\', \'k\', \'o\', \'p\', \'q\']@, or equivalently,
--   @\"ijkopq\"@. And that is what @'cropRect' (1,2) (2,4) 6 [\'a\'..\'x\']@
--   returns.
cropRect :: (Int, Int) -> (Int, Int) -> [a] -> Int -> [a]
cropRect :: (Int, Int) -> (Int, Int) -> [a] -> Int -> [a]
cropRect (Int
a,Int
b) (Int
c, Int
d) [a]
xs Int
k = ([a] -> [a]) -> [[a]] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [a] -> [a]
forall a. [a] -> [a]
f [[a]]
selectedRows
  where rows :: [[a]]
rows = if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 then [] else Int -> [a] -> [[a]]
forall e. Int -> [e] -> [[e]]
chunksOf Int
k [a]
xs
        selectedRows :: [[a]]
selectedRows = Int -> Int -> [[a]] -> [[a]]
forall a. Int -> Int -> [a] -> [a]
safeSlice Int
a Int
c [[a]]
rows
        f :: [a] -> [a]
f = Int -> Int -> [a] -> [a]
forall a. Int -> Int -> [a] -> [a]
safeSlice Int
b Int
d

safeSlice :: Int -> Int -> [a] -> [a]
safeSlice :: Int -> Int -> [a] -> [a]
safeSlice Int
a Int
b = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
a ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int
bInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

-- | @'isqrt' n@ returns the greatest integer not greater than the square root
--   of @n@.
isqrt :: (Integral a, Integral b) => a -> b
isqrt :: a -> b
isqrt a
n = (Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> b) -> (Float -> Float) -> Float -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float
forall a. Floating a => a -> a
sqrt) Float
n'
  where n' :: Float
n' = a -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n :: Float

-- | @'ilogBase' n m@ returns the greatest integer not greater than the log
--   base n of @m@.
ilogBase :: (Integral a, Integral b, Integral c) => a -> b -> c
ilogBase :: a -> b -> c
ilogBase a
n b
m = (Float -> c
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> c) -> (Float -> Float) -> Float -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float -> Float
forall a. Floating a => a -> a -> a
logBase Float
n') Float
m'
  where n' :: Float
n' = a -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n :: Float
        m' :: Float
m' = b -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
m :: Float

-- | @'perfectSquare' n@ returns @True@ if @n@ is a perfect square (i.e., if
--   there exists an _integer_ m such that m*m = n)
perfectSquare :: Integral a => a -> Bool
perfectSquare :: a -> Bool
perfectSquare a
n = a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
ma -> a -> a
forall a. Num a => a -> a -> a
*a
m
  where m :: a
m = a -> a
forall a b. (Integral a, Integral b) => a -> b
isqrt a
n

-- | @n 'isPowerOf' m@ returns @True@ if @n@ is a power of m (i.e., if
--   there exists an _integer_ k such that m^k = n)
isPowerOf :: Integral a => a -> a -> Bool
isPowerOf :: a -> a -> Bool
isPowerOf a
n a
m = a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
ma -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^Int
k
  where k :: Int
k = a -> a -> Int
forall a b c. (Integral a, Integral b, Integral c) => a -> b -> c
ilogBase a
m a
n :: Int

reverseLookup :: (Eq b) => b -> [(a,b)] -> Maybe a
reverseLookup :: b -> [(a, b)] -> Maybe a
reverseLookup b
_ []          =  Maybe a
forall a. Maybe a
Nothing
reverseLookup b
value ((a
x,b
y):[(a, b)]
xys)
    | b
value b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
y =  a -> Maybe a
forall a. a -> Maybe a
Just a
x
    | Bool
otherwise  =  b -> [(a, b)] -> Maybe a
forall b a. Eq b => b -> [(a, b)] -> Maybe a
reverseLookup b
value [(a, b)]
xys

stateMap :: Monad m => (s -> t) -> (t -> s) -> StateT s m a -> StateT t m a
stateMap :: (s -> t) -> (t -> s) -> StateT s m a -> StateT t m a
stateMap s -> t
f t -> s
g (StateT s -> m (a, s)
h) = (t -> m (a, t)) -> StateT t m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((t -> m (a, t)) -> StateT t m a)
-> (t -> m (a, t)) -> StateT t m a
forall a b. (a -> b) -> a -> b
$ ((a, s) -> (a, t)) -> m (a, s) -> m (a, t)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((s -> t) -> (a, s) -> (a, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap s -> t
f) (m (a, s) -> m (a, t)) -> (t -> m (a, s)) -> t -> m (a, t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m (a, s)
h (s -> m (a, s)) -> (t -> s) -> t -> m (a, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> s
g

-- | The 'fromEither' function takes a default value and an 'Either'
--   value.  If the 'Either' is 'Left', it returns the default value;
--   otherwise, it returns the value contained in the 'Right'.
fromEither     :: a -> Either e a -> a
fromEither :: a -> Either e a -> a
fromEither a
d Either e a
x = case Either e a
x of {Left e
_ -> a
d; Right a
v  -> a
v}

-- | Takes a list of 'Either's and returns a list of all the 'Right'
--   values.
catEithers              :: [Either e a] -> [a]
catEithers :: [Either e a] -> [a]
catEithers [Either e a]
ls = [a
x | Right a
x <- [Either e a]
ls]

-- | Like modify, but the function that maps the old state to the
--   new state operates in the inner monad.
--   For example,
--
--   > s <- get
--   > s' = lift $ f s
--   > put s'
--
--   can be replaced with
--
--   > modifyLift f
modifyLift :: Monad m => (s -> m s) -> StateT s m ()
modifyLift :: (s -> m s) -> StateT s m ()
modifyLift s -> m s
f = StateT s m s
forall s (m :: * -> *). MonadState s m => m s
get StateT s m s -> (s -> StateT s m s) -> StateT s m s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m s -> StateT s m s
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m s -> StateT s m s) -> (s -> m s) -> s -> StateT s m s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m s
f StateT s m s -> (s -> StateT s m ()) -> StateT s m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> StateT s m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put

-- | Invoke a function in the inner monad, and pass the state as
--   a parameter.
--   Similar to modifyLift, but the function being invoked doesn't
--   have a return value, so the state is not modified.
--   For example,
--
--   > s <- get
--   > s' = lift $ f s
--
--   can be replaced with
--
--   > getLift f
getLift :: Monad m => (s -> m ()) -> StateT s m ()
getLift :: (s -> m ()) -> StateT s m ()
getLift s -> m ()
f = StateT s m s
forall s (m :: * -> *). MonadState s m => m s
get StateT s m s -> (s -> StateT s m ()) -> StateT s m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ()) -> (s -> m ()) -> s -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
f StateT s m () -> StateT s m () -> StateT s m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> StateT s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

rotate :: [a] -> [a]
rotate :: [a] -> [a]
rotate [] = []
rotate (a
x:[a]
xs) = [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
x]

-- | Convert a list of bits to a string of @0@s and @1@s.
boolsToBits :: [Bool] -> String
boolsToBits :: [Bool] -> String
boolsToBits = (Bool -> Char) -> [Bool] -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Bool
b -> if Bool
b then Char
'1' else Char
'0')

-- | Show /non-negative/ 'Integral' numbers in binary.
showBin :: (Integral a,Show a) => a -> ShowS
showBin :: a -> ShowS
showBin = a -> (Int -> Char) -> a -> ShowS
forall a. (Integral a, Show a) => a -> (Int -> Char) -> a -> ShowS
showIntAtBase a
2 Int -> Char
intToDigit