{-# LANGUAGE TypeFamilies #-}

-- |
-- Module     : Simulation.Aivika.IO.Var
-- 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 is an instance of 'MonadVar'.
--
module Simulation.Aivika.IO.Var () where

import Control.Monad.Trans

import Data.Array

import Simulation.Aivika.Trans.DES
import Simulation.Aivika.Trans.Internal.Specs
import Simulation.Aivika.Trans.Internal.Simulation
import Simulation.Aivika.Trans.Internal.Dynamics
import Simulation.Aivika.Trans.Internal.Event
import Simulation.Aivika.Trans.Ref
import Simulation.Aivika.Trans.Signal
import Simulation.Aivika.Trans.Var

import Simulation.Aivika.IO.DES

import qualified Simulation.Aivika.Vector as V
import qualified Simulation.Aivika.Vector.Unboxed as UV

-- | The 'IO' monad is an instance of 'MonadVar'.
instance MonadVar IO where
-- instance (Monad m, MonadDES m, MonadIO m, MonadTemplate m) => MonadVar m where

  {-# SPECIALISE instance MonadVar IO #-}

  -- | A template-based implementation of the variable.
  data Var IO a =
    Var { varXS    :: UV.Vector Double,
          varMS    :: V.Vector a,
          varYS    :: V.Vector a,
          varChangedSource :: SignalSource IO a }

  {-# INLINABLE newVar #-}
  newVar a =
    Simulation $ \r ->
    do xs <- liftIO UV.newVector
       ms <- liftIO V.newVector
       ys <- liftIO V.newVector
       liftIO $ UV.appendVector xs $ spcStartTime $ runSpecs r
       liftIO $ V.appendVector ms a
       liftIO $ V.appendVector ys a
       s  <- invokeSimulation r newSignalSource
       return Var { varXS = xs,
                    varMS = ms,
                    varYS = ms,
                    varChangedSource = s }

  {-# INLINABLE varMemo #-}
  varMemo v =
    runEventWith CurrentEventsOrFromPast $
    Event $ \p ->
    liftIO $
    do let xs = varXS v
           ms = varMS v
           ys = varYS v
           t  = pointTime p
       count <- UV.vectorCount xs
       let i = count - 1
       x <- UV.readVector xs i
       if x < t
         then do a <- V.readVector ys i
                 UV.appendVector xs t
                 V.appendVector ms a
                 V.appendVector ys a
                 return a
         else if x == t
              then V.readVector ms i
              else do i <- UV.vectorBinarySearch xs t
                      if i >= 0
                        then V.readVector ms i
                        else V.readVector ms $ - (i + 1) - 1

  {-# INLINABLE readVar #-}
  readVar v =
    Event $ \p ->
    liftIO $
    do let xs = varXS v
           ys = varYS v
           t  = pointTime p
       count <- UV.vectorCount xs
       let i = count - 1
       x <- UV.readVector xs i
       if x <= t
         then V.readVector ys i
         else do i <- UV.vectorBinarySearch xs t
                 if i >= 0
                   then V.readVector ys i
                   else V.readVector ys $ - (i + 1) - 1

  {-# INLINABLE writeVar #-}
  writeVar v a =
    Event $ \p ->
    do let xs = varXS v
           ms = varMS v
           ys = varYS v
           t  = pointTime p
           s  = varChangedSource v
       count <- liftIO $ UV.vectorCount xs
       let i = count - 1
       x <- liftIO $ UV.readVector xs i
       if t < x
         then error "Cannot update the past data: writeVar."
         else if t == x
              then liftIO $ V.writeVector ys i $! a
              else liftIO $
                   do UV.appendVector xs t
                      V.appendVector ms $! a
                      V.appendVector ys $! a
       invokeEvent p $ triggerSignal s a

  {-# INLINABLE modifyVar #-}
  modifyVar v f =
    Event $ \p ->
    do let xs = varXS v
           ms = varMS v
           ys = varYS v
           t  = pointTime p
           s  = varChangedSource v
       count <- liftIO $ UV.vectorCount xs
       let i = count - 1
       x <- liftIO $ UV.readVector xs i
       if t < x
         then error "Cannot update the past data: modifyVar."
         else if t == x
              then do a <- liftIO $ V.readVector ys i
                      let b = f a
                      liftIO $ V.writeVector ys i $! b
                      invokeEvent p $ triggerSignal s b
              else do a <- liftIO $ V.readVector ys i
                      let b = f a
                      liftIO $ UV.appendVector xs t
                      liftIO $ V.appendVector ms $! b
                      liftIO $ V.appendVector ys $! b
                      invokeEvent p $ triggerSignal s b

  {-# INLINABLE freezeVar #-}
  freezeVar v =
    Event $ \p ->
    liftIO $
    do xs <- UV.freezeVector (varXS v)
       ms <- V.freezeVector (varMS v)
       ys <- V.freezeVector (varYS v)
       return (xs, ms, ys)

  {-# INLINE varChanged #-}
  varChanged v = publishSignal (varChangedSource v)

  {-# INLINE varChanged_ #-}
  varChanged_ v = mapSignal (const ()) $ varChanged v