From 8b1fabc4cbea32412b5ce6f9ac803e401500b613 Mon Sep 17 00:00:00 2001
From: Jeffrey Benjamin Brown <jeffbrown.the@gmail.com>
Date: Sat, 26 Nov 2022 20:25:35 -0500
Subject: [PATCH] Define `meta` and `replace`.

  +meta :: forall a b.
  +        Pattern (Pattern a -> Pattern b) -> Pattern a -> Pattern b

  +replace :: forall a b. Ord a =>
  +           [(a,b)] -> Pattern a -> Pattern b

Here's a minimal example using both.

  This plays the pattern "ho*8"
  at normal speed for the first half,
  and at double speed for the second half.

  let slang = [ (0, id)
               , (1, fast 2) ]
     in p 1 $ meta (replace slang "0 1") "ho*8"
---
 src/Sound/Tidal/Pattern.hs | 25 +++++++++++++++++++++++++
 src/Sound/Tidal/UI.hs      | 27 +++++++++++++++++++++++++--
 2 files changed, 50 insertions(+), 2 deletions(-)

diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs
index 0440024fb..1d1fdd0c6 100644
--- a/src/Sound/Tidal/Pattern.hs
+++ b/src/Sound/Tidal/Pattern.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 {-
@@ -563,6 +564,30 @@ tParam3 f a b c p = innerJoin $ (\x y z -> f x y z p) <$> a <*> b <*> c
 tParamSqueeze :: (a -> Pattern b -> Pattern c) -> (Pattern a -> Pattern b -> Pattern c)
 tParamSqueeze f tv p = squeezeJoin $ (`f` p) <$> tv
 
+-- | `meta` resembles `Applicative`: whereas
+-- `<*>`  has type `f (  a ->   b) -> f a -> f b`,
+-- `meta` has type `f (f a -> f b) -> f a -> f b`.
+--
+-- Here's a minimal example. It plays the pattern "ho*8"
+-- at normal speed for the first half,
+-- and at double speed for the second half.
+-- `let slang = [ (0, id)
+--              , (1, fast 2) ]
+--    in p 1 $ meta (replace slang "0 1") "ho*8"`
+meta :: forall a b.
+        Pattern (Pattern a -> Pattern b) -> Pattern a -> Pattern b
+meta pf pa = Pattern { query = q } where
+  q :: State -> [Event b]
+  q s = let
+    changes :: [ Event (Pattern a -> Pattern b) ]
+    changes = query pf s
+    ap :: Event (Pattern a -> Pattern b) -> [Event b]
+    ap c = query (value c pa)
+           $ State { arc = part c,
+                     controls = controls s }
+    in concatMap ap changes
+
+
 -- ** Context
 
 combineContexts :: [Context] -> Context
diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs
index d3a78103d..0a73f7e53 100644
--- a/src/Sound/Tidal/UI.hs
+++ b/src/Sound/Tidal/UI.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings, ScopedTypeVariables #-}
 
 module Sound.Tidal.UI where
 
@@ -29,7 +29,7 @@ import           Data.Bits (testBit, Bits, xor, shiftL, shiftR)
 import           Data.Ratio ((%), Ratio)
 import           Data.Fixed (mod')
 import           Data.List (sort, sortOn, findIndices, elemIndex, groupBy, transpose, intercalate, findIndex)
-import           Data.Maybe (isJust, fromJust, fromMaybe, mapMaybe)
+import           Data.Maybe (isJust, fromJust, fromMaybe, mapMaybe, catMaybes)
 import qualified Data.Text as T
 import qualified Data.Map.Strict as Map
 import           Data.Bool (bool)
@@ -1376,6 +1376,29 @@ ur t outer_p ps fs = _slow t $ unwrap $ adjust <$> timedValues (getPat . split <
         matchF str = fromMaybe id $ lookup str fs
         timedValues = withEvent (\(Event c (Just a) a' v) -> Event c (Just a) a' (a,v)) . filterDigital
 
+-- | `replace` uses a lookup table to transform a
+-- `Pattern a` into a `Pattern b`.
+-- Anything not found in the lookup table is discarded.
+-- `replace` is, useful to create the first argument to `meta`
+-- (that is, the `Pattern (Pattern a -> Pattern b)`.
+replace :: forall a b. Ord a =>
+           [(a,b)] -> Pattern a -> Pattern b
+replace pairs pat = let
+  -- Since `Pattern` is a `Functor`,
+  -- there might be an easier way,
+  -- but the `Maybe` makes a simple `fmap` unworkable.
+  f :: a -> Maybe b
+  f a = Map.lookup a $ Map.fromList pairs
+  rep :: Event a -> Maybe (Event b)
+  rep ea = let mb :: Maybe b
+               mb = f $ value ea
+    in case mb of
+         Nothing -> Nothing
+         Just b -> Just $ ea { value   = b }
+  q :: State -> [Event b]
+  q s = catMaybes $ map rep $ query pat s
+  in Pattern {query = q}
+
 inhabit :: [(String, Pattern a)] -> Pattern String -> Pattern a
 inhabit ps p = squeezeJoin $ (\s -> fromMaybe silence $ lookup s ps) <$> p