{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}

-- |
-- Module     : Simulation.Aivika.IO.Dynamics.Memo.Unboxed
-- Copyright  : Copyright (c) 2009-2017, David Sorokin <david.sorokin@gmail.com>
-- License    : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability  : experimental
-- Tested with: GHC 8.0.1
--
-- The 'IO' monad can be an instance of the 'MonadMemo' type class.
--

module Simulation.Aivika.IO.Dynamics.Memo.Unboxed () where

import Control.Monad
import Control.Monad.Trans

import Data.Array.IO.Safe
import Data.Array.MArray.Safe
import Data.IORef

import Simulation.Aivika.Trans.Internal.Specs
import Simulation.Aivika.Trans.Internal.Parameter
import Simulation.Aivika.Trans.Internal.Simulation
import Simulation.Aivika.Trans.Internal.Dynamics
import Simulation.Aivika.Trans.Dynamics.Memo.Unboxed
import Simulation.Aivika.Trans.Dynamics.Extra
import Simulation.Aivika.Trans.Array

-- | The 'IO' based monad can be an instance of the 'MonadMemo' type class.
instance MArray IOUArray e IO => MonadMemo IO e where
-- instance (Monad m, MonadIO m, MonadTemplate m, MArray IOUArray e IO) => MonadMemo m e where

  {-# SPECIALISE instance MonadMemo IO Double #-}
  {-# SPECIALISE instance MonadMemo IO Float #-}
  {-# SPECIALISE instance MonadMemo IO Int #-}

  {-# INLINE memoDynamics #-}
  memoDynamics :: Dynamics IO e -> Simulation IO (Dynamics IO e)
memoDynamics (Dynamics Point IO -> IO e
m) = 
    (Run IO -> IO (Dynamics IO e)) -> Simulation IO (Dynamics IO e)
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run IO -> IO (Dynamics IO e)) -> Simulation IO (Dynamics IO e))
-> (Run IO -> IO (Dynamics IO e)) -> Simulation IO (Dynamics IO e)
forall a b. (a -> b) -> a -> b
$ \Run IO
r ->
    do let sc :: Specs IO
sc  = Run IO -> Specs IO
forall (m :: * -> *). Run m -> Specs m
runSpecs Run IO
r
           (Int
phl, Int
phu) = Specs IO -> (Int, Int)
forall (m :: * -> *). Specs m -> (Int, Int)
integPhaseBnds Specs IO
sc
           (Int
nl, Int
nu)   = Specs IO -> (Int, Int)
forall (m :: * -> *). Specs m -> (Int, Int)
integIterationBnds Specs IO
sc
       IOUArray (Int, Int) e
arr   <- IO (IOUArray (Int, Int) e) -> IO (IOUArray (Int, Int) e)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IOUArray (Int, Int) e) -> IO (IOUArray (Int, Int) e))
-> IO (IOUArray (Int, Int) e) -> IO (IOUArray (Int, Int) e)
forall a b. (a -> b) -> a -> b
$ ((Int, Int), (Int, Int)) -> IO (IOUArray (Int, Int) e)
forall i e.
(Ix i, MArray IOUArray e IO) =>
(i, i) -> IO (IOUArray i e)
newIOUArray_ ((Int
phl, Int
nl), (Int
phu, Int
nu))
       IORef Int
nref  <- IO (IORef Int) -> IO (IORef Int)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Int) -> IO (IORef Int))
-> IO (IORef Int) -> IO (IORef Int)
forall a b. (a -> b) -> a -> b
$ Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
       IORef Int
phref <- IO (IORef Int) -> IO (IORef Int)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Int) -> IO (IORef Int))
-> IO (IORef Int) -> IO (IORef Int)
forall a b. (a -> b) -> a -> b
$ Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
       let r :: Point IO -> IO e
r Point IO
p = 
             do let n :: Int
n  = Point IO -> Int
forall (m :: * -> *). Point m -> Int
pointIteration Point IO
p
                    ph :: Int
ph = Point IO -> Int
forall (m :: * -> *). Point m -> Int
pointPhase Point IO
p
                    loop :: Int -> Int -> IO e
loop Int
n' Int
ph' = 
                      if (Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n) Bool -> Bool -> Bool
|| ((Int
n' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n) Bool -> Bool -> Bool
&& (Int
ph' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
ph)) 
                      then 
                        IO e -> IO e
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO e -> IO e) -> IO e -> IO e
forall a b. (a -> b) -> a -> b
$ IOUArray (Int, Int) e -> (Int, Int) -> IO e
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOUArray (Int, Int) e
arr (Int
ph, Int
n)
                      else 
                        let p' :: Point IO
p' = Point IO
p { pointIteration = n', pointPhase = ph',
                                     pointTime = basicTime sc n' ph' }
                        in do e
a <- Point IO -> IO e
m Point IO
p'
                              e
a e -> IO () -> IO ()
forall a b. a -> b -> b
`seq` IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOUArray (Int, Int) e -> (Int, Int) -> e -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray (Int, Int) e
arr (Int
ph', Int
n') e
a
                              if Int
ph' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
phu 
                                then do IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
phref Int
0
                                        IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
nref (Int
n' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                                        Int -> Int -> IO e
loop (Int
n' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
0
                                else do IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
phref (Int
ph' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                                        Int -> Int -> IO e
loop Int
n' (Int
ph' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                Int
n'  <- IO Int -> IO Int
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
nref
                Int
ph' <- IO Int -> IO Int
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
phref
                Int -> Int -> IO e
loop Int
n' Int
ph'
       Dynamics IO e -> IO (Dynamics IO e)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dynamics IO e -> IO (Dynamics IO e))
-> Dynamics IO e -> IO (Dynamics IO e)
forall a b. (a -> b) -> a -> b
$ Dynamics IO e -> Dynamics IO e
forall (m :: * -> *) a. Dynamics m a -> Dynamics m a
interpolateDynamics (Dynamics IO e -> Dynamics IO e) -> Dynamics IO e -> Dynamics IO e
forall a b. (a -> b) -> a -> b
$ (Point IO -> IO e) -> Dynamics IO e
forall (m :: * -> *) a. (Point m -> m a) -> Dynamics m a
Dynamics Point IO -> IO e
r

  {-# INLINE memo0Dynamics #-}
  memo0Dynamics :: Dynamics IO e -> Simulation IO (Dynamics IO e)
memo0Dynamics (Dynamics Point IO -> IO e
m) = 
    (Run IO -> IO (Dynamics IO e)) -> Simulation IO (Dynamics IO e)
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run IO -> IO (Dynamics IO e)) -> Simulation IO (Dynamics IO e))
-> (Run IO -> IO (Dynamics IO e)) -> Simulation IO (Dynamics IO e)
forall a b. (a -> b) -> a -> b
$ \Run IO
r ->
    do let sc :: Specs IO
sc = Run IO -> Specs IO
forall (m :: * -> *). Run m -> Specs m
runSpecs Run IO
r
           bnds :: (Int, Int)
bnds = Specs IO -> (Int, Int)
forall (m :: * -> *). Specs m -> (Int, Int)
integIterationBnds Specs IO
sc
       IOUArray Int e
arr  <- IO (IOUArray Int e) -> IO (IOUArray Int e)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IOUArray Int e) -> IO (IOUArray Int e))
-> IO (IOUArray Int e) -> IO (IOUArray Int e)
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> IO (IOUArray Int e)
forall i e.
(Ix i, MArray IOUArray e IO) =>
(i, i) -> IO (IOUArray i e)
newIOUArray_ (Int, Int)
bnds
       IORef Int
nref <- IO (IORef Int) -> IO (IORef Int)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Int) -> IO (IORef Int))
-> IO (IORef Int) -> IO (IORef Int)
forall a b. (a -> b) -> a -> b
$ Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
       let r :: Point IO -> IO e
r Point IO
p =
             do let sc :: Specs IO
sc = Point IO -> Specs IO
forall (m :: * -> *). Point m -> Specs m
pointSpecs Point IO
p
                    n :: Int
n  = Point IO -> Int
forall (m :: * -> *). Point m -> Int
pointIteration Point IO
p
                    loop :: Int -> IO e
loop Int
n' = 
                      if Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n
                      then 
                        IO e -> IO e
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO e -> IO e) -> IO e -> IO e
forall a b. (a -> b) -> a -> b
$ IOUArray Int e -> Int -> IO e
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOUArray Int e
arr Int
n
                      else 
                        let p' :: Point IO
p' = Point IO
p { pointIteration = n', pointPhase = 0,
                                     pointTime = basicTime sc n' 0 }
                        in do e
a <- Point IO -> IO e
m Point IO
p'
                              e
a e -> IO () -> IO ()
forall a b. a -> b -> b
`seq` IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOUArray Int e -> Int -> e -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Int e
arr Int
n' e
a
                              IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
nref (Int
n' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                              Int -> IO e
loop (Int
n' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                Int
n' <- IO Int -> IO Int
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
nref
                Int -> IO e
loop Int
n'
       Dynamics IO e -> IO (Dynamics IO e)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dynamics IO e -> IO (Dynamics IO e))
-> Dynamics IO e -> IO (Dynamics IO e)
forall a b. (a -> b) -> a -> b
$ Dynamics IO e -> Dynamics IO e
forall (m :: * -> *) a. Dynamics m a -> Dynamics m a
discreteDynamics (Dynamics IO e -> Dynamics IO e) -> Dynamics IO e -> Dynamics IO e
forall a b. (a -> b) -> a -> b
$ (Point IO -> IO e) -> Dynamics IO e
forall (m :: * -> *) a. (Point m -> m a) -> Dynamics m a
Dynamics Point IO -> IO e
r