-- | Miscellaneous helper functions used internally

{-# LANGUAGE BangPatterns, PolyKinds, GeneralizedNewtypeDeriving #-}
module Math.Combinat.Helper where

--------------------------------------------------------------------------------

import Control.Monad
import Control.Applicative ( Applicative(..) )    -- required before AMP (before GHC 7.10)
import Data.Functor.Identity

import Data.List
import Data.Ord
import Data.Proxy

import Data.Set (Set) ; import qualified Data.Set as Set
import Data.Map (Map) ; import qualified Data.Map as Map

import Debug.Trace

import System.Random
import Control.Monad.Trans.State

--------------------------------------------------------------------------------
-- * debugging

debug :: Show a => a -> b -> b
debug :: a -> b -> b
debug a
x b
y = String -> b -> b
forall a. String -> a -> a
trace (String
"-- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n") b
y

--------------------------------------------------------------------------------
-- * pairs

swap :: (a,b) -> (b,a)
swap :: (a, b) -> (b, a)
swap (a
x,b
y) = (b
y,a
x)

pairs :: [a] -> [(a,a)]
pairs :: [a] -> [(a, a)]
pairs = [a] -> [(a, a)]
forall b. [b] -> [(b, b)]
go where
  go :: [b] -> [(b, b)]
go (b
x:xs :: [b]
xs@(b
y:[b]
_)) = (b
x,b
y) (b, b) -> [(b, b)] -> [(b, b)]
forall a. a -> [a] -> [a]
: [b] -> [(b, b)]
go [b]
xs
  go [b]
_            = []

pairsWith :: (a -> a -> b) -> [a] -> [b]
pairsWith :: (a -> a -> b) -> [a] -> [b]
pairsWith a -> a -> b
f = [a] -> [b]
go where
  go :: [a] -> [b]
go (a
x:xs :: [a]
xs@(a
y:[a]
_)) = a -> a -> b
f a
x a
y b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [a] -> [b]
go [a]
xs
  go [a]
_            = []

--------------------------------------------------------------------------------
-- * lists

{-# SPECIALIZE sum' :: [Int]     -> Int     #-}
{-# SPECIALIZE sum' :: [Integer] -> Integer #-}
sum' :: Num a => [a] -> a
sum' :: [a] -> a
sum' = (a -> a -> a) -> a -> [a] -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> a -> a
forall a. Num a => a -> a -> a
(+) a
0

interleave :: [a] -> [a] -> [a]
interleave :: [a] -> [a] -> [a]
interleave (a
x:[a]
xs) (a
y:[a]
ys) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
interleave [a]
xs [a]
ys
interleave [a
x]    []     = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: []
interleave []     []     = []
interleave [a]
_      [a]
_      = String -> [a]
forall a. HasCallStack => String -> a
error String
"interleave: shouldn't happen"

evens, odds :: [a] -> [a] 
evens :: [a] -> [a]
evens (a
x:[a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
forall a. [a] -> [a]
odds [a]
xs
evens [] = []
odds :: [a] -> [a]
odds (a
x:[a]
xs) = [a] -> [a]
forall a. [a] -> [a]
evens [a]
xs
odds [] = []

--------------------------------------------------------------------------------
-- * multiplication

-- | Product of list of integers, but in interleaved order (for a list of big numbers,
-- it should be faster than the linear order)
productInterleaved :: [Integer] -> Integer
productInterleaved :: [Integer] -> Integer
productInterleaved = [Integer] -> Integer
forall a. Num a => [a] -> a
go where
  go :: [a] -> a
go []    = a
1
  go [a
x]   = a
x
  go [a
x,a
y] = a
xa -> a -> a
forall a. Num a => a -> a -> a
*a
y
  go [a]
list  = [a] -> a
go ([a] -> [a]
forall a. [a] -> [a]
evens [a]
list) a -> a -> a
forall a. Num a => a -> a -> a
* [a] -> a
go ([a] -> [a]
forall a. [a] -> [a]
odds [a]
list)

-- | Faster implementation of @product [ i | i <- [a+1..b] ]@
productFromTo :: Integral a => a -> a -> Integer
productFromTo :: a -> a -> Integer
productFromTo = a -> a -> Integer
forall a p. (Num p, Integral a) => a -> a -> p
go where
  go :: a -> a -> p
go !a
a !a
b 
    | a
dif a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
1     = p
1
    | a
dif a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
5     = [p] -> p
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [ a -> p
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i | a
i<-[a
aa -> a -> a
forall a. Num a => a -> a -> a
+a
1..a
b] ]
    | Bool
otherwise   = a -> a -> p
go a
a a
half p -> p -> p
forall a. Num a => a -> a -> a
* a -> a -> p
go a
half a
b
    where
      dif :: a
dif  = a
b a -> a -> a
forall a. Num a => a -> a -> a
- a
a
      half :: a
half = a -> a -> a
forall a. Integral a => a -> a -> a
div (a
aa -> a -> a
forall a. Num a => a -> a -> a
+a
ba -> a -> a
forall a. Num a => a -> a -> a
+a
1) a
2

-- | Faster implementation of product @[ i | i <- [a+1,a+3,..b] ]@
productFromToStride2 :: Integral a => a -> a -> Integer
productFromToStride2 :: a -> a -> Integer
productFromToStride2 = a -> a -> Integer
forall a p. (Num p, Integral a) => a -> a -> p
go where
  go :: t -> t -> p
go !t
a !t
b 
    | t
dif t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
1     = p
1
    | t
dif t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
9     = [p] -> p
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [ t -> p
forall a b. (Integral a, Num b) => a -> b
fromIntegral t
i | t
i<-[t
at -> t -> t
forall a. Num a => a -> a -> a
+t
1,t
at -> t -> t
forall a. Num a => a -> a -> a
+t
3..t
b] ]
    | Bool
otherwise   = t -> t -> p
go t
a t
half p -> p -> p
forall a. Num a => a -> a -> a
* t -> t -> p
go t
half t
b
    where
      dif :: t
dif  = t
b t -> t -> t
forall a. Num a => a -> a -> a
- t
a
      half :: t
half = t
a t -> t -> t
forall a. Num a => a -> a -> a
+ t
2t -> t -> t
forall a. Num a => a -> a -> a
*(t -> t -> t
forall a. Integral a => a -> a -> a
div t
dif t
4)

--------------------------------------------------------------------------------
-- * equality and ordering 

equating :: Eq b => (a -> b) -> a -> a -> Bool
equating :: (a -> b) -> a -> a -> Bool
equating a -> b
f a
x a
y = (a -> b
f a
x b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== a -> b
f a
y)

reverseOrdering :: Ordering -> Ordering
reverseOrdering :: Ordering -> Ordering
reverseOrdering Ordering
LT = Ordering
GT
reverseOrdering Ordering
GT = Ordering
LT
reverseOrdering Ordering
EQ = Ordering
EQ

reverseComparing :: Ord b => (a -> b) -> a -> a -> Ordering
reverseComparing :: (a -> b) -> a -> a -> Ordering
reverseComparing a -> b
f a
x a
y = b -> b -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> b
f a
y) (a -> b
f a
x)

reverseCompare :: Ord a => a -> a -> Ordering
reverseCompare :: a -> a -> Ordering
reverseCompare a
x a
y = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
y a
x   -- reverseOrdering $ compare x y

reverseSort :: Ord a => [a] -> [a]
reverseSort :: [a] -> [a]
reverseSort = (a -> a -> Ordering) -> [a] -> [a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
reverseCompare

groupSortBy :: (Eq b, Ord b) => (a -> b) -> [a] -> [[a]]
groupSortBy :: (a -> b) -> [a] -> [[a]]
groupSortBy a -> b
f = (a -> a -> Bool) -> [a] -> [[a]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ((a -> b) -> a -> a -> Bool
forall b a. Eq b => (a -> b) -> a -> a -> Bool
equating a -> b
f) ([a] -> [[a]]) -> ([a] -> [a]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> Ordering) -> [a] -> [a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((a -> b) -> a -> a -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing a -> b
f) 

nubOrd :: Ord a => [a] -> [a]
nubOrd :: [a] -> [a]
nubOrd = Set a -> [a] -> [a]
forall a. Ord a => Set a -> [a] -> [a]
worker Set a
forall a. Set a
Set.empty where
  worker :: Set a -> [a] -> [a]
worker Set a
_ [] = []
  worker Set a
s (a
x:[a]
xs) 
    | a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member a
x Set a
s = Set a -> [a] -> [a]
worker Set a
s [a]
xs
    | Bool
otherwise      = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
worker (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
s) [a]
xs

--------------------------------------------------------------------------------
-- * increasing \/ decreasing sequences

{-# SPECIALIZE isWeaklyIncreasing :: [Int] -> Bool #-}
isWeaklyIncreasing :: Ord a => [a] -> Bool
isWeaklyIncreasing :: [a] -> Bool
isWeaklyIncreasing = [a] -> Bool
forall a. Ord a => [a] -> Bool
go where
  go :: [a] -> Bool
go [a]
xs = case [a]
xs of 
    (a
a:rest :: [a]
rest@(a
b:[a]
_)) -> a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
b Bool -> Bool -> Bool
&& [a] -> Bool
go [a]
rest
    [a
_]            -> Bool
True
    []             -> Bool
True

{-# SPECIALIZE isStrictlyIncreasing :: [Int] -> Bool #-}
isStrictlyIncreasing :: Ord a => [a] -> Bool
isStrictlyIncreasing :: [a] -> Bool
isStrictlyIncreasing = [a] -> Bool
forall a. Ord a => [a] -> Bool
go where
  go :: [a] -> Bool
go [a]
xs = case [a]
xs of 
    (a
a:rest :: [a]
rest@(a
b:[a]
_)) -> a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
b Bool -> Bool -> Bool
&& [a] -> Bool
go [a]
rest
    [a
_]            -> Bool
True
    []             -> Bool
True

{-# SPECIALIZE isWeaklyDecreasing :: [Int] -> Bool #-}
isWeaklyDecreasing :: Ord a => [a] -> Bool
isWeaklyDecreasing :: [a] -> Bool
isWeaklyDecreasing = [a] -> Bool
forall a. Ord a => [a] -> Bool
go where
  go :: [a] -> Bool
go [a]
xs = case [a]
xs of 
    (a
a:rest :: [a]
rest@(a
b:[a]
_)) -> a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
b Bool -> Bool -> Bool
&& [a] -> Bool
go [a]
rest
    [a
_]            -> Bool
True
    []             -> Bool
True

{-# SPECIALIZE isStrictlyDecreasing :: [Int] -> Bool #-}
isStrictlyDecreasing :: Ord a => [a] -> Bool
isStrictlyDecreasing :: [a] -> Bool
isStrictlyDecreasing = [a] -> Bool
forall a. Ord a => [a] -> Bool
go where
  go :: [a] -> Bool
go [a]
xs = case [a]
xs of 
    (a
a:rest :: [a]
rest@(a
b:[a]
_)) -> a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
b Bool -> Bool -> Bool
&& [a] -> Bool
go [a]
rest
    [a
_]            -> Bool
True
    []             -> Bool
True

--------------------------------------------------------------------------------
-- * first \/ last 

-- | The boolean argument will @True@ only for the last element
mapWithLast :: (Bool -> a -> b) -> [a] -> [b]
mapWithLast :: (Bool -> a -> b) -> [a] -> [b]
mapWithLast Bool -> a -> b
f = [a] -> [b]
go where
  go :: [a] -> [b]
go (a
x : []) = Bool -> a -> b
f Bool
True  a
x b -> [b] -> [b]
forall a. a -> [a] -> [a]
: []
  go (a
x : [a]
xs) = Bool -> a -> b
f Bool
False a
x b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [a] -> [b]
go [a]
xs

mapWithFirst :: (Bool -> a -> b) -> [a] -> [b]
mapWithFirst :: (Bool -> a -> b) -> [a] -> [b]
mapWithFirst Bool -> a -> b
f = Bool -> [a] -> [b]
go Bool
True where
  go :: Bool -> [a] -> [b]
go Bool
b (a
x:[a]
xs) = Bool -> a -> b
f Bool
b a
x b -> [b] -> [b]
forall a. a -> [a] -> [a]
: Bool -> [a] -> [b]
go Bool
False [a]
xs 
  
mapWithFirstLast :: (Bool -> Bool -> a -> b) -> [a] -> [b]
mapWithFirstLast :: (Bool -> Bool -> a -> b) -> [a] -> [b]
mapWithFirstLast Bool -> Bool -> a -> b
f = Bool -> [a] -> [b]
go Bool
True where
  go :: Bool -> [a] -> [b]
go Bool
b (a
x : []) = Bool -> Bool -> a -> b
f Bool
b Bool
True  a
x b -> [b] -> [b]
forall a. a -> [a] -> [a]
: []
  go Bool
b (a
x : [a]
xs) = Bool -> Bool -> a -> b
f Bool
b Bool
False a
x b -> [b] -> [b]
forall a. a -> [a] -> [a]
: Bool -> [a] -> [b]
go Bool
False [a]
xs

--------------------------------------------------------------------------------
-- * older helpers for ASCII drawing

-- | extend lines with spaces so that they have the same line
mkLinesUniformWidth :: [String] -> [String]
mkLinesUniformWidth :: [String] -> [String]
mkLinesUniformWidth [String]
old = (Int -> String -> String) -> [Int] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> String -> String
worker [Int]
ls [String]
old where
  ls :: [Int]
ls = (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
old
  m :: Int
m  = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
ls
  worker :: Int -> String -> String
worker Int
l String
s = String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
l) Char
' '

mkBlocksUniformHeight :: [[String]] -> [[String]]
mkBlocksUniformHeight :: [[String]] -> [[String]]
mkBlocksUniformHeight [[String]]
old = (Int -> [String] -> [String]) -> [Int] -> [[String]] -> [[String]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> [String] -> [String]
worker [Int]
ls [[String]]
old where
  ls :: [Int]
ls = ([String] -> Int) -> [[String]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[String]]
old
  m :: Int
m  = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
ls
  worker :: Int -> [String] -> [String]
worker Int
l [String]
s = [String]
s [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Int -> String -> [String]
forall a. Int -> a -> [a]
replicate (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
l) String
""
    
mkUniformBlocks :: [[String]] -> [[String]] 
mkUniformBlocks :: [[String]] -> [[String]]
mkUniformBlocks = ([String] -> [String]) -> [[String]] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> [String]
mkLinesUniformWidth ([[String]] -> [[String]])
-> ([[String]] -> [[String]]) -> [[String]] -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [[String]]
mkBlocksUniformHeight
    
hConcatLines :: [[String]] -> [String]
hConcatLines :: [[String]] -> [String]
hConcatLines = ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String])
-> ([[String]] -> [[String]]) -> [[String]] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [[String]]
forall a. [[a]] -> [[a]]
transpose ([[String]] -> [[String]])
-> ([[String]] -> [[String]]) -> [[String]] -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [[String]]
mkUniformBlocks

vConcatLines :: [[String]] -> [String]  
vConcatLines :: [[String]] -> [String]
vConcatLines = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat

--------------------------------------------------------------------------------
-- * counting

-- helps testing the random rutines 
count :: Eq a => a -> [a] -> Int
count :: a -> [a] -> Int
count a
x [a]
xs = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int) -> [a] -> Int
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
x) [a]
xs

histogram :: (Eq a, Ord a) => [a] -> [(a,Int)]
histogram :: [a] -> [(a, Int)]
histogram [a]
xs = Map a Int -> [(a, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList Map a Int
table where
  table :: Map a Int
table = (Int -> Int -> Int) -> [(a, Int)] -> Map a Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) [ (a
x,Int
1) | a
x<-[a]
xs ] 

--------------------------------------------------------------------------------
-- * maybe

fromJust :: Maybe a -> a
fromJust :: Maybe a -> a
fromJust (Just a
x) = a
x
fromJust Maybe a
Nothing = String -> a
forall a. HasCallStack => String -> a
error String
"fromJust: Nothing"

--------------------------------------------------------------------------------
-- * bool

intToBool :: Int -> Bool
intToBool :: Int -> Bool
intToBool Int
0 = Bool
False
intToBool Int
1 = Bool
True
intToBool Int
_ = String -> Bool
forall a. HasCallStack => String -> a
error String
"intToBool"

boolToInt :: Bool -> Int 
boolToInt :: Bool -> Int
boolToInt Bool
False = Int
0
boolToInt Bool
True  = Int
1

--------------------------------------------------------------------------------
-- * iteration
    
-- iterated function application
nest :: Int -> (a -> a) -> a -> a
nest :: Int -> (a -> a) -> a -> a
nest !Int
0 a -> a
_ a
x = a
x
nest !Int
n a -> a
f a
x = Int -> (a -> a) -> a -> a
forall a. Int -> (a -> a) -> a -> a
nest (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) a -> a
f (a -> a
f a
x)

unfold1 :: (a -> Maybe a) -> a -> [a]
unfold1 :: (a -> Maybe a) -> a -> [a]
unfold1 a -> Maybe a
f a
x = case a -> Maybe a
f a
x of 
  Maybe a
Nothing -> [a
x] 
  Just a
y  -> a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> Maybe a) -> a -> [a]
forall a. (a -> Maybe a) -> a -> [a]
unfold1 a -> Maybe a
f a
y 
  
unfold :: (b -> (a,Maybe b)) -> b -> [a]
unfold :: (b -> (a, Maybe b)) -> b -> [a]
unfold b -> (a, Maybe b)
f b
y = let (a
x,Maybe b
m) = b -> (a, Maybe b)
f b
y in case Maybe b
m of 
  Maybe b
Nothing -> [a
x]
  Just b
y' -> a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (b -> (a, Maybe b)) -> b -> [a]
forall b a. (b -> (a, Maybe b)) -> b -> [a]
unfold b -> (a, Maybe b)
f b
y'

unfoldEither :: (b -> Either c (b,a)) -> b -> (c,[a])
unfoldEither :: (b -> Either c (b, a)) -> b -> (c, [a])
unfoldEither b -> Either c (b, a)
f b
y = case b -> Either c (b, a)
f b
y of
  Left c
z -> (c
z,[])
  Right (b
y,a
x) -> let (c
z,[a]
xs) = (b -> Either c (b, a)) -> b -> (c, [a])
forall b c a. (b -> Either c (b, a)) -> b -> (c, [a])
unfoldEither b -> Either c (b, a)
f b
y in (c
z,a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
  
unfoldM :: Monad m => (b -> m (a,Maybe b)) -> b -> m [a]
unfoldM :: (b -> m (a, Maybe b)) -> b -> m [a]
unfoldM b -> m (a, Maybe b)
f b
y = do
  (a
x,Maybe b
m) <- b -> m (a, Maybe b)
f b
y
  case Maybe b
m of
    Maybe b
Nothing -> [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a
x]
    Just b
y' -> do
      [a]
xs <- (b -> m (a, Maybe b)) -> b -> m [a]
forall (m :: * -> *) b a.
Monad m =>
(b -> m (a, Maybe b)) -> b -> m [a]
unfoldM b -> m (a, Maybe b)
f b
y'
      [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)

mapAccumM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumM :: (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumM acc -> x -> m (acc, y)
_ acc
s [] = (acc, [y]) -> m (acc, [y])
forall (m :: * -> *) a. Monad m => a -> m a
return (acc
s, [])
mapAccumM acc -> x -> m (acc, y)
f acc
s (x
x:[x]
xs) = do
  (acc
s1,y
y) <- acc -> x -> m (acc, y)
f acc
s x
x
  (acc
s2,[y]
ys) <- (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumM acc -> x -> m (acc, y)
f acc
s1 [x]
xs
  (acc, [y]) -> m (acc, [y])
forall (m :: * -> *) a. Monad m => a -> m a
return (acc
s2, y
yy -> [y] -> [y]
forall a. a -> [a] -> [a]
:[y]
ys)

--------------------------------------------------------------------------------
-- * long zipwith    

longZipWith :: a -> b -> (a -> b -> c) -> [a] -> [b] -> [c]
longZipWith :: a -> b -> (a -> b -> c) -> [a] -> [b] -> [c]
longZipWith a
a0 b
b0 a -> b -> c
f = [a] -> [b] -> [c]
go where
  go :: [a] -> [b] -> [c]
go (a
x:[a]
xs) (b
y:[b]
ys)  =   a -> b -> c
f a
x  b
y c -> [c] -> [c]
forall a. a -> [a] -> [a]
: [a] -> [b] -> [c]
go [a]
xs [b]
ys
  go []     [b]
ys      = [ a -> b -> c
f a
a0 b
y | b
y<-[b]
ys ]
  go [a]
xs     []      = [ a -> b -> c
f a
x b
b0 | a
x<-[a]
xs ]

{-
longZipWithZero :: (Num a, Num b) => (a -> b -> c) -> [a] -> [b] -> [c]
longZipWithZero = longZipWith 0 0 
-}

--------------------------------------------------------------------------------
-- * random

-- | A simple random monad to make life suck less
type Rand g = RandT g Identity

runRand :: Rand g a -> g -> (a,g)
runRand :: Rand g a -> g -> (a, g)
runRand Rand g a
action g
g = Identity (a, g) -> (a, g)
forall a. Identity a -> a
runIdentity (Rand g a -> g -> Identity (a, g)
forall g (m :: * -> *) a. RandT g m a -> g -> m (a, g)
runRandT Rand g a
action g
g)

flipRunRand :: Rand s a -> s -> (s,a)
flipRunRand :: Rand s a -> s -> (s, a)
flipRunRand Rand s a
action s
g = Identity (s, a) -> (s, a)
forall a. Identity a -> a
runIdentity (Rand s a -> s -> Identity (s, a)
forall (m :: * -> *) s a. Monad m => RandT s m a -> s -> m (s, a)
flipRunRandT Rand s a
action s
g)


-- | The Rand monad transformer
newtype RandT g m a = RandT (StateT g m a) deriving (a -> RandT g m b -> RandT g m a
(a -> b) -> RandT g m a -> RandT g m b
(forall a b. (a -> b) -> RandT g m a -> RandT g m b)
-> (forall a b. a -> RandT g m b -> RandT g m a)
-> Functor (RandT g m)
forall a b. a -> RandT g m b -> RandT g m a
forall a b. (a -> b) -> RandT g m a -> RandT g m b
forall g (m :: * -> *) a b.
Functor m =>
a -> RandT g m b -> RandT g m a
forall g (m :: * -> *) a b.
Functor m =>
(a -> b) -> RandT g m a -> RandT g m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> RandT g m b -> RandT g m a
$c<$ :: forall g (m :: * -> *) a b.
Functor m =>
a -> RandT g m b -> RandT g m a
fmap :: (a -> b) -> RandT g m a -> RandT g m b
$cfmap :: forall g (m :: * -> *) a b.
Functor m =>
(a -> b) -> RandT g m a -> RandT g m b
Functor,Functor (RandT g m)
a -> RandT g m a
Functor (RandT g m)
-> (forall a. a -> RandT g m a)
-> (forall a b. RandT g m (a -> b) -> RandT g m a -> RandT g m b)
-> (forall a b c.
    (a -> b -> c) -> RandT g m a -> RandT g m b -> RandT g m c)
-> (forall a b. RandT g m a -> RandT g m b -> RandT g m b)
-> (forall a b. RandT g m a -> RandT g m b -> RandT g m a)
-> Applicative (RandT g m)
RandT g m a -> RandT g m b -> RandT g m b
RandT g m a -> RandT g m b -> RandT g m a
RandT g m (a -> b) -> RandT g m a -> RandT g m b
(a -> b -> c) -> RandT g m a -> RandT g m b -> RandT g m c
forall a. a -> RandT g m a
forall a b. RandT g m a -> RandT g m b -> RandT g m a
forall a b. RandT g m a -> RandT g m b -> RandT g m b
forall a b. RandT g m (a -> b) -> RandT g m a -> RandT g m b
forall a b c.
(a -> b -> c) -> RandT g m a -> RandT g m b -> RandT g m c
forall g (m :: * -> *). Monad m => Functor (RandT g m)
forall g (m :: * -> *) a. Monad m => a -> RandT g m a
forall g (m :: * -> *) a b.
Monad m =>
RandT g m a -> RandT g m b -> RandT g m a
forall g (m :: * -> *) a b.
Monad m =>
RandT g m a -> RandT g m b -> RandT g m b
forall g (m :: * -> *) a b.
Monad m =>
RandT g m (a -> b) -> RandT g m a -> RandT g m b
forall g (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> RandT g m a -> RandT g m b -> RandT g m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: RandT g m a -> RandT g m b -> RandT g m a
$c<* :: forall g (m :: * -> *) a b.
Monad m =>
RandT g m a -> RandT g m b -> RandT g m a
*> :: RandT g m a -> RandT g m b -> RandT g m b
$c*> :: forall g (m :: * -> *) a b.
Monad m =>
RandT g m a -> RandT g m b -> RandT g m b
liftA2 :: (a -> b -> c) -> RandT g m a -> RandT g m b -> RandT g m c
$cliftA2 :: forall g (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> RandT g m a -> RandT g m b -> RandT g m c
<*> :: RandT g m (a -> b) -> RandT g m a -> RandT g m b
$c<*> :: forall g (m :: * -> *) a b.
Monad m =>
RandT g m (a -> b) -> RandT g m a -> RandT g m b
pure :: a -> RandT g m a
$cpure :: forall g (m :: * -> *) a. Monad m => a -> RandT g m a
$cp1Applicative :: forall g (m :: * -> *). Monad m => Functor (RandT g m)
Applicative,Applicative (RandT g m)
a -> RandT g m a
Applicative (RandT g m)
-> (forall a b. RandT g m a -> (a -> RandT g m b) -> RandT g m b)
-> (forall a b. RandT g m a -> RandT g m b -> RandT g m b)
-> (forall a. a -> RandT g m a)
-> Monad (RandT g m)
RandT g m a -> (a -> RandT g m b) -> RandT g m b
RandT g m a -> RandT g m b -> RandT g m b
forall a. a -> RandT g m a
forall a b. RandT g m a -> RandT g m b -> RandT g m b
forall a b. RandT g m a -> (a -> RandT g m b) -> RandT g m b
forall g (m :: * -> *). Monad m => Applicative (RandT g m)
forall g (m :: * -> *) a. Monad m => a -> RandT g m a
forall g (m :: * -> *) a b.
Monad m =>
RandT g m a -> RandT g m b -> RandT g m b
forall g (m :: * -> *) a b.
Monad m =>
RandT g m a -> (a -> RandT g m b) -> RandT g m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> RandT g m a
$creturn :: forall g (m :: * -> *) a. Monad m => a -> RandT g m a
>> :: RandT g m a -> RandT g m b -> RandT g m b
$c>> :: forall g (m :: * -> *) a b.
Monad m =>
RandT g m a -> RandT g m b -> RandT g m b
>>= :: RandT g m a -> (a -> RandT g m b) -> RandT g m b
$c>>= :: forall g (m :: * -> *) a b.
Monad m =>
RandT g m a -> (a -> RandT g m b) -> RandT g m b
$cp1Monad :: forall g (m :: * -> *). Monad m => Applicative (RandT g m)
Monad)

runRandT :: RandT g m a -> g -> m (a,g)
runRandT :: RandT g m a -> g -> m (a, g)
runRandT (RandT StateT g m a
stuff) = StateT g m a -> g -> m (a, g)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT g m a
stuff

-- | This may be occasionally useful
flipRunRandT :: Monad m => RandT s m a -> s -> m (s,a)
flipRunRandT :: RandT s m a -> s -> m (s, a)
flipRunRandT RandT s m a
action s
ini = ((a, s) -> (s, a)) -> m (a, s) -> m (s, a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a, s) -> (s, a)
forall a b. (a, b) -> (b, a)
swap (m (a, s) -> m (s, a)) -> m (a, s) -> m (s, a)
forall a b. (a -> b) -> a -> b
$ RandT s m a -> s -> m (a, s)
forall g (m :: * -> *) a. RandT g m a -> g -> m (a, g)
runRandT RandT s m a
action s
ini


-- | Puts a standard-conforming random function into the monad
rand :: (g -> (a,g)) -> Rand g a
rand :: (g -> (a, g)) -> Rand g a
rand g -> (a, g)
user = StateT g Identity a -> Rand g a
forall g (m :: * -> *) a. StateT g m a -> RandT g m a
RandT ((g -> (a, g)) -> StateT g Identity a
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state g -> (a, g)
user)

randRoll :: (RandomGen g, Random a) => Rand g a
randRoll :: Rand g a
randRoll = (g -> (a, g)) -> Rand g a
forall g a. (g -> (a, g)) -> Rand g a
rand g -> (a, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random

randChoose :: (RandomGen g, Random a) => (a,a) -> Rand g a
randChoose :: (a, a) -> Rand g a
randChoose (a, a)
uv = (g -> (a, g)) -> Rand g a
forall g a. (g -> (a, g)) -> Rand g a
rand ((a, a) -> g -> (a, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (a, a)
uv)

randProxy1 :: Rand g (f n) -> Proxy n -> Rand g (f n)
randProxy1 :: Rand g (f n) -> Proxy n -> Rand g (f n)
randProxy1 Rand g (f n)
action Proxy n
_ = Rand g (f n)
action

--------------------------------------------------------------------------------