{-# language PatternSignatures, TypeApplications, TupleSections #-}

module Autolib.Util.Zufall 

( module Autolib.Util.Zufall
, module Autolib.Util.RandoM
)

where

import Autolib.Util.RandoM

import Data.List ( sort )
import Control.Monad ( forM, foldM, replicateM, void )

import Math.Combinatorics.Exact.Binomial (choose)

import qualified Data.Map.Strict as M

someIO :: RandomC m => [a] -> Int -> m [a]
someIO :: forall (m :: * -> *) a. RandomC m => [a] -> Int -> m [a]
someIO [a]
alpha Int
0 = [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
someIO [a]
alpha Int
k = do
    x <- [a] -> m a
forall (m :: * -> *) a. RandomC m => [a] -> m a
eins [a]
alpha
    xs <- someIO alpha (k-1)
    return $ x : xs

entweder :: RandomC m => m a -> m a -> m a
entweder :: forall (m :: * -> *) a. RandomC m => m a -> m a -> m a
entweder m a
x m a
y = do
    f <- (Bool, Bool) -> m Bool
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (RandomC m, Random a) => (a, a) -> m a
randomRIO (Bool
False, Bool
True)
    if f then x else y

entweders ::  RandomC m => [ m a ] -> m a
entweders :: forall (m :: * -> *) a. RandomC m => [m a] -> m a
entweders [m a]
acts = do
    act <- [m a] -> m (m a)
forall (m :: * -> *) a. RandomC m => [a] -> m a
eins [m a]
acts
    act

eins :: RandomC m =>  [a] -> m a
eins :: forall (m :: * -> *) a. RandomC m => [a] -> m a
eins [] = [Char] -> m a
forall a. HasCallStack => [Char] -> a
error [Char]
"Autolib.Util.Zufall.eins []"
eins [a]
xs =  do
    k <- (Int, Int) -> m Int
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (RandomC m, Random a) => (a, a) -> m a
randomRIO (Int
1, [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs)
    return $ xs !! (k - 1)

einige ::  RandomC m => Int -> [a] -> m [a]
einige :: forall (m :: * -> *) a. RandomC m => Int -> [a] -> m [a]
einige Int
n [a]
xs = [m a] -> m [a]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([m a] -> m [a]) -> [m a] -> m [a]
forall a b. (a -> b) -> a -> b
$ Int -> m a -> [m a]
forall a. Int -> a -> [a]
replicate Int
n (m a -> [m a]) -> m a -> [m a]
forall a b. (a -> b) -> a -> b
$ [a] -> m a
forall (m :: * -> *) a. RandomC m => [a] -> m a
eins [a]
xs

genau :: ( Eq a , RandomC m ) 
      => Int -> [a] -> m [a]
genau :: forall a (m :: * -> *). (Eq a, RandomC m) => Int -> [a] -> m [a]
genau Int
0 [a]
_ = [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
genau Int
n [a]
xs = do x <- [a] -> m a
forall (m :: * -> *) a. RandomC m => [a] -> m a
eins [a]
xs
                ys <- genau (pred n) $ filter (/=x) xs
                return $ x : ys

repeat_until ::  RandomC m => m a -> (a -> Bool) -> m a
repeat_until :: forall (m :: * -> *) a. RandomC m => m a -> (a -> Bool) -> m a
repeat_until m a
act a -> Bool
p = 
    do x <- m a
act
       -- putStr " * "
       if p x then return x else repeat_until act p

permutation ::  RandomC m => [a] -> m [a]
permutation :: forall (m :: * -> *) a. RandomC m => [a] -> m [a]
permutation [a]
xs = Int -> [a] -> m [a]
forall (m :: * -> *) a. RandomC m => Int -> [a] -> m [a]
selektion ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) [a]
xs

pick :: RandomC m =>  [a] -> m (a,[a])
pick :: forall (m :: * -> *) a. RandomC m => [a] -> m (a, [a])
pick [a]
xs | Bool -> Bool
not ([a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs) = do
  i <- (Int, Int) -> m Int
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (RandomC m, Random a) => (a, a) -> m a
randomRIO (Int
0, [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  let (here, y : there) = splitAt i xs
  return (y, here <> there)

-- | without duplicates, arbitrary order
selektion :: RandomC m =>  Int -> [a] -> m [a]
selektion :: forall (m :: * -> *) a. RandomC m => Int -> [a] -> m [a]
selektion Int
0 [a]
xs = [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return  []
selektion Int
k [] = [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
selektion Int
k [a]
xs = do
  (y,ys) <- [a] -> m (a, [a])
forall (m :: * -> *) a. RandomC m => [a] -> m (a, [a])
pick [a]
xs
  zs <- selektion (pred k) ys
  return $ y : zs

test_ms :: IO ()
test_ms = IO [()] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [()] -> IO ()) -> IO [()] -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO () -> IO [()]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
20 (IO () -> IO [()]) -> IO () -> IO [()]
forall a b. (a -> b) -> a -> b
$ do
  ([Integer], [Integer]) -> IO ()
forall a. Show a => a -> IO ()
print (([Integer], [Integer]) -> IO ())
-> IO ([Integer], [Integer]) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> [Integer] -> IO ([Integer], [Integer])
forall (m :: * -> *) a. RandomC m => Int -> [a] -> m ([a], [a])
monotonic_subsequence Int
5 [Integer
1..Integer
20]

monotonic_subsequence
  :: RandomC m =>  Int -> [a] -> m ([a], [a])
monotonic_subsequence :: forall (m :: * -> *) a. RandomC m => Int -> [a] -> m ([a], [a])
monotonic_subsequence Int
0 [a]
xs = ([a], [a]) -> m ([a], [a])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return  ( [], [a]
xs )
monotonic_subsequence Int
k [a]
xs | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs = ([a], [a]) -> m ([a], [a])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
xs, [])
monotonic_subsequence Int
k (a
x:[a]
xs) = do
  let p :: Int
p = Int -> Int -> Int
forall a. Integral a => a -> a -> a
choose ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
k
      q :: Int
q = Int -> Int -> Int
forall a. Integral a => a -> a -> a
choose ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
      f :: Double
f = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
q Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
p :: Double
  use_first <- (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
f) (Double -> Bool) -> m Double -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double, Double) -> m Double
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (RandomC m, Random a) => (a, a) -> m a
randomRIO (Double
0, Double
1)
  if use_first
    then (\ ([a]
ys,[a]
zs) -> (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys,[a]
zs)) <$> monotonic_subsequence (k-1) xs
    else (\ ([a]
ys,[a]
zs) -> ([a]
ys,a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
zs)) <$> monotonic_subsequence k xs

subsequence :: RandomC m =>  Int -> [a] -> m ([a], [a])
subsequence :: forall (m :: * -> *) a. RandomC m => Int -> [a] -> m ([a], [a])
subsequence Int
0 [a]
xs = ([a], [a]) -> m ([a], [a])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return  ( [], [a]
xs )
subsequence Int
k [a]
xs = do
         i <- (Int, Int) -> m Int
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (RandomC m, Random a) => (a, a) -> m a
randomRIO (Int
0, [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
         let (here, y : there) = splitAt i xs
         ( ys, zs )  <- subsequence (pred k) $ here ++ there
         return ( y : ys, zs )

contiguous_subsequence :: RandomC m =>  Int -> [a] -> m ([a], [a], [a])
contiguous_subsequence :: forall (m :: * -> *) a.
RandomC m =>
Int -> [a] -> m ([a], [a], [a])
contiguous_subsequence Int
k [a]
xs = do
         start <- (Int, Int) -> m Int
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (RandomC m, Random a) => (a, a) -> m a
randomRIO ( Int
0, [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k )
         let ( pre, midpost ) = splitAt start xs
             ( mid, post ) = splitAt k midpost
         return ( pre, mid, post )

-- | finde eine zerlegung von n in genau k summanden >= 1
-- achtung: ist nicht gleichverteilt (?)
-- Laufzeit ist Theta (k)
summe ::  RandomC m => Int -> Int -> m [ Int ]
summe :: forall (m :: * -> *). RandomC m => Int -> Int -> m [Int]
summe Int
k Int
n | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = [Char] -> m [Int]
forall a. HasCallStack => [Char] -> a
error [Char]
"Util.Zufall.summe: k < 0"
summe Int
k Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = [Char] -> m [Int]
forall a. HasCallStack => [Char] -> a
error [Char]
"Util.Zufall.summe: n < 0"
summe Int
k Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
k = [Char] -> m [Int]
forall a. HasCallStack => [Char] -> a
error ([Char] -> m [Int]) -> [Char] -> m [Int]
forall a b. (a -> b) -> a -> b
$ [Char]
"Util.Zufall.summe: n < k" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Int
k, Int
n)
summe Int
1 Int
n = [Int] -> m [Int]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Int
n]
summe Int
k Int
n | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k = [Int] -> m [Int]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> m [Int]) -> [Int] -> m [Int]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate Int
k Int
1
summe Int
k Int
n = do    
    x <- (Int, Int) -> m Int
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (RandomC m, Random a) => (a, a) -> m a
randomRIO (Int
1, Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    xs <- summe (k-1) (n-x)
    return $ x : xs

-- | Zerlegung von n in genau k Summanden >= 1.
-- Summanden sind nicht geordnet.
-- Vorsicht: Laufzeit ist Theta(n),
-- denn  Implementierung würfelt (n-k) mal
random_partition :: Int -> Int -> m [a]
random_partition Int
k Int
n | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n = do
  xs <- Int -> m Int -> m [Int]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
k) (m Int -> m [Int]) -> m Int -> m [Int]
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> m Int
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (RandomC m, Random a) => (a, a) -> m a
randomRIO (Int
0, Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
  return $ M.elems $ M.fromListWith (+) . map (,1)
    $ [ 0 .. k-1] <> xs 

random_partition Int
k Int
n | Bool
False, Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n =
  ([a] -> () -> m [a]) -> [a] -> [()] -> m [a]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ( \ [a]
xs () -> do
            i <- (Int, Int) -> m Int
forall a. Random a => (a, a) -> m a
forall (m :: * -> *) a. (RandomC m, Random a) => (a, a) -> m a
randomRIO (Int
0,Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
            let (pre,p:ost) = splitAt i xs
            return $ pre ++ succ p : ost
        ) (Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
k a
0) ([()] -> m [a]) -> [()] -> m [a]
forall a b. (a -> b) -> a -> b
$ Int -> () -> [()]
forall a. Int -> a -> [a]
replicate Int
n ()


-- | equal elements will be permuted randomly
randomized_sort :: Ord a => [a] -> IO [a]
randomized_sort :: forall a. Ord a => [a] -> IO [a]
randomized_sort [a]
xs = do
    xys <- [a] -> (a -> IO (a, Double)) -> IO [(a, Double)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [a]
xs ((a -> IO (a, Double)) -> IO [(a, Double)])
-> (a -> IO (a, Double)) -> IO [(a, Double)]
forall a b. (a -> b) -> a -> b
$ \ a
x -> do
        y :: Double <- (Double, Double) -> IO Double
forall a. Random a => (a, a) -> IO a
forall (m :: * -> *) a. (RandomC m, Random a) => (a, a) -> m a
randomRIO ( Double
0, Double
1 )
        return ( x, y )
    return $ map fst $ sort xys