prune, shift, stack, interleave, ap

README.md

@@ -1,3 +1 @@
 # syzygy
-
-

package.yaml

@@ -24,3 +24,4 @@ tests:
     dependencies:
       - syzygy
       - hspec
+      - QuickCheck

src/Syzygy.hs

@@ -1,37 +1,74 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE RankNTypes #-}
 
 module Syzygy where
 
-import Data.Function ((&))
 import Data.Profunctor
+import Data.Function ((&))
 
 type Time = Rational
 type Interval = (Time, Time) -- left-closed and right-open intervals
 type Event a = (Interval, a)
 type Signal a = Interval -> [Event a] -- A signal is defined by the "integral" of a sampling function
 
--- newtype Behavior a = MkBehavior (forall b. (Signal (a -> b) -> Signal b)) -- TODO: checkout paf31's encoding, looks like a constrained signal transformer
-
 embed :: a -> Signal a
 embed x (queryStart, queryEnd) = do
   let
-    start = (fromIntegral @Integer) . ceiling $ queryStart
-    end = (fromIntegral @Integer) . floor $ queryEnd - 1/256 -- FIMXE: make less hacky
-  beat <- [start..end]
+    start = (fromIntegral @Integer) . floor $ queryStart
+    end = (fromIntegral @Integer) . ceiling $ queryEnd
+  beat <- [start..end - 1]
   return ((beat, beat + 1), x)
 
-fast :: Rational -> Signal a -> Signal a
-fast n = dimap mapQuery mapResult
+
+prune :: Signal a -> Signal a
+prune signal (queryStart, queryEnd) = filter inBounds $ signal (queryStart, queryEnd)
   where
-    mapQuery :: Interval -> Interval
-    mapQuery (start, end) = (start * n, end * n)
+    inBounds ((s, _), _) = s >= queryStart && s < queryEnd
+
+-- | shift forward in time
+shift :: Time -> Signal a -> Signal a
+shift t f = f
+  & lmap (\(start, end) -> (start - t, end - t))
+  & rmap (\res -> [((start + t, end + t), x) | ((start, end), x) <- res])
+
+stack :: [Signal a] -> Signal a
+stack sigs query = do
+  sig <- sigs
+  sig query
 
-    mapResult :: [Event a] -> [Event a]
-    mapResult res = do
-      ((start, end), x) <- res
-      return $ ((start / n, end / n), x)
+interleave :: [Signal a] -> Signal a
+interleave sigs query = do
+  let (fromIntegral -> len) = length sigs
+  (sig, n) <- zip sigs [0..]
+  shift (n/len) sig query
+
+-- | scale faster in time
+fast :: Rational -> Signal a -> Signal a
+fast n sig = sig
+  & lmap (\(start, end) -> (start * n, end * n))
+  & rmap (\res -> [((start/n, end/n), x) | ((start, end), x) <- res])
+
+ap ::  Signal (a -> b) -> Signal a -> Signal b
+ap sigF (prune -> sigX) = prune $ \query0 ->  do
+  (query1, f) <- sigF query0
+  (query2, x) <- sigX query1
+  return (query2, f x)
+
+-- A Behavior is a continuous function that is defined at every point in the sampling space
+type Behavior a = forall b. (Signal (a -> b) -> Signal b)
+runBehavior :: Behavior (a -> b) -> Signal a -> Signal b
+runBehavior b s = b $ (fmap . fmap . fmap) (flip ($)) s
+
+liftContinuous :: (Time -> a) -> Behavior a
+liftContinuous fn sig query = do
+  let events = sig query
+  ((s, e), f) <- events
+  let
+    midpoint = (s + e) * 0.5
+    y = fn midpoint
+  return ((s, e), f y)
 
-showSignal :: (Show a) => Signal a -> String
-showSignal pat = pat & ($(0, 1)) & show
+sine :: Behavior Double
+sine = liftContinuous $ sin . fromRational

syzygy.cabal

@@ -37,6 +37,7 @@ test-suite syzygy-test
     , profunctors
     , syzygy
     , hspec
+    , QuickCheck
   other-modules:
       SyzygySpec
   default-language: Haskell2010

test/SyzygySpec.hs

@@ -1,11 +1,16 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TupleSections #-}
 
 module SyzygySpec where
 
 import Test.Hspec
 import Syzygy
-import Data.Function ((&))
 import Data.Monoid
+import Test.QuickCheck
+import Data.Function ((&))
 
 queryWith :: Interval -> Signal a -> [Event a]
 queryWith x p = p x
@@ -18,22 +23,40 @@ spec = do
       it "should work" $ do
         pat (0, 1) `shouldBe` [((0, 1), ())]
         pat (0, 2) `shouldBe` [((0, 1), ()), ((1, 2), ())]
-        pat (0.5, 1.5) `shouldBe` [((1, 2), ())]
-        pat (0.5, 2.5) `shouldBe` [((1, 2), ()), ((2, 3), ())]
+        pat (0.5, 1.5) `shouldBe` [((0, 1), ()), ((1, 2), ())]
+        pat (0.5, 2.5) `shouldBe` [((0, 1), ()), ((1, 2), ()), ((2, 3), ())]
+
+      it "starts of events should be less than query ends" $ property $ \input ->
+        let
+          ((NonNegative (start :: Rational), NonNegative (dur :: Rational))) = input
+          end = start + dur
+          events = pat (start, end)
+          offendingEvents = filter (\((s, e), _) -> s >= end) events
+        in
+          length offendingEvents == 0
 
-      it "should return nothing for infinitesimally small queries" $ do
-        (pat (0, 0)) `shouldBe` []
+      it "ends of events should be greater than query starts" $ property $ \input ->
+        let
+          ((NonNegative (start :: Rational), NonNegative (dur :: Rational))) = input
+          end = start + dur
+          events = pat (start, end)
+          offendingEvents = filter (\((s, e), _) -> e <= start) events
+        in
+          length offendingEvents == 0
 
-      it "should have transparently divisible queries" $ do
-        (pat (0, 0) <> pat (0, 1)) `shouldBe` pat (0, 1)
-        (pat (0, 1) <> pat (1, 1)) `shouldBe` pat (0, 1)
-        (pat (0, 0.5) <> pat (0.5, 1.0)) `shouldBe` pat (0, 1)
-        (pat (0, 0.3) <> pat (0.3, 1.3) <> pat (1.3, 2)) `shouldBe` pat (0, 2)
+      describe "when pruned" $ do
+        let pat = embed () & prune
+
+        it "should have transparently divisible queries" $ do
+          (pat (0, 0) <> pat (0, 1)) `shouldBe` pat (0, 1)
+          (pat (0, 1) <> pat (1, 1)) `shouldBe` pat (0, 1)
+          (pat (0, 0.5) <> pat (0.5, 1.0)) `shouldBe` pat (0, 1)
+          (pat (0, 0.3) <> pat (0.3, 1.3) <> pat (1.3, 2)) `shouldBe` pat (0, 2)
 
     describe "fast" $ do
       let pat = embed ()
       it "should noop for fast 1" $ do
-        (fast 1 pat) (0, 1)  `shouldBe`(fast 1 pat) (0, 1)
+        (fast 1 pat) (0, 1)  `shouldBe` pat (0, 1)
 
       it "should work for fast 2" $ do
         (fast 2 pat) (0, 0.5) `shouldBe` [((0, 1/2), ())]
@@ -44,3 +67,45 @@ spec = do
         (fast 3 pat) (0, 1/3) `shouldBe` [((0, 1/3), ())]
         (fast 3 pat) (0, 1) `shouldBe` [((0, 1/3), ()), ((1/3, 2/3), ()), ((2/3, 1), ())]
         (fast 3 pat) (2/3, 4/3) `shouldBe` [((2/3, 1), ()), ((1, 4/3), ())]
+
+      it "should noop for fast 0.5" $ do
+        (fast 0.5 pat) (0, 1)  `shouldBe` [((0, 2), ())]
+        (fast 0.5 pat) (0, 2)  `shouldBe` [((0, 2), ())]
+
+    describe "shift" $ do
+      let pat = embed ()
+      it "should noop for shift 0" $ do
+        (shift 0 pat) (0, 1)  `shouldBe` pat (0, 1)
+
+      it "should work" $ do
+        (shift 0 pat) (0, 1)  `shouldBe` [((0, 1), ())]
+        (shift 0.5 pat) (0, 1)  `shouldBe` [((-1/2, 1/2), ()), ((1/2, 3/2), ())]
+        (shift 1 pat) (0, 1)  `shouldBe` [((0, 1), ())]
+
+      it "should shift forwards in time" $ do
+        (shift 0.25 pat) (0, 1)  `shouldBe` [((-3/4, 1/4), ()), ((1/4, 5/4), ())]
+
+    describe "stack" $ do
+      let pat = embed ()
+      it "should stack patterns" $ do
+        stack [(shift 0.25 pat), (shift 0.5 pat)] (0, 1) `shouldBe` [((-3/4, 1/4), ()), ((1/4, 5/4), ()), ((-1/2, 1/2), ()), ((1/2, 3/2), ())]
+
+    describe "interleave" $ do
+      let pat = embed ()
+      it "should noop for 1" $ do
+        interleave [pat] (0, 1) `shouldBe` pat (0, 1)
+
+      it "should stack patterns, shifted" $ do
+        interleave [pat, pat] (0, 1) `shouldBe` stack [(shift 0 pat), (shift 0.5 pat)] (0, 1)
+        interleave [pat, pat, pat] (0, 1) `shouldBe` stack [(shift 0 pat), (shift (1/3) pat), (shift (2/3) pat)] (0, 1)
+
+    describe "ap" $ do
+      let pat = embed ()
+
+      it "should noop for pure id" $ do
+        (ap (embed id) pat) (0, 1)  `shouldBe` [((0, 1), ())]
+
+      it "should work" $ do
+        let patF = interleave $ embed <$> [("a",), ("b",)]
+        (ap patF pat) (0, 1) `shouldBe` [((0, 1), ("a", ())), ((0, 1), ("b", ()))] -- FIXME: is this really what we want?
+        (ap patF (fast 2 pat)) (0, 1)  `shouldBe` [((0, 1/2), ("a", ())), ((1/2, 1), ("a", ())), ((0, 1/2), ("b", ())), ((1/2, 1), ("b", ()))]