{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{- |
Data type that allows handling of piecewise constant signals
independently from the source.
-}
module Synthesizer.LLVM.ConstantPiece where

import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as SigP
import qualified Synthesizer.LLVM.Parameter as Param

import qualified Synthesizer.LLVM.Storable.LazySizeIterator as SizeIt
import qualified Data.StorableVector.Lazy.Pattern as SVP

import qualified Synthesizer.LLVM.EventIterator as EventIt
import qualified Data.EventList.Relative.BodyTime as EventList
import qualified Numeric.NonNegative.Wrapper as NonNeg

import qualified LLVM.Extra.MaybeContinuation as Maybe
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Class as Class
import qualified LLVM.Extra.Arithmetic as A
import LLVM.Extra.Control (whileLoop, )
import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, )

import LLVM.Util.Loop (Phi, phis, addPhis, )
import LLVM.Core (Value, valueOf, )
import qualified LLVM.Core as LLVM

import Types.Data.Num (d0, d1, )

import Data.Word (Word32, )
import Foreign.Storable.Tuple ()
import Foreign.Storable (Storable, )
import Foreign.Ptr (Ptr, )
import qualified Synthesizer.LLVM.Alloc as Alloc

import Control.Applicative (liftA2, )

import NumericPrelude.Numeric
import NumericPrelude.Base


data T a = Cons (Value Word32) a

instance (Phi a) => Phi (T a) where
   phis bb (Cons len y) =
      liftA2 Cons (phis bb len) (phis bb y)
   addPhis bb (Cons lenA ya) (Cons lenB yb) =
      addPhis bb lenA lenB >> addPhis bb ya yb

instance (Undefined a) =>
      Undefined (T a) where
   undefTuple =
      Cons Class.undefTuple Class.undefTuple

instance (Class.Zero a) =>
      Class.Zero (T a) where
   zeroTuple =
      Cons Class.zeroTuple Class.zeroTuple

type Struct a = LLVM.Struct (Word32, (a, ()))

parameterMemory ::
   (Memory.C a) =>
   Memory.Record r (Struct (Memory.Struct a)) (T a)
parameterMemory =
   liftA2 Cons
      (Memory.element (\(Cons len _y) -> len) d0)
      (Memory.element (\(Cons _len y) -> y)   d1)

instance (Memory.C a) => Memory.C (T a) where
   type Struct (T a) = Struct (Memory.Struct a)
   load = Memory.loadRecord parameterMemory
   store = Memory.storeRecord parameterMemory
   decompose = Memory.decomposeRecord parameterMemory
   compose = Memory.composeRecord parameterMemory


flatten ::
   (Memory.C value) =>
   SigP.T p (T value) ->
   SigP.T p value
flatten (SigP.Cons next start createIOContext deleteIOContext) =
   SigP.Cons
      (\nextParam state0 -> do
         (Cons length1 y1, s1) <-
            Maybe.fromBool $
            whileLoop (valueOf True, state0)
               (\(cont, (Cons len _y, _s)) ->
                  LLVM.and cont =<< A.cmp LLVM.CmpEQ len (valueOf 0))
               (\(_cont, (Cons _len _y, s)) ->
                  Maybe.toBool $ next nextParam s)
         length2 <- Maybe.lift (A.dec length1)
         return (y1, (Cons length2 y1, s1)))
      (\startParam ->
         fmap ((,) (Cons (valueOf 0) undefTuple)) $
         start startParam)
      createIOContext deleteIOContext


piecewiseConstant ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
   Param.T p (EventList.T NonNeg.Int a) ->
   SigP.T p (T value)
piecewiseConstant evs = SigP.Cons
   (\(stable, yPtr) () -> do
      len <- Maybe.lift $ do
         nextFn <- LLVM.staticFunction EventIt.nextCallBack
         LLVM.call nextFn stable yPtr
      Maybe.guard =<<
         Maybe.lift (A.cmp LLVM.CmpNE len (valueOf 0))
      y <- Maybe.lift $ Memory.load yPtr
      return (Cons len y, ()))
   return
   (\p -> do
      stable <- EventIt.new (Param.get evs p)
      yPtr <- Alloc.malloc
      return ((stable, asTypeOfEventListElement yPtr evs),
              ((stable, Memory.castStorablePtr yPtr), ())))
   (\(stable,yPtr) -> do
      EventIt.dispose stable
      Alloc.free yPtr)

asTypeOfEventListElement ::
   Ptr a ->
   Param.T p (EventList.T NonNeg.Int a) ->
   Ptr a
asTypeOfEventListElement ptr _ = ptr


lazySize ::
   Param.T p SVP.LazySize ->
   SigP.T p (T ())
lazySize size = SigP.Cons
   (\stable () -> do
      len <- Maybe.lift $ do
         nextFn <- LLVM.staticFunction SizeIt.nextCallBack
         LLVM.call nextFn stable
      Maybe.guard =<<
         Maybe.lift (A.cmp LLVM.CmpNE len (valueOf 0))
      return (Cons len (), ()))
   return
   (\p -> do
      stable <- SizeIt.new (Param.get size p)
      return (stable, (stable, ())))
   SizeIt.dispose