degrade pat

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

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

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'

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