-XArrows for tidal join functions almost working

2025-09-09.tidal.hs

:set -XArrows

:set -i.

:load Arr.hs

:script bin/Tidal.ghci

import Control.Arrow

d1 $ mconcat [ cat ["bd hc?",
  n "c g d a e b" # "supergong" # decay (range 0.1 0.6 $ slow 8 saw) # djf 0.3],
  runJoinProg $ proc s -> do
    ncopy <- squeezeA -< pure <$> slow 8 "1 2 3 2"
    returnA -< stut ncopy 1 1 $ n "<c e g a4>" # "superzow" # gain 0.5 # djf (slow 6 $ range 0.1 0.5 perlin)
  ] # room 0.3

Arr.hs

{-# LANGUAGE Arrows #-}
{-# LANGUAGE GADTs #-}

-- cabal install --lib free-category
-- place it next to the .tidal file
module Arr where

import Control.Applicative (liftA2)
import Control.Arrow
import Control.Arrow.Free
import Control.Category
import Sound.Tidal.Context
import Sound.Tidal.Pattern
import Prelude hiding (id, (.))

-- primitives (edges) you can use inside proc
data JoinPrim a b where
  ArrP :: (a -> b) -> JoinPrim a b
  UnwrapP :: JoinPrim (Pattern (Pattern a)) (Pattern a)
  InnerP :: JoinPrim (Pattern (Pattern a)) (Pattern a)
  OuterP :: JoinPrim (Pattern (Pattern a)) (Pattern a)
  SqueezeP :: JoinPrim (Pattern (Pattern a)) (Pattern a)
  TrigP :: Bool -> JoinPrim (Pattern (Pattern a)) (Pattern a)

-- helpers to lift primitives to the Free Arrow
unwrapA :: Arr JoinPrim (Pattern (Pattern a)) (Pattern a)
unwrapA = liftArr UnwrapP

innerA :: Arr JoinPrim (Pattern (Pattern a)) (Pattern a)
innerA = liftArr InnerP

outerA :: Arr JoinPrim (Pattern (Pattern a)) (Pattern a)
outerA = liftArr OuterP

squeezeA :: Arr JoinPrim (Pattern (Pattern a)) (Pattern a)
squeezeA = liftArr SqueezeP

trigA :: Bool -> Arr JoinPrim (Pattern (Pattern a)) (Pattern a)
trigA b = liftArr (TrigP b)

-- Arrow in the interpreter's codomain: Pattern a -> Pattern b
newtype PArr a b = PArr {runPArr :: Pattern a -> Pattern b}

instance Category PArr where
  id = PArr id
  (PArr f) . (PArr g) = PArr (f . g)

instance Arrow PArr where
  arr f = PArr (fmap f)
  first (PArr f) = PArr $ \pac ->
    let pa = fmap fst pac
        pc = fmap snd pac
     in liftA2 (,) (f pa) pc
  second (PArr f) = PArr $ \pac ->
    let pa = fmap fst pac
        pc = fmap snd pac
     in liftA2 (,) pa (f pc)
  (PArr f) *** (PArr g) = PArr $ \pab ->
    liftA2 (,) (f (fmap fst pab)) (g (fmap snd pab))
  (PArr f) &&& (PArr g) = PArr $ \pa ->
    liftA2 (,) (f pa) (g pa)

-- interpreter: gives semantics to the arrow term
interp :: JoinPrim a b -> PArr a b
interp (ArrP f) = PArr (fmap f)
interp UnwrapP = PArr unwrap
interp InnerP = PArr innerJoin
interp OuterP = PArr outerJoin
interp SqueezeP = PArr squeezeJoin
interp (TrigP b) = PArr (_trigJoin b)

runJoinProg :: Arr JoinPrim () (Pattern b) -> Pattern b
runJoinProg arr = unwrap $ foldArr interp arr `runPArr` pure ()

-- Usage (what you wanted):
-- typechecks, but in the .tidal file it 
prog :: Pattern Int
prog = runJoinProg $ proc s -> do
  x <- squeezeA -< _irand 4
  y <- squeezeA -< _irand 3
  z <- trigA False -< _irand 5
  returnA -< x + y + z