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 hiding (length)
import Zwirn.Core.Core
import Zwirn.Core.Lib.Conditional
import Zwirn.Core.Lib.Cord hiding (length)
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
  cyclesPerSecond = pure 0.575

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)]
    ]