experiments.cabal

Name:          experiments
Version:       0.1
Cabal-Version: >= 1.8
Build-Type:    Simple

Executable experiments
  Main-Is:        Main.hs
  ghc-options: -Wall -rtsopts -auto-all -caf-all -O2 -fno-warn-unused-imports
               -fno-spec-constr
               -- -ddump-ds
               -- -fext-core -ddump-simpl -dsuppress-module-prefixes -dsuppress-uniques
  hs-source-dirs: .
  Build-Depends:
    base >=3 && <5

Main.hs

{-# LANGUAGE Arrows, TemplateHaskell #-}


module Main where


import Prelude hiding (id, init, (.))
import Control.Arrow
import Control.Category

newtype RecArrow a b = RecArrow { runRecArrow :: (a -> (b, RecArrow a b)) }

instance Category RecArrow where
  id    = RecArrow $ \x -> (x, id) --let x = RecArrow (\y -> (y, x)) in x
  f . g =
    RecArrow $ \x ->
      let (y, g') = runRecArrow g x
          (z, f') = runRecArrow f y
      in (z, f' . g')

instance Arrow RecArrow where
  arr f = h
    where h = RecArrow $ \x -> (f x, h)
  first (RecArrow f) = RecArrow $ \ ~(x,y) ->
        let (x', f') = f x
        in ((x',y), first f')
  f &&& g = RecArrow $ \x ->
    let (y, f') = runRecArrow f x
        (z, g') = runRecArrow g x
    in ((y,z),f' &&& g')
  f *** g = RecArrow $ \ ~(x,y) ->
    let (x', f') = runRecArrow f x
        (y', g') = runRecArrow g y
    in ((x', y'), f' *** g')

instance ArrowLoop RecArrow where
  loop f = RecArrow $ \x ->
    let
      ((x', y), f') = runRecArrow f (x, y)
    in (x', loop f')

init i = RecArrow $ \x -> (i, init x)

run :: RecArrow a b -> [a] -> [b]
run _ [] = []
run f (x:xs) =
  let (y, f') = runRecArrow f x
  in y : run f' xs

{-
oscFixed :: ArrowInit a => Double -> a () Double
oscFixed freq =
  let omh = 2 * pi * freq
      d   = sin omh
      c   = 2 * cos omh
      sf  = proc () -> do
               rec
                 let r = c * d2 - d1
                 d1 <- init 0         -< d2
                 d2 <- init d         -< r
               returnA -< r
  in sf
-}

oscFixed''' :: Double -> RecArrow () Double
oscFixed''' freq =
  let omh = 2 * pi * freq
      d   = sin omh
      c   = 2 * cos omh
      sf  = loop $ proc ((), (d1, d2)) -> do
                 let r = c*d2-d1
                 d1 <- init 0         -< d2 --(undefined::Double)  -- replacing d2 with undefined makes test2 terminate
                 d2 <- init d         -< r
                 returnA -< (r, (d1, d2))
  in sf

test1 = mapM_ print $ run (oscFixed''' 0.04) $ replicate 5 ()
test2 = mapM_ print $ run (oscFixed''' 0.04) $ replicate 1 ()

main :: IO ()
main = do
  --mapM_ print $ run (oscFixed 0.04) $ replicate 5 ()
  test1