Skip to content

Commit

Permalink
etc
Browse files Browse the repository at this point in the history
  • Loading branch information
@ejconlon
ejconlon committed Jan 22, 2024
1 parent 01e3b66 commit 15a5312
Show file tree
Hide file tree
Showing 3 changed files with 138 additions and 137 deletions.
11 changes: 5 additions & 6 deletions minipat/src/Minipat/Interp.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down
34 changes: 16 additions & 18 deletions minipat/src/Minipat/Norm.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -21,37 +21,35 @@ 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
q :<|| Empty -> pure q
_ -> 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)
230 changes: 117 additions & 113 deletions minipat/test/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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"
Expand Down Expand Up @@ -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]"
,
Expand All @@ -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"
Expand All @@ -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
-- , "<x>"
-- , mkTPatStream (PatStreamPure (Anno (Arc 0 1) "x"))
-- )
-- ,
-- ( "alt two"
-- , Nothing
-- , "<x y>"
-- , mkTPatStream (PatStreamPure (Anno (Arc 0 1) "x"))
-- )
-- ,
-- ( "alt many"
-- , Just (mkCtx (Arc 5 8))
-- , "<x y z>"
-- , 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
, "<x>"
,
[ Ev (Span (Arc 0 1) (Just (Arc 0 1))) "x"
]
)
,
( "alt two"
, Nothing
, "<x y>"
,
[ Ev (Span (Arc 0 1) (Just (Arc 0 1))) "x"
]
)
,
( "alt many"
, Just (Arc 5 8)
, "<x y z>"
,
[ 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 ()
Expand Down

0 comments on commit 15a5312

Please sign in to comment.