Last active
October 2, 2021 07:30
-
-
Save mikesol/fdb89e760230b3e4ab30ab3fbd85a9cf to your computer and use it in GitHub Desktop.
Tidal wags
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module Main where | |
import Prelude hiding (between) | |
import Control.Alt ((<|>)) | |
import Control.Comonad (extract) | |
import Control.Comonad.Cofree ((:<)) | |
import Control.Comonad.Cofree.Class (unwrapCofree) | |
import Data.Array as A | |
import Data.Either (Either(..), hush) | |
import Data.Filterable (compact, filter, filterMap) | |
import Data.Function (on) | |
import Data.FunctorWithIndex (mapWithIndex) | |
import Data.Generic.Rep (class Generic) | |
import Data.Int (toNumber) | |
import Data.Lens (_2, over, traversed) | |
import Data.List (List(..), (:)) | |
import Data.List as L | |
import Data.List.NonEmpty (sortBy) | |
import Data.List.NonEmpty as NEL | |
import Data.List.Types (NonEmptyList(..)) | |
import Data.Maybe (Maybe(..), maybe) | |
import Data.Newtype (class Newtype, unwrap, wrap) | |
import Data.NonEmpty ((:|)) | |
import Data.Show.Generic (genericShow) | |
import Data.String.CodeUnits (fromCharArray) | |
import Data.Traversable (traverse) | |
import Data.Tuple (fst, snd, uncurry) | |
import Data.Tuple.Nested ((/\), type (/\)) | |
import Data.Typelevel.Num (D16) | |
import Effect (Effect) | |
import Text.Parsing.StringParser (Parser, fail, runParser, try) | |
import Text.Parsing.StringParser.CodePoints (satisfy) | |
import Text.Parsing.StringParser.CodeUnits (skipSpaces, string, char) | |
import Text.Parsing.StringParser.Combinators (between, many, sepBy) | |
import Type.Proxy (Proxy(..)) | |
import WAGS.Control.Functions.Subgraph as SG | |
import WAGS.Create.Optionals (gain, playBuf, speaker, subgraph) | |
import WAGS.Graph.AudioUnit (OnOff(..)) | |
import WAGS.Graph.Parameter (ff) | |
import WAGS.Lib.BufferPool (AScoredBufferPool, Buffy(..), makeScoredBufferPool) | |
import WAGS.Lib.Learn (buffers, play, usingc) | |
import WAGS.Lib.Score (CfNoteStream) | |
import WAGS.Math (calcSlope) | |
import WAGS.Run (SceneI(..)) | |
import WAGS.Subgraph (SubSceneSig) | |
import WAGS.WebAPI (BrowserAudioBuffer) | |
newtype CycleLength = CycleLength Number | |
derive instance newtypeCycleLength :: Newtype CycleLength _ | |
derive instance eqCycleLength :: Eq CycleLength | |
derive instance ordCycleLength :: Ord CycleLength | |
newtype TidalNote' sample = TidalNote | |
{ sample :: sample | |
, startsAt :: Number | |
, duration :: Number | |
, cycleLength :: Number | |
} | |
type TidalNote = TidalNote' (Maybe Sample) | |
type TidalNote_ = TidalNote' Sample | |
derive instance nwetypeTidalNote :: Newtype (TidalNote' sample) _ | |
derive instance genericTidalNote :: Generic (TidalNote' sample) _ | |
derive instance eqTidalNote :: Eq sample => Eq (TidalNote' sample) | |
derive instance ordTidalNote :: Ord sample => Ord (TidalNote' sample) | |
instance showTidalNote :: Show sample => Show (TidalNote' sample) where | |
show x = genericShow x | |
data Sample = Kick0 | Kick1 | SideStick0 | Snare0 | Clap0 | SnareRoll0 | ClosedHH0 | Shaker0 | OpenHH0 | Tamb0 | Crash0 | Ride0 | |
derive instance genericSample :: Generic Sample _ | |
derive instance eqSample :: Eq Sample | |
derive instance ordSample :: Ord Sample | |
instance showSample :: Show Sample where | |
show x = genericShow x | |
data Cycle | |
= Branching (NonEmptyList Cycle) | |
| Simultaneous (NonEmptyList Cycle) | |
| Sequential (NonEmptyList Cycle) | |
| Internal (NonEmptyList Cycle) | |
| SingleSample (Maybe Sample) | |
derive instance genericCycle :: Generic Cycle _ | |
derive instance eqCycle :: Eq Cycle | |
derive instance ordCycle :: Ord Cycle | |
instance showCycle :: Show Cycle where | |
show x = genericShow x | |
notes :: Array (String /\ Maybe Sample) | |
notes = | |
over (traversed <<< _2) Just | |
[ "kick:0" /\ Kick0 | |
, "kick:1" /\ Kick1 | |
, "kick" /\ Kick0 | |
, "ss:0" /\ SideStick0 | |
, "ss" /\ SideStick0 | |
, "snare:0" /\ Snare0 | |
, "snare" /\ Snare0 | |
, "clap:0" /\ Clap0 | |
, "clap" /\ Clap0 | |
, "roll:0" /\ SnareRoll0 | |
, "roll" /\ SnareRoll0 | |
, "hh:0" /\ ClosedHH0 | |
, "hh" /\ ClosedHH0 | |
, "shaker:0" /\ Shaker0 | |
, "shaker" /\ Shaker0 | |
, "ohh:0" /\ OpenHH0 | |
, "ohh" /\ OpenHH0 | |
, "tamb:0" /\ Tamb0 | |
, "tamb" /\ Tamb0 | |
, "crash:0" /\ Crash0 | |
, "crash" /\ Crash0 | |
, "ride:0" /\ Ride0 | |
, "ride" /\ Ride0 | |
] <> [ "~" /\ Nothing ] | |
sampleP :: Parser (Maybe Sample) | |
sampleP = go $ L.fromFoldable notes | |
where | |
go (a : b) = (try (string (fst a)) $> snd a) <|> go b | |
go Nil = fail "Could not find a note" | |
internalcyclePInternal :: Parser Cycle | |
internalcyclePInternal = Internal <$> | |
between (skipSpaces *> char '[' *> skipSpaces) (skipSpaces *> char ']' *> skipSpaces) do | |
pure unit -- breaks recursion | |
cyc <- cyclePInternal unit | |
case cyc of | |
Sequential l -> pure l | |
x -> pure (pure x) | |
branchingcyclePInternal :: Parser Cycle | |
branchingcyclePInternal = Branching <$> | |
between (skipSpaces *> char '<' *> skipSpaces) (skipSpaces *> char '>' *> skipSpaces) do | |
pure unit -- breaks recursion | |
cyc <- cyclePInternal unit | |
case cyc of | |
Sequential l -> pure l | |
x -> pure (pure x) | |
simultaneouscyclePInternal :: Unit -> Parser Cycle | |
simultaneouscyclePInternal _ = Simultaneous <$> do | |
sep <- sepBy ((fromCharArray <<< A.fromFoldable) <$> many (satisfy (not <<< eq ','))) (string ",") | |
case sep of | |
Nil -> fail "Lacks comma" | |
(_ : Nil) -> fail "Lacks comma" | |
(a : b : c) -> case traverse (runParser reducedP) (NonEmptyList (a :| b : c)) of | |
Left e -> fail $ show e | |
Right r -> pure r | |
where | |
reducedP = try branchingcyclePInternal | |
<|> try sequentialcyclePInternal | |
<|> try internalcyclePInternal | |
<|> try singleSampleP | |
<|> fail "Could not parse cycle" | |
joinSequential :: List Cycle -> List Cycle | |
joinSequential Nil = Nil | |
joinSequential (Sequential (NonEmptyList (a :| b)) : c) = (a : joinSequential b) <> joinSequential c | |
joinSequential (a : b) = a : joinSequential b | |
sequentialcyclePInternal :: Parser Cycle | |
sequentialcyclePInternal = Sequential <$> do | |
skipSpaces | |
leadsWith <- try internalcyclePInternal <|> singleSampleP | |
skipSpaces | |
rest <- joinSequential <$> many (cyclePInternal unit) | |
pure (NonEmptyList (leadsWith :| rest)) | |
singleSampleP :: Parser Cycle | |
singleSampleP = SingleSample <$> do | |
skipSpaces | |
sample <- sampleP | |
skipSpaces | |
pure sample | |
cyclePInternal :: Unit -> Parser Cycle | |
cyclePInternal _ = try branchingcyclePInternal | |
<|> try (simultaneouscyclePInternal unit) | |
<|> try sequentialcyclePInternal | |
<|> try singleSampleP | |
<|> fail "Could not parse cycle" | |
cycleP :: Parser Cycle | |
cycleP = go <$> cyclePInternal unit | |
where | |
go (Branching (NonEmptyList (a :| Nil))) = go a | |
go (Simultaneous (NonEmptyList (a :| Nil))) = go a | |
go (Sequential (NonEmptyList (a :| Nil))) = go a | |
go (Internal (NonEmptyList (a :| Nil))) = go a | |
go (Branching nel) = Branching (map go nel) | |
go (Simultaneous nel) = Simultaneous (map go nel) | |
go (Sequential nel) = Sequential (map go nel) | |
go (Internal nel) = Internal (map go nel) | |
go (SingleSample sample) = SingleSample sample | |
flatMap :: NonEmptyList (NonEmptyList (NonEmptyList TidalNote)) -> NonEmptyList (NonEmptyList TidalNote) | |
flatMap (NonEmptyList (a :| Nil)) = a | |
flatMap (NonEmptyList (a :| b : c)) = join $ a # map \a' -> flatMap (wrap (b :| c)) # map \b' -> a' <> b' | |
cycleToSequence :: CycleLength -> Cycle -> NonEmptyList (NonEmptyList TidalNote) | |
cycleToSequence (CycleLength cycleLength) = go { currentSubdivision: cycleLength, currentOffset: 0.0 } | |
where | |
go state (Branching nel) = join $ map (go state) nel | |
go state (Simultaneous nel) = map (sortBy (compare `on` (unwrap >>> _.startsAt))) | |
$ flatMap | |
$ map (go state) nel | |
go state (Sequential nel) = seq state nel | |
go state (Internal nel) = seq state nel | |
go state (SingleSample sample) = pure $ pure $ TidalNote | |
{ duration: state.currentSubdivision | |
, startsAt: state.currentOffset | |
, sample | |
, cycleLength | |
} | |
seq state nel = | |
let | |
currentSubdivision = state.currentSubdivision / (toNumber (NEL.length nel)) | |
in | |
flatMap $ mapWithIndex | |
( go | |
<<< { currentSubdivision, currentOffset: _ } | |
<<< add state.currentOffset | |
<<< mul currentSubdivision | |
<<< toNumber | |
) | |
nel | |
unrest :: NonEmptyList (NonEmptyList TidalNote) -> List (List TidalNote_) | |
unrest = filter (not <<< eq Nil) <<< NEL.toList <<< map go | |
where | |
go = | |
filterMap | |
( \(TidalNote { startsAt, duration, cycleLength, sample }) -> | |
TidalNote <<< { startsAt, duration, cycleLength, sample: _ } <$> sample | |
) <<< NEL.toList | |
asScore :: NonEmptyList (NonEmptyList TidalNote_) -> CfNoteStream RBuf | |
asScore l = go 0.0 0.0 flattened | |
where | |
ll = NEL.length l | |
flattened = join $ mapWithIndex | |
( \i -> map | |
( \(TidalNote { sample, duration, startsAt, cycleLength }) -> TidalNote | |
{ sample | |
, duration | |
, startsAt: startsAt + cycleLength * toNumber i | |
, cycleLength: cycleLength * toNumber ll | |
} | |
) | |
) | |
l | |
go currentCount prevCycleEnded (NonEmptyList (TidalNote a :| b)) = | |
let | |
st = prevCycleEnded + a.startsAt | |
in | |
{ startsAfter: st - currentCount, rest: { sampleF: sampleToBuffers a.sample, duration: a.duration } } :< | |
\_ -> uncurry (go st) case b of | |
Nil -> (prevCycleEnded + a.cycleLength) /\ flattened | |
(c : d) -> prevCycleEnded /\ NonEmptyList (c :| d) | |
type NBuf | |
= D16 | |
type RBuf | |
= { sampleF :: Instruments BrowserAudioBuffer -> BrowserAudioBuffer, duration :: Number } | |
type Acc | |
= { buffers :: AScoredBufferPool Unit NBuf RBuf } | |
acc :: CfNoteStream RBuf -> Acc | |
acc cf = | |
{ buffers: makeScoredBufferPool | |
{ startsAt: 0.0 | |
, noteStream: \_ -> cf # map \{ startsAfter, rest } -> | |
{ startsAfter | |
, rest: | |
{ rest: const rest | |
, duration: const $ const $ const Just rest.duration | |
} | |
} | |
} | |
} | |
globalFF = 0.03 :: Number | |
type Instruments'' (a :: Type) (r :: Row Type) | |
= (kick0 :: a, sideStick0 :: a, snare0 :: a, clap0 :: a, snareRoll0 :: a, kick1 :: a, closedHH0 :: a, shaker0 :: a, openHH0 :: a, tamb0 :: a, crash0 :: a, ride0 :: a | r) | |
type Instruments' (a :: Type) | |
= Instruments'' a () | |
type Instruments a | |
= { | Instruments' a } | |
sampleToBuffers :: Sample -> Instruments BrowserAudioBuffer -> BrowserAudioBuffer | |
sampleToBuffers = case _ of | |
Kick0 -> _.kick0 | |
Kick1 -> _.kick1 | |
SideStick0 -> _.sideStick0 | |
Snare0 -> _.snare0 | |
Clap0 -> _.clap0 | |
SnareRoll0 -> _.snareRoll0 | |
ClosedHH0 -> _.closedHH0 | |
Shaker0 -> _.shaker0 | |
OpenHH0 -> _.openHH0 | |
Tamb0 -> _.tamb0 | |
Crash0 -> _.crash0 | |
Ride0 -> _.ride0 | |
tidal :: Number -> String -> Effect Unit | |
tidal dur = | |
maybe (play "https://freesound.org/data/previews/350/350439_4557960-hq.mp3") | |
( \i -> play $ usingc | |
( buffers | |
{ kick0: "https://freesound.org/data/previews/171/171104_2394245-hq.mp3" | |
, sideStick0: "https://freesound.org/data/previews/209/209890_3797507-hq.mp3" | |
, snare0: "https://freesound.org/data/previews/495/495777_10741529-hq.mp3" | |
, clap0: "https://freesound.org/data/previews/183/183102_2394245-hq.mp3" | |
, snareRoll0: "https://freesound.org/data/previews/50/50710_179538-hq.mp3" | |
, kick1: "https://freesound.org/data/previews/148/148634_2614600-hq.mp3" | |
, closedHH0: "https://freesound.org/data/previews/269/269720_4965320-hq.mp3" | |
, shaker0: "https://freesound.org/data/previews/432/432205_8738244-hq.mp3" | |
, openHH0: "https://freesound.org/data/previews/416/416249_8218607-hq.mp3" | |
, tamb0: "https://freesound.org/data/previews/207/207925_19852-hq.mp3" | |
, crash0: "https://freesound.org/data/previews/528/528490_3797507-hq.mp3" | |
, ride0: "https://freesound.org/data/previews/270/270138_1125482-hq.mp3" | |
} | |
) | |
(acc i) | |
\(SceneI { time: time', headroomInSeconds, world: { buffers } }) control -> | |
let | |
actualized = control.buffers { time: time', headroomInSeconds, input: unit } | |
internal0 :: SubSceneSig "singleton" () | |
{ buf :: Maybe (Buffy RBuf) | |
, time :: Number | |
} | |
internal0 = unit # SG.loopUsingScene \{ time, buf } _ -> | |
{ control: unit | |
, scene: | |
{ singleton: case buf of | |
Just (Buffy { starting, startTime, rest: { sampleF, duration } }) -> | |
gain | |
( ff globalFF $ pure $ | |
if time > startTime + duration then calcSlope (startTime + duration) 1.0 (startTime + duration + 0.5) 0.0 time else 1.0 | |
) | |
( playBuf | |
{ onOff: | |
ff globalFF | |
$ | |
if starting then | |
ff (max 0.0 (startTime - time)) (pure OffOn) | |
else | |
pure On | |
} | |
(sampleF buffers) | |
) | |
Nothing -> gain 0.0 (playBuf { onOff: Off } buffers.kick1) | |
} | |
} | |
in | |
{ control: { buffers: unwrapCofree actualized } | |
, scene: speaker | |
{ gn: gain 1.0 | |
{ sg: subgraph | |
(extract actualized) | |
(const $ const internal0) | |
(const $ { time: time', buf: _ }) | |
{} | |
} | |
} | |
} | |
) | |
<<< map asScore | |
<<< join | |
<<< map | |
( NEL.fromList | |
<<< compact | |
<<< map NEL.fromList | |
<<< (unrest <<< cycleToSequence (wrap dur)) | |
) | |
<<< hush | |
<<< runParser cycleP | |
main :: Effect Unit | |
main = tidal 1.0 "[hh:0 <kick:0 snare:0>] clap:0" | |
--main = tidal 2.0 "[hh hh hh] [clap roll clap <roll shaker>]" | |
--main = tidal 1.0 "kick kick clap ~" | |
--main = tidal 1.5 "clap [hh <ohh hh>] [roll <hh clap tamb>] , kick:0 kick:1" |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment