Signal.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fglasgow-exts #-}
{- glasgow-exts are for the rules -}
module Synthesizer.FusionList.Signal where

import qualified Synthesizer.Plain.Signal   as Sig
import qualified Synthesizer.Plain.Modifier as Modifier
import qualified Data.List as List

import qualified Data.StorableVector.Lazy as Vector
import Data.StorableVector.Lazy (ChunkSize, Vector)
import Foreign.Storable (Storable, )

import qualified Algebra.Module   as Module
import qualified Algebra.Additive as Additive
import Algebra.Additive (zero)

import Algebra.Module ((*>))

import qualified Synthesizer.Format as Format

import Control.Monad.Trans.State (runState, )

import Data.Monoid (Monoid, mempty, mappend, )

import qualified Data.List.HT    as ListHT
import Data.Tuple.HT (mapFst, mapSnd, mapPair, fst3, snd3, thd3, )

import Data.Maybe.HT (toMaybe)
import NumericPrelude (fromInteger, )

import Text.Show (Show(showsPrec), showParen, showString, )
import Data.Maybe (Maybe(Just, Nothing), maybe)
import Prelude
   ((.), ($), id, const, flip, curry, uncurry, fst, snd, error,
    (>), (>=), max, Ord,
    succ, pred, Bool, not, Int, Functor, fmap,
    (>>), (>>=), fail, return, (=<<),
--    fromInteger,
    )
-- import qualified Prelude as P
{-
import Prelude hiding
   ((++), iterate, foldl, map, repeat, replicate,
    zipWith, zipWith3, take, takeWhile)
-}


newtype T y = Cons {decons :: [y]}

instance (Show y) => Show (T y) where
   showsPrec p x =
      showParen (p >= 10)
         (showString "FusionList.fromList " . showsPrec 11 (toList x))

instance Format.C T where
   format = showsPrec

instance Functor T where
   fmap = map

instance Monoid (T y) where
   mempty = empty
   mappend = append


{- * functions based on 'generate' -}

{-# NOINLINE [0] generate #-}
generate :: (acc -> Maybe (y, acc)) -> acc -> T y
generate f = Cons . snd . Sig.unfoldR f

{-# INLINE unfoldR #-}
unfoldR :: (acc -> Maybe (y, acc)) -> acc -> T y
unfoldR = generate

{-# INLINE generateInfinite #-}
generateInfinite :: (acc -> (y, acc)) -> acc -> T y
generateInfinite f = generate (Just . f)

{-# INLINE fromList #-}
fromList :: [y] -> T y
fromList = generate ListHT.viewL

{-# INLINE toList #-}
toList :: T y -> [y]
toList = decons


toStorableSignal :: Storable y => ChunkSize -> T y -> Vector y
toStorableSignal size  =  Vector.pack size . decons

fromStorableSignal :: Storable y => Vector y -> T y
fromStorableSignal  =  Cons . Vector.unpack


{-# INLINE iterate #-}
iterate :: (a -> a) -> a -> T a
iterate f = generateInfinite (\x -> (x, f x))

{-# INLINE iterateAssociative #-}
iterateAssociative :: (a -> a -> a) -> a -> T a
iterateAssociative op x = iterate (op x) x -- should be optimized

{-# INLINE repeat #-}
repeat :: a -> T a
repeat = iterate id


{- * functions based on 'crochetL' -}

{-# NOINLINE [0] crochetL #-}
crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y
crochetL f a = Cons . Sig.crochetL f a . decons

{-# INLINE scanL #-}
scanL :: (acc -> x -> acc) -> acc -> T x -> T acc
{-
scanL f start xs =
   cons start
     (crochetL (\x acc -> let y = f acc x in Just (y, y)) start xs)
-}
scanL f start =
   cons start .
   crochetL (\x acc -> let y = f acc x in Just (y, y)) start

-- | input and output have equal length, that's better for fusion
scanLClip :: (acc -> x -> acc) -> acc -> T x -> T acc
scanLClip f start =
   crochetL (\x acc -> Just (acc, f acc x)) start

{-# INLINE map #-}
map :: (a -> b) -> (T a -> T b)
map f = crochetL (\x _ -> Just (f x, ())) ()

{-# RULEZ
  "FusionList.map-crochetL" forall f.
     map f = crochetL (\x _ -> Just (f x, ())) () ;

  "FusionList.repeat-iterate"
     repeat = iterate id ;

  "FusionList.iterate-generate" forall f.
     iterate f = generate (\x -> Just (x, f x)) ;

  "FusionList.take-crochetL"
     take = crochetL (\x n -> toMaybe (n>zero) (x, pred n)) ;

  "FusionList.unfold-dollar" forall f x.
     f $ x = f x ;

  "FusionList.unfold-dot" forall f g.
     f . g  =  \x -> f (g x) ;
  #-}

{-# INLINE unzip #-}
unzip :: T (a,b) -> (T a, T b)
unzip x = (map fst x, map snd x)

{-# INLINE unzip3 #-}
unzip3 :: T (a,b,c) -> (T a, T b, T c)
unzip3 xs = (map fst3 xs, map snd3 xs, map thd3 xs)


{-# INLINE delay1 #-}
{- |
This is a fusion friendly implementation of delay.
However, in order to be a 'crochetL'
the output has the same length as the input,
that is, the last element is removed - at least for finite input.
-}
delay1 :: a -> T a -> T a
delay1 = crochetL (flip (curry Just))

{-# INLINE delay #-}
delay :: y -> Int -> T y -> T y
delay z n = append (replicate n z)


{-# INLINE take #-}
take :: Int -> T a -> T a
take = crochetL (\x n -> toMaybe (n>zero) (x, pred n))

{-# INLINE takeWhile #-}
takeWhile :: (a -> Bool) -> T a -> T a
takeWhile p = crochetL (\x _ -> toMaybe (p x) (x, ())) ()

{-# INLINE replicate #-}
replicate :: Int -> a -> T a
replicate n = take n . repeat

{-# RULES
  "FusionList.map/repeat" forall f x.
     map f (repeat x) = repeat (f x) ;

  "FusionList.map/replicate" forall f n x.
     map f (replicate n x) = replicate n (f x) ;

  "FusionList.map/cons" forall f x xs.
      map f (cons x xs) = cons (f x) (map f xs) ;

  "FusionList.map/append" forall f xs ys.
      map f (append xs ys) = append (map f xs) (map f ys) ;

  {- should be subsumed by the map/cons rule,
       but it doesn't fire sometimes
  "FusionList.map/cons/compose" forall f g x xs.
      map f ((cons x . g) xs) = cons (f x) (map f (g xs)) ;
  -}

  {- this does not fire, since 'map' is inlined, crochetL/cons should fire instead -}
  "FusionList.map/scanL" forall f g x0 xs.
      map g (scanL f x0 xs) =
         cons (g x0)
            (crochetL (\x acc -> let y = f acc x in Just (g y, y)) x0 xs) ;

  "FusionList.map/zipWith" forall f g x y.
     map f (zipWith g x y) =
        zipWith (\xi yi -> f (g xi yi)) x y ;

  "FusionList.zipWith/map,*" forall f g x y.
     zipWith g (map f x) y =
        zipWith (\xi yi -> g (f xi) yi) x y ;

  "FusionList.zipWith/*,map" forall f g x y.
     zipWith g x (map f y) =
        zipWith (\xi yi -> g xi (f yi)) x y ;
  #-}

{- * functions consuming multiple lists -}

{-# NOINLINE [0] zipWith #-}
zipWith :: (a -> b -> c) -> (T a -> T b -> T c)
zipWith f s0 s1 =
   Cons $ List.zipWith f (decons s0) (decons s1)

{-# INLINE zipWith3 #-}
zipWith3 :: (a -> b -> c -> d) -> (T a -> T b -> T c -> T d)
zipWith3 f s0 s1 =
   zipWith (uncurry f) (zip s0 s1)

{-# INLINE zipWith4 #-}
zipWith4 :: (a -> b -> c -> d -> e) -> (T a -> T b -> T c -> T d -> T e)
zipWith4 f s0 s1 =
   zipWith3 (uncurry f) (zip s0 s1)


{-# INLINE zip #-}
zip :: T a -> T b -> T (a,b)
zip = zipWith (,)

{-# INLINE zip3 #-}
zip3 :: T a -> T b -> T c -> T (a,b,c)
zip3 = zipWith3 (,,)

{-# INLINE zip4 #-}
zip4 :: T a -> T b -> T c -> T d -> T (a,b,c,d)
zip4 = zipWith4 (,,,)


{- * functions based on 'reduceL' -}

reduceL :: (x -> acc -> Maybe acc) -> acc -> T x -> acc
reduceL f x = Sig.reduceL f x . decons

{-# INLINE foldL' #-}
foldL' :: (x -> acc -> acc) -> acc -> T x -> acc
foldL' f = reduceL (\x -> Just . f x)

{-# INLINE foldL #-}
foldL :: (acc -> x -> acc) -> acc -> T x -> acc
foldL f = foldL' (flip f)

{-# INLINE lengthSlow #-}
{- | can be used to check against native length implementation -}
lengthSlow :: T a -> Int
lengthSlow = foldL' (const succ) zero


{-
Do we still need rules for fusion of
  map f (repeat x)
  zipWith f (repeat x) ys
?
-}

{- * Fusion helpers -}

{-# INLINE zipWithGenerate #-}
zipWithGenerate ::
      (a -> b -> c)
   -> (acc -> Maybe (a, acc))
   -> acc
   -> T b -> T c
zipWithGenerate h f a y =
   crochetL (\y0 a0 ->
       do (x0,a1) <- f a0
          Just (h x0 y0, a1)) a y

{-# INLINE zipWithCrochetL #-}
zipWithCrochetL ::
      (a -> b -> c)
   -> (x -> acc -> Maybe (a, acc))
   -> acc
   -> T x -> T b -> T c
zipWithCrochetL h f a x y =
   crochetL (\(x0,y0) a0 ->
       do (z0,a1) <- f x0 a0
          Just (h z0 y0, a1))
      a (zip x y)

{-# INLINE mixGenerate #-}
mixGenerate :: (Additive.C a) =>
      (a -> a -> a)
   -> (acc -> Maybe (a, acc))
   -> acc
   -> T a -> T a
mixGenerate plus f a =
   crochetL
      (\y0 a0 ->
         Just (maybe
            (y0, Nothing)
            (\(x0,a1) -> (plus x0 y0, Just a1))
            (f =<< a0)))
      (Just a)

{-# INLINE crochetLCons #-}
crochetLCons ::
      (a -> acc -> Maybe (b, acc))
   -> acc
   -> a -> T a -> T b
crochetLCons f a0 x xs =
   maybe
      empty
      (\(y,a1) -> cons y (crochetL f a1 xs))
      (f x a0)

{-
{-# INLINE crochetLAppend #-}
crochetLAppend ::
      (a -> acc -> Maybe (b, acc))
   -> acc
   -> a -> T a -> T a -> T b
crochetLAppend f a0 x xs ys =
   maybe
      empty
      (\(y,a1) -> cons y (crochetL f a1 xs))
      (f x a0)
-}

{-# INLINE reduceLCons #-}
reduceLCons ::
      (a -> acc -> Maybe acc)
   -> acc
   -> a -> T a -> acc
reduceLCons f a0 x xs =
   maybe a0 (flip (reduceL f) xs) (f x a0)


{-
applyThroughCons ::
   (a -> Maybe (b,acc)) -> (T a -> acc -> T b) -> T a -> T b
applyThroughCons f g =
   maybe empty
      (\(x,xs) -> cons (f x) (g xs)) . viewL
-}

{-# INLINE zipWithCons #-}
zipWithCons ::
      (a -> b -> c)
   -> a -> T a -> T b -> T c
zipWithCons f x xs =
   maybe
      empty
      (\(y,ys) -> cons (f x y) (zipWith f xs ys))
    . viewL


{-# RULES
  "FusionList.crochetL/generate" forall f g a b.
     crochetL g b (generate f a) =
        generate (\(a0,b0) ->
            do (y0,a1) <- f a0
               (z0,b1) <- g y0 b0
               Just (z0, (a1,b1))) (a,b) ;

  "FusionList.crochetL/crochetL" forall f g a b x.
     crochetL g b (crochetL f a x) =
        crochetL (\x0 (a0,b0) ->
            do (y0,a1) <- f x0 a0
               (z0,b1) <- g y0 b0
               Just (z0, (a1,b1))) (a,b) x ;

  "FusionList.crochetL/cons" forall g b x xs.
     crochetL g b (cons x xs) =
        crochetLCons g b x xs ;


  "FusionList.tail/generate" forall f a.
     tail (generate f a) =
        maybe (error "FusionList.tail: empty list")
           (generate f . snd) (f a) ;

  "FusionList.tail/cons" forall x xs.
     tail (cons x xs) = xs ;

  "FusionList.zipWith/generate,*" forall f h a y.
     zipWith h (generate f a) y =
        zipWithGenerate h f a y ;

  "FusionList.zipWith/crochetL,*" forall f h a x y.
     zipWith h (crochetL f a x) y =
        zipWithCrochetL h f a x y ;

  "FusionList.zipWith/*,generate" forall f h a y.
     zipWith h y (generate f a) =
        zipWithGenerate (flip h) f a y ;

  "FusionList.zipWith/*,crochetL" forall f h a x y.
     zipWith h y (crochetL f a x) =
        zipWithCrochetL (flip h) f a x y ;

  "FusionList.mix/generate,*" forall f a y.
     mix (generate f a) y =
        mixGenerate (Additive.+) f a y ;

  "FusionList.mix/*,generate" forall f a y.
     mix y (generate f a) =
        mixGenerate (flip (Additive.+)) f a y ;


{- this blocks further fusion and
   is not necessary if the non-cons operand is a 'generate'
  "FusionList.zipWith/cons,*" forall h x xs ys.
     zipWith h (cons x xs) ys =
        zipWithCons h x xs ys ;

  "FusionList.zipWith/*,cons" forall h x xs ys.
     zipWith h ys (cons x xs) =
        zipWithCons (flip h) x xs ys ;
-}

  "FusionList.zipWith/cons,cons" forall h x xs y ys.
     zipWith h (cons x xs) (cons y ys) =
        cons (h x y) (zipWith h xs ys) ;

  "FusionList.zipWith/share" forall (h :: a->a->b) (x :: T a).
     zipWith h x x = map (\xi -> h xi xi) x ;



  "FusionList.reduceL/generate" forall f g a b.
     reduceL g b (generate f a) =
        snd
          (recourse (\(a0,b0) ->
              do (y,a1) <- f a0
                 b1 <- g y b0
                 Just (a1, b1)) (a,b)) ;

  "FusionList.reduceL/crochetL" forall f g a b x.
     reduceL g b (crochetL f a x) =
        snd
          (reduceL (\x0 (a0,b0) ->
              do (y,a1) <- f x0 a0
                 b1 <- g y b0
                 Just (a1, b1)) (a,b) x) ;

  "FusionList.reduceL/cons" forall g b x xs.
     reduceL g b (cons x xs) =
        reduceLCons g b x xs ;


  "FusionList.viewL/cons" forall x xs.
     viewL (cons x xs) = Just (x,xs) ;

  "FusionList.viewL/generateInfinite" forall f x.
     viewL (generateInfinite f x) =
        Just (mapSnd (generateInfinite f) (f x)) ;

  "FusionList.viewL/generate" forall f x.
     viewL (generate f x) =
        fmap (mapSnd (generate f)) (f x) ;

  "FusionList.viewL/crochetL" forall f a xt.
     viewL (crochetL f a xt) =
        do (x,xs) <- viewL xt
           (y,a') <- f x a
           return (y, crochetL f a' xs) ;
  #-}


{- * Other functions -}

null :: T a -> Bool
null = List.null . decons

empty :: T a
empty = Cons []

singleton :: a -> T a
singleton = Cons . (: [])

{-# NOINLINE [0] cons #-}
cons :: a -> T a -> T a
cons x = Cons . (x :) . decons

length :: T a -> Int
length = List.length . decons

viewL :: T a -> Maybe (a, T a)
viewL =
   fmap (mapSnd Cons) . ListHT.viewL . decons

viewR :: T a -> Maybe (T a, a)
viewR =
   fmap (mapFst Cons) . ListHT.viewR . decons

extendConstant :: T a -> T a
extendConstant xt =
   maybe empty (append xt . repeat . snd) $
   viewR xt

{-# NOINLINE [0] tail #-}
tail :: T a -> T a
tail = Cons . List.tail . decons

head :: T a -> a
head = List.head . decons

drop :: Int -> T a -> T a
drop n = Cons . List.drop n . decons

dropMarginRem :: Int -> Int -> T a -> (Int, T a)
dropMarginRem n m = mapSnd Cons . Sig.dropMarginRem n m . decons

{-
This implementation does only walk once through the dropped prefix.
It is maximally lazy and minimally space consuming.
-}
dropMargin :: Int -> Int -> T a -> T a
dropMargin n m = Cons . Sig.dropMargin n m . decons


index :: Int -> T a -> a
index n = (List.!! n) . decons


splitAt :: Int -> T a -> (T a, T a)
splitAt n = mapPair (Cons, Cons) . List.splitAt n . decons

dropWhile :: (a -> Bool) -> T a -> T a
dropWhile p = Cons . List.dropWhile p . decons

span :: (a -> Bool) -> T a -> (T a, T a)
span p = mapPair (Cons, Cons) . List.span p . decons

mapAccumL :: (acc -> x -> (acc, y)) -> acc -> T x -> (acc, T y)
mapAccumL f acc = mapSnd Cons . List.mapAccumL f acc . decons

mapAccumR :: (acc -> x -> (acc, y)) -> acc -> T x -> (acc, T y)
mapAccumR f acc = mapSnd Cons . List.mapAccumR f acc . decons


cycle :: T a -> T a
cycle = Cons . List.cycle . decons

{-# NOINLINE [0] mix #-}
mix :: Additive.C a => T a -> T a -> T a
mix (Cons xs) (Cons ys)  =  Cons (xs Additive.+ ys)

{-# NOINLINE [0] sub #-}
sub :: Additive.C a => T a -> T a -> T a
sub (Cons xs) (Cons ys)  =  Cons (xs Additive.- ys)

{-# NOINLINE [0] neg #-}
neg :: Additive.C a => T a -> T a
neg (Cons xs)  =  Cons (Additive.negate xs)

instance Additive.C y => Additive.C (T y) where
   zero = empty
   (+) = mix
   (-) = sub
   negate = neg

instance Module.C y yv => Module.C y (T yv) where
   (*>) x y = map (x*>) y


infixr 5 `append`

{-# NOINLINE [0] append #-}
append :: T a -> T a -> T a
append (Cons xs) (Cons ys)  =  Cons (xs List.++ ys)

concat :: [T a] -> T a
concat  =  Cons . List.concat . List.map decons

reverse :: T a -> T a
reverse = Cons . List.reverse . decons



sum :: (Additive.C a) => T a -> a
sum = foldL' (Additive.+) Additive.zero

maximum :: (Ord a) => T a -> a
maximum =
   maybe
      (error "FusionList.maximum: empty list")
      (uncurry (foldL' max))
    . viewL

tails :: T y -> [T y]
tails = List.map Cons . List.tails . decons

init :: T y -> T y
init = Cons . List.init . decons

sliceVert :: Int -> T y -> [T y]
sliceVert n =
   List.map (take n) . List.takeWhile (not . null) . List.iterate (drop n)


zapWith :: (a -> a -> b) -> T a -> T b
zapWith f xs0 =
   let xs1 = maybe empty snd (viewL xs0)
   in  zipWith f xs0 xs1

modifyStatic :: Modifier.Simple s ctrl a b -> ctrl -> T a -> T b
modifyStatic modif control x =
   crochetL
      (\a acc ->
         Just (runState (Modifier.step modif control a) acc))
      (Modifier.init modif) x

{-| Here the control may vary over the time. -}
modifyModulated :: Modifier.Simple s ctrl a b -> T ctrl -> T a -> T b
modifyModulated modif control x =
   crochetL
      (\ca acc ->
         Just (runState (uncurry (Modifier.step modif) ca) acc))
      (Modifier.init modif)
      (zip control x)


-- cf. Module.linearComb
linearComb ::
   (Module.C t y) =>
   T t -> T y -> y
linearComb ts ys =
   sum $ zipWith (*>) ts ys


-- comonadic 'bind'
-- only non-empty suffixes are processed
mapTails ::
   (T y0 -> y1) -> T y0 -> T y1
mapTails f =
   generate (\xs ->
      do (_,ys) <- viewL xs
         return (f xs, ys))

-- only non-empty suffixes are processed
zipWithTails ::
   (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2
zipWithTails f =
   curry $ generate (\(xs0,ys0) ->
      do (x,xs) <- viewL xs0
         (_,ys) <- viewL ys0
         return (f x ys0, (xs,ys)))

zipWithRest ::
   (y0 -> y0 -> y1) ->
   T y0 -> T y0 ->
   (T y1, (Bool, T y0))
zipWithRest f xs ys =
   mapPair (fromList, mapSnd fromList) $
   Sig.zipWithRest f
      (toList xs) (toList ys)

zipWithAppend ::
   (y -> y -> y) ->
   T y -> T y -> T y
zipWithAppend f xs ys =
   uncurry append $ mapSnd snd $ zipWithRest f xs ys

delayLoop ::
      (T y -> T y)
            -- ^ processor that shall be run in a feedback loop
   -> T y   -- ^ prefix of the output, its length determines the delay
   -> T y
delayLoop proc prefix =
   let ys = append prefix (proc ys)
   in  ys

delayLoopOverlap ::
   (Additive.C y) =>
      Int
   -> (T y -> T y)
            -- ^ processor that shall be run in a feedback loop
   -> T y   -- ^ input
   -> T y   -- ^ output has the same length as the input
delayLoopOverlap time proc xs =
   let ys = zipWith (Additive.+) xs (delay zero time (proc ys))
   in  ys


-- maybe candidate for Utility

recourse :: (acc -> Maybe acc) -> acc -> acc
recourse f =
   let aux x = maybe x aux (f x)
   in  aux