-- |
-- Module     : Simulation.Aivika.Lattice.Internal.Lattice
-- Copyright  : Copyright (c) 2016-2017, David Sorokin <david.sorokin@gmail.com>
-- License    : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability  : experimental
-- Tested with: GHC 7.10.3
--
-- This module defines the lattice.
--
module Simulation.Aivika.Lattice.Internal.Lattice
       (LIOLattice(..),
        lattice,
        newRandomLattice,
        newRandomLatticeWithProb) where

import Control.Monad
import Control.Monad.Trans

import Data.Array

import qualified System.Random.MWC as MWC

-- | Specifies the lattice.
data LIOLattice =
  LIOLattice { LIOLattice -> Int -> Int -> Int
lioParentMemberIndex :: Int -> Int -> Int,
               -- ^ Get the parent member index by the specified
               -- time and member indices.
               LIOLattice -> Int
lioSize :: Int
               -- ^ Tha lattice size.
             }

-- | Create a new random lattice by the specified probability and size,
-- where the probability defines whether the interior child node derives
-- from the right parent.
newRandomLatticeWithProb :: Double -> Int -> IO LIOLattice
newRandomLatticeWithProb :: Double -> Int -> IO LIOLattice
newRandomLatticeWithProb Double
p Int
m =
  do Gen RealWorld
g <- (Gen (PrimState IO) -> IO (Gen RealWorld)) -> IO (Gen RealWorld)
forall (m :: * -> *) a.
PrimBase m =>
(Gen (PrimState m) -> m a) -> IO a
MWC.withSystemRandom (Gen (PrimState IO) -> IO (Gen (PrimState IO))
forall (m :: * -> *) a. Monad m => a -> m a
return :: MWC.GenIO -> IO MWC.GenIO)
     [Array Int Int]
xss0 <- [Int] -> (Int -> IO (Array Int Int)) -> IO [Array Int Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0 .. Int
m] ((Int -> IO (Array Int Int)) -> IO [Array Int Int])
-> (Int -> IO (Array Int Int)) -> IO [Array Int Int]
forall a b. (a -> b) -> a -> b
$ \Int
i ->
       do [Int]
xs0 <- [Int] -> (Int -> IO Int) -> IO [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0 .. Int
i] ((Int -> IO Int) -> IO [Int]) -> (Int -> IO Int) -> IO [Int]
forall a b. (a -> b) -> a -> b
$ \Int
k ->
            if Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
            then Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
k
            else if Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i
                 then Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                 else do Double
x <- Gen (PrimState IO) -> IO Double
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
Gen (PrimState m) -> m a
MWC.uniform Gen RealWorld
Gen (PrimState IO)
g :: IO Double
                         if Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
p
                           then Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                           else Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
k
          Array Int Int -> IO (Array Int Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Array Int Int -> IO (Array Int Int))
-> Array Int Int -> IO (Array Int Int)
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> [Int] -> Array Int Int
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
i) [Int]
xs0
     let xss :: Array Int (Array Int Int)
xss = (Int, Int) -> [Array Int Int] -> Array Int (Array Int Int)
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
m) [Array Int Int]
xss0
     LIOLattice -> IO LIOLattice
forall (m :: * -> *) a. Monad m => a -> m a
return LIOLattice :: (Int -> Int -> Int) -> Int -> LIOLattice
LIOLattice { lioParentMemberIndex :: Int -> Int -> Int
lioParentMemberIndex = \Int
i Int
k -> (Array Int (Array Int Int)
xss Array Int (Array Int Int) -> Int -> Array Int Int
forall i e. Ix i => Array i e -> i -> e
! Int
i) Array Int Int -> Int -> Int
forall i e. Ix i => Array i e -> i -> e
! Int
k,
                         lioSize :: Int
lioSize = Int
m
                       }

-- | Create a new random lattice by the specified size with equal probabilities,
-- whether the interior child node derives from the left or right parents.
newRandomLattice :: Int -> IO LIOLattice
newRandomLattice :: Int -> IO LIOLattice
newRandomLattice = Double -> Int -> IO LIOLattice
newRandomLatticeWithProb Double
0.5

-- | Return a lattice by the specifed size and the parent member function.
lattice :: Int
           -- ^ the lattice size
           -> (Int -> Int -> Int)
           -- ^ get the parent member index by the specified
           -- time and member indices
           -> LIOLattice
lattice :: Int -> (Int -> Int -> Int) -> LIOLattice
lattice Int
m Int -> Int -> Int
f = (Int -> Int -> Int) -> Int -> LIOLattice
LIOLattice Int -> Int -> Int
f Int
m