diff --git a/minipat/src/Minipat/Interp.hs b/minipat/src/Minipat/Interp.hs index ff76dfb..2f52e5f 100644 --- a/minipat/src/Minipat/Interp.hs +++ b/minipat/src/Minipat/Interp.hs @@ -6,11 +6,10 @@ where import Control.Applicative (Alternative (..)) import Control.Exception (Exception) -import Control.Monad.Except (Except, ExceptT, runExcept, runExceptT) +import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.Trans (lift) import Data.Foldable (foldMap') -import Data.Foldable1 (foldMap1', foldl1') -import Data.Semigroup (Sum (..)) +import Data.Foldable1 (foldl1') import Data.Sequence.NonEmpty qualified as NESeq import Minipat.Ast qualified as A import Minipat.Base qualified as B @@ -34,13 +33,13 @@ lookInterp = \case A.PatTime t -> case t of A.TimeShort _ -> R.throwRw InterpErrShort - A.TimeLong melw t -> do + A.TimeLong melw u -> do (el, w) <- lift melw - case t of + case u of A.LongTimeElongate f -> pure (el, A.factorValue f * w) A.LongTimeReplicate mf -> let v = maybe 2 fromInteger mf - in pure (B.patConcat (NESeq.replicate v (el, 1)), fromIntegral v) + in pure (B.patConcat (NESeq.replicate v (el, 1)), fromIntegral v) A.PatGroup (A.Group _ ty els) -> do els' <- lift (sequenceA els) case ty of diff --git a/minipat/src/Minipat/Norm.hs b/minipat/src/Minipat/Norm.hs index 196b75c..f3b2677 100644 --- a/minipat/src/Minipat/Norm.hs +++ b/minipat/src/Minipat/Norm.hs @@ -10,8 +10,8 @@ import Data.Sequence.NonEmpty qualified as NESeq import Minipat.Ast qualified as A import Minipat.Rewrite qualified as R -foldNorm :: NESeq (A.UnPat b a) -> NESeq (A.UnPat b a) -foldNorm = goFirst +foldNorm :: (b -> b -> b) -> NESeq (A.UnPat b a) -> NESeq (A.UnPat b a) +foldNorm f = goFirst where goFirst (y :<|| ys) = do goRest (NESeq.singleton y) ys @@ -21,31 +21,26 @@ foldNorm = goFirst let ws' = case pf of A.PatTime (A.TimeShort s) -> case (s, wlpf) of - (A.ShortTimeReplicate, A.PatTime (A.TimeLong c (A.LongTimeReplicate x))) -> - error "TODO" - (A.ShortTimeElongate, A.PatTime (A.TimeLong c (A.LongTimeElongate mx))) -> - error "TODO" + (A.ShortTimeElongate, A.PatTime (A.TimeLong c (A.LongTimeElongate x))) -> + let pf' = A.PatTime (A.TimeLong c (A.LongTimeElongate (x + 1))) + in winit :||> JotP (f wlb b) pf' + (A.ShortTimeReplicate, A.PatTime (A.TimeLong c (A.LongTimeReplicate mx))) -> + let pf' = A.PatTime (A.TimeLong c (A.LongTimeReplicate (Just (maybe 3 (+ 1) mx)))) + in winit :||> JotP (f wlb b) pf' _ -> let pf' = A.PatTime $ A.TimeLong wlast $ case s of A.ShortTimeElongate -> A.LongTimeElongate 2 A.ShortTimeReplicate -> A.LongTimeReplicate Nothing - in winit :||> JotP b pf' - A.PatTime (A.TimeLong q l) -> - case (l, wlpf) of - (A.LongTimeReplicate i, A.PatTime (A.TimeLong c (A.LongTimeReplicate x))) -> - error "TODO" - (A.LongTimeElongate i, A.PatTime (A.TimeLong c (A.LongTimeElongate mx))) -> - error "TODO" - _ -> ws + in winit :||> JotP b pf' _ -> ws NESeq.|> y in goRest ws' ys -subNorm :: A.PatX b a (A.UnPat b a) -> R.Rw b (A.UnPat b a) -subNorm x = case x of +subNorm :: (b -> b -> b) -> A.PatX b a (A.UnPat b a) -> R.Rw b (A.UnPat b a) +subNorm f x = case x of A.PatGroup (A.Group lvl ty ss) -> do -- Fold over sequences, eliminating time shorthands let ss' = case ty of - A.GroupTypeSeq _ -> foldNorm ss + A.GroupTypeSeq _ -> foldNorm f ss _ -> ss -- Unwrap any group singletons we find case ss' of @@ -53,5 +48,8 @@ subNorm x = case x of _ -> R.wrapRw (A.PatGroup (A.Group lvl ty ss')) _ -> R.wrapRw x +normPat' :: (b -> b -> b) -> A.Pat b a -> A.Pat b a +normPat' f = A.Pat . R.overhaul (subNorm f) . A.unPat + normPat :: A.Pat b a -> A.Pat b a -normPat = A.Pat . R.overhaul subNorm . A.unPat +normPat = normPat' (\_ b -> b) diff --git a/minipat/test/Main.hs b/minipat/test/Main.hs index 2d58395..41d4030 100644 --- a/minipat/test/Main.hs +++ b/minipat/test/Main.hs @@ -393,8 +393,7 @@ testPatNormCases = , ( "repeat three short" , "x ! !" - , let xpart = patTime (patPure "x") (LongTimeReplicate Nothing) - in Pat (patTime xpart (LongTimeReplicate Nothing)) + , Pat (patTime (patPure "x") (LongTimeReplicate (Just 3))) ) , ( "repeat seq short" @@ -475,10 +474,12 @@ testPatInterpCases = ( "slow down" , Nothing , "x/2" - , [ Ev (Span (Arc 0 1) (Just (Arc 0 2))) "x" + , + [ Ev (Span (Arc 0 1) (Just (Arc 0 2))) "x" ] ) - , ( "seq simple" + , + ( "seq simple" , Nothing , "[x y]" , @@ -490,7 +491,8 @@ testPatInterpCases = ( "seq two cycle" , Just (Arc 0 2) , "[x y]" - , [ Ev (Span (Arc 0 (1 % 2)) (Just (Arc 0 (1 % 2)))) "x" + , + [ Ev (Span (Arc 0 (1 % 2)) (Just (Arc 0 (1 % 2)))) "x" , Ev (Span (Arc (1 % 2) 1) (Just (Arc (1 % 2) 1))) "y" , Ev (Span (Arc 1 (3 % 2)) (Just (Arc 1 (3 % 2)))) "x" , Ev (Span (Arc (3 % 2) 2) (Just (Arc (3 % 2) 2))) "y" @@ -500,145 +502,147 @@ testPatInterpCases = ( "repeat one long" , Nothing , "x!1" - , [ Ev (Span (Arc 0 1) (Just (Arc 0 1))) "x" + , + [ Ev (Span (Arc 0 1) (Just (Arc 0 1))) "x" ] ) , ( "repeat two long" , Nothing , "x!2" - , [ Ev (Span (Arc 0 (1%2)) (Just (Arc 0 (1%2)))) "x" - , Ev (Span (Arc (1%2) 1) (Just (Arc (1%2) 1))) "x" + , + [ Ev (Span (Arc 0 (1 % 2)) (Just (Arc 0 (1 % 2)))) "x" + , Ev (Span (Arc (1 % 2) 1) (Just (Arc (1 % 2) 1))) "x" ] ) - , + , ( "repeat two long implicit" , Nothing , "x!" - , [ Ev (Span (Arc 0 (1%2)) (Just (Arc 0 (1%2)))) "x" - , Ev (Span (Arc (1%2) 1) (Just (Arc (1%2) 1))) "x" + , + [ Ev (Span (Arc 0 (1 % 2)) (Just (Arc 0 (1 % 2)))) "x" + , Ev (Span (Arc (1 % 2) 1) (Just (Arc (1 % 2) 1))) "x" ] ) , ( "repeat two short" , Nothing , "x !" - , [ Ev (Span (Arc 0 (1%2)) (Just (Arc 0 (1%2)))) "x" - , Ev (Span (Arc (1%2) 1) (Just (Arc (1%2) 1))) "x" + , + [ Ev (Span (Arc 0 (1 % 2)) (Just (Arc 0 (1 % 2)))) "x" + , Ev (Span (Arc (1 % 2) 1) (Just (Arc (1 % 2) 1))) "x" ] ) , ( "repeat three long" , Nothing , "x!3" - , [ Ev (Span (Arc 0 (1%3)) (Just (Arc 0 (1%3)))) "x" - , Ev (Span (Arc (1%3) (2%3)) (Just (Arc (1%3) (2%3)))) "x" - , Ev (Span (Arc (2%3) 1) (Just (Arc (2%3) 1))) "x" + , + [ Ev (Span (Arc 0 (1 % 3)) (Just (Arc 0 (1 % 3)))) "x" + , Ev (Span (Arc (1 % 3) (2 % 3)) (Just (Arc (1 % 3) (2 % 3)))) "x" + , Ev (Span (Arc (2 % 3) 1) (Just (Arc (2 % 3) 1))) "x" ] ) , ( "repeat three short" , Nothing , "x ! !" - , [ Ev (Span (Arc 0 (1%3)) (Just (Arc 0 (1%3)))) "x" - , Ev (Span (Arc (1%3) (2%3)) (Just (Arc (1%3) (2%3)))) "x" - , Ev (Span (Arc (2%3) 1) (Just (Arc (2%3) 1))) "x" + , + [ Ev (Span (Arc 0 (1 % 3)) (Just (Arc 0 (1 % 3)))) "x" + , Ev (Span (Arc (1 % 3) (2 % 3)) (Just (Arc (1 % 3) (2 % 3)))) "x" + , Ev (Span (Arc (2 % 3) 1) (Just (Arc (2 % 3) 1))) "x" + ] + ) + , + ( "repeat seq short" + , Nothing + , "x ! y" + , + [ Ev (Span (Arc 0 (1 % 3)) (Just (Arc 0 (1 % 3)))) "x" + , Ev (Span (Arc (1 % 3) (2 % 3)) (Just (Arc (1 % 3) (2 % 3)))) "x" + , Ev (Span (Arc (2 % 3) 1) (Just (Arc (2 % 3) 1))) "y" + ] + ) + , + ( "elongate noop" + , Nothing + , "x@2" + , + [ Ev (Span (Arc 0 1) (Just (Arc 0 1))) "x" + ] + ) + , + ( "elongate long seq" + , Nothing + , "x@2 y" + , + [ Ev (Span (Arc 0 (2 % 3)) (Just (Arc 0 (2 % 3)))) "x" + , Ev (Span (Arc (2 % 3) 1) (Just (Arc (2 % 3) 1))) "y" ] ) - -- , - -- ( "repeat seq short" - -- , Nothing - -- , "x ! y" - -- , mkTPatStream $ - -- PatStreamBranch PatStreamTypeSeq $ - -- neseq - -- [ mkTPatStream (PatStreamPure (Anno (Arc 0 (1 % 3)) "x")) - -- , mkTPatStream (PatStreamPure (Anno (Arc (1 % 3) (2 % 3)) "x")) - -- , mkTPatStream (PatStreamPure (Anno (Arc (2 % 3) 1) "y")) - -- ] - -- ) - -- , - -- ( "elongate noop" - -- , Nothing - -- , "x@2" - -- , mkTPatStream (PatStreamPure (Anno (Arc 0 1) "x")) - -- ) - -- , - -- ( "elongate long seq" - -- , Nothing - -- , "x@2 y" - -- , mkTPatStream $ - -- PatStreamBranch PatStreamTypeSeq $ - -- neseq - -- [ mkTPatStream (PatStreamPure (Anno (Arc 0 (2 % 3)) "x")) - -- , mkTPatStream (PatStreamPure (Anno (Arc (2 % 3) 1) "y")) - -- ] - -- ) - -- , - -- ( "elongate short seq" - -- , Nothing - -- , "x _ y" - -- , mkTPatStream $ - -- PatStreamBranch PatStreamTypeSeq $ - -- neseq - -- [ mkTPatStream (PatStreamPure (Anno (Arc 0 (2 % 3)) "x")) - -- , mkTPatStream (PatStreamPure (Anno (Arc (2 % 3) 1) "y")) - -- ] - -- ) - -- , - -- ( "rand two" - -- , Nothing - -- , "[x | y]" - -- , mkTPatStream (PatStreamPure (Anno (Arc 0 1) "x")) - -- ) - -- , - -- ( "rand many" - -- , Just (mkCtx (Arc 5 8)) - -- , "[x | y | z]" - -- , mkTPatStream $ - -- PatStreamBranch PatStreamTypeSeq $ - -- neseq - -- [ mkTPatStream (PatStreamPure (Anno (Arc 5 6) "x")) - -- , mkTPatStream (PatStreamPure (Anno (Arc 6 7) "x")) - -- , mkTPatStream (PatStreamPure (Anno (Arc 7 8) "y")) - -- ] - -- ) - -- , - -- ( "alt singleton" - -- , Nothing - -- , "" - -- , mkTPatStream (PatStreamPure (Anno (Arc 0 1) "x")) - -- ) - -- , - -- ( "alt two" - -- , Nothing - -- , "" - -- , mkTPatStream (PatStreamPure (Anno (Arc 0 1) "x")) - -- ) - -- , - -- ( "alt many" - -- , Just (mkCtx (Arc 5 8)) - -- , "" - -- , mkTPatStream $ - -- PatStreamBranch PatStreamTypeSeq $ - -- neseq - -- [ mkTPatStream (PatStreamPure (Anno (Arc 5 6) "z")) - -- , mkTPatStream (PatStreamPure (Anno (Arc 6 7) "x")) - -- , mkTPatStream (PatStreamPure (Anno (Arc 7 8) "y")) - -- ] - -- ) - -- , - -- ( "par many" - -- , Nothing - -- , "[x , y , z]" - -- , mkTPatStream $ - -- PatStreamBranch PatStreamTypePar $ - -- neseq - -- [ mkTPatStream (PatStreamPure (Anno (Arc 0 1) "x")) - -- , mkTPatStream (PatStreamPure (Anno (Arc 0 1) "y")) - -- , mkTPatStream (PatStreamPure (Anno (Arc 0 1) "z")) - -- ] - -- ) + , + ( "elongate short seq" + , Nothing + , "x _ y" + , + [ Ev (Span (Arc 0 (2 % 3)) (Just (Arc 0 (2 % 3)))) "x" + , Ev (Span (Arc (2 % 3) 1) (Just (Arc (2 % 3) 1))) "y" + ] + ) + , + ( "rand two" + , Nothing + , "[x | y]" + , + [ Ev (Span (Arc 0 1) (Just (Arc 0 1))) "x" + ] + ) + , + ( "rand many" + , Just (Arc 5 8) + , "[x | y | z]" + , + [ Ev (Span (Arc 5 6) (Just (Arc 5 6))) "x" + , Ev (Span (Arc 6 7) (Just (Arc 6 7))) "y" + , Ev (Span (Arc 7 8) (Just (Arc 7 8))) "x" + ] -- Arbitrary, based on rand seed + ) + , + ( "alt singleton" + , Nothing + , "" + , + [ Ev (Span (Arc 0 1) (Just (Arc 0 1))) "x" + ] + ) + , + ( "alt two" + , Nothing + , "" + , + [ Ev (Span (Arc 0 1) (Just (Arc 0 1))) "x" + ] + ) + , + ( "alt many" + , Just (Arc 5 8) + , "" + , + [ Ev (Span (Arc 5 6) (Just (Arc 5 6))) "z" + , Ev (Span (Arc 6 7) (Just (Arc 6 7))) "x" + , Ev (Span (Arc 7 8) (Just (Arc 7 8))) "y" + ] + ) + , + ( "par many" + , Nothing + , "[x , y , z]" + , + [ Ev (Span (Arc 0 1) (Just (Arc 0 1))) "x" + , Ev (Span (Arc 0 1) (Just (Arc 0 1))) "z" + , Ev (Span (Arc 0 1) (Just (Arc 0 1))) "y" + ] -- Note this order is arbitrary, just comes from heap behavior + ) ] main :: IO ()