Main.hs

{-# LANGUAGE MultiParamTypeClasses #-}

import Control.Monad
import Data.Bifunctor (first)
import Data.Functor.Identity
import qualified Data.List as L
import qualified Data.Map as Map
import qualified Data.Ratio as R
import Test.Tasty
import Test.Tasty.HUnit
import Zwirn.Core.Cord as Z
import Zwirn.Core.Core
import Zwirn.Core.Lib.Conditional
import Zwirn.Core.Lib.Cord
import Zwirn.Core.Lib.Core
import Zwirn.Core.Lib.Map
import Zwirn.Core.Lib.Modulate
import Zwirn.Core.Lib.Number
import Zwirn.Core.Lib.Random
import Zwirn.Core.Lib.Structure
import Zwirn.Core.Query
import Zwirn.Core.Time
import Zwirn.Core.Tree (Tree (..))
import Zwirn.Core.Types

main = defaultMain tests

tests :: TestTree
tests = testGroup "Tests" [unitTests]

queryFirst :: Cord () () a -> [(Time, a)]
queryFirst = findAllValuesWithTime (Time 0 1, Time 1 1) ()

queryN :: Rational -> Cord () () a -> [(Time, a)]
queryN n = findAllValuesWithTime (Time 0 1, Time n 1) ()

(@?~) :: (Show a, Eq a) => [(Time, a)] -> [(Time, a)] -> Assertion
(@?~) actual expected = unless (Prelude.and check && length actual == length expected) (assertFailure msg)
  where
    msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual
    check = zipWith (\(a, v1) (b, v2) -> abs (a - b) < 0.01 && v1 == v2) expected actual

-- | should be used for signals
(~@?~) :: (Show a, Eq a, Fractional a, Ord a) => [(Time, a)] -> [(Time, a)] -> Assertion
(~@?~) actual expected = unless (Prelude.and check && length actual == length expected) (assertFailure msg)
  where
    msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual
    check = zipWith (\(a, v1) (b, v2) -> abs (a - b) < 0.01 && (abs (v1 - v2) < 0.01)) expected actual

(%) :: Integer -> Integer -> Time
(%) x y = Time (x R.% y) (0 R.% 1)

simpleZwirn :: Cord () () Int
simpleZwirn = fastcat [pure 1, pure 2, pure 3, pure 4]

nestedZwirn :: Cord () () Int
nestedZwirn = fastcat [pure 10, pure 20, fastcat [pure 30, pure 40]]

veryNested :: Cord () () Int
veryNested = fastcat [simpleZwirn, nestedZwirn]

simpleCord :: Cord () () Int
simpleCord = stack [pure 10, simpleZwirn]

instance State Tree () () where
  beatsPerCycle = pure 8

unitTests =
  testGroup
    "Unit tests"
    [ testCase "pure for Zwirns" $
        queryFirst (pure 1 :: Cord () () Int) @?~ [(0, 1)],
      testCase "simple nesting" $
        queryFirst simpleZwirn @?~ [(0, 1), (1 % 4, 2), (1 % 2, 3), (3 % 4, 4)],
      testCase "more nesting" $
        queryFirst nestedZwirn @?~ [(0, 10), (1 % 3, 20), (2 % 3, 30), (5 % 6, 40)],
      testCase "very nested" $
        queryFirst veryNested @?~ [(0, 1), (1 % 8, 2), (2 % 8, 3), (3 % 8, 4), (1 % 2, 10), (4 % 6, 20), (5 % 6, 30), (11 % 12, 40)],
      testCase "reverse simple Zwirn" $
        queryFirst (rev simpleZwirn) @?~ [(0, 4), (1 % 4, 3), (1 % 2, 2), (3 % 4, 1)],
      testCase "reverse more nesting" $
        queryFirst (rev nestedZwirn) @?~ [(0, 40), (1 % 6, 30), (1 % 3, 20), (2 % 3, 10)],
      testCase "reverse inside" $
        queryFirst (fastcat [pure 100, rev simpleZwirn, pure 200, pure 300]) @?~ [(0, 100), (4 % 16, 4), (5 % 16, 3), (6 % 16, 2), (7 % 16, 1), (1 % 2, 200), (3 % 4, 300)],
      testCase "reverse reverse inside" $
        queryFirst (rev $ fastcat [pure 100, rev simpleZwirn, pure 200, pure 300]) @?~ [(0, 300), (1 % 4, 200), (8 % 16, 1), (9 % 16, 2), (10 % 16, 3), (11 % 16, 4), (3 % 4, 100)],
      testCase "squeezeJoin" $
        queryFirst (squeezeJoin $ fmap (const $ fastcat [pure 10, pure 20 :: Cord () () Int]) simpleZwirn) @?~ [(0, 10), (1 % 8, 20), (2 % 8, 10), (3 % 8, 20), (4 % 8, 10), (5 % 8, 20), (6 % 8, 10), (7 % 8, 20)],
      testCase "ply" $
        queryFirst (ply (pure 2) simpleZwirn) @?~ [(0, 1), (1 / 8, 1), (1 / 4, 2), (3 / 8, 2), (1 / 2, 3), (5 / 8, 3), (3 / 4, 4), (7 / 8, 4)],
      testCase "loop" $
        queryFirst (loop (pure 0.25) (pure 0.75) simpleZwirn) @?~ [(0, 2), (1 / 4, 3), (1 / 2, 2), (3 / 4, 3)],
      testCase "zoom rev" $
        queryFirst (zoom (pure 1) (pure 0) simpleZwirn) @?~ queryFirst (rev simpleZwirn),
      testCase "timeloop" $
        queryFirst (timeloop (pure 0.25) simpleZwirn) @?~ [(0, 1), (1 / 4, 1), (1 / 2, 1), (3 / 4, 1)],
      testCase "cat" $
        queryN 4 (cat (0.25, pure 1) (0.25, pure 2)) @?~ [(0, 1), (1 / 4, 2), (2, 1), (9 / 4, 2)],
      testCase "cyclecat" $
        queryN 3 (cyclecat [(1, pure 10), (2, slow (pure 2) $ pure 20)]) @?~ [(0, 10), (1, 20)],
      testCase "cyclecat 2" $
        queryN 2 (cyclecat [(0.5, pure 10), (1, pure 20), (0.5, pure 30)]) @?~ [(0, 10), (1 / 2, 20), (3 / 2, 30)],
      testCase "fastcyclecat" $
        queryFirst (fastcyclecat [(0.25, pure 1), (0.25, pure 2)]) @?~ [(0, 1), (1 / 4, 2), (1 / 2, 1), (3 / 4, 2)],
      testCase "fastcyclecat2" $
        queryFirst (fastcyclecat [(0.5, pure 1), (0.25, pure 2)]) @?~ [(0, 1), (1 / 2, 2), (3 / 4, 1)],
      testCase "euclid" $
        queryFirst (euclid (pure 3) (pure 8) (pure 1)) @?~ [(0, 1), (3 / 8, 1), (3 / 4, 1)],
      testCase "everyFor" $
        queryFirst (everyFor (pure 1) (pure 0.5) (pure $ fmap succ) simpleZwirn) @?~ [(0, 2), (1 / 4, 3), (1 / 2, 3), (3 / 4, 4)],
      testCase "everyFor 2" $
        queryN 2 (everyFor (pure 0.75) (pure 0.5) (pure $ fmap (const 100)) simpleZwirn) @?~ [(0, 100), (1 / 4, 100), (1 / 2, 3), (3 / 4, 100), (1, 100), (5 / 4, 2), (3 / 2, 100), (7 / 4, 100)],
      testCase "ifthen" $
        queryFirst (ifthen (fastcat [pure True, pure False]) (pure 10) (fastcat [pure 20, pure 30])) @?~ [(0, 10), (1 / 2, 30)],
      testCase "ifthen 2" $
        queryFirst (ifthen (fastcat [pure True, pure False]) simpleZwirn simpleZwirn) @?~ [(0, 1), (1 / 4, 2), (1 / 2, 3), (3 / 4, 4)],
      testCase "while" $
        queryFirst (while (fastcat [pure True, pure False]) (pure $ fmap succ) simpleZwirn) @?~ [(0, 2), (1 / 4, 3), (1 / 2, 3), (3 / 4, 4)],
      testCase "simpleCord" $
        queryFirst simpleCord @?~ [(0, 10), (0, 1), (1 / 4, 2), (1 / 2, 3), (3 / 4, 4)],
      testCase "enum cord" $
        queryFirst (enumFromToStack (pure 0) (pure 4)) @?~ [(0, 0), (0, 1), (0, 2), (0, 3)],
      testCase "zipApply" $
        queryFirst (zipApply (stack [pure $ fmap (+ 10), pure $ fmap (+ 100)]) (stack [fastcat [pure 1, pure 2], pure 3])) @?~ [(0 % 1, 11), (0 % 1, 103), (1 % 2, 12)],
      testCase "sine" $
        queryFirst (segment (pure 4) sine) ~@?~ [(0, 0.5), (1 / 4, 1), (1 / 2, 0.5), (3 / 4, 0)],
      testCase "rev sine" $
        queryFirst (segment (pure 4) $ rev sine) ~@?~ [(0, 0.5), (1 / 4, 0), (1 / 2, 0.5), (3 / 4, 1)],
      testCase "singleton" $
        queryFirst (singleton (pure "n") (fast (pure 2) $ pure 1)) @?~ [(0, Map.singleton "n" 1), (1 / 2, Map.singleton "n" 1)],
      testCase "union" $
        queryFirst (singleton (pure "n") (fast (pure 2) $ pure 1) `union` singleton (pure "s") (pure 1))
          @?~ [ (0, Map.singleton "n" 1 `Map.union` Map.singleton "s" 1),
                (1 / 2, Map.singleton "n" 1 `Map.union` Map.singleton "s" 1)
              ],
      testCase "fix" $
        queryFirst (fix (fastcat [pure "n"]) (pure $ const $ pure 10) (singleton (pure "n") (fast (pure 2) $ pure 1) `union` singleton (pure "s") (pure 1)))
          @?~ [ (0, Map.singleton "n" 10 `Map.union` Map.singleton "s" 1),
                (1 / 2, Map.singleton "n" 10 `Map.union` Map.singleton "s" 1)
              ],
      testCase "fix 2" $
        queryFirst (fix (fastcat [pure "n", pure "s"]) (pure $ const $ pure 10) (singleton (pure "n") (fast (pure 2) $ pure 1) `union` singleton (pure "s") (pure 1)))
          @?~ [ (0, Map.singleton "n" 10 `Map.union` Map.singleton "s" 1),
                (1 / 2, Map.singleton "n" 1 `Map.union` Map.singleton "s" 10)
              ],
      testCase "chunked" $
        queryFirst (chunked (pure "I:") (pure 1))
          @?~ [(0, 1), (1 / 4, 1), (3 / 8, 1), (1 / 2, 1), (3 / 4, 1), (7 / 8, 1)],
      testCase "chunked2" $
        queryFirst (fast (pure $ 5 / 8) $ chunked (pure "vi") (pure 1))
          @?~ [(1 / 5, 1), (2 / 5, 1), (3 / 5, 1), (4 / 5, 1)],
      testCase "chunked3" $
        queryFirst (chunked (pure "i~") (fastcat [pure 1, pure 2]))
          @?~ [(0, 1), (1 / 8, 1), (1 / 4, 1), (1 / 2, 2), (5 / 8, 2), (3 / 4, 2)],
      testCase "chunk" $
        queryFirst (chunk (pure "i~"))
          @?~ [(0, 0), (1 / 8, 1), (1 / 4, 2), (1 / 2, 0), (5 / 8, 1), (3 / 4, 2)],
      testCase "nested chunk" $
        queryFirst (slow (pure 2) $ chunked (pure "I[:]~") (pure 1))
          @?~ [(0, 1), (1 / 2, 1), (5 / 8, 1)],
      testCase "binary" $
        queryFirst (slow (pure 2) $ chunked (binary (pure 5)) (pure 1))
          @?~ [(0, 1), (1 / 2, 1), (3 / 4, 1)],
      testCase "christoffel" $
        queryFirst (chunked (christoffel (pure 3) (pure 5)) (pure 1))
          @?~ [(0, 1), (1 / 8, 1), (3 / 8, 1), (1 / 2, 1), (3 / 4, 1)],
      testCase "silence" $
        queryFirst (fastcat [silence, pure 2, silence, pure 4])
          @?~ [(1 / 4, 2), (3 / 4, 4)],
      testCase "everyBeat" $
        queryFirst (everyBeat (pure 4) (pure $ \x -> x + 1) simpleZwirn)
          @?~ [(0, 2), (1 / 4, 2), (1 / 2, 4), (3 / 4, 4)]
    ]