synthesizer-0.0.3: src/Synthesizer/FusionList/Signal.hs

{-# OPTIONS_GHC -O -fglasgow-exts -fno-implicit-prelude #-}
{- glasgow-exts are for the rules -}
module Synthesizer.FusionList.Signal where

import qualified Synthesizer.Generic.Signal as SigG

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.State (State, runState, )

import Synthesizer.Utility
   (viewListL, viewListR, mapFst, mapSnd, mapPair, fst3, snd3, thd3)

import NumericPrelude.Condition (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 SigG.C T where
   empty = empty
   null = null
   cons = cons
   fromList = fromList
   toList = toList
   repeat = repeat
   cycle = cycle
   replicate = replicate
   iterate = iterate
   iterateAssoc op x = iterate (op x) x -- should be optimized
   unfoldR = generate
   map = map
   mix = mix
   zipWith = zipWith
   scanL = scanL
   viewL = viewL
   viewR = viewR
   foldL = foldL
   length = length
   take = take
   drop = drop
   splitAt = splitAt
   dropMarginRem = dropMarginRem
   takeWhile = takeWhile
   dropWhile = dropWhile
   span = span
   append = append
   concat = concat
   reverse = reverse
{-
   mapAccumL = mapAccumL
   mapAccumR = mapAccumR
-}
   crochetL = crochetL



{- * 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 viewListL

{-# 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 iterateAssoc #-}
iterateAssoc :: (a -> a -> a) -> a -> T a
iterateAssoc 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
          (recurse (\(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) . viewListL . decons

viewR :: T a -> Maybe (T a, a)
viewR =
   fmap (mapFst Cons) . viewListR . 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)))

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

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