Point.hs

module ADP.Fusion.Term.Chr.Point where

import           Data.Proxy
import           Data.Strict.Tuple
import           Debug.Trace
import qualified Data.Vector.Fusion.Stream.Monadic as S
import qualified Data.Vector.Generic as VG

import           Data.PrimitiveArray

import           ADP.Fusion.Base
import           ADP.Fusion.Term.Chr.Type

import           ADP.Fusion.Base.Term



-- | First try in getting this right with a @termStream@.
--
-- TODO use @PointL i@ since this is probably the same for all single-tape
-- instances with @ElmChr@.
--
-- TODO it might even be possible to auto-generate this code via TH.

instance
  ( TmkCtx1 m ls (Chr r x) (PointL i)
  ) => MkStream m (ls :!: Chr r x) (PointL i) where
  mkStream (ls :!: Chr f xs) sv us is
    = S.map (\(ss,ee,ii,oo) -> ElmChr ee ii oo ss) -- recover ElmChr
    . addTermStream1 (Chr f xs) sv us is
    $ mkStream ls (termStaticVar (Chr f xs) sv is) us (termStreamIndex (Chr f xs) sv is)
  {-# Inline mkStream #-}



-- | Current first try for using @TermStream@
--
-- TODO what happens to fusion if @staticCheck@ happens before @S.map@?
--
-- NOTE / TODO a bit faster with @seq xs@ ?

instance
  ( TstCtx1 m ts a is (PointL I)
  ) => TermStream m (TermSymbol ts (Chr r x)) a (is:.PointL I) where
  termStream (ts:|Chr f xs) (cs:.IStatic d) (us:.PointL u) (is:.PointL i)
    = seq xs . staticCheck (i>0 && i<=u && i<= VG.length xs)
    . S.map (\(TState s a b ii oo ee) -> TState s a b (ii:.PointL i) (oo:.PointL 0) (ee:. f xs (i-1)))
    . termStream ts cs us is
  {-# Inline termStream #-}

instance
  ( TstCtx1 m ts a is (PointL O)
  ) => TermStream m (TermSymbol ts (Chr r x)) a (is:.PointL O) where
  termStream (ts:|Chr f xs) (cs:.OStatic d) (us:.PointL u) (is:.PointL i)
    = S.map (\(TState s a b ii oo ee) ->
                let PointL k = getIndex a (Proxy :: Proxy (is:.PointL O))
                    o        = getIndex b (Proxy :: Proxy (is:.PointL O))
                in  TState s a b (ii:.PointL (k-d+1)) (oo:.o) (ee:.f xs (k-d-1)))
    . termStream ts cs us is
  {-# Inline termStream #-}



instance TermStaticVar (Chr r x) (PointL I) where
  termStaticVar   _ sv _                = sv
  termStreamIndex _ _  (PointL j) = PointL $ j-1
  {-# Inline [0] termStaticVar #-}
  {-# Inline [0] termStreamIndex #-}

instance TermStaticVar (Chr r x) (PointL O) where
  termStaticVar   _ (OStatic d) _ = OStatic (d+1) 
  termStreamIndex _ _           j = j
  {-# Inline [0] termStaticVar #-}
  {-# Inline [0] termStreamIndex #-}