module Medium where

import qualified Medium.Temporal as Temporal


infixr 7 +:+  {- like multiplication -}
infixr 6 =:=  {- like addition -}


class Construct medium where
   prim :: a -> medium a

   {- for easy compatibility with Haskore 2000 songs
      replace :+: by +:+ and :=: by =:= -}
   (+:+), (=:=) :: medium a -> medium a -> medium a

   serial, parallel :: Temporal.C a => [medium a] -> medium a
   serial1, parallel1 :: [medium a] -> medium a

class Construct medium => C medium where
   {- Do actions on each (virtual) constructor, don't recourse. -}
   switchBinary ::
         (a -> b) -> (medium a -> medium a -> b) -> (medium a -> medium a -> b)
      -> (b -> medium a -> b)
   switchList :: (a -> b) -> ([medium a] -> b) -> ([medium a] -> b)
      -> medium a -> b


{- A variant of fmap that does not only allow manipulation of primitives
   but also of the compositions.
   Though the structure must be preserved. -}
mapList :: (Temporal.C b, Medium.C medium) =>
   (a->b) -> ([medium b]->[medium b]) -> ([medium b]->[medium b]) -> medium a -> medium b
mapList f g h = foldList (prim . f) (serial . g) (parallel . h)

mapListFlat :: (Temporal.C b, Medium.C medium) =>
   (a -> b) -> ([medium a] -> [medium b]) -> ([medium a] -> [medium b]) -> medium a -> medium b
mapListFlat f g h = switchList (prim . f) (serial . g) (parallel . h)


{- This is even more general than mapList -}
foldList :: Medium.C medium => (a->b) -> ([b]->b) -> ([b]->b) -> medium a -> b
foldList f g h =
   let recourse = map (foldList f g h)
   in  switchList f (g . recourse) (h . recourse)

foldBin :: Medium.C medium => (a->b) -> (b->b->b) -> (b->b->b) -> b -> medium a -> b
foldBin f g h z =
   -- foldList f (foldr1 g) (foldr1 h)
   -- this implementation preserves the structure of the binary tree
   let recourse op x y = foldBin f g h z x `op` foldBin f g h z y
   in  switchBinary f (recourse g) (recourse h) z


listMediumFromAny :: (Construct dst, C src, Temporal.C a) => src a -> dst a
listMediumFromAny  =  foldList prim serial parallel

binaryMediumFromAny :: (Construct dst, C src) => dst a -> src a -> dst a
binaryMediumFromAny z  =  foldBin prim (+:+) (=:=) z