diff --git a/minipat/src/Minipat/Ast.hs b/minipat/src/Minipat/Ast.hs index 83e0476..1e80065 100644 --- a/minipat/src/Minipat/Ast.hs +++ b/minipat/src/Minipat/Ast.hs @@ -209,9 +209,6 @@ data Speed b = Speed } deriving stock (Eq, Ord, Show) --- instance Foldable Speed where --- foldr f z (Speed x y) = Speed x (bifoldr f y) - instance Pretty (Speed b) where pretty (Speed dir facs) = P.hcat [pretty dir, pretty facs] @@ -229,11 +226,11 @@ instance Pretty Euclid where ["(", pretty i, ",", pretty j] ++ maybe [")"] (\k -> [",", pretty k, ")"]) mk -- | Degradation (random dropout) -newtype Degrade = Degrade {unDegrade :: Maybe Factor} +newtype Degrade b = Degrade {unDegrade :: Maybe (Pat b Factor)} deriving stock (Show) deriving newtype (Eq, Ord) -instance Pretty Degrade where +instance Pretty (Degrade b) where pretty (Degrade mfp) = P.hcat ["?", maybe mempty pretty mfp] -- | Elongate element by the given factor @@ -256,7 +253,7 @@ instance Pretty Replicate where -- | Controls that can be applied to a given pattern data ModType b - = ModTypeDegrade !Degrade + = ModTypeDegrade !(Degrade b) | ModTypeEuclid !Euclid | ModTypeSpeed !(Speed b) | ModTypeElongate !Elongate @@ -430,11 +427,12 @@ instance Bifunctor Pat where PatMod (Mod r m) -> PatMod (Mod (goJ r) (goM m)) PatPoly (Poly rs mi) -> PatPoly (Poly (fmap goJ rs) mi) goM = \case - ModTypeDegrade d -> ModTypeDegrade d + ModTypeDegrade d -> ModTypeDegrade (goD d) ModTypeEuclid e -> ModTypeEuclid e ModTypeSpeed s -> ModTypeSpeed (goS s) ModTypeElongate e -> ModTypeElongate e ModTypeReplicate r -> ModTypeReplicate r + goD (Degrade mp) = Degrade (fmap (first f) mp) goS (Speed d p) = Speed d (first f p) instance Bifoldable Pat where @@ -450,11 +448,12 @@ instance Bifoldable Pat where PatMod (Mod r m) -> goJ (goM z m) r PatPoly (Poly rs _) -> foldr (flip goJ) z rs goM z = \case - ModTypeDegrade _ -> z + ModTypeDegrade d -> goD z d ModTypeEuclid _ -> z ModTypeSpeed s -> goS z s ModTypeElongate _ -> z ModTypeReplicate _ -> z + goD z (Degrade mp) = maybe z (bifoldr f (\_ w -> w) z) mp goS z (Speed _ p) = bifoldr f (\_ w -> w) z p instance Bitraversable Pat where @@ -470,11 +469,12 @@ instance Bitraversable Pat where PatMod (Mod r m) -> liftA2 (\r' m' -> PatMod (Mod r' m')) (goJ r) (goM m) PatPoly (Poly rs mi) -> fmap (\rs' -> PatPoly (Poly rs' mi)) (traverse goJ rs) goM = \case - ModTypeDegrade d -> pure (ModTypeDegrade d) + ModTypeDegrade d -> fmap ModTypeDegrade (goD d) ModTypeEuclid e -> pure (ModTypeEuclid e) ModTypeSpeed s -> fmap ModTypeSpeed (goS s) ModTypeElongate e -> pure (ModTypeElongate e) ModTypeReplicate r -> pure (ModTypeReplicate r) + goD (Degrade mp) = fmap Degrade (traverse (bitraverse f pure) mp) goS (Speed d p) = fmap (Speed d) (bitraverse f pure p) mkPat :: (Monoid b) => PatF b a (UnPat b a) -> Pat b a @@ -528,17 +528,10 @@ instance (Monoid b) => Pattern (Pat b) where -- TODO figure this out -- --- data Sub f k a = Sub --- { subElems :: !(Map k (f a)) --- , subXforms :: !(Map Ident (f a -> f a)) --- } --- --- patSub :: Sub f k a -> f k -> f a --- -- ur -- :: (Pattern f, Ord k) --- => f k +-- => Pat (Select k Ident) -- -> [(k, f a)] -- -> [(Ident, f a -> f a)] -- -> f a --- ur p xs ys = patSub (Sub (Map.fromList xs) (Map.fromList ys)) p +-- ur p0 xs ys = go (Map.fromList xs) (Map.fromList ys) p0 diff --git a/minipat/src/Minipat/Interp.hs b/minipat/src/Minipat/Interp.hs index 35ec11f..eff47e0 100644 --- a/minipat/src/Minipat/Interp.hs +++ b/minipat/src/Minipat/Interp.hs @@ -67,9 +67,11 @@ lookInterp = \case spat'' = fmap factorValue spat' el' = f spat'' el pure (el', w) - ModTypeDegrade (Degrade dd) -> do - let d = maybe (1 % 2) factorValue dd - let el' = patDegBy d el + ModTypeDegrade (Degrade mdpat) -> do + dpat' <- case mdpat of + Nothing -> pure (patPure (1 % 2)) + Just dpat -> fmap (fmap factorValue) (embedRw (interpPat dpat)) + let el' = patDeg dpat' el pure (el', w) ModTypeEuclid euc -> do let el' = patEuc euc el diff --git a/minipat/src/Minipat/Parser.hs b/minipat/src/Minipat/Parser.hs index 7618c25..edad6cc 100644 --- a/minipat/src/Minipat/Parser.hs +++ b/minipat/src/Minipat/Parser.hs @@ -153,14 +153,14 @@ bracedP :: Brace -> P a -> P a bracedP b = L.betweenP (stripTokP (braceOpenChar b)) (tokP (braceCloseChar b)) speedFastP :: P (PPat Factor) -> P (Speed Loc) -speedFastP ps = do +speedFastP pp = do tokP '*' - Speed SpeedDirFast <$> ps + Speed SpeedDirFast <$> pp speedSlowP :: P (PPat Factor) -> P (Speed Loc) -speedSlowP ps = do +speedSlowP pp = do tokP '/' - Speed SpeedDirSlow <$> ps + Speed SpeedDirSlow <$> pp elongateShortP :: P Short elongateShortP = ShortElongate <$ tokP '_' @@ -178,10 +178,10 @@ replicateLongP = do tokP '!' Replicate <$> L.optP L.uintP -degradeP :: P Degrade -degradeP = do +degradeP :: P (PPat Factor) -> P (Degrade Loc) +degradeP pp = do tokP '?' - fmap Degrade (L.optP factorP) + fmap Degrade (L.optP pp) euclidP :: P Euclid euclidP = do @@ -212,18 +212,18 @@ shortReplicatePatP :: P (PPat a) shortReplicatePatP = Pat <$> jotP (PatShort <$> replicateShortP) withPatDecosP :: P (PPat Factor) -> PPat a -> P (PPat a) -withPatDecosP ps = go +withPatDecosP pp = go where - go p@(Pat pp) = do + go p@(Pat pf) = do mp' <- fmap (fmap Pat) . mayJotP $ do mc <- L.lookP L.unconsP case mc of - Just '@' -> fmap (Just . PatMod . Mod pp . ModTypeElongate) elongateLongP - Just '!' -> fmap (Just . PatMod . Mod pp . ModTypeReplicate) replicateLongP - Just '*' -> fmap (Just . PatMod . Mod pp . ModTypeSpeed) (speedFastP ps) - Just '/' -> fmap (Just . PatMod . Mod pp . ModTypeSpeed) (speedSlowP ps) - Just '(' -> fmap (Just . PatMod . Mod pp . ModTypeEuclid) euclidP - Just '?' -> fmap (Just . PatMod . Mod pp . ModTypeDegrade) degradeP + Just '@' -> fmap (Just . PatMod . Mod pf . ModTypeElongate) elongateLongP + Just '!' -> fmap (Just . PatMod . Mod pf . ModTypeReplicate) replicateLongP + Just '*' -> fmap (Just . PatMod . Mod pf . ModTypeSpeed) (speedFastP pp) + Just '/' -> fmap (Just . PatMod . Mod pf . ModTypeSpeed) (speedSlowP pp) + Just '(' -> fmap (Just . PatMod . Mod pf . ModTypeEuclid) euclidP + Just '?' -> fmap (Just . PatMod . Mod pf . ModTypeDegrade) (degradeP pp) _ -> pure Nothing case mp' of Just p' -> go p' diff --git a/minipat/test/Main.hs b/minipat/test/Main.hs index d82c8fa..9f63a68 100644 --- a/minipat/test/Main.hs +++ b/minipat/test/Main.hs @@ -186,7 +186,9 @@ patParseTests = , mkUnitRT "pat adj optional explicit" (expectText "x?0.5" (expectParseOk tpatP)) - (mkTPat (PatMod (Mod xPatIdent (ModTypeDegrade (Degrade (Just (FactorRational RationalPresDec (1 % 2)))))))) + ( mkTPat + (PatMod (Mod xPatIdent (ModTypeDegrade (Degrade (Just (mkTPat (PatPure (FactorRational RationalPresDec (1 % 2))))))))) + ) , mkUnitRT "pat adj euclid 2" (expectText "x(1,2)" (expectParseOk tpatP))