├── interactive ├── m ├── monome.hs ├── dispatch.hs ├── most.ghci ├── Dispatch.Lazy.ghci ├── ear-train.hs ├── unload-vivid.hs └── hearing-test.hs ├── m ├── _unused ├── Setup.hs ├── ChangeLog.md ├── test │ └── Spec.hs ├── Vivid.hs ├── docs,kind-of-obvious │ └── abbreviations.hs └── package.yaml ├── Montevideo ├── Random │ ├── README.md │ ├── Types.hs │ ├── Types │ │ ├── Other.hs │ │ └── AbstractSignal.hs │ ├── MentionsSig.hs │ ├── Render.hs │ ├── RandomSynth.hs │ └── RandomSignal.hs ├── Synth │ ├── Boop.ghci.hs │ ├── Vivid_Demo.hs │ ├── README.md │ ├── Axe.hs.unused │ ├── Config.hs │ ├── Zot.ghci.hs │ ├── Distortion.hs │ ├── Vap.hs │ ├── Vap.ghci.hs │ └── Envelope.hs ├── Monome │ ├── meh │ │ └── BreakLoop.hs │ ├── research │ │ ├── simplify_stSustained │ │ │ └── README.md │ │ └── python │ │ │ └── grid_study_1.py │ ├── Config │ │ ├── Monome.hs │ │ └── Monome │ │ │ └── HandTest.hs │ ├── EnvDemo.hs │ ├── Types │ │ ├── Monome.hs │ │ ├── Params.hs │ │ ├── Edo.hs │ │ └── Instances.hs │ ├── Test │ │ ├── Types │ │ │ └── Params.hs │ │ ├── JI.hs │ │ └── EdoMath.hs │ ├── refs.md │ ├── Presets.hs │ ├── Window │ │ ├── ChordBank │ │ │ ├── Function.hs │ │ │ └── Bank.hs │ │ ├── Record.hs │ │ ├── Change.hs │ │ └── Param │ │ │ ├── Group.hs │ │ │ └── Val.hs │ ├── Types.hs │ ├── Interactive.hs │ ├── Network │ │ ├── ListenAndLogOsc.hs │ │ ├── Monome.hs │ │ └── Util.hs │ └── Util │ │ └── OSC.hs ├── Types.hs ├── EarTrain │ ├── Types.hs │ ├── handy.hs │ └── Audio.hs ├── Dispatch-Unused │ ├── README.md │ ├── RandomString.hs │ ├── HasStart.hs │ ├── DeepseqInstances.hs │ ├── Distribloop-debug.hs │ ├── Join.hs │ ├── Parse │ │ ├── Distrib.test.hs │ │ ├── Params.hs │ │ └── Utils.hs │ ├── Test.hs │ ├── Types.hs │ ├── Parse.hs │ └── Scheduling_and_CSV.hs ├── Dispatch │ ├── README.md │ ├── Types.hs │ ├── Config.hs │ ├── Interactive.hs │ ├── Lazy │ │ ├── Util.hs │ │ └── Test │ │ │ └── Intervals.hs │ └── Types │ │ └── Time.hs ├── JI │ ├── Curiosities.hs │ ├── intervals.hs │ ├── Types.hs │ ├── Thanos │ │ ├── SearchParams.hs │ │ └── thanos2-handy.hs │ ├── Grid.hs │ ├── Dead.hs │ └── Notation.hs ├── Util │ └── Edo.hs ├── Test.hs ├── Test │ ├── Recording.hs │ ├── Util.hs │ └── Hode.hs └── ReadHsAsGhci.hs ├── shell.nix ├── bash └── list-synthy-hs-files.sh ├── .gitignore ├── cabal.project ├── mtv-lang ├── docs │ ├── very-experimental │ │ └── hode.md │ ├── samples.hs │ ├── scale-and-root-progression.hs │ ├── pattern-of-transformations.hs │ ├── merge-two-patterns.hs │ ├── scale-progression.hs │ └── synths.hs ├── sketches │ ├── 1 │ │ ├── 1.hs │ │ ├── 2.hs │ │ ├── 3.hs │ │ └── 4.hs │ ├── 2 │ │ ├── 2.hs │ │ ├── 1.hs │ │ └── 3.hs │ ├── 6 │ │ ├── 1.hs │ │ ├── 2.hs │ │ └── 3.hs │ ├── 7 │ │ ├── 1.hs │ │ └── 2.hs │ ├── 8 │ │ ├── 1 │ │ │ └── 1.hs │ │ ├── 1.hs │ │ └── 2.hs │ ├── tests │ │ ├── onoff.hs │ │ └── octaves.hs │ ├── m │ │ ├── test.hode │ │ ├── 1.hs │ │ ├── 2.hs │ │ └── 3.hs │ ├── drums │ │ └── 1.hs │ ├── 4.hs │ ├── 8.hs │ ├── 3.hs │ ├── 2.hs │ └── 5.hs └── mtv-lang.cabal ├── learning ├── awaiting-email │ ├── transform-message.hs │ └── perc-envelope │ │ ├── trigger-perc,bad-doneAction.hs │ │ └── retrigger-adsr,too-complicated.hs ├── vivid │ ├── sc-buffer.hs │ ├── synth-examples │ │ ├── tone.hs │ │ └── wobble.hs │ ├── envelope.hs │ ├── persistent-buffer.hs │ ├── param-as-arg.hs │ └── sched.hs ├── subset-constraints │ ├── problem-statement.hs │ ├── subset-family-definition.hs │ ├── solution.hs │ └── earlier-fumblings,gadt-forget │ │ ├── simplest.hs │ │ └── close-to-vivid.hs ├── fb │ ├── fb,via-localbuf.hs │ └── fb.hs ├── mvar │ ├── pitch.hs │ └── toggle-loop.hs ├── vivid,random │ ├── random-choice-of-IO.hs │ └── render.hs └── _mostly-internalized │ ├── melody-via-list.hs │ └── multi-synth,targeted-messages.hs ├── sc-start.sh ├── stack.yaml ├── BRANCHES.md ├── research └── bugs │ └── slow-load.hs ├── common-mods └── print-on-each-monome-keypress.diff └── README.md /interactive/m: -------------------------------------------------------------------------------- 1 | ../m/ -------------------------------------------------------------------------------- /m: -------------------------------------------------------------------------------- 1 | mtv-lang/sketches/ -------------------------------------------------------------------------------- /interactive/monome.hs: -------------------------------------------------------------------------------- 1 | ../Montevideo/Monome/Interactive.hs -------------------------------------------------------------------------------- /interactive/dispatch.hs: -------------------------------------------------------------------------------- 1 | ../Montevideo/Dispatch/Interactive.hs -------------------------------------------------------------------------------- /_unused/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /_unused/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for vivid-dispatch 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /_unused/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /Montevideo/Random/README.md: -------------------------------------------------------------------------------- 1 | This code is imported nowhere. 2 | I guess I was using it from GHCI for something. 3 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | with import { }; 2 | mkShell { 3 | buildInputs = [ 4 | # haskell.compiler.ghc921 5 | # glibc.2.34 6 | ]; 7 | } 8 | -------------------------------------------------------------------------------- /bash/list-synthy-hs-files.sh: -------------------------------------------------------------------------------- 1 | find . -name "*.hs" \ 2 | | grep "Montevideo" \ 3 | | egrep -v ".stack-work|learning|mtv-earTrain|mtv-ji|Unused" \ 4 | > hs-files 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | .emacs.desktop* 3 | Reaktor_Spark_Manual_English.pdf 4 | TAGS 5 | git-comment 6 | stack.yaml.lock 7 | temp* 8 | 9 | .stack-work/ 10 | dist-newstyle 11 | -------------------------------------------------------------------------------- /Montevideo/Random/Types.hs: -------------------------------------------------------------------------------- 1 | module Montevideo.Random.Types ( 2 | module Montevideo.X 3 | ) where 4 | 5 | import Random.Types.AbstractSignal as X 6 | import Random.Types.Other as X 7 | -------------------------------------------------------------------------------- /_unused/Vivid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | module Montevideo.Vivid ( 4 | module Montevideo.Vivid.NoPlugins 5 | ) where 6 | 7 | import Vivid.NoPlugins 8 | -------------------------------------------------------------------------------- /Montevideo/Synth/Boop.ghci.hs: -------------------------------------------------------------------------------- 1 | :set -XDataKinds 2 | :set prompt "> " 3 | s <- synth boop () 4 | set s (0.1 :: I "amp", 440 :: I "freq") 5 | 6 | set s (1 :: I "on") 7 | set s (0 :: I "on") 8 | -------------------------------------------------------------------------------- /Montevideo/Monome/meh/BreakLoop.hs: -------------------------------------------------------------------------------- 1 | module Montevideo.Monome.Break where 2 | 3 | -- http://www.haskellforall.com/2012/07/breaking-from-loop.html 4 | -- I can't find EitherT in recent versions of Stackage 5 | -------------------------------------------------------------------------------- /Montevideo/Monome/research/simplify_stSustained/README.md: -------------------------------------------------------------------------------- 1 | The problem with this is now when I release sustain, the images are still lit. I think I have to change st_fingers at the same time; here I've only changed st_sustained. 2 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: *.cabal 2 | 3 | -- vivid 4 | --source-repository-package 5 | -- type: git 6 | -- location: /home/jeff/code/music/vivid/hackage-vivid/vivid-0.5.2.0 7 | -- tag: e2d530f42fd985eb7e0a15533c6e468b359bc26c 8 | -------------------------------------------------------------------------------- /Montevideo/Types.hs: -------------------------------------------------------------------------------- 1 | module Montevideo.Types where 2 | 3 | 4 | type Cents = Float 5 | type Interval = Int -- ^ A value from an Edo system. For instance, 6 | -- the perfect fifth in Edo 31 is Interval 18. 7 | type Edo = Int -- ^ e.g. 12 for "normal" music, 31 for even better music ... 8 | -------------------------------------------------------------------------------- /Montevideo/EarTrain/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables 2 | #-} 3 | 4 | module Montevideo.EarTrain.Types where 5 | 6 | type PlayQuestion = IO () -- ^ make a sound, for the user to identify 7 | type ShowAnswer = IO () -- ^ display something, e.g. "it was a major chord" 8 | type Test = (PlayQuestion, ShowAnswer) 9 | -------------------------------------------------------------------------------- /Montevideo/Dispatch-Unused/README.md: -------------------------------------------------------------------------------- 1 | These are things I hope never to have to write or use again -- 2 | but if I have to use them again, better to not write them again. 3 | At least some of this code has surely gone stale, 4 | as it depends on data structures and algorithms that *are* used, 5 | and that have been evolving. 6 | -------------------------------------------------------------------------------- /mtv-lang/docs/very-experimental/hode.md: -------------------------------------------------------------------------------- 1 | ## Super-experimental 2 | 3 | Hode is an editor for higher-order data. 4 | It's like a graph database, 5 | but more expressive. 6 | 7 | To see how controlling `Montevideo` using 8 | [Hode](https://github.com/JeffreyBenjaminBrown/hode) works, 9 | try running `playSong disp testRslt 10`. 10 | -------------------------------------------------------------------------------- /Montevideo/Monome/Config/Monome.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Montevideo.Monome.Config.Monome where 4 | 5 | import Montevideo.Monome.Types 6 | 7 | 8 | type Port = Int 9 | 10 | monomePort :: MonomeId -> Port 11 | 12 | monomePort Monome_256 = 19236 13 | monomePort Monome_128 = 10739 14 | monomePort Monome_old = 12630 15 | -------------------------------------------------------------------------------- /Montevideo/Dispatch/README.md: -------------------------------------------------------------------------------- 1 | # These modules sorted by dependencies 2 | 3 | (There's no one way to sort a graph in general.) 4 | 5 | Dispatch.Config 6 | Dispatch.Types 7 | Dispatch.Msg.Mk 8 | Dispatch.Msg.Act 9 | Dispatch.Transform 10 | Dispatch.Time 11 | Dispatch.Museq 12 | Dispatch.Join.Internal 13 | Dispatch.Join 14 | Dispatch.Msg.Act 15 | Dispatch.Dispatch 16 | Abbrevs.hs 17 | -------------------------------------------------------------------------------- /mtv-lang/sketches/tests/onoff.hs: -------------------------------------------------------------------------------- 1 | -- Cycles between a note and silence, evenly spaced, 2 | -- across the span of one second. 3 | 4 | pat = ( mmh 1 $ pre2 "blark" 5 | [ (0, mfl [("freq", 600), 6 | ("amp", 0.2), 7 | ("on", 1)]), 8 | (1/2, m1 "on" 0) ] ) 9 | 10 | ch $ mfl [ 11 | ("1", nZot pat) 12 | -- ("2", nBoop pat) 13 | ] 14 | -------------------------------------------------------------------------------- /mtv-lang/sketches/m/test.hode: -------------------------------------------------------------------------------- 1 | -- in Haskell 2 | pat = mmho 3 $ pre2 "a" 3 | [ (0, m1 "freq" 400) 4 | , (1, m1 "freq" 500) ] 5 | chAll $ mfl [ 6 | ("1", nBoop pat ) 7 | ] 8 | 9 | -- in Hode 10 | st <- uiFromRslt baseRslt 11 | 12 | /a a #when 0 #plays (#freq 400) 13 | /a a #when 1 #plays (#freq 500) 14 | /a song 1 #sends (#nBoop (3 ##mmho a)) 15 | 16 | _addrToRefExpr $ st ^. appRslt 17 | 18 | playSong disp testRslt 10 -------------------------------------------------------------------------------- /Montevideo/JI/Curiosities.hs: -------------------------------------------------------------------------------- 1 | module Montevideo.JI.Curiosities where 2 | 3 | 4 | -- | These EDOs permit a fun cousin of the diminished scale: 5 | -- Two fourths a tritone apart, 6 | -- both split into three equal pieces. 7 | equalDiminishedEdos :: IO () 8 | equalDiminishedEdos = 9 | myPrint [ edo 10 | | edo <- [1..100] 11 | , mod (fromIntegral edo) 2 == 0 12 | , mod (best edo (4/3) ^. _1) 3 == 0 ] 13 | -------------------------------------------------------------------------------- /Montevideo/Util/Edo.hs: -------------------------------------------------------------------------------- 1 | module Montevideo.Util.Edo where 2 | 3 | 4 | centsToRatio :: Double -> Double 5 | centsToRatio _cents = exp $ log 2 * centsToOctaves _cents 6 | 7 | ratioToCents :: Floating a => Rational -> a 8 | ratioToCents r = octavesToCents $ log (fromRational r) / log 2 9 | 10 | centsToOctaves :: Fractional a => a -> a 11 | centsToOctaves x = x / 1200 12 | 13 | octavesToCents :: Num a => a -> a 14 | octavesToCents = (*) 1200 15 | -------------------------------------------------------------------------------- /learning/awaiting-email/transform-message.hs: -------------------------------------------------------------------------------- 1 | -- Asking on Haskell-art: "Filter a message based on its type (parameter)?" 2 | 3 | {-# LANGUAGE -- DataKinds, ExtendedDefaultRules, 4 | ScopedTypeVariables #-} 5 | 6 | import Vivid 7 | 8 | f :: forall inParams outParams. 9 | ( VarList inParams, VarList outParams 10 | , Subset (InnerVars inParams) '["freq","amp"] 11 | , Subset (InnerVars outParams) '["whack"] ) 12 | => inParams -> outParams 13 | f _ = () 14 | 15 | f () = () 16 | -------------------------------------------------------------------------------- /Montevideo/Dispatch-Unused/RandomString.hs: -------------------------------------------------------------------------------- 1 | import System.Random 2 | 3 | -- | There are 94 Unicode characters bewteen ! and ~ (inclusive). 4 | -- The chance of collision between two 32 character strings of those 5 | -- is (1/94)**32 = 7.242836554608488e-64 6 | randomString :: IO [Char] 7 | randomString = do 8 | gen <- newStdGen 9 | return $ Prelude.take 32 $ randomRs 10 | ('!','~') -- widest possible on normal keyboard 11 | gen 12 | -------------------------------------------------------------------------------- /Montevideo/EarTrain/handy.hs: -------------------------------------------------------------------------------- 1 | -- module Montevideo.EarTrain.Convenience where 2 | 3 | import Montevideo.EarTrain 4 | import Montevideo.EarTrain.Audio 5 | import Montevideo.EarTrain.Types 6 | 7 | 8 | earTrainChromatic 46 3 46 9 | earTrainFromChordList 46 $ [ [0,a,b] | a <- [0..46], b <- [0..46], a > 0, b > a, b > 4] 10 | 11 | 12 | earTrainFromChordList 31 $ map (\n -> [0,n]) [24..29] 13 | earTrainFromScale 46 2 [0,15,27] -- the major chord 14 | playFreqs $ (*400) <$> [1,5/4+0.03,3/2-0.01] 15 | -------------------------------------------------------------------------------- /learning/vivid/sc-buffer.hs: -------------------------------------------------------------------------------- 1 | -- example by Tom Murphy: 2 | -- https://we.lurk.org/hyperkitty/list/livecode@we.lurk.org/thread/6JD5SHXPQQ25VZH4PVKIR5Y7HEAPXZWL/ 3 | 4 | {-# LANGUAGE DataKinds, ExtendedDefaultRules #-} 5 | 6 | import Vivid 7 | 8 | foo = sd (0 :: I "buf") $ do 9 | let buf = V::V "buf" 10 | s <- playBuf (buf_ buf, rate_ $ bufRateScale buf ~* 3, doneAction_ 2) 11 | out 0 [s,s] 12 | 13 | main = do 14 | buf <- newBufferFromFile "the_letter.flac" 15 | synth foo (b2i buf :: I "buf") 16 | -------------------------------------------------------------------------------- /sc-start.sh: -------------------------------------------------------------------------------- 1 | export SC_JACK_DEFAULT_INPUTS="system" 2 | export SC_JACK_DEFAULT_OUTPUTS="system" 3 | scsynth -u 57110 \ 4 | -m 1000000 5 | # -U /home/jeff/.local/share/SuperCollider/Extensions/ 6 | # The above -U option was needed before NixOS offered a native 7 | # sc3-plugins package. 8 | # PITFALL: Must include *all* plugin folders, as the ones normally scanned are not if this option is used. 9 | 10 | # scsynth options: 11 | # -u : UDP address. 12 | # -m 1000000 : Assigns 1 GB of memory it. 13 | -------------------------------------------------------------------------------- /Montevideo/Dispatch-Unused/HasStart.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | MultiParamTypeClasses 3 | , FunctionalDependencies 4 | , FlexibleInstances 5 | , UndecidableInstances 6 | #-} 7 | 8 | module Montevideo.Dispatch.HasStart where 9 | 10 | import Control.Lens 11 | 12 | class HasStart h n | h -> n where 13 | start :: Lens' h n 14 | 15 | instance HasStart Rational Rational where 16 | start = id 17 | 18 | instance HasStart Float Float where 19 | start = id 20 | 21 | instance HasStart a n => HasStart (a,b) n where 22 | start = _1 . start 23 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-17.15 2 | 3 | packages: 4 | - ./mtv-earTrain 5 | - ./mtv-ji 6 | - ./mtv-lang 7 | - ./mtv-monome 8 | - ./mtv-synth 9 | - ./mtv-test 10 | - ./mtv-util 11 | 12 | nix: 13 | enable: true 14 | 15 | extra-deps: 16 | - vivid-0.4.2.3@sha256:00d6bf34c982d747c3171e4279ef109f6fef7dcd39e55ee666dbcefb0f95cf3d,8219 17 | - vivid-osc-0.5.0.0@sha256:633e5c1c87633feaa26019442c3ae63946001c7afe2afa4d2cf22586bd4b182c,2786 18 | - vivid-supercollider-0.4.1.2@sha256:c7493f2a67b04589df8943e58a7445803e3365c6ad439603bf35695734b9bd65,1738 19 | -------------------------------------------------------------------------------- /BRANCHES.md: -------------------------------------------------------------------------------- 1 | These are the most important branches. 2 | 3 | # `master` 4 | 5 | is what it sounds like. 6 | 7 | # `zot` 8 | 9 | is an older version of this code, 10 | using the more complex `Zot` synth. 11 | (`master` uses the newer, simpler `Axe` synth.) 12 | I'd like to reconcile them, but Vivid makes that difficult, 13 | by forcing the two synths to be different types. 14 | 15 | # `legato` 16 | 17 | contains work I did toward implementing a legato mode. 18 | It was mostly smooth sailing, until I got to 19 | `Montevideo.Monome.Window.Keyboard.Keyboard`. 20 | -------------------------------------------------------------------------------- /learning/vivid/synth-examples/tone.hs: -------------------------------------------------------------------------------- 1 | -- copied without modification from http://www.vivid-synth.com/, 2018 07 01 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | 5 | import Vivid 6 | 7 | tone = sd (0::I "note") $ do 8 | a <- lfTri (freq_ 0.2) ? KR ~* 0.5 ~+ 0.5 9 | freq <- lag (in_ $ midiCPS (V::V "note"), lagSecs_ 1.25) ? KR 10 | b <- 0.1 ~* varSaw (freq_ freq, width_ a) 11 | out 0 [b, b] 12 | 13 | main = do 14 | s <- synth tone (45::I "note") 15 | forever $ forM_ [45, 57, 64, 55] $ \freq -> do 16 | set s (freq :: I "note") 17 | wait 2.5 18 | -------------------------------------------------------------------------------- /Montevideo/Synth/Vivid_Demo.hs: -------------------------------------------------------------------------------- 1 | -- | Demonstrates how to use Vivid. 2 | 3 | {-# LANGUAGE DataKinds 4 | , ExtendedDefaultRules 5 | , ScopedTypeVariables 6 | , GADTs #-} 7 | 8 | module Montevideo.Synth.Vivid_Demo where 9 | 10 | import Vivid 11 | 12 | 13 | doot :: SynthDef '["freq","amp"] 14 | doot = sd ( 100 :: I "freq", 15 | 0.2 :: I "amp" ) $ 16 | do s1 <- (V::V "amp") ~* pulse (freq_ (V::V "freq")) 17 | out 0 [s1, s1] 18 | 19 | go :: Float -> IO () 20 | go a = do 21 | s <- synth doot (toI (min a 0.2) :: I "amp") 22 | wait 1 23 | free s 24 | -------------------------------------------------------------------------------- /learning/vivid/synth-examples/wobble.hs: -------------------------------------------------------------------------------- 1 | -- copied without modification from http://www.vivid-synth.com/, 2018 07 01 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | 5 | import Vivid 6 | 7 | wobble = sd (0 :: I "note") $ do 8 | s <- 50 ~* sinOsc (freq_ 10) ? KR 9 | s1 <- 0.1 ~* sinOsc (freq_ $ midiCPS (V::V "note") ~+ s) 10 | out 0 [s1, s1] 11 | 12 | main = do 13 | s <- synth wobble () 14 | let notes = take 12 $ 15 | [ x | x <- [38..], (x `mod` 12) `elem` [0,3,5] ] 16 | forM_ (cycle notes) $ \note -> do 17 | set s (toI note :: I "note") 18 | wait 0.2 19 | -------------------------------------------------------------------------------- /Montevideo/Dispatch/Types.hs: -------------------------------------------------------------------------------- 1 | -- | A few types are also defined in Jbb.Synths 2 | 3 | {-# LANGUAGE DataKinds 4 | , DeriveFunctor 5 | , ExtendedDefaultRules 6 | , ScopedTypeVariables 7 | , TupleSections 8 | , TemplateHaskell 9 | , GADTs 10 | #-} 11 | 12 | module Montevideo.Dispatch.Types ( 13 | module Montevideo.Dispatch.Types.Time 14 | , module Montevideo.Dispatch.Types.Many 15 | , module Montevideo.Dispatch.Types.Functions 16 | ) where 17 | 18 | import Montevideo.Dispatch.Types.Time 19 | import Montevideo.Dispatch.Types.Many 20 | import Montevideo.Dispatch.Types.Functions 21 | -------------------------------------------------------------------------------- /mtv-lang/sketches/8/1/1.hs: -------------------------------------------------------------------------------- 1 | -- simpler patterns 2 | s1 = mmt1 2 $ map (_1 %~ RTime) $ [ (0, S_Km), (1, S_Kt) ] 3 | s13 = mmt1 2 $ map (_1 %~ RTime) $ [ (0, S_Km), (5/3, S_Kt) ] 4 | s2 = mmt1 3 $ map (_1 %~ RTime) $ [ (0, S_Hl_et), (1, S_Sp_t) ] 5 | 6 | viewDurs = vec .~ mempty 7 | 8 | ch $ mfl 9 | [ 10 | ("2", fast 2 $ stack [ cat [ sparse 2 $ cat [ mempty 11 | , early (1/6) $ dense 2 s2 ] 12 | , dense 3 s2 ] 13 | , cat [ s13, s1, dur .~ 2 $ mempty, s1 14 | ] ] ) 15 | ] 16 | -------------------------------------------------------------------------------- /Montevideo/EarTrain/Audio.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables 2 | , DataKinds 3 | #-} 4 | 5 | module Montevideo.EarTrain.Audio where 6 | 7 | import Vivid 8 | import Montevideo.Synth 9 | import Montevideo.Types 10 | import Montevideo.Util 11 | 12 | 13 | -- | = Making sounds 14 | 15 | playFreqs :: (Real a, Floating a) => [a] -> IO () 16 | playFreqs freqs = do 17 | let msg a = (toI a :: I "freq", 0.02 :: I "amp") 18 | synths <- mapM (synth boopSaw . msg) freqs 19 | wait (2 :: Int) 20 | mapM_ free synths 21 | 22 | edoValToFreq :: Floating a => Edo -> a -> a -> a 23 | edoValToFreq edo baseFreq p = 24 | 2**(p/fromIntegral edo) * baseFreq 25 | -------------------------------------------------------------------------------- /Montevideo/Dispatch/Config.hs: -------------------------------------------------------------------------------- 1 | module Montevideo.Dispatch.Config where 2 | 3 | import Montevideo.Dispatch.Types 4 | 5 | 6 | -- | Arcs are computed one frame at a time. 7 | -- Frame duration also determines how long it takes to delete a synth: 8 | -- half a frame after a synth is silenced, it is deleted 9 | -- (by dispatchConsumeScAction_Free). 10 | frameDuration :: Time 11 | frameDuration = 0.1 12 | 13 | -- | 3 ms after sending a trigger=1 message to a sampler, 14 | -- send a trigger=0 message. 15 | -- This is necessary because the samplers are trigger when they detect 16 | -- a change from negative to positive. 17 | retriggerLag :: Time 18 | retriggerLag = 0.003 19 | -------------------------------------------------------------------------------- /Montevideo/Monome/EnvDemo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, ExtendedDefaultRules #-} 2 | 3 | import Vivid 4 | 5 | 6 | main :: IO (Synth '["gate"]) 7 | main = do 8 | s <- synth foo () 9 | putStrLn "Now we fade in!" 10 | set s (1 ::I "gate") 11 | return s 12 | 13 | e :: EnvLiterally '["gate"] 14 | e = env 0 -- Start at 0. 15 | [ (1, 0.1),(1,1),(0,0.1) -- Fade in fast, hold, fade out. 16 | , (1,0.1),(0,0.1)] -- Fade in and out again fast. 17 | Curve_Lin 18 | 19 | foo :: SynthDef '["gate"] 20 | foo = sd (1 ::I "gate") $ do 21 | e' <- envGen_wGate (V::V "gate") 1 e DoNothing 22 | s <- sinOsc (freq_ 440) ~* e' 23 | out 0 [s,s] 24 | -------------------------------------------------------------------------------- /Montevideo/Monome/research/python/grid_study_1.py: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env python3 2 | 3 | import asyncio 4 | import monome 5 | 6 | class GridStudies(monome.App): 7 | def __init__(self): 8 | super().__init__('/monome') 9 | 10 | def on_grid_key(self, x, y, s): 11 | print("\n" + self.grid.prefix) 12 | print("key:", x, y, s) 13 | self.grid.led_level_set(x, y, s*15) 14 | 15 | def main(): 16 | grid_studies = GridStudies() 17 | 18 | loop = asyncio.get_event_loop() 19 | asyncio.async( 20 | monome.SerialOsc.create( 21 | loop=loop, autoconnect_app=grid_studies 22 | ) ) 23 | loop.run_forever() 24 | 25 | if __name__ == '__main__': 26 | main() 27 | -------------------------------------------------------------------------------- /interactive/most.ghci: -------------------------------------------------------------------------------- 1 | -- This allows you to type `:. path-to-file-without-.hs-extension` 2 | -- to run the music in a file. 3 | -- For further brevity, it's useful to define symlinks from where you run GHCI 4 | -- to where your music is stored. This repo comes with one such symlink, 5 | -- called "m". Thus I can run the sketch at "mtv-lang/sketches/1/1" 6 | -- by calling ":. m/1/1". 7 | :m Montevideo.ReadHsAsGhci 8 | :def! . readHsAsGhci 9 | 10 | :set prompt "> " 11 | 12 | -- permits multi-line GHCI expressions without :{ :} 13 | :set +m 14 | :set prompt-cont "| " 15 | 16 | :set -XDataKinds 17 | :set -XTupleSections 18 | :set -XScopedTypeVariables 19 | 20 | :s interactive/import-all.hs 21 | -------------------------------------------------------------------------------- /learning/subset-constraints/problem-statement.hs: -------------------------------------------------------------------------------- 1 | -- | Why won't `boopMessage` compile? 2 | -- I need a function that returns messages of different types 3 | -- but all acceptable to a particular kind of `Synth`. 4 | 5 | {-# LANGUAGE DataKinds 6 | , ExtendedDefaultRules 7 | , ScopedTypeVariables 8 | , GADTs #-} 9 | 10 | import Vivid 11 | 12 | boop :: SynthDef '["freq","amp"] 13 | boop = sd ( (0,0.01) -- default values 14 | :: (I "freq",I "amp")) $ do 15 | s1 <- (V::V "amp") ~* sinOsc (freq_ (V::V "freq")) 16 | out 0 [s1, s1] 17 | 18 | boopMessage 0 = (toI 444 :: I "freq") 19 | boopMessage 1 = (toI 0.1 :: I "amp") 20 | boopMessage _ = () 21 | -------------------------------------------------------------------------------- /interactive/Dispatch.Lazy.ghci: -------------------------------------------------------------------------------- 1 | -- This allows you to type `:. path-to-file-without-.hs-extension` 2 | -- to run the music in a file. 3 | -- For further brevity, it's useful to define symlinks from where you run GHCI 4 | -- to where your music is stored. This repo comes with one such symlink, 5 | -- called "m". Thus I can run the sketch at "mtv-lang/sketches/1/1" 6 | -- by calling ":. m/1/1". 7 | :m Montevideo.ReadHsAsGhci 8 | :def! . readHsAsGhci 9 | 10 | :set prompt "> " 11 | 12 | -- permits multi-line GHCI expressions without :{ :} 13 | :set +m 14 | :set prompt-cont "| " 15 | 16 | :set -XDataKinds 17 | :set -XTupleSections 18 | :set -XScopedTypeVariables 19 | 20 | :s interactive/import-all.hs 21 | -------------------------------------------------------------------------------- /learning/fb/fb,via-localbuf.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, ExtendedDefaultRules #-} 2 | 3 | import Vivid 4 | 5 | foo :: SynthDef '[] 6 | foo = sd () $ do 7 | l <- localBuf (numChans_ 1, numFrames_ 100) 8 | fb <- playBuf (buf_ l, loop_ 1) 9 | -- pluck <- percGen( attackSecs_ 0.005 -- TODO 10 | -- , releaseSecs_ 0.005 11 | -- , level_ 4 12 | ---- , curve_ (Curve_Curve $ 0) 13 | -- , doneAction_ 0 ) 14 | s <- lpf( in_ $ (0.1 ~* whiteNoise) ~+ (0.999 ~* fb) 15 | , freq_ 1500 ) 16 | recordBuf (buf_ l, in_ s, loop_ 1) 17 | out 0 [s,s] 18 | 19 | main = do 20 | s <- synth foo () 21 | wait 4 22 | free s 23 | -------------------------------------------------------------------------------- /Montevideo/Monome/Types/Monome.hs: -------------------------------------------------------------------------------- 1 | module Montevideo.Monome.Types.Monome 2 | ( HostName, Socket 3 | , X, Y, Switch, Led 4 | ) where 5 | 6 | import qualified Network.Socket as NS 7 | 8 | 9 | type HostName = NS.HostName 10 | type Socket = NS.Socket 11 | 12 | -- | X and Y are coordinates on the monome. 13 | -- PITFALL: X rises from left to right, but Y rises from top to bottom. 14 | -- Thus (0,1) is just under the top-left corner. 15 | -- PITFALL: The monome will respond to out-of-bounds (x,y) values. 16 | -- I don't use that feature. 17 | type X = Int 18 | type Y = Int 19 | 20 | type Switch = Bool -- | Whether a monome button is pressed. 21 | type Led = Bool -- | Whether a monome LED is lit. 22 | -------------------------------------------------------------------------------- /mtv-lang/sketches/m/1.hs: -------------------------------------------------------------------------------- 1 | p f g h = mmho 7 $ pre2 "a" 2 | [ (0, m1 "freq" f) 3 | , (1, m1 "freq" $ f*g) 4 | , (2, m1 "freq" $ f*h/2) 5 | , (3, m1 "on" 0) 6 | , (4, m1 "freq" $ f*g) 7 | , (5, m1 "freq" f) 8 | , (6, m1 "on" 0) ] 9 | 10 | m = mmh 7 [ trip "a" 0 id 11 | , trip "a" 3 $ early (1/2) ] 12 | 13 | --ch1 "2" $ nBoop $ fast 2 $ p 300 (12/7) (7/6) 14 | --ch1 "3" $ nBoop $ fast 4 $ p 600 (12/11) (9/5) 15 | 16 | ch $ mfl [ 17 | ("1", nBoop $ p 200 (11/8) (8/5) ) 18 | , ("2", nBoop $ meta m $ fast 2 $ p 350 (12/9) (9/6) ) 19 | , ("3", nBoop $ fast 4 $ cat [ p 600 (12/11) (9/5) 20 | , p 500 (13/11) (9/5) ] ) ] 21 | -------------------------------------------------------------------------------- /mtv-lang/sketches/m/2.hs: -------------------------------------------------------------------------------- 1 | pat f g h = mmho 4 $ pre2 "a" 2 | [ (0, m1 "freq" f) 3 | , (1, m1 "freq" $ f*g) 4 | , (2, m1 "freq" $ f*h) 5 | , (3, m1 "on" 0) ] 6 | 7 | pit f = mmho 1 $ pre2 "a" [ (0, m1 "freq" f) ] 8 | 9 | mRyt = mmh 7 [ trip "a" 0 $ fast 2 10 | , trip "a" 3 $ early 1 ] 11 | 12 | ch $ mfl [ 13 | ("1", nBoop $ pat 125 (5/4) (3/2)) 14 | , ("2", nBoop 15 | (merge0a 16 | (pat 250 (5/4) (3/2)) 17 | (stack 18 | [ slow 2 $ pat 1 (10/8) (10/7) 19 | , early 2 $ fast 2 $ pat 3 (9/8) (9/6) 20 | , meta (slow 2 $ mRyt) $ fast 4 $ pat (5/2) (5/4) (9/6) 21 | ] ) ) ) 22 | , ("3", nBoop $ meta mRyt $ pat 750 (5/4) (3/2) ) ] 23 | -------------------------------------------------------------------------------- /mtv-lang/sketches/1/1.hs: -------------------------------------------------------------------------------- 1 | dur0 = 6 2 | pat = mmho dur0 $ pre2 "a" 3 | [ (0, m1 "freq" 0) 4 | , (1/2, m1 "freq" 1) 5 | , (1, m1 "freq" 2) 6 | , (2, m1 "freq" 3) 7 | , (3, m1 "freq" 4) 8 | , (4, m1 "freq" 5) 9 | , (5, m1 "on" 0) ] 10 | 11 | scalePat = mmh (4*dur0) $ pre2 "a" 12 | [ ( 0 , maj3 ) 13 | , ( dur0 , dim ) 14 | , ( 2*dur0, aol3 ) 15 | , ( 3*dur0, aug ) ] 16 | 17 | toScale = nBoop 18 | . ops [("freq", (*) 300 . \p -> 2**(p/12))] 19 | . scale 12 scalePat 20 | 21 | ch $ mfl [ 22 | ("1", toScale $ ops [("freq",((-) 12))] $ rev pat) 23 | , ("2", toScale $ ops [("freq",(+ 2))] $ fast 2 pat) 24 | , ("3", toScale $ ops [("freq",(+ 4))] $ fast 4 $ early 2 $ pat) ] 25 | -------------------------------------------------------------------------------- /mtv-lang/sketches/6/1.hs: -------------------------------------------------------------------------------- 1 | p1 = stack2 a b where 2 | a = mmho 2 $ pre2 "a" [(0, m1 "freq" 0) 3 | ,(1, m1 "freq" 2)] 4 | b = mmho 2 $ pre2 "b" [(0, m1 "on" 0) 5 | ,(1, m1 "freq" 4)] 6 | 7 | p2 = mmho 6 $ pre2 "a" $ zip (map RTime [0..]) 8 | $ map (m1 "freq" . (-) 0) [0..5] 9 | 10 | go = nBoop . toHz . rootScale 12 rs where 11 | toHz = ops [("freq", (*) 200 . \p -> 2**(p/12))] 12 | rs = slow 12 $ mmh 2 $ pre2 "a" $ [ (0, (0, phr3)) 13 | , (1, (4, lyd)) 14 | ] 15 | 16 | ch $ mfl [ 17 | ("1", go $ merge0fa p1 p2) 18 | , ("2", go $ ops [("freq",(+7))] $ fast 2 $ rev $ merge0fa p1 p2) 19 | ] 20 | -------------------------------------------------------------------------------- /mtv-lang/sketches/m/3.hs: -------------------------------------------------------------------------------- 1 | pat = mmho 6 $ pre2 "a" 2 | [ (0, m1 "freq" 0) 3 | , (1/2, m1 "freq" 1) 4 | , (1, m1 "freq" 2) 5 | , (2, m1 "freq" 3) 6 | , (3, m1 "freq" 4) 7 | , (4, m1 "freq" 5) 8 | , (5, m1 "on" 0) ] 9 | 10 | scalePat = mmh 24 $ pre2 "a" 11 | [ ( 0, maj3 ) 12 | , ( 6, dim ) 13 | , ( 12, aol3 ) 14 | , ( 18, aug ) ] 15 | 16 | --scalePat = mmh 24 $ pre2 "a" $ [(0, [0,4,7,11,4,11,2])] 17 | 18 | toScale = nBoop 19 | . ops [("freq", (*) 300 . \p -> 2**(p/12))] 20 | . scale 12 scalePat 21 | 22 | ch $ mfl [ 23 | ("1", toScale $ ops [("freq",((-) 12))] $ pat) 24 | , ("2", toScale $ ops [("freq",(+ 2))] $ fast 2 pat) 25 | , ("3", toScale $ ops [("freq",(+ 4))] $ fast 4 $ early 2 $ pat) ] 26 | -------------------------------------------------------------------------------- /Montevideo/Monome/Test/Types/Params.hs: -------------------------------------------------------------------------------- 1 | module Montevideo.Monome.Test.Types.Params where 2 | 3 | import Data.Either 4 | import Test.HUnit 5 | 6 | import Montevideo.Monome.Types.Params 7 | import Montevideo.Synth 8 | 9 | 10 | tests :: Test 11 | tests = TestList 12 | [ TestLabel "test_paramGroup_toParam" test_paramGroup_toParam 13 | , TestLabel "test_paramGroup_toXy" test_paramGroup_toXy 14 | ] 15 | 16 | test_paramGroup_toXy :: Test 17 | test_paramGroup_toXy = TestCase $ do 18 | assertBool "" $ paramGroup_toXy The_PG == (0,0) 19 | 20 | test_paramGroup_toParam :: Test 21 | test_paramGroup_toParam = TestCase $ do 22 | assertBool "0" $ paramGroup_toParam The_PG 0 == Right Axe_amp 23 | assertBool "2" $ isLeft $ paramGroup_toParam The_PG 32 24 | -------------------------------------------------------------------------------- /Montevideo/Monome/refs.md: -------------------------------------------------------------------------------- 1 | # Some links I used: 2 | 3 | monome OSC protocol 4 | https://llllllll.co/t/getting-started-with-the-serialosc-protocol/16834 5 | 6 | 7 | ## probably stale 8 | 9 | asking Reddit Haskel 10 | https://www.reddit.com/r/haskellquestions/comments/9kb7uo/interacting_with_a_monome_via_osc/ 11 | 12 | HOsc 13 | https://www.stackage.org/package/hosc 14 | 15 | monome python tutorial 16 | https://monome.org/docs/grid-studies/python/ 17 | 18 | pymonome (cloned at python/pymonome) 19 | https://github.com/artfwo/pymonome 20 | 21 | setting up a monome on Linux: 22 | https://monome.org/docs/linux/ 23 | https://llllllll.co/t/inconsistencies-in-the-linux-setup-page/16506 24 | https://llllllll.co/t/use-monome-from-python-on-linux-without-wine/15203 25 | -------------------------------------------------------------------------------- /learning/awaiting-email/perc-envelope/trigger-perc,bad-doneAction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, ExtendedDefaultRules #-} 2 | 3 | import Vivid 4 | 5 | foo :: SynthDef '["attackSecs","releaseSecs","level","doneAction"] 6 | foo = sd (1 :: I "attackSecs" 7 | ,1 :: I "releaseSecs" 8 | ,1 :: I "level" 9 | ,0 :: I "doneAction") $ do 10 | e <- percGen (attackSecs_ (V::V"attackSecs") 11 | ,releaseSecs_ (V::V"releaseSecs") 12 | ,level_ (V::V"level") 13 | ,doneAction_ (V::V"doneAction")) 14 | s <- e ~* sinOsc (freq_ (500 ~+ (100 ~* e))) 15 | out 0 [s,s] 16 | 17 | test = doScheduledIn 0.1 test' where 18 | test' = do 19 | s <- synth foo () 20 | wait 2 21 | set s (1 :: I "level") 22 | wait 4 23 | free s 24 | -------------------------------------------------------------------------------- /Montevideo/Monome/Presets.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | 3 | module Montevideo.Monome.Presets where 4 | 5 | import qualified Data.Bimap as B 6 | import qualified Data.Map as M 7 | 8 | import Montevideo.Monome.Types 9 | import Montevideo.Synth.Axe 10 | 11 | 12 | storePreset :: St app -> IO () 13 | storePreset st = let 14 | pairs = map showPair $ M.toList $ _stAxeDefaults st where 15 | showPair (p,f) = "(" ++ (axeConstructors B.! p) ++ ", " ++ show f ++ ")" 16 | ss = [ "\n_ = M.fromList" 17 | , " [ " ++ head pairs ] 18 | ++ map (\p -> " , " ++ p) (tail pairs) 19 | ++ [" ]"] 20 | in appendFile 21 | "Montevideo/Monome/Presets.hs" 22 | $ unlines ss 23 | 24 | -- pr1, pr2, pr3, pr4, pr5, pr6, pr7, pr8 :: M.Map AxeParam Float 25 | -------------------------------------------------------------------------------- /learning/subset-constraints/subset-family-definition.hs: -------------------------------------------------------------------------------- 1 | -- the type families here are duplicated from Vivid/SynthDef/TypesafeArgs.hs 2 | 3 | {-# LANGUAGE TypeOperators 4 | , TypeFamilies 5 | , MultiParamTypeClasses 6 | , DataKinds 7 | , GADTs #-} 8 | 9 | import GHC.TypeLits 10 | import GHC.Exts (Constraint) 11 | 12 | type family Elem (a :: Symbol) (xs :: [Symbol]) :: Constraint where 13 | Elem a (a ': xs) = () 14 | Elem a (x ': xs) = Elem a xs 15 | 16 | type family Subset (as :: [Symbol]) (bs :: [Symbol]) :: Constraint where 17 | Subset '[] bs = () 18 | Subset (a ': as) bs = (Elem a bs, Subset as bs) 19 | 20 | data X phantoms where 21 | X :: String -> X phantoms 22 | 23 | instance Show (X phantoms) where 24 | show (X string) = string 25 | -------------------------------------------------------------------------------- /Montevideo/Dispatch-Unused/DeepseqInstances.hs: -------------------------------------------------------------------------------- 1 | module Montevideo.Dispatch.Instances where 2 | 3 | import Control.DeepSeq 4 | 5 | import Vivid 6 | import Dispatch.Types 7 | import Synths 8 | 9 | 10 | instance NFData (Synth a) where 11 | rnf s = _unNodeId (_unSynth s) `deepseq` () 12 | 13 | instance NFData SynthRegister where 14 | rnf r = _boops r `deepseq` _vaps r `deepseq` _sqfms r `deepseq` () 15 | 16 | instance NFData a => NFData (Museq a) where 17 | rnf m = _dur m `deepseq` _sup m `deepseq` _vec m `deepseq` () 18 | 19 | instance NFData ScAction where 20 | rnf (New s n) = s `deepseq` n `deepseq` () 21 | rnf (Free s n) = s `deepseq` n `deepseq` () 22 | rnf (Send s n m) = s `deepseq` n `deepseq` m `deepseq` () 23 | 24 | instance NFData SynthDefEnum where 25 | rnf a = a `seq` () 26 | -------------------------------------------------------------------------------- /Montevideo/Dispatch-Unused/Distribloop-debug.hs: -------------------------------------------------------------------------------- 1 | -- deepseq (time0, tempoPeriod, museqsMap, reg, now, np0, startRender) 2 | -- (return evs) 3 | 4 | -- let rNow = now - time0 5 | -- rNp0 = np0 - time0 6 | -- rStartRender = startRender - time0 7 | -- rEvs = flip map evs $ over _1 (+(-time0)) 8 | 9 | -- putStrLn $ "\nNow: " ++ show rNow ++ "\nnp0: " ++ show rNp0 10 | -- ++ "\nstartRender: " ++ show rStartRender 11 | -- ++ "\ntempoPeriod: " ++ show tempoPeriod 12 | -- ++ "\nmuseqsMap: " ++ concatMap ((++"\n") . show) (M.toList $ museqsMap) 13 | 14 | -- putStrLn $ "\nlength evs: " ++ show (length evs) ++ "\nevs: " 15 | -- ++ concatMap (\(t,a) -> "\n" ++ show (t-time0) ++ ": " ++ show a) evs 16 | -- ++ "\nThat's all of them?\n" 17 | -------------------------------------------------------------------------------- /Montevideo/Dispatch/Interactive.hs: -------------------------------------------------------------------------------- 1 | hushDispatch -- don't worry if this is not defined 2 | putStrLn "If hush just produced an error, don't worry, it's cool." 3 | quitDispatch -- don't worry if this is not defined 4 | putStrLn "If off just produced an error, don't worry, it's cool." 5 | 6 | -- Hopefully you'll never need to use these explicitly. 7 | disp <- newDispatch 8 | tid <- startDispatchLoop disp 9 | quitDispatch = killThread tid >> freeAll -- kill the program 10 | 11 | -- These, though, you'll use a lot. 12 | ch1 = replace_inDisp disp -- change one Museq 13 | ch = replaceAll_inDisp disp -- change every Museq 14 | hush1 = stop_inDisp disp -- stop (and lose) one thing 15 | hush = replaceAll_inDisp disp M.empty -- stop (and lose) everything 16 | period = chTempoPeriod disp 17 | -------------------------------------------------------------------------------- /Montevideo/Monome/Window/ChordBank/Function.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables 2 | #-} 3 | 4 | module Montevideo.Monome.Window.ChordBank.Function ( 5 | chordFunctionWindow 6 | ) where 7 | 8 | import Prelude hiding (pred) 9 | 10 | import Montevideo.Monome.Types.Most 11 | 12 | 13 | buttonStore :: (X,Y) 14 | buttonStore = (0,0) 15 | 16 | label :: WindowId 17 | label = ChordFunctionWindow 18 | 19 | chordFunctionWindow :: Window app 20 | chordFunctionWindow = Window { 21 | windowLabel = label 22 | , windowContains = flip elem [buttonStore] 23 | , windowInitLeds = \_ _ -> Right [] 24 | , windowHandler = \x y -> return $ handler x y } 25 | 26 | handler :: forall app. 27 | St app -> (MonomeId, ((X,Y), Switch)) 28 | -> Either String (St app) 29 | handler st (mid, (xy,sw)) = Right st 30 | -------------------------------------------------------------------------------- /mtv-lang/sketches/1/2.hs: -------------------------------------------------------------------------------- 1 | dur0 = 6 2 | pat = mmho dur0 $ pre2 "a" 3 | [ (0, m1 "freq" 0) 4 | , (1/2, m1 "freq" 1) 5 | , (1, m1 "freq" 2) 6 | , (2, m1 "freq" 3) 7 | , (3, m1 "freq" 4) 8 | , (4, m1 "freq" 5) 9 | , (5, m1 "on" 0) ] 10 | 11 | scalePat = mmh (4*dur0) $ pre2 "a" 12 | [ ( 0 , maj3 ) 13 | , ( dur0 , dim ) 14 | , ( 2*dur0, aol3 ) 15 | , ( 3*dur0, aug ) ] 16 | 17 | revPat = mmh (2*dur0) $ pre2 "a" 18 | [ (0, id) 19 | , (dur0, rev) ] 20 | 21 | toScale = nBoop 22 | . ops [("freq", (*) 300 . \p -> 2**(p/12))] 23 | . scale 12 scalePat 24 | 25 | ch $ mfl [ 26 | ("1", toScale $ ops [("freq",((-) 12))] $ meta revPat pat) 27 | , ("2", toScale $ ops [("freq",(+ 2))] $ fast 2 $ meta revPat pat) 28 | , ("3", toScale $ ops [("freq",(+ 4))] $ fast 4 $ early 2 $ meta revPat pat) ] 29 | -------------------------------------------------------------------------------- /learning/vivid/envelope.hs: -------------------------------------------------------------------------------- 1 | -- Based on an example by Tom Murphy: 2 | -- https://we.lurk.org/hyperkitty/list/livecode@we.lurk.org/thread/ZQBFCHMBFIIM36KB7S77IDAPYJKMBRF2/ 3 | 4 | -- The signal grows to unity for 1s, decays for 1s, then plateaus at 0.3. 5 | -- After main has counted to 5 it sends a gate=0 signal, 6 | -- which triggers a second of release. 7 | 8 | {-# LANGUAGE DataKinds, ExtendedDefaultRules #-} 9 | 10 | import Vivid 11 | 12 | foo = sd (1 :: I "gate") $ do 13 | e <- adsrGen 1 1 0.3 1 14 | (Curve_Curve $ 0) 15 | (gate_ (V::V "gate")) 16 | s <- e ~* sinOsc (freq_ 500) 17 | out 0 [s,s] 18 | 19 | count 0 = (putStrLn $ show 0) >> return () 20 | count n = do putStrLn $ show n 21 | wait 1 22 | count $ n-1 23 | 24 | main = do 25 | s <- synth foo () 26 | count 5 27 | set s (0 :: I "gate") 28 | count 3 29 | free s 30 | -------------------------------------------------------------------------------- /mtv-lang/sketches/drums/1.hs: -------------------------------------------------------------------------------- 1 | seq d e f = [ (0, d) 2 | , (1, e) 3 | , (2, d) 4 | , (2.5, e) 5 | , (3, f) ] 6 | patKs = mmt1 4 $ seq S_Km S_Sm_peb S_Km 7 | patHat = mmt1 4 $ seq S_Hl_dc S_Hl_tfc S_Hl_tfc 8 | 9 | modPat f g = mmh 4 $ pre2 "a" 10 | [ (0, f . g) 11 | , (1, id) 12 | , (2, f) 13 | , (3, g) ] 14 | 15 | -- For m out of n beats, play normally. 16 | -- For the remainder, slow by r. 17 | rareSlow r m n = mmh n $ pre2 "b" -- what's this string for? 18 | [ (0, id), 19 | (m, slow r) ] 20 | 21 | ch $ mfl 22 | [ ("1" 23 | , meta (rareSlow 4 14 16) $ stack 24 | [ meta ( slow 4 $ early 2 $ 25 | modPat (fast 2) (late 1)) 26 | $ append patKs $ dense 2 patKs 27 | , meta ( slow 4 $ 28 | modPat (fast 2 . early 1) (fast 2)) 29 | $ early (1/2) patHat 30 | ] ) 31 | ] 32 | -------------------------------------------------------------------------------- /Montevideo/Synth/README.md: -------------------------------------------------------------------------------- 1 | Parameters for these synths can be confusing. 2 | Most synths have an "amp" parameter. 3 | Some can also be controlled by an "on" parameter. 4 | Hopefully eventually all of them will be. 5 | The preferred way to control *whether* a voice is sounding is via "on", 6 | whereas "amp" should be reserved for controlling its level. 7 | Don't send "amp=0" messages, because they erase the amplitude state. 8 | 9 | For instance, this is good form: 10 | ```haskell 11 | pat = ( mmh 1 $ pre2 "blark" 12 | [ (0, mfl [("freq", 600), 13 | ("amp", 0.2), 14 | ("on", 1)]), 15 | (1/2, m1 "on" 0) ] ) 16 | 17 | chAll $ mfl [ 18 | ("1", nZot pat) 19 | -- ("2", nBoop pat) 20 | ] 21 | ``` 22 | 23 | The `onOffEnvelope` SynthDef uses the "on" parameter (and some others). 24 | The synths that respond to "on" messages are exactly those that use it. 25 | -------------------------------------------------------------------------------- /Montevideo/JI/intervals.hs: -------------------------------------------------------------------------------- 1 | -- TODO : Incorporate these into a real module. 2 | 3 | let 4 | -- By modifying the values assigned to x and y, 5 | -- and maybe even i and j, 6 | -- this can be useful for finding JI scales. 7 | f :: Float -- should be a power of 10 8 | -> [Rational] -- the primes (or other factors] 9 | -> [ ( Integer, 10 | (Integer, Integer), 11 | (Integer, Integer), 12 | Rational ) ] 13 | f rounder primes = 14 | L.sort $ unique 15 | [ let v = firstOctave $ x'^^i * y'^^j 16 | in ( round $ ratioToCents v / rounder, 17 | (round x',i), 18 | (round y',j), 19 | v) 20 | | x <- primes 21 | , y <- primes 22 | , i <- [-1..1] 23 | , j <- [-1..1] 24 | , x' <- return $ if i == 0 then 1 else x 25 | , y' <- return $ if j == 0 then 1 else y 26 | , x' < y' 27 | , not $ i == 0 && j == 0 ] 28 | -------------------------------------------------------------------------------- /mtv-lang/sketches/6/2.hs: -------------------------------------------------------------------------------- 1 | p1 = stack2 a b & dur .~ 4 where 2 | a = mmho 3 $ pre2 "a" [(0, m1 "freq" 0) 3 | ,(1, m1 "freq" 2)] 4 | b = mmho 2 $ pre2 "b" [(0, m1 "on" 0) 5 | ,(1, m1 "freq" 4)] 6 | 7 | p2 :: Int -> Museq String ScParams = \n -> 8 | mmho (fromIntegral n) $ pre2 "a" $ 9 | zip (map RTime [0..]) $ 10 | map (M.singleton "freq" . (+) 0) $ 11 | map fromIntegral [0..n-1] 12 | 13 | go = nBoop . toHz . rootScale 12 rs where 14 | toHz = ops [("freq", (*) 200 . \p -> 2**(p/12))] 15 | rs = slow 12 $ mmh 3 $ pre2 "a" $ [ (0, (0, phr3)) 16 | , (1, (4, lyd)) 17 | , (2, (1, lyd7)) 18 | ] 19 | 20 | ch $ mfl [ 21 | ("1", go $ fast 2 $ merge0fa (slow 4 $ p2 4) $ merge0fa (p2 4) p1) 22 | , ("2", go $ fast 4 $ merge0fa (slow 8 $ p2 4) $ merge0fa (p2 3) p1) 23 | ] 24 | -------------------------------------------------------------------------------- /Montevideo/Monome/Types.hs: -------------------------------------------------------------------------------- 1 | module Montevideo.Monome.Types 2 | ( module Montevideo.Monome.Types.Device 3 | , module Montevideo.Monome.Types.Edo 4 | 5 | -- The instances defined in Montevideo.Monome.Types.Instances 6 | -- are all for types defined in Montevideo.Monome.Types.Most, 7 | -- so once Montevideo.Monome.Types.Most is exported, 8 | -- there is no need to export Montevideo.Monome.Types.Instances, 9 | -- and in fact doing so elicits a warning from GHC. 10 | -- module Montevideo.Monome.Types.Instances 11 | 12 | , module Montevideo.Monome.Types.Monome 13 | , module Montevideo.Monome.Types.Most 14 | , module Montevideo.Monome.Types.Params 15 | ) where 16 | 17 | import Montevideo.Monome.Types.Device 18 | import Montevideo.Monome.Types.Edo 19 | import Montevideo.Monome.Types.Instances() 20 | import Montevideo.Monome.Types.Monome 21 | import Montevideo.Monome.Types.Most 22 | import Montevideo.Monome.Types.Params 23 | -------------------------------------------------------------------------------- /Montevideo/Random/Types/Other.hs: -------------------------------------------------------------------------------- 1 | module Montevideo.Random.Types.Other ( 2 | RandConstraints(..), 3 | mkRandConstraints 4 | ) where 5 | 6 | type NParams = Int 7 | type MaxSignals = Int 8 | type MaxDepth = Int 9 | 10 | -- | Without RandConstraints we would usually create invalid signal graphs 11 | -- For instance, we can't refer to the 5th named signal if there are only 4. 12 | -- TODO ? This is really a hodgepodge of constraints (e.g. maxSignals) 13 | -- and state (e.g. namedSignals, which should not exceed maxSignals). 14 | data RandConstraints = RandConstraints 15 | { nParams :: Int -- in [1,8] 16 | , namedSignals :: Int -- in [0,maxSignals] 17 | , maxSignals :: Int -- in [1,8] 18 | , depth :: Int -- in [1, maxDepth] 19 | , maxDepth :: Int -- greater than 1 20 | } deriving (Show, Eq) 21 | 22 | mkRandConstraints :: NParams -> MaxSignals -> MaxDepth -> RandConstraints 23 | mkRandConstraints a b c = RandConstraints a 0 b 1 c 24 | -------------------------------------------------------------------------------- /Montevideo/Synth/Axe.hs.unused: -------------------------------------------------------------------------------- 1 | -- For reverb: 2 | ,"rev-mix","rev-room","rev-damp" 3 | , 0 :: I "rev-mix" 4 | , 0 :: I "rev-room" 5 | , 0 :: I "rev-damp" 6 | verbed <- freeVerb ( in_ filtered 7 | , mix_ (V::V"rev-mix") 8 | , room_ (V::V"rev-room") 9 | , damp_ (V::V"rev-damp") 10 | ) 11 | 12 | -- For feedback: 13 | fb <- head <$> localIn(1) -- uses the feedback output 14 | localOut( [tanh' filtered] ) -- feeds "filtered" back. Comes later in the program. 15 | 16 | -- To add phase modulation to some sine wave: 17 | sinOsc ( _something 18 | , phase_ $ (V::V"pm") ~* saw ( freq_ $ (V::V"freq") ~* 19 | (V::V"pf") ) ) 20 | 21 | -- A frequency signal with pulse-modulated vibrato. 22 | f <- (V::V"freq") ~* ( 1 ~+ (V::V"vm") ~* 23 | pulse ( freq_ $ (V::V"vf") 24 | ~* (V::V"freq") ) ) 25 | -------------------------------------------------------------------------------- /Montevideo/JI/Types.hs: -------------------------------------------------------------------------------- 1 | module Montevideo.JI.Types where 2 | 3 | import Montevideo.Types 4 | 5 | 6 | data Approximation = Approximation { 7 | approximationEdo :: Edo, 8 | approximationTarget :: Rational, 9 | approximationTargetCents :: Float, 10 | approximationSteps :: Int, 11 | approximationCents :: Float, 12 | approximationError :: Float } 13 | deriving (Show, Eq, Ord) 14 | 15 | type Approximation_OneLine = 16 | ( Rational, -- ^ approximationTarget 17 | Float, -- ^ approximationTargetCents 18 | Int, -- ^ approximationSteps 19 | Float, -- ^ approximationCents 20 | Float ) -- ^ approximationError 21 | 22 | approx_oneLine :: Approximation -> Approximation_OneLine 23 | approx_oneLine a = 24 | let f x = fromIntegral (round $ x * 10) / 10 25 | in ( approximationTarget a, 26 | f $ approximationTargetCents a, 27 | approximationSteps a, 28 | f $ approximationCents a, 29 | approximationError a ) 30 | -------------------------------------------------------------------------------- /mtv-lang/sketches/tests/octaves.hs: -------------------------------------------------------------------------------- 1 | -- Cycles between a note and its octave, evenly spaced, 2 | -- across the span of one second. 3 | 4 | m = Museq 5 | { _dur = 1 6 | , _sup = 1 7 | , _vec = V.fromList 8 | [ Event { _evLabel = "a" 9 | , _evArc = (0, 1/2) 10 | , _evData = Note 11 | { _noteSd = Zot 12 | , _noteScParams = M.fromList 13 | [ ("freq", 440) ] 14 | } } 15 | , Event { _evLabel = "a" 16 | , _evArc = (1/2,1) 17 | , _evData = Note 18 | { _noteSd = Zot 19 | , _noteScParams = M.fromList 20 | [ ("freq", 220) ] 21 | } } 22 | ] } 23 | 24 | ch $ mfl [ 25 | ("1", m ) 26 | ] 27 | -------------------------------------------------------------------------------- /mtv-lang/docs/samples.hs: -------------------------------------------------------------------------------- 1 | drums = ( -- This is a drum pattern. 2 | mmt1 2 -- The 2 here gives it a duration of 2. 3 | -- "mmt" = "mm" (make a Museq) + "t" (for trigger messages). 4 | -- It attaches a "trigger=1" message to each sample, 5 | -- which would be annoying to have to write by hand. 6 | [ ( 0 -- At time 0, 7 | , S_Kd) -- play one of the kick drum samples. 8 | , ( 1 -- At time 1, 9 | , S_Sm_m) -- play one of the snare drum samples 10 | ] 11 | ) 12 | 13 | 14 | 15 | chAll $ -- `chAll` = "change all" = "play the following, and nothing else" 16 | mfl -- `mfl` = `Data.Map.fromList` 17 | [ ( "1" -- From a voice named "1", 18 | , drums) -- play the `drums` pattern. 19 | , ( "2" -- From a voice named "2", 20 | , late (1/8) $ fast 4 -- play the same pattern, 4 times as fast 21 | -- and 1/8 of a tempo period ("a bar") late 22 | drums) 23 | ] 24 | -------------------------------------------------------------------------------- /learning/mvar/pitch.hs: -------------------------------------------------------------------------------- 1 | -- Here's a loop (in the CS sense, not the musical one) 2 | -- that can be modified as it runs. 3 | -- Example: 4 | -- > x <- newMVar (444 :: Int) 5 | -- > f x 6 | -- > swapMVar x 555 -- the old value 444 returned here doesn't matter 7 | 8 | {-# LANGUAGE DataKinds #-} 9 | 10 | import Vivid 11 | import Data.List as L 12 | import Control.Concurrent.MVar 13 | 14 | boop :: SynthDef '["note","amp"] 15 | boop = sd ((0,0.1) -- default values 16 | :: (I "note",I "amp")) $ do 17 | s1 <- (V::V "amp") ~* sinOsc (freq_ (V::V "note")) 18 | out 0 [s1, s1] 19 | 20 | abc :: VividAction m => m [Synth '["note", "amp"]] 21 | abc = do 22 | a <- synth boop () 23 | b <- synth boop () 24 | c <- synth boop () 25 | return [a,b,c] 26 | 27 | f :: MVar Int -> IO () 28 | f m = do 29 | s <- synth boop () 30 | fork $ loop s 31 | where 32 | loop s = do 33 | freq <- readMVar m 34 | set s (toI freq :: I "note") 35 | wait 0.1 36 | loop s 37 | -------------------------------------------------------------------------------- /learning/subset-constraints/solution.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds 2 | , ExtendedDefaultRules 3 | , ScopedTypeVariables 4 | , GADTs #-} 5 | 6 | import Vivid 7 | 8 | boop :: SynthDef '["freq","amp"] 9 | boop = sd ( (0,0.01) -- default values 10 | :: (I "freq",I "amp")) $ do 11 | s1 <- (V::V "amp") ~* sinOsc (freq_ (V::V "freq")) 12 | out 0 [s1, s1] 13 | 14 | data Message sdArgs where 15 | Message :: forall params sdArgs. 16 | (VarList params 17 | , Subset (InnerVars params) sdArgs) 18 | => params -> Message sdArgs 19 | 20 | message :: Int -> Message '["freq","amp"] 21 | message 0 = Message (toI 444 :: I "freq") 22 | message 1 = Message (toI 0.1 :: I "amp") 23 | message _ = Message () 24 | 25 | main = do 26 | s <- synth boop () 27 | case message 0 of 28 | Message a -> set s a 29 | _ -> return () 30 | case message 1 of 31 | Message a -> set s a 32 | _ -> return () 33 | wait 1 34 | freeAll 35 | -------------------------------------------------------------------------------- /mtv-lang/sketches/4.hs: -------------------------------------------------------------------------------- 1 | p1 = fast 2 $ early 1 $ mmho 4 $ pre2 "a" 2 | [ (0, m1 "freq" 0) 3 | , (1, m1 "freq" 2) 4 | , (2, m1 "freq" 4) 5 | , (3, m1 "on" 0) ] 6 | p2 f = mmho 1 $ [ ("a", 0, m1 "freq" f) 7 | , ("b", 0, m1 "freq" 0) 8 | ] 9 | p3 = merge0 p1 $ stack2 (p2 3) (p2 10) 10 | 11 | rootPat = slow 8 $ mmh 8 $ pre2 "a" 12 | [ ( 0, 0 ) 13 | , ( 2, 5 ) 14 | , ( 3, 0 ) 15 | , ( 4, 7 ) 16 | , ( 5, 5 ) 17 | , ( 6, 0 ) 18 | , ( 7, 7 ) ] 19 | 20 | scalePat = slow 4 $ cat [dense 2 s1, dense 2 s2] where 21 | s1 = mmh 2 $ pre2 "a" 22 | [ ( 0 , dor2 ) 23 | , ( 1 , loc6 ) ] 24 | s2 = mmh 2 $ pre2 "a" 25 | [ ( 0 , maj ) 26 | , ( 1 , lyd7 ) ] 27 | 28 | toScale = nBoop 29 | . ops [("freq", (*) 200 . \p -> 2**(p/12))] 30 | . root (slow 8 rootPat) 31 | . scale 12 (fast 2 scalePat) 32 | 33 | ch $ mfl [ 34 | ("1", toScale $ cat [p1,p3] ) 35 | , ("2", toScale $ rev $ ops [("freq",(+4))] p3 ) 36 | ] 37 | -------------------------------------------------------------------------------- /learning/vivid,random/random-choice-of-IO.hs: -------------------------------------------------------------------------------- 1 | -- I wrote this so I could ask GHCI for the type signature of `f` 2 | -- (which I then included in the code). 3 | -- This is based on Tom Murphy's code suggested here: 4 | -- https://we.lurk.org/hyperkitty/list/livecode@we.lurk.org/thread/25W4GB76BWXONUSUEMW5NV6Y6OO6NPAR/ 5 | 6 | {-# LANGUAGE DataKinds, ExtendedDefaultRules #-} 7 | 8 | import Vivid 9 | 10 | boop :: SynthDef '["freq","amp"] 11 | boop = sd ((0,0.1) -- default values 12 | :: (I "freq",I "amp")) $ do 13 | s1 <- (V::V "amp") ~* sinOsc (freq_ (V::V "freq")) 14 | out 0 [s1, s1] 15 | 16 | f :: IO (Synth '["freq", "amp"] -> Integer -> IO ()) 17 | f = pick ( [ \s n -> set s (toI n :: I "freq") 18 | , \s n -> set s (toI n :: I "amp") 19 | ] ) 20 | 21 | main = do 22 | s <- synth boop () 23 | set' <- f 24 | -- run it four times so that both amp and freq are likely to be set 25 | set' s 400 26 | set' s 400 27 | set' s 400 28 | set' s 400 29 | freeAll 30 | -------------------------------------------------------------------------------- /Montevideo/Synth/Config.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE DataKinds #-} 3 | 4 | module Montevideo.Synth.Config where 5 | 6 | 7 | -- | PITFALL: This is not a binding maximum, 8 | -- just an arbitrary level that other things are defined in terms of. 9 | -- SuperCollider distorts for values outside of [-1,1]. 10 | maxAmp :: Fractional a => a 11 | maxAmp = 0.05 12 | 13 | dirtSamplesFolder :: FilePath 14 | dirtSamplesFolder = "/home/jeff/code/music/Tidal/Dirt-Samples" 15 | 16 | filterFreqMax, filterFreqMin :: Num a => a 17 | 18 | -- | This is the Nyquist frequency if sampling at 44.1 KHz. 19 | -- Frequencies above this cannot be worked with. 20 | filterFreqMax = 22050 21 | 22 | -- | On the low side, human hearing only extends to about 40 Hz. 23 | -- Some filters go crazy at values "close to zero". 24 | -- I don't know what "close" means, but at least for the synths I've written 25 | -- so far, I don't think I lose anything by flooring filter frequencies 26 | -- at 10 Hz. 27 | filterFreqMin = 10 28 | -------------------------------------------------------------------------------- /Montevideo/Synth/Zot.ghci.hs: -------------------------------------------------------------------------------- 1 | s <- synth zot () 2 | set s (0.1 :: I "amp", (1/300) :: I "del", 0.5 :: I "pulse", 400 :: I "f") 3 | 4 | set s (2 :: I"sh", 2::I"sh-b") 5 | 6 | set s (2::I"sh",0.2::I"sh-b") 7 | set s (1 :: I"rm",2::I"rm-b",0::I"rm-f") 8 | 9 | 10 | set s (1 :: I "pm-b", 1 :: I "pm-m", 1 :: I "pm-f") 11 | set s (44 :: I "fm-b", 30 :: I "fm-m", 300 :: I "fm-f") 12 | set s (0.5 :: I "w", 1 :: I "wm-b", 30 :: I "wm-m", 300 :: I "wm-f") 13 | set s (0.7 :: I"rm",0.25::I"rm-b",100::I"rm-f") 14 | set s (0.1 :: I"am",0.5::I"am-b",10::I"am-f") 15 | set s (3000 :: I"bpf",1 :: I"bpf-m",0.5::I"bpf-q") 16 | set s (500 :: I"hpf",1 :: I"hpf-m") 17 | set s (2000 :: I"lpf",1 :: I"lpf-m") 18 | set s (2 :: I"lim") 19 | 20 | t <- synth zot () 21 | set t (0.1 :: I "amp", (1/300) :: I "del", 0.5 :: I "pulse", 400::I"f") 22 | set t (1 :: I "pm-b", 1 :: I "pm-m", 1 :: I "pm-f") 23 | set t (400 :: I "f", 3 :: I "fm-b", 30 :: I "fm-m", 300 :: I "fm-f") 24 | set t (0.5 :: I "w", 1 :: I "wm-b", 30 :: I "wm-m", 300 :: I "wm-f") 25 | 26 | -------------------------------------------------------------------------------- /learning/mvar/toggle-loop.hs: -------------------------------------------------------------------------------- 1 | -- A loop (in the CS sense, not the musical one) that can be stopped. 2 | -- Example 3 | -- > on <- newMVar True 4 | -- > loop on -- the sound starts 5 | -- > swapMVar on False -- it stops 6 | -- True -- ignore this return value; it's the old value of on 7 | -- > swapMVar on True 8 | -- False 9 | -- > loop on -- it starts again 10 | 11 | {-# LANGUAGE DataKinds #-} 12 | 13 | import Vivid 14 | import Data.List as L 15 | import Control.Concurrent.MVar 16 | 17 | 18 | boop :: SynthDef '["note","amp"] 19 | boop = sd ((0,0.1) -- default values 20 | :: (I "note",I "amp")) $ do 21 | s1 <- (V::V "amp") ~* sinOsc (freq_ (V::V "note")) 22 | out 0 [s1, s1] 23 | 24 | loop :: MVar Bool -> IO () 25 | loop continue = do 26 | s <- synth boop () 27 | let go = do 28 | set s (toI 500 :: I "note") 29 | c <- readMVar continue 30 | if c 31 | then do wait 0.1 32 | go 33 | else do freeAll 34 | return () 35 | fork go 36 | -------------------------------------------------------------------------------- /learning/fb/fb.hs: -------------------------------------------------------------------------------- 1 | -- This is the preferred feedback method; for some reason using localIn 2 | -- and localOut sounds better than using localBuf, playBuf and recordBuf. 3 | -- Notice that there can only be one (audio rate) localIn/localOut pair 4 | -- per synthdef. That's no problem, because it can have lots of channels. 5 | 6 | {-# LANGUAGE DataKinds, ExtendedDefaultRules #-} 7 | 8 | import Vivid 9 | 10 | foo :: SynthDef '[] 11 | foo = sd () $ do 12 | [s_fb,t_fb] <- localIn(2) 13 | 14 | s <- lpf( in_ $ (0.1 ~* whiteNoise) 15 | ~+ (0.999 ~* toSig s_fb) 16 | , freq_ 1500 ) 17 | s' <- delayL( in_ s 18 | , maxDelaySecs_ 1 19 | , delaySecs_ 0.01 ) 20 | 21 | t <- lpf( in_ $ (0.1 ~* whiteNoise) 22 | ~+ (0.999 ~* toSig t_fb) 23 | , freq_ 1500 ) 24 | t' <- delayL( in_ t 25 | , maxDelaySecs_ 1 26 | , delaySecs_ 0.0075 ) 27 | 28 | localOut( [s',t'] ) 29 | out 0 [s,t] 30 | 31 | main = do 32 | s <- synth foo () 33 | wait 4 34 | free s 35 | -------------------------------------------------------------------------------- /mtv-lang/docs/scale-and-root-progression.hs: -------------------------------------------------------------------------------- 1 | -- This is a slight variation on "scale-progression.hs"; 2 | -- anything not documented here might be documented there. 3 | 4 | scaleStepPattern = 5 | mmho 3 6 | $ pre2 "a" 7 | [ (0, m1 "freq" 0) 8 | , (1/2, m1 "freq" 1) 9 | , (1, m1 "freq" 2) 10 | , (2, m1 "freq" 3) ] 11 | 12 | rootScalePat = slow 4 $ 13 | mmh 2 $ pre2 "a" 14 | [ ( 0 -- Starting at time 0, 15 | , (0, dor7) ) -- use dorian b7 (a.k.a. harmonic minor) rooted at 0. 16 | , ( 1 -- Starting at time 1, 17 | , (3, lyd7) ) ] -- use lydian b7 rooted at 3. 18 | -- The root of the second scale is 3 halfsteps above the root of the first. 19 | 20 | render = (<$>) (Note Boop) 21 | . ops [( "freq" 22 | , (*) 300 . \p -> 2**(p/12) )] 23 | . rootScale 12 rootScalePat 24 | 25 | chAll $ mfl 26 | [ ( "1" 27 | , render scaleStepPattern) 28 | , ( "2" 29 | , render $ 30 | freq (+2) $ 31 | fast 2 $ 32 | scaleStepPattern) 33 | , ( "mushy bongo sasquatch", 34 | render $ freq (+4) $ fast 4 $ scaleStepPattern) ] 35 | -------------------------------------------------------------------------------- /learning/_mostly-internalized/melody-via-list.hs: -------------------------------------------------------------------------------- 1 | -- Here's a synth with two parameters. 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | 5 | import Vivid 6 | import Data.List as L 7 | 8 | boop :: SynthDef '["freq","amp"] 9 | boop = sd ((0,0.01) -- default values 10 | :: (I "freq",I "amp")) $ do 11 | s1 <- (V::V "amp") ~* sinOsc (freq_ (V::V "freq")) 12 | out 0 [s1, s1] 13 | 14 | main :: IO () 15 | main = do 16 | s <- synth boop () 17 | s' <- synth boop () 18 | s'' <- synth boop () 19 | let freqs = [200,400] 20 | freqs' = [250,350,450] 21 | freqs'' = [650,675,725,750,1825,1825,775,1775] 22 | amps = [0.05,0.1,0.15,0.1,0] 23 | amps' = [0.05,0.15,0.1,0,0,0,0.1,0] 24 | forM_ (L.zip5 (cycle freqs) (cycle freqs') (cycle freqs'') 25 | (cycle amps) (cycle amps') 26 | ) 27 | $ \(n,n',n'',a,a') -> do 28 | set s (toI n :: I "freq") 29 | set s (toI a :: I "amp") 30 | set s' (toI n' :: I "freq") 31 | set s' (toI a' :: I "amp") 32 | set s'' (toI n' :: I "freq") 33 | -- s'' will keep its default amp value 34 | wait 0.1 35 | -------------------------------------------------------------------------------- /Montevideo/Test.hs: -------------------------------------------------------------------------------- 1 | module Montevideo.Test where 2 | 3 | import Test.HUnit 4 | 5 | import Montevideo.JI.Thanos.Test 6 | import Montevideo.Monome.Test.EdoMath 7 | import Montevideo.Monome.Test.JI 8 | import Montevideo.Monome.Test.Misc 9 | import Montevideo.Monome.Test.Sustain 10 | import Montevideo.Monome.Test.Types.Params 11 | import Montevideo.Monome.Test.Windows 12 | import Montevideo.Dispatch.Lazy.Test.Intervals 13 | import Montevideo.Dispatch.Lazy.Test.Points 14 | import Montevideo.Test.Dispatch 15 | import Montevideo.Test.Recording 16 | import Montevideo.Test.Util 17 | 18 | 19 | allTests :: IO Counts 20 | allTests = runTestTT $ TestList 21 | [ Montevideo.JI.Thanos.Test.tests 22 | , Montevideo.Monome.Test.EdoMath.tests 23 | , Montevideo.Monome.Test.JI.tests 24 | , Montevideo.Monome.Test.Misc.tests 25 | , Montevideo.Monome.Test.Sustain.tests 26 | , Montevideo.Monome.Test.Types.Params.tests 27 | , Montevideo.Monome.Test.Windows.tests 28 | , Montevideo.Test.Dispatch.tests 29 | , Montevideo.Test.Recording.tests 30 | , Montevideo.Test.Util.tests 31 | , Montevideo.Dispatch.Lazy.Test.Intervals.tests 32 | , Montevideo.Dispatch.Lazy.Test.Points.tests 33 | ] 34 | -------------------------------------------------------------------------------- /_unused/docs,kind-of-obvious/abbreviations.hs: -------------------------------------------------------------------------------- 1 | p f g = mmho 3 $ -- mmho = make museq + holds + ons 2 | -- 'h': hold each event until the next 3 | -- 'o': insert "on=1" wherever "on" isn't 0 4 | pre2 "a" -- to each of these pairs, prefix "a" 5 | [ (0, m1 "freq" f) 6 | , (1, m1 "freq" $ f*g) 7 | , (2, m1 "on" 0) ] 8 | 9 | m = mmh 9 -- mmh = make museq' + holds 10 | -- (ons only makes sense for Msg payloads; these are functions) 11 | [ trip "a" 0 id 12 | , trip "a" 3 $ fast 2 13 | , trip "b" 3 $ fast 4 14 | -- Wart: For safety, to prevent hanging notes, 15 | -- all voices must be turned off explicitly. 16 | , trip "a" 7 $ offs 17 | , trip "b" 7 $ offs 18 | ] 19 | 20 | m2 = mmh 9 $ pre2 "a" [ (0,id), (5,early (1/2)) ] 21 | 22 | chAll $ mfl 23 | [ ("1", nBoop $ -- nBoop :: Museq l Msg -> Museq l Note 24 | meta m $ 25 | merge0a (p 400 $ 5/4) $ 26 | meta m2 $ fast 2 $ p 1 $ 3/5 ) 27 | , ("2", nBoop $ 28 | meta (fast 2 m) $ 29 | merge0a (p 300 $ 10/11) $ 30 | fast 2 $ p 1 $ 3/7 ) ] 31 | 32 | ch "3" $ nBoop $ -- ch = change 33 | meta m $ 34 | merge0a (p 500 $ 10/11) $ 35 | fast 2 $ p 1 $ 13/9 36 | -------------------------------------------------------------------------------- /Montevideo/Monome/Interactive.hs: -------------------------------------------------------------------------------- 1 | (mst, startRecording, stopRecording, quitMonome) <- ( 2 | edoMonome MonomeConfig.myKite ) -- Start synth. 3 | -- my58_15_2 4 | -- my46_8_3 5 | -- my55_16_7 6 | -- my58_15_2 7 | -- my58_12_5 8 | -- my58_17_5 9 | -- my58_8_13 10 | -- my58_11_3 11 | -- my58_11_7 12 | sh aLens = (^. aLens) <$> readMVar mst -- show things 13 | ch aLens aFunc = modifyMVar_ mst $ return . (aLens %~ aFunc) -- change things 14 | d :: AxeParam -> Float -> IO () = chDefault mst -- change a parameter 15 | shd = sh stAxeDefaults >>= myPrint . M.toList -- show defaults, readably 16 | sp :: IO () = ( -- store a preset (at Presets.hs) 17 | readMVar mst >>= storePreset ) 18 | lp :: Map AxeParam Float -> IO () = ( \m -> -- load a preset 19 | ch stAxeDefaults $ const m ) 20 | hey :: IO () = freeAllVoices mst 21 | 22 | -- I never use these, and the don't play nicely 23 | -- with the new `NumScale_Enum` constructor. 24 | -- 25 | -- b :: AxeParam -> Rational -> IO () = ( \p r -> -- change a range's floor 26 | -- ch (stAxeRanges . at p . _Just . _2) $ const r ) 27 | -- t :: AxeParam -> Rational -> IO () = ( \p r -> -- change a range's ceiling 28 | -- ch (stAxeRanges . at p . _Just . _3) $ const r ) 29 | -------------------------------------------------------------------------------- /mtv-lang/sketches/8.hs: -------------------------------------------------------------------------------- 1 | seq evs = f $ zip (map RTime [0..]) evs where 2 | f [] = [] 3 | f [a] = [a] 4 | f ((t,ev):b:more) = (t+1/2, ev) : b : f more 5 | 6 | patKs = mmt1 4 $ seq [ S_Km, S_Sm_peb, S_Sl_blip ] 7 | patHat = mmt1 4 $ seq [ S_Hl_et, S_Hl_tfc, S_Hl_tfc ] 8 | 9 | -- simpler patterns 10 | s1 = mmt1 2 $ map (_1 %~ RTime) $ [ (0, S_Km), (1, S_Kt) ] 11 | s2 = mmt1 2 $ map (_1 %~ RTime) $ [ (0, S_Hl_et), (1, S_Sp_t) ] 12 | 13 | viewDurs = vec .~ mempty 14 | 15 | ch $ mfl 16 | [ 17 | 18 | -- ("1", let x = stack [ patKs 19 | -- , early 1 $ fast 4 patKs 20 | -- , fast 4 $ 21 | -- meta ( slow 4 $ mmh 2 $ pre2 "b" $ 22 | -- seq [ early $ 1/2, late $ 1/2 ] ) $ 23 | -- patHat ] 24 | -- in cat [ stack [sparse 2 x, early 2.75 $ sparse 2 x] 25 | -- , x ] 26 | -- ) 27 | -- , 28 | 29 | ("2", fast 2 $ stack [ cat [ sparse 2 $ cat [ mempty 30 | , dense 2 s2 ] 31 | , dense 4 s2 32 | ] 33 | , cat [dur .~ 6 $ s1, slow 2 mempty ] ] ) 34 | 35 | ] 36 | -------------------------------------------------------------------------------- /mtv-lang/sketches/8/1.hs: -------------------------------------------------------------------------------- 1 | seq evs = f $ zip (map RTime [0..]) evs where 2 | f [] = [] 3 | f [a] = [a] 4 | f ((t,ev):b:more) = (t+1/2, ev) : b : f more 5 | 6 | patKs = mmt1 4 $ seq [ S_Km, S_Sm_peb, S_Sl_blip ] 7 | patHat = mmt1 4 $ seq [ S_Hl_et, S_Hl_tfc, S_Hl_tfc ] 8 | 9 | -- simpler patterns 10 | s1 = mmt1 2 $ map (_1 %~ RTime) $ [ (0, S_Km), (1, S_Kt) ] 11 | s2 = mmt1 2 $ map (_1 %~ RTime) $ [ (0, S_Hl_et), (1, S_Sp_t) ] 12 | 13 | viewDurs = vec .~ mempty 14 | 15 | ch $ mfl 16 | [ 17 | 18 | -- ("1", let x = stack [ patKs 19 | -- , early 1 $ fast 4 patKs 20 | -- , fast 4 $ 21 | -- meta ( slow 4 $ mmh 2 $ pre2 "b" $ 22 | -- seq [ early $ 1/2, late $ 1/2 ] ) $ 23 | -- patHat ] 24 | -- in cat [ stack [sparse 2 x, early 2.75 $ sparse 2 x] 25 | -- , x ] 26 | -- ) 27 | -- , 28 | 29 | ("2", fast 2 $ stack [ cat [ sparse 2 $ cat [ mempty 30 | , dense 2 s2 ] 31 | , dense 4 s2 32 | ] 33 | , cat [dur .~ 6 $ s1, slow 2 mempty ] ] ) 34 | 35 | ] 36 | -------------------------------------------------------------------------------- /interactive/ear-train.hs: -------------------------------------------------------------------------------- 1 | -- Roughly 24-edo, in 46-edo. 2 | someIntervals = let ps = [ 2, 4, 6, 8, 10,12, 3 | 15,17,19,21,23,25, 4 | 27,29,31,32, 5 | 37,39,42,44, 6 | in ps ++ (23 : map (\p -> 46-p) ps) 7 | 8 | 9 | earTrainFromChordList 46 $ map (\x -> [0,x]) $ someIntervals 10 | 11 | earTrainFromChordList 46 $ map (\x -> [0,x]) $ [31,32] 12 | 13 | earTrainFromChordList 46 $ map (\x -> [0,x,27]) [12..15] 14 | earTrainFromChordList 46 $ map (\x -> [0,x,27]) [10,12] 15 | earTrainFromChordList 46 $ map (\x -> [0,x,27]) [10..13] 16 | earTrainFromChordList 46 $ map (\x -> [0,x,27]) [17,18] 17 | 18 | earTrainFromChordList 46 $ map (\x -> [0,x]) [37,39] 19 | earTrainFromChordList 46 $ map (\x -> [0,x,27]) [12..15] 20 | earTrainFromChordList 46 $ map (\x -> [0,x,27]) [15..19] 21 | earTrainFromChordList 46 $ map (\x -> [0,x,27]) [8..12] 22 | 23 | earTrainFromChordList 46 $ map (\x -> [0,x]) [26,28] 24 | 25 | earTrain3ClusterFreeChromatic 46 3 150 26 | 27 | earTrain3ClusterFreeChromatic 22 3 22 28 | 29 | let base = [10,12] 30 | mirrored = base ++ map (22 -) base 31 | dyads = S.toList . S.fromList $ 32 | map (\x -> [0,x]) mirrored 33 | in earTrainFromChordList 22 dyads 34 | -------------------------------------------------------------------------------- /mtv-lang/sketches/3.hs: -------------------------------------------------------------------------------- 1 | d = 3 2 | p1 = slow (d/4) $ mmho 4 $ pre2 "a" 3 | [ (0, m1 "freq" 0) 4 | , (1, m1 "freq" 2) 5 | , (2, m1 "freq" 4) 6 | , (3, m1 "on" 0) ] 7 | 8 | p2 = slow d $ mmho 4 $ pre2 "a" 9 | [ (0, m1 "freq" 0) 10 | , (1, m1 "freq" 1) 11 | , (2, m1 "freq" 2) 12 | , (3, m1 "freq" 1) ] 13 | 14 | scalePat = slow (d/2) $ mmh 2 $ pre2 "a" 15 | [ ( 0 , maj3 ) 16 | , ( 1 , aol3 ) 17 | ] 18 | 19 | halfDur f = slow (d/2) $ mmh 2 $ pre2 "a" 20 | [ (0, id) 21 | , (1, f) ] 22 | 23 | toScale = nBoop 24 | . meta (slow 4 $ halfDur $ ops [("freq",(*) (4/3))]) 25 | . ops [("freq", (*) 200 . \p -> 2**(p/12))] 26 | . scale 12 scalePat 27 | 28 | ch $ mfl [ 29 | ("1", toScale $ ops [("amp",const 0.1)] $ 30 | meta (slow 2 $ halfDur $ ops [("on",const 0)]) $ 31 | meta (halfDur rev) $ merge0 p1 p2) 32 | , ("2", toScale $ ops [("freq",((-) 12))] $ fast 2 $ 33 | meta ( meta (slow 3 $ halfDur $ early 2 . fast 3) $ 34 | halfDur $ ops [("on",const 0)] ) 35 | p1 ) 36 | , ("3", toScale $ ops [("freq",((-) 9))] $ fast 2 $ 37 | meta ( meta (slow 3 $ halfDur $ early 1 . fast 3) $ 38 | fast 2 $ halfDur $ ops [("on",const 0)] ) 39 | p1 ) 40 | ] 41 | -------------------------------------------------------------------------------- /learning/subset-constraints/earlier-fumblings,gadt-forget/simplest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, ExtendedDefaultRules, GADTs #-} 2 | 3 | data Aware a where 4 | Aware :: Int -> Aware a 5 | 6 | instance Show a => Show (Aware a) where 7 | show (Aware a) = "Aware " ++ show a 8 | 9 | xAdd :: Aware a -> Aware a -> Aware a 10 | xAdd (Aware a) (Aware b) = Aware $ a + b 11 | 12 | data Forgot where 13 | Forgot :: Aware a -> Forgot 14 | 15 | -- Of course the following function doesn't compile: 16 | -- How would we know whether a and b are the same type? 17 | forgetAdd :: Forgot -> Forgot -> Forgot 18 | forgetAdd (Forgot a) (Forgot b) = Forgot $ xAdd a b 19 | 20 | -- I would like to be able to use forgetAdd on `Forgot`s 21 | -- that were created from the same type of `Aware`, as in the following: 22 | main = do 23 | let list = [Forgot (Aware 1 :: Aware ()), Forgot (Aware 2 :: Aware (()))] 24 | list' = [Forgot (Aware 10 :: Aware ()), Forgot (Aware 20 :: Aware (()))] 25 | aSum = forgetAdd (head list) (head list') 26 | return () 27 | 28 | -- In Vivid I have a similar problem: I want to keep a collection of Synths, 29 | -- and a collection of VarLists (note that VarList is a class, not a type), 30 | -- and dispatch messages from the second collection to synths from the 31 | -- first collection. 32 | -------------------------------------------------------------------------------- /learning/awaiting-email/perc-envelope/retrigger-adsr,too-complicated.hs: -------------------------------------------------------------------------------- 1 | -- Awkward: You've got to "close" the ADSR envelope, and then wait for 2 | -- about a milisecond, before you can "open" it again, raising it above 3 | -- its sustaining level. See comments in `main` for details. 4 | 5 | -- Based on an example by Tom Murphy: 6 | -- https://we.lurk.org/hyperkitty/list/livecode@we.lurk.org/thread/ZQBFCHMBFIIM36KB7S77IDAPYJKMBRF2/ 7 | 8 | {-# LANGUAGE DataKinds, ExtendedDefaultRules, ViewPatterns #-} 9 | 10 | import Vivid 11 | 12 | foo :: SynthDef '["gate"] 13 | foo = sd (1 :: I "gate") $ do 14 | e <- adsrGen 1 1 0.5 1 15 | (Curve_Curve $ 0) 16 | (gate_ (V::V "gate")) 17 | s <- e ~* sinOsc (freq_ (500 ~+ (100 ~* e))) 18 | out 0 [s,s] 19 | 20 | test pauseLength = doScheduledIn 0.1 $ test' pauseLength 21 | test' pauseLength = do 22 | s <- synth foo () -- start the ADSR envelope, with a default gate=1 vlaue 23 | wait 2 24 | 25 | set s (0 :: I "gate") -- trigger the R phase 26 | -- The next "gate" signal will only retrigger the AD phase 27 | -- if the R phase is allowed to progress for at least a milisecond. 28 | -- (To see this, try running `test 0.001` vs. `test 0.0001`.) 29 | wait pauseLength 30 | 31 | set s (1 :: I "gate") -- retrigger the AD phase 32 | wait 2 33 | 34 | free s 35 | -------------------------------------------------------------------------------- /mtv-lang/docs/pattern-of-transformations.hs: -------------------------------------------------------------------------------- 1 | -- the "kick kick snare silence" pattern (ala "we will rock you") 2 | ks :: Museq String Note = 3 | -- `ks` has a duration of 1, because the `4` arguments to `fast` 4 | -- and `mmt1` cancel out. 5 | fast 4 $ 6 | mmt1 4 $ -- "mmt" = "mm" (make a Museq) + "t" (for trigger messages). 7 | -- It attaches a "trigger=1" message to each sample, 8 | -- which would be annoying to have to write by hand. 9 | map (_1 %~ RTime) $ -- convert the first thing in each pair from a number 10 | -- to an `RTime` 11 | [ (0, S_Km) 12 | , (1, S_Kt) 13 | , (2, S_Sp_t) ] 14 | 15 | hats = fast 4 $ mmt1 4 $ -- causes hats to have a duration of 1 16 | map (_1 %~ RTime) $ 17 | [ (0, S_Hl_et) 18 | , (2, S_Hl_et) 19 | , (3, S_Hl_et) ] 20 | 21 | transformations = mm 4 $ pre3 "a" 22 | [ (0, 1, id) -- from time 0 to time 1, this is the identity function 23 | , (1, 2, rev) -- from 1 to 2, it is the reversal function 24 | , (2, 3, early $ 1/2) -- etc. 25 | , (3, 3.5, fast 2) 26 | -- PITFALL: From 3.5 to 4, there is no transformation. 27 | -- The result is silence. 28 | ] 29 | 30 | chAll $ mfl 31 | [ ("hat", meta (fast (3/2) transformations) $ fast 2 hats ) 32 | , ("kick snare", meta (slow 4 transformations) ks) ] 33 | -------------------------------------------------------------------------------- /mtv-lang/sketches/1/3.hs: -------------------------------------------------------------------------------- 1 | dur0 = 6 2 | evs = [ (0, m1 "freq" 0) 3 | , (1/2, m1 "freq" 1) 4 | , (1, m1 "freq" 2) 5 | , (2, m1 "freq" 3) 6 | , (3, m1 "freq" 4) 7 | , (4, m1 "freq" 5) 8 | , (5, m1 "on" 0) ] 9 | pat = mmho dur0 $ pre2 "a" evs 10 | hatPat = mmt1 6 $ map (_2 %~ f) evs where 11 | f :: M.Map String Float -> Sample 12 | f = maybe S_Sl_b (const S_Hl_cg) . M.lookup "freq" 13 | kickSnarePat = mmt1 2 [ (0, S_Kd) 14 | , (1, S_Sp_t) ] 15 | 16 | scalePat = mmh (4*dur0) $ pre2 "a" 17 | [ ( 0 , maj3 ) 18 | , ( dur0 , dim ) 19 | , ( 2*dur0, aol3 ) 20 | , ( 3*dur0, aug ) ] 21 | 22 | revPat = mmh (2*dur0) $ pre2 "a" 23 | [ (0, id) 24 | , (dur0, rev) ] 25 | 26 | toScale = nBoop 27 | . ops [("freq", (*) 300 . \p -> 2**(p/12))] 28 | . scale 12 scalePat 29 | 30 | ch $ mfl [ 31 | ("1", toScale $ ops [("freq",((-) 12))] $ meta revPat pat) 32 | , ("2", toScale $ ops [("freq",(+ 2))] $ fast 2 $ meta revPat pat) 33 | , ("3", toScale $ ops [("freq",(+ 4))] $ fast 4 $ early 2 $ meta revPat pat) 34 | , ("4", stack [ fast 2 $ early (1/4) $ kickSnarePat 35 | , append hatPat (rev $ fast 4 hatPat) 36 | , fast 4 $ early (1/2) $ meta revPat $ hatPat 37 | , kickSnarePat ] ) 38 | ] 39 | -------------------------------------------------------------------------------- /Montevideo/Monome/Window/Record.hs: -------------------------------------------------------------------------------- 1 | -- | A single-button window to start and stop recording. 2 | 3 | {-# LANGUAGE RankNTypes 4 | , ScopedTypeVariables 5 | #-} 6 | 7 | module Montevideo.Monome.Window.Record ( 8 | recordWindow 9 | ) where 10 | 11 | import Prelude hiding (pred) 12 | import Control.Lens hiding (Choice) 13 | import Vivid (getTime) 14 | 15 | import Montevideo.Dispatch.Types 16 | import Montevideo.Dispatch.Recording 17 | import Montevideo.Monome.Types.Most 18 | 19 | 20 | recordWindow :: Window app 21 | recordWindow = Window 22 | { windowLabel = RecordWindow 23 | , windowContains = (==) (0,0) 24 | , windowInitLeds = \_ _ -> Right [] 25 | , windowHandler = handler } 26 | 27 | handler :: forall app. 28 | St app -> (MonomeId, ((X,Y), Switch)) 29 | -> IO (Either String (St app)) 30 | handler st (_, (_, False)) = 31 | return $ Right st 32 | handler st (_, (_, True)) = 33 | case _stIsRecording st of 34 | False -> do -- start recording 35 | nr <- newRecording 36 | return $ Right $ st 37 | & stIsRecording .~ True 38 | & stRecordings %~ (nr :) 39 | True -> do -- stop recording 40 | now <- unTimestamp <$> getTime 41 | return $ Right $ st 42 | & stIsRecording .~ False 43 | & stRecordings . _head . recordingEnd .~ Just now 44 | -------------------------------------------------------------------------------- /Montevideo/Synth/Distortion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, ExtendedDefaultRules #-} 2 | 3 | module Montevideo.Synth.Distortion where 4 | 5 | import Vivid 6 | 7 | 8 | busNum = 23 9 | voiceLevel = 0.05 -- Levels near 1 seem to distort. 10 | dist = 30 11 | volume = 0.3 / voiceLevel 12 | 13 | effect :: SynthDef '["in", "out"] 14 | effect = sd (23 ::I "in", 0 ::I "out") $ do 15 | i <- aIn (bus_ (V::V "in")) 16 | -- s <- clip2 i 1 17 | s <- tanh' (dist ~* i) ~* volume ~/ dist 18 | out' [s,s] 19 | 20 | origin :: SynthDef '["out", "freq"] 21 | origin = sd ( 0 :: I "out" 22 | , 400 :: I "freq") $ do 23 | s <- voiceLevel ~* sinOsc (freq_ (V::V "freq")) 24 | out' [s,s] 25 | 26 | main :: IO () 27 | main = do 28 | fx <- synth effect (toI busNum :: I "in") 29 | 30 | -- When we're not feeding one synth into another one, we usually don't care 31 | -- what order synths get processed. When we do, input comes before output: 32 | in1 <- synthBefore fx origin ( toI busNum :: I "out" 33 | , 1000 / 3 :: I "freq" ) 34 | wait 1 35 | in2 <- synthBefore fx origin ( toI busNum :: I "out" 36 | , 1250 / 3 :: I "freq" ) 37 | in3 <- synthBefore fx origin ( toI busNum :: I "out" 38 | , 1500 / 3 :: I "freq" ) 39 | wait 2 40 | free fx 41 | -- mapM_ free [in1,in2,in3] 42 | -------------------------------------------------------------------------------- /research/bugs/slow-load.hs: -------------------------------------------------------------------------------- 1 | -- Takes 30 secodns to load, 2 | -- unless I use the edit described at the end. 3 | 4 | p1 = let 5 | a = mmho 3 $ pre2 "a" [(0, m1 "freq" 0) 6 | ,(1, m1 "freq" 2)] 7 | b = mmho 2 $ pre2 "b" [(0, m1 "on" 0) 8 | ,(1, m1 "freq" 4)] 9 | in stack' a b & dur .~ 4 10 | 11 | p2 :: Int -> Museq String ScParams = let 12 | in \n -> ( mmho (fromIntegral n) $ pre2 "a" $ 13 | zip (map RTime [0..]) $ 14 | map (M.singleton "freq" . (+) 0) $ 15 | map fromIntegral [0..n-1] ) 16 | 17 | go = let 18 | toHz = ops [("freq", (*) 200 . \p -> 2**(p/12))] 19 | rs = slow 12 $ mmh 3 $ pre2 "a" $ [ (0, (0, phr3)) 20 | , (1, (4, lyd)) 21 | , (2, (1, lyd7)) ] 22 | in nBoop . toHz . rootScale 12 rs where 23 | 24 | wave = ( slow 4 $ mmh 2 $ pre2 "a" $ zip (map RTime [0..]) $ 25 | [id, early $ 1] ) 26 | 27 | chAll $ mfl [ 28 | ("1", go $ fast 2 $ merge0fa (slow 4 $ p2 4) $ merge0fa (p2 4) p1) 29 | , ("2", go $ fast 4 $ meta wave $ 30 | merge0fa (slow 8 $ p2 4) $ merge0fa (p2 3) $ 31 | cat [p1, p2 3, dense 2 p1] ) 32 | -- if I delete the "p2 3" from this last line, 33 | -- it takes effect immediately. (Using two instances of append 34 | -- instead of one cat has no effect.) 35 | ] 36 | -------------------------------------------------------------------------------- /learning/_mostly-internalized/multi-synth,targeted-messages.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, ExtendedDefaultRules, GADTs #-} 2 | 3 | import Vivid 4 | import Data.List as L 5 | import Data.Map as M 6 | import GHC.TypeLits 7 | 8 | 9 | -- | = messages, which know where they're going 10 | 11 | data Msg where 12 | ParamMsg :: (VarList usedParams, Subset (InnerVars usedParams) allParams) 13 | => Synth allParams -> usedParams -> Msg 14 | FreeMsg :: Synth params -> Msg 15 | 16 | send :: VividAction m => Msg -> m () 17 | send (ParamMsg synth params) = set synth params 18 | send (FreeMsg synth) = free synth 19 | 20 | 21 | -- | = main 22 | 23 | main = do 24 | b <- synth bop () 25 | b' <- synth boop () 26 | let m = ParamMsg b (toI 500 :: I "freq") 27 | m' = ParamMsg b' (toI 600 :: I "freq", toI 0.02 :: I "amp") 28 | fm = FreeMsg b 29 | fm' = FreeMsg b' 30 | messages = [m,m',fm,fm'] -- checking whether the compiler minds 31 | mapM_ send [m,m'] 32 | wait 1 33 | mapM_ send [fm,fm'] 34 | 35 | 36 | -- | = synths 37 | 38 | bop :: SynthDef '["freq"] 39 | bop = sd ( 0 :: I "freq" 40 | ) $ do 41 | s1 <- 0.01 ~* sinOsc (freq_ (V::V "freq")) 42 | out 0 [s1, s1] 43 | 44 | boop :: SynthDef '["freq","amp"] 45 | boop = sd ( 0 :: I "freq" 46 | , 0.01 :: I "amp" 47 | ) $ do 48 | s1 <- (V::V "amp") ~* sinOsc (freq_ (V::V "freq")) 49 | out 0 [s1, s1] 50 | -------------------------------------------------------------------------------- /mtv-lang/sketches/6/3.hs: -------------------------------------------------------------------------------- 1 | p1 = stack2 a b & dur .~ 4 where 2 | a = mmho 3 $ pre2 "a" [(0, m1 "freq" 0) 3 | ,(1, m1 "freq" 2)] 4 | b = mmho 2 $ pre2 "b" [(0, m1 "on" 0) 5 | ,(1, m1 "freq" 4)] 6 | 7 | run :: Int -> Museq String ScParams = \n -> 8 | mmho (fromIntegral n) $ pre2 "a" $ 9 | zip (map RTime [0..]) $ 10 | map (M.singleton "freq" . (+) 0) $ 11 | map fromIntegral [0..n-1] 12 | 13 | chord :: [Float] -> Museq String ScParams = 14 | mmho 1 . pre2 "a" . 15 | map (\f -> (0,M.singleton "freq" f)) 16 | 17 | ampSeq :: Float -> Museq String ScParams = \f -> 18 | mmho 1 [("a",0,m1 "amp" f)] 19 | 20 | go = nBoop . toHz . rootScale 12 rs where 21 | toHz = ops [("freq", (*) 200 . \p -> 2**(p/12))] 22 | rs = slow 12 $ mmh 3 $ pre2 "a" $ [ (0, (0, phr3)) 23 | , (1, (4, lyd)) 24 | , (2, (1, lyd7)) 25 | ] 26 | 27 | wave = slow 4 $ mmh 2 $ pre2 "a" $ zip (map RTime [0..]) $ 28 | [id, early $ 1] 29 | 30 | ch $ mfl [ 31 | ("1", go $ fast 2 $ merge0fa (slow 4 $ run 4) $ merge0fa (run 4) p1) 32 | , ("2", go $ fast 4 $ meta wave $ 33 | merge0fa (slow 8 $ run 4) $ merge0fa (run 3) $ 34 | cat [p1, dense 2 p1]) 35 | , ("3", go $ merge0fa (merge0 (ampSeq 0.001) $ chord [10,12]) $ 36 | merge0fa (slow 4 $ run 4) $ merge0fa (run 4) p1) 37 | ] 38 | -------------------------------------------------------------------------------- /_unused/package.yaml: -------------------------------------------------------------------------------- 1 | name: vivid-dispatch 2 | version: 0.1.0.0 3 | github: "githubuser/vivid-dispatch" 4 | license: BSD3 5 | author: "Author name here" 6 | maintainer: "example@example.com" 7 | copyright: "2019 Author name here" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | 25 | library: 26 | source-dirs: src 27 | 28 | executables: 29 | vivid-dispatch-exe: 30 | main: Main.hs 31 | source-dirs: app 32 | ghc-options: 33 | - -threaded 34 | - -rtsopts 35 | - -with-rtsopts=-N 36 | dependencies: 37 | - vivid-dispatch 38 | 39 | tests: 40 | vivid-dispatch-test: 41 | main: Spec.hs 42 | source-dirs: test 43 | ghc-options: 44 | - -threaded 45 | - -rtsopts 46 | - -with-rtsopts=-N 47 | dependencies: 48 | - vivid-dispatch 49 | -------------------------------------------------------------------------------- /mtv-lang/sketches/2.hs: -------------------------------------------------------------------------------- 1 | seq d e f = [ (0, d) 2 | , (1, e) 3 | , (2, d) 4 | , (2.5, e) 5 | , (3, f) ] 6 | patPitch = mmho 4 $ pre2 "a" $ 7 | map (_2 %~ m1 "freq") $ seq 0 1 2 8 | patKs = mmt1 4 $ seq S_Sm_peb S_Km S_Km 9 | patHat = mmt1 4 $ seq S_Hl_dc S_Hl_tfc S_Hl_tfc 10 | 11 | modPat f g = mmh 4 $ pre2 "a" 12 | [ (0, f . g) 13 | , (1, id) 14 | , (2, f) 15 | , (3, g) ] 16 | 17 | scalePat = mmh 2 $ pre2 "a" 18 | [ ( 0 , maj3 ) 19 | , ( 1 , aol3 ) 20 | ] 21 | 22 | toScale = nBoop 23 | . ops [("freq", (*) 200 . \p -> 2**(p/12))] 24 | . scale 12 scalePat 25 | 26 | ch $ mfl 27 | [ ("1", meta ( slow 4 $ early 2 $ 28 | modPat (fast 2) (late 1)) $ 29 | append patKs $ dense 2 patKs) 30 | , ("2", meta ( slow 8 $ 31 | modPat (early $ 1/4) (early $ 1/2)) $ 32 | meta ( slow 4 $ 33 | modPat (fast 4 . early 1) (fast 2)) 34 | patHat) 35 | , ("4", toScale $ 36 | stack2 patPitch $ stack 37 | [ ( merge0 (mm1 $ m1 "freq" 6) $ fast 2 $ rev patPitch ) 38 | , ( merge0 (mm1 $ m1 "freq" 12) $ fast 6 $ rev patPitch ) ] ) 39 | -- , ("4.1", toScale $ stack -- this takes advantage of a bug 40 | -- [ patPitch 41 | -- , merge0 (mm1 $ m1 "freq" 6) $ fast 2 $ rev patPitch 42 | -- , merge0 (mm1 $ m1 "freq" 12) $ fast 6 $ rev patPitch ] ) 43 | ] 44 | -------------------------------------------------------------------------------- /mtv-lang/sketches/5.hs: -------------------------------------------------------------------------------- 1 | p0 = mmho 4 $ [ ("a",0,m1 "freq" 0) 2 | , ("b",0,m1 "freq" 2) 3 | , ("c",0,m1 "freq" 4) 4 | , ("d",0,m1 "freq" 6) 5 | ] 6 | 7 | p1 = mmho 4 $ pre2 "a" 8 | [ (0, m1 "freq" 0) 9 | , (1+2/3, m1 "freq" 2) 10 | , (2, m1 "freq" 4) 11 | , (3, m1 "on" 0) ] 12 | 13 | p2 = mmho 4 $ pre2 "a" 14 | [ (0, m1 "freq" 0) 15 | , (1, m1 "freq" 3) 16 | , (2+2/3, m1 "freq" 6) 17 | , (3, m1 "on" 0) ] 18 | 19 | t1 = mmh 6 $ pre2 "a" 20 | [ (0, id) 21 | , (1,fast 2) 22 | , (2,id) 23 | , (3, early 1) 24 | , (4, id) 25 | , (5, fast 2 . early 1) ] 26 | 27 | fe = fast 2 . early 1 28 | 29 | r1 = mmh 5 $ pre2 "a" 30 | [ ( 0, 0 ) 31 | , ( 3, 3 ) ] 32 | 33 | s1 = mmh 3 $ pre2 "a" 34 | [ ( 0 , dor2 ) 35 | , ( 1 , loc6 ) 36 | , ( 2 , [0,4,2,4,7,11] ) ] 37 | 38 | toScale = nBoop . 39 | ops [("freq", (*) 200 . \p -> 2**(p/12))] . 40 | scale 12 (slow 2 s1) . root (slow 4 r1) . 41 | merge0 p0 42 | 43 | --ch $ mfl [ 44 | -- ("1", toScale $ ops [("freq",(+) 2)] $ 45 | -- meta (fast 2 t1) $ cat [sparse 2 p1, fast 2 p2] ) 46 | -- , ("2", toScale $ ops [("freq",(-) 8)] $ 47 | -- meta t1 $ cat [dense 2 p1, p2] ) 48 | -- ] 49 | 50 | ch $ mfl [ 51 | ("1", toScale $ cat [sparse 2 $ fe p1, fe p2] ) 52 | , ("2", toScale $ ops [("freq",(-) 7)] $ cat [dense 2 $ fe p1, fe p2] ) 53 | ] 54 | -------------------------------------------------------------------------------- /Montevideo/Random/MentionsSig.hs: -------------------------------------------------------------------------------- 1 | module Montevideo.Random.MentionsSig where 2 | 3 | import Random.Types 4 | 5 | 6 | class MentionsSig a where 7 | mentionsSig :: AbSigName -> a -> Bool 8 | 9 | allMentions :: MentionsSig a => RandConstraints -> a -> [AbSigName] 10 | allMentions cs a = let names = take (maxSignals cs) theAbSigNames 11 | in filter (\y -> mentionsSig y a) names 12 | 13 | instance MentionsSig AbSig where 14 | mentionsSig name (AbSigFormula f) = mentionsSig name f 15 | mentionsSig name (AbSigGen g) = mentionsSig name g 16 | mentionsSig name (AbSig n) = mentionsSig name n 17 | mentionsSig name (AbV p) = mentionsSig name p 18 | mentionsSig _ (AbConst _) = False 19 | 20 | instance MentionsSig AbFormula where 21 | mentionsSig name (AbProd x y) = mentionsSig name x || mentionsSig name y 22 | mentionsSig name (AbSum x y) = mentionsSig name x || mentionsSig name y 23 | 24 | instance MentionsSig AbGen where 25 | mentionsSig name (AbSin x) = mentionsSig name x 26 | mentionsSig name (AbSaw x) = mentionsSig name x 27 | 28 | instance MentionsSig AbSinMsg where 29 | mentionsSig name (AbSinMsg x y) = mentionsSig name x || mentionsSig name y 30 | 31 | instance MentionsSig AbSawMsg where 32 | mentionsSig name (AbSawMsg x) = mentionsSig name x 33 | 34 | instance MentionsSig AbSigName where 35 | mentionsSig = (==) 36 | 37 | instance MentionsSig AbParam where 38 | mentionsSig _ _ = False 39 | -------------------------------------------------------------------------------- /learning/vivid/persistent-buffer.hs: -------------------------------------------------------------------------------- 1 | -- | This illustrates how to re-trigger a buffer. 2 | -- (Another, perhaps more standard, idiom is to free the synth 3 | -- after playing the buffer.) 4 | 5 | {-# LANGUAGE DataKinds, ExtendedDefaultRules #-} 6 | 7 | import Vivid 8 | 9 | 10 | bufferPlayer :: SynthDef '["buf", "trigger"] 11 | bufferPlayer = sd ( 0 :: I "buf" 12 | , 1 :: I "trigger") $ do 13 | let buf = V::V "buf" 14 | s <- playBuf 15 | ( trigger_ (V::V"trigger") 16 | , buf_ buf 17 | , rate_ $ bufRateScale buf ~* (1::Float) 18 | , doneAction_ (0::Int) -- with this, `s` persists after it 19 | -- finishes playing. (With 2 instead of 0, it would disappear.) 20 | ) 21 | out (0::Int) [s,s] 22 | 23 | main :: IO () 24 | main = do 25 | buf <- newBufferFromFile $ "/home/jeff/code/Tidal/Dirt-Samples/latibro/000_Sound2.wav" 26 | s <- synth bufferPlayer ( b2i buf :: I "buf") 27 | set s (0 :: I "trigger") -- get ready to be retriggered. 28 | wait (1/2::Float) -- without this wait, the first bufferPlayer 29 | -- will be interrupted by the second before there's time to hear it. 30 | set s (1 :: I "trigger") -- whenever "trigger" goes from 0 to greater 31 | -- than 0, the buffer is replayed. (But some amount of time must 32 | -- be allowed to elapse between them.) 33 | wait (1/2::Float) -- without this wait, the synth would disappear 34 | -- before the second bufferPlayer was heard. 35 | free s 36 | -------------------------------------------------------------------------------- /Montevideo/Monome/Network/ListenAndLogOsc.hs: -------------------------------------------------------------------------------- 1 | -- import Montevideo.Monome.Network.ListenAndLogOsc 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Montevideo.Monome.Network.ListenAndLogOsc where 6 | 7 | import Control.Concurrent (forkIO) 8 | import Control.Concurrent.MVar 9 | import Control.Monad (forever) 10 | 11 | import qualified Network.Socket as NS 12 | import Vivid.OSC 13 | 14 | import Montevideo.Monome.Network.Util 15 | 16 | 17 | -- ^ Tries to read as OSC, then prints (as OSC or otherwise). 18 | -- Also accumulates a list of OSC messages. 19 | -- Useful when running `requestDeviceList` or `requestDeviceInfo` 20 | -- from another repl. 21 | listenAndLogOsc 22 | :: Int -- ^ the port to listen to 23 | -> IO [OSC] 24 | listenAndLogOsc port = do 25 | 26 | skt :: NS.Socket <- receivesAt "127.0.0.1" port 27 | acc <- newMVar [] 28 | let loop :: IO [OSC] 29 | loop = getChar >>= 30 | \case 'q' -> close skt >> readMVar acc >>= return 31 | _ -> loop 32 | logAndShow :: OSC -> IO () 33 | logAndShow osc = do accNow <- takeMVar acc 34 | putMVar acc $ osc : accNow 35 | putStrLn . show $ osc 36 | logAndShowEitherOsc :: Either String OSC -> IO () 37 | logAndShowEitherOsc (Left s) = putStrLn $ show s 38 | logAndShowEitherOsc (Right osc) = logAndShow osc 39 | _ <- forkIO $ forever $ 40 | decodeOSC <$> recv skt 4096 >>= logAndShowEitherOsc 41 | loop 42 | -------------------------------------------------------------------------------- /Montevideo/Random/Types/AbstractSignal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Montevideo.Random.Types.AbstractSignal where 4 | 5 | import qualified Data.Map as M 6 | 7 | 8 | type AbSynth = M.Map AbSigName AbSig 9 | 10 | data AbSig = AbSigFormula AbFormula 11 | | AbSigGen AbGen 12 | | AbSig AbSigName -- ^ a previously constructed AbSig 13 | | AbV AbParam 14 | | AbConst Float 15 | deriving (Show, Eq, Ord) 16 | 17 | data AbFormula = AbProd AbSig AbSig 18 | | AbSum AbSig AbSig 19 | deriving (Show, Eq, Ord) 20 | 21 | data AbGen = AbSin AbSinMsg 22 | | AbSaw AbSawMsg 23 | deriving (Show, Eq, Ord) 24 | 25 | data AbSinMsg = AbSinMsg { abSinFreq :: AbSig, abSinPhase :: AbSig } 26 | deriving (Show, Eq, Ord) 27 | 28 | data AbSawMsg = AbSawMsg { abSawFreq :: AbSig } 29 | deriving (Show, Eq, Ord) 30 | 31 | -- | Not every abstract signal has a name. 32 | -- Those that do can be referred to by later signals. 33 | data AbSigName = AS1 | AS2 | AS3 | AS4 | AS5 | AS6 | AS7 | AS8 34 | deriving (Show, Eq, Ord) 35 | 36 | theAbSigNames :: [AbSigName] 37 | theAbSigNames = [AS1, AS2, AS3, AS4, AS5, AS6, AS7, AS8] 38 | 39 | -- | = Every random synth has up to eight parameters. 40 | data AbParam = AP1 | AP2 | AP3 | AP4 | AP5 | AP6 | AP7 | AP8 41 | deriving (Show, Eq, Ord) 42 | 43 | type TheAbParams = '["AP1", "AP2", "AP3", "AP4", "AP5", "AP6", "AP7", "AP8"] 44 | 45 | theAbParams :: [AbParam] 46 | theAbParams = [AP1, AP2, AP3, AP4, AP5, AP6, AP7, AP8] 47 | -------------------------------------------------------------------------------- /Montevideo/Dispatch-Unused/Join.hs: -------------------------------------------------------------------------------- 1 | mergeIO :: forall a. Show a => 2 | (a -> a -> a) -> Museq a -> Museq a -> IO (Museq a) 3 | mergeIO op x y = do 4 | let tbr = timeForBoth_toAppearToFinish x y 5 | xs, ys, xps, yps :: [((RTime,RTime),a)] 6 | xs = concatMap V.toList $ unsafeExplicitReps tbr x 7 | ys = concatMap V.toList $ unsafeExplicitReps tbr y 8 | bs = boundaries $ map fst $ xs ++ ys :: [RTime] 9 | xps = partitionAndGroupEventsAtBoundaries bs xs 10 | yps = partitionAndGroupEventsAtBoundaries bs ys 11 | putStrLn $ "\ntbr: " ++ show tbr 12 | ++ "\nbs: " ++ show bs 13 | ++ "\nxs: " ++ show xs 14 | ++ "\nys: " ++ show ys 15 | ++ "\nxps: " ++ show xps 16 | ++ "\nyps: " ++ show yps 17 | evs <- alignAndMergeIO op xps yps 18 | return $ Museq { _dur = _dur x -- arbitrary 19 | , _sup = tbr 20 | , _vec = V.fromList evs} 21 | 22 | alignAndMergeIO,mergeEventsIO :: forall a. 23 | (a -> a -> a) -> [Ev a] -> [Ev a] -> IO [Ev a] 24 | alignAndMergeIO _ [] _ = return [] 25 | alignAndMergeIO _ _ [] = return [] 26 | alignAndMergeIO op aEvs@((arcA,_):aEvsRest) bEvs@((arcB,_):bEvsRest) 27 | | arcA < arcB = alignAndMergeIO op aEvsRest bEvs 28 | | arcB < arcA = alignAndMergeIO op aEvs bEvsRest 29 | | arcA == arcB = mergeEventsIO op aEvs bEvs 30 | mergeEventsIO op ((arc,a):aEvs) bEvs = do 31 | let bEvsMatch = takeWhile ((== arc) . fst) bEvs 32 | merged = over _2 (op a) <$> bEvsMatch 33 | x <- alignAndMergeIO op aEvs bEvs 34 | return $ merged ++ x 35 | -------------------------------------------------------------------------------- /learning/vivid/param-as-arg.hs: -------------------------------------------------------------------------------- 1 | -- Main idea: set' takes a param(string) and a number, 2 | -- rather than a value of type `I s`. Thus 3 | -- it can send a value to a target param selected by the computer at runtime, 4 | -- rather than requiring the programmer to choose that param at compile time. 5 | 6 | {-# LANGUAGE DataKinds, ExtendedDefaultRules #-} 7 | 8 | import Vivid 9 | import Data.List as L 10 | import Data.Map as M 11 | import GHC.TypeLits 12 | 13 | 14 | type MyParams = '["freq", "amp", "width", "width-vib"] 15 | 16 | set' :: (Subset MyParams sdArgs 17 | , Real n, VividAction m) 18 | => String -> Synth sdArgs -> n -> m () 19 | set' "freq" s n = set s (toI n :: I "freq") 20 | set' "amp" s n = set s (toI n :: I "amp" ) 21 | 22 | boop :: SynthDef MyParams 23 | boop = sd ( 0 :: I "freq" 24 | , 0.01 :: I "amp" 25 | -- the next two params do nothing, but are needed so that boop has 26 | -- the same interface as boop', so that both can be used with set' 27 | , 0 :: I "width" 28 | , 0 :: I "width-vib" 29 | ) $ do 30 | s1 <- (V::V "amp") ~* sinOsc (freq_ (V::V "freq")) 31 | out 0 [s1, s1] 32 | 33 | boop' :: SynthDef MyParams 34 | boop' = sd ( 0 :: I "freq" 35 | , 0.1 :: I "amp" 36 | , 50 :: I "width" 37 | , 51 :: I "width-vib" 38 | ) $ do 39 | s0 <- sinOsc (freq_ (V::V "width-vib")) 40 | s1 <- sinOsc (freq_ (V::V "width")) ~+ s0 41 | s2 <- (V::V "amp") ~* pulse (freq_ (V::V "freq"), width_ s1) 42 | out 0 [s2, s2] 43 | -------------------------------------------------------------------------------- /Montevideo/Test/Recording.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | 3 | module Montevideo.Test.Recording where 4 | 5 | import Test.HUnit 6 | 7 | import qualified Data.Map as M 8 | import qualified Data.Vector as V 9 | 10 | import Montevideo.Dispatch.Recording 11 | import Montevideo.Dispatch.Types.Many 12 | import Montevideo.Dispatch.Types.Time 13 | import Montevideo.Synth 14 | import Montevideo.Synth.Msg 15 | 16 | 17 | tests :: Test 18 | tests = TestList [ 19 | TestLabel "test_monomeRecording_toMuseq" test_monomeRecording_toMuseq 20 | ] 21 | 22 | test_monomeRecording_toMuseq :: Test 23 | test_monomeRecording_toMuseq = TestCase $ do 24 | let r = Recording 25 | { _recordingStart = 100 26 | , _recordingEnd = Just 200 27 | , _recordingData = map (uncurry Observation) 28 | [ ( Time 150, 29 | ScAction_Free { _actionSynthDefEnum = Zot 30 | , _actionSynthName = "a" } ) 31 | , ( Time 100, 32 | ScAction_New { _actionSynthDefEnum = Zot 33 | , _actionSynthName = "a" 34 | , _actionScParams = M.singleton "freq" 333 } ) 35 | ] } 36 | 37 | assertBool "" $ monomeRecording_toMuseq r == 38 | ( Right $ Museq 39 | { _dur = 1 40 | , _sup = 1 41 | , _vec = V.fromList 42 | [ Event { _evLabel = "a" 43 | , _evArc = (0, 1/2) 44 | , _evData = M.singleton "freq" 333 45 | } ] } ) 46 | -------------------------------------------------------------------------------- /Montevideo/Dispatch-Unused/Parse/Distrib.test.hs: -------------------------------------------------------------------------------- 1 | :set prompt "> " 2 | import Text.Megaparsec (parse) 3 | import Control.Concurrent (forkIO) 4 | import Control.Concurrent.MVar (readMVar) 5 | import Data.Either 6 | import Data.Map (size, keys) 7 | 8 | 9 | reg <- emptySynthRegister 10 | f s = forkIO $ mapM_ act' $ fromRight [] $ parse (msgs reg) "" s 11 | 12 | -- | = comma separation works 13 | size <$> readMVar (boops reg) -- should be 0 14 | (Right as) = parse (msgs reg) "" "new boop 3, free boop 3" 15 | act' $ as !! 0 16 | size <$> readMVar (boops reg) -- should be 1 17 | act' $ as !! 1 18 | size <$> readMVar (boops reg) -- should be 0 19 | 20 | -- | = new works 21 | (Right as) = parse (msgs reg) "" "new boop 1" 22 | mapM_ act' as 23 | size <$> readMVar (boops reg) -- should be 1 24 | 25 | -- | = send works 26 | (Right as) = parse (msgs reg) "" "send boop 1 freq 444.0 amp 0.2" 27 | mapM_ act' as 28 | r <- readMVar (boops reg) 29 | size r 30 | 31 | -- | = free works 32 | (Right as) = parse (msgs reg) "" "free boop 1" 33 | mapM_ act' as 34 | r <- readMVar (boops reg) 35 | size r -- at this point it should have size 0 36 | 37 | -- | = it all works! 38 | reg <- emptySynthRegister 39 | mapM_ act' $ fromRight [] $ parse (msgs reg) "" "new boop 2, send boop 2 freq 444.0 amp 0.1, wait 1.0, free boop 2" 40 | 41 | -- if this gives [], it didn't work 42 | aTest s = fromRight [] $ parse (msgs reg) "" s 43 | 44 | -- playing with sqfm 45 | f "new sqfm margaret, send sqfm margaret freq 555.0 amp 0.2 width 0.1 width-vib-freq 22.0 width-vib-amp 0.1, wait 1.0, free sqfm margaret" 46 | -------------------------------------------------------------------------------- /interactive/unload-vivid.hs: -------------------------------------------------------------------------------- 1 | -- :m -Vivid.SCServer -- this defines freeAll 2 | 3 | :m -Vivid.Actions.Class 4 | :m -Vivid.Actions.IO 5 | :m -Vivid.Actions.NRT 6 | :m -Vivid.Actions.Scheduled 7 | :m -Vivid.ByteBeat 8 | :m -Vivid.Envelopes 9 | :m -Vivid.NoPlugins 10 | :m -Vivid.OSC.Bundles 11 | :m -Vivid.Randomness 12 | :m -Vivid.SCServer.Connection 13 | :m -Vivid.SCServer.State 14 | :m -Vivid.SCServer.Types 15 | :m -Vivid.SynthDef 16 | :m -Vivid.SynthDef.FromUA 17 | :m -Vivid.SynthDef.ToSig 18 | :m -Vivid.SynthDef.Types 19 | :m -Vivid.SynthDef.TypesafeArgs 20 | :m -Vivid.UGens 21 | :m -Vivid.UGens.Algebraic 22 | :m -Vivid.UGens.Analysis 23 | :m -Vivid.UGens.Args 24 | :m -Vivid.UGens.Buffer 25 | :m -Vivid.UGens.Conversion 26 | :m -Vivid.UGens.Convolution 27 | :m -Vivid.UGens.Delays 28 | :m -Vivid.UGens.Demand 29 | :m -Vivid.UGens.Dynamics 30 | :m -Vivid.UGens.Envelopes 31 | :m -Vivid.UGens.Examples 32 | :m -Vivid.UGens.FFT 33 | :m -Vivid.UGens.Filters 34 | :m -Vivid.UGens.Filters.BEQSuite 35 | :m -Vivid.UGens.Filters.Linear 36 | :m -Vivid.UGens.Filters.Nonlinear 37 | :m -Vivid.UGens.Filters.Pitch 38 | :m -Vivid.UGens.Generators.Chaotic 39 | :m -Vivid.UGens.Generators.Deterministic 40 | :m -Vivid.UGens.Generators.Granular 41 | :m -Vivid.UGens.Generators.SingleValue 42 | :m -Vivid.UGens.Generators.Stochastic 43 | :m -Vivid.UGens.InOut 44 | :m -Vivid.UGens.Info 45 | :m -Vivid.UGens.Maths 46 | :m -Vivid.UGens.Multichannel 47 | :m -Vivid.UGens.Random 48 | :m -Vivid.UGens.Reverbs 49 | :m -Vivid.UGens.SynthControl 50 | :m -Vivid.UGens.Triggers 51 | :m -Vivid.UGens.Undocumented 52 | :m -Vivid.UGens.UserInteraction 53 | :m -Vivid.UGens.UserInteraction 54 | -------------------------------------------------------------------------------- /mtv-lang/sketches/2/2.hs: -------------------------------------------------------------------------------- 1 | seq d e f = [ (0, d) 2 | , (1, e) 3 | , (2, d) 4 | , (2.5, f) ] 5 | patPitch = mmho 3 $ pre2 "a" $ 6 | map (_2 %~ m1 "freq") $ seq 0 1 2 7 | patJump = mmho 3 $ pre2 "b" $ 8 | map (_2 %~ m1 "freq") $ seq 0 6 12 9 | patKs = mmt1 3 $ seq S_Sm_peb S_Km S_Km 10 | patHat = mmt1 3 $ seq S_Hl_dc S_Hl_tfc S_Hl_tfc 11 | 12 | modPat f g = mmh 3 $ pre2 "c" 13 | [ (0, f . g) 14 | , (1, id) 15 | , (2, f) 16 | , (2.5, g) ] 17 | 18 | scalePat = slow 3 $ mmh 8 $ pre2 "d" 19 | [ ( 0 , (0, maj3) ) 20 | , ( 3 , (-1, loc7) ) 21 | , ( 4 , (2, aol5) ) 22 | , ( 7 , (-1, loc7) ) 23 | ] 24 | 25 | toScale = nBoop 26 | . ops [("freq", (*) 200 . \p -> 2**(p/12))] 27 | . rootScale 12 scalePat 28 | 29 | ch $ mfl 30 | [ ("1", meta ( slow 4 $ early 2 $ 31 | modPat (fast 2) (late 1)) $ 32 | append patKs $ dense 2 patKs) 33 | , ("2", meta ( slow 8 $ 34 | modPat (early $ 1/4) (early $ 1/2)) $ 35 | meta ( slow 4 $ 36 | modPat (fast 4 . early 1) (fast 2)) 37 | patHat) 38 | , ("4.1", toScale $ stack $ -- this takes advantage of a bug 39 | let p = append patPitch $ rev patPitch in 40 | [ merge0 (fast 2 patPitch) $ 41 | meta (mmh 4 $ pre2 "e" $ seq (fast 2) (early 1) id) $ 42 | slow 2 $ p 43 | , merge0 (mm1 $ m1 "freq" 4) $ fast 2 $ 44 | merge0 (fast 2 patJump) $ rev p 45 | , merge0 (mm1 $ m1 "freq" 9) $ fast 2 $ 46 | rev p 47 | ] ) 48 | ] 49 | -------------------------------------------------------------------------------- /mtv-lang/sketches/2/1.hs: -------------------------------------------------------------------------------- 1 | seq d e f = [ (0, d) 2 | , (1, e) 3 | , (2, d) 4 | , (2.5, e) 5 | , (3, f) ] 6 | patPitch = mmho 4 $ pre2 "a" $ 7 | map (_2 %~ m1 "freq") $ seq 0 1 2 8 | patJump = mmho 4 $ pre2 "a" $ 9 | map (_2 %~ m1 "freq") $ seq 0 6 12 10 | patKs = mmt1 4 $ seq S_Sm_peb S_Km S_Km 11 | patHat = mmt1 4 $ seq S_Hl_dc S_Hl_tfc S_Hl_tfc 12 | 13 | modPat f g = mmh 4 $ pre2 "b" 14 | [ (0, f . g) 15 | , (1, id) 16 | , (2, f) 17 | , (3, g) ] 18 | 19 | scalePat = slow 2 $ mmh 8 $ pre2 "c" 20 | [ ( 0 , (0, maj3) ) 21 | , ( 3 , (-1, loc7) ) 22 | , ( 4 , (2, aol5) ) 23 | , ( 7 , (-1, loc7) ) 24 | ] 25 | 26 | toScale = nBoop 27 | . ops [("freq", (*) 200 . \p -> 2**(p/12))] 28 | . rootScale 12 scalePat 29 | 30 | ch $ mfl 31 | [ ("1", meta ( slow 4 $ early 2 $ 32 | modPat (fast 2) (late 1)) $ 33 | append patKs $ dense 2 patKs) 34 | , ("2", meta ( slow 8 $ 35 | modPat (early $ 1/4) (early $ 1/2)) $ 36 | meta ( slow 4 $ 37 | modPat (fast 4 . early 1) (fast 2)) 38 | patHat) 39 | , ("4.1", toScale $ stack $ -- this takes advantage of a bug 40 | let p = append patPitch $ rev patPitch in 41 | [ merge0 (fast 2 patPitch) $ 42 | meta (mmh 4 $ pre2 "d" $ seq (fast 2) (early 1) id) $ 43 | slow 2 $ p 44 | , merge0 (mm1 $ m1 "freq" 4) $ fast 2 $ 45 | merge0 (fast 3 patJump) $ rev p 46 | , merge0 (mm1 $ m1 "freq" 9) $ fast 3 $ 47 | rev p ] ) 48 | ] 49 | -------------------------------------------------------------------------------- /Montevideo/Dispatch-Unused/Test.hs: -------------------------------------------------------------------------------- 1 | testAllWaiting = TestCase $ do 2 | now <- unTimestamp <$> getTime 3 | dist <- newDispatch 4 | let mm = mTimeMuseqs dist 5 | swapMVar mm $ M.fromList [("a",(now+1,emptyMuseq)) 6 | ,("b",(now+1,emptyMuseq))] 7 | assertBool "all waiting" =<< allWaiting dist 8 | swapMVar mm $ M.fromList [("a",(now-1,emptyMuseq)) 9 | ,("b",(now+1,emptyMuseq))] 10 | assertBool "one is not waiting" =<< not <$> allWaiting dist 11 | 12 | testFindNextEvents = TestCase $ do 13 | let bp f = New Boop $ show f 14 | events = [(0,bp 1),(0.25,bp 2),(0.5,bp 3),(0.5,bp 4),(0.75,bp 5)] 15 | assertBool "testFindNextEvents, midway" $ 16 | (findNextEvents 1 10 29 $ museq 2 events) 17 | -- findNextEvents time0 tempoPeriod now museq 18 | == (2, Prelude.map snd $ V.toList $ V.slice 2 2 $ V.fromList events) 19 | -- last phase 0 was at 21s, so now (29) is 2s before halfway through 20 | assertBool "testFindNextEvents, end (wraparound)" $ 21 | (findNextEvents 1 10 39.5 $ museq 2 events) 22 | == (1.5, Prelude.map snd $ V.toList $ V.slice 0 1 $ V.fromList events) 23 | 24 | let events' = tail events -- PITFALL, maybe confusing: below I use both 25 | assertBool "testFindNextEvents, no zero event, this cycle" $ 26 | (findNextEvents 1 50 123 $ museq 2 events') -- next is 126 27 | == (3, Prelude.map snd $ V.toList $ V.slice 1 1 $ V.fromList events) 28 | assertBool "testFindNextEvents, no zero event, next cycle" $ 29 | (findNextEvents 1 50 100 $ museq 2 events') -- next is 126 30 | == (26, Prelude.map snd $ V.toList $ V.slice 1 1 $ V.fromList events) 31 | -------------------------------------------------------------------------------- /Montevideo/Monome/Network/Monome.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Montevideo.Monome.Network.Monome where 4 | 5 | import Vivid.OSC 6 | 7 | import Montevideo.Util 8 | import Data.ByteString (ByteString) 9 | import Data.ByteString.Char8 (pack) 10 | import Montevideo.Monome.Network.Util (localhost) 11 | 12 | 13 | -- | * to the SerialOSC server 14 | 15 | requestDeviceList :: Int -> ByteString 16 | requestDeviceList mailboxPort = do 17 | encodeOSC $ OSC "/serialosc/list" [ OSC_S localhost 18 | , OSC_I $ fi mailboxPort ] 19 | 20 | 21 | -- | * to a device, esp. a monome 22 | 23 | requestDeviceInfo :: Int -> ByteString 24 | requestDeviceInfo mailboxPort = do 25 | encodeOSC $ OSC "/sys/info" [ OSC_S localhost, OSC_I $ fi mailboxPort ] 26 | 27 | requestSendTo :: Int -> [ByteString] 28 | requestSendTo mailboxPort = 29 | [ encodeOSC $ OSC "/sys/host" [OSC_S localhost] 30 | , encodeOSC $ OSC "/sys/port" [OSC_I $ fi mailboxPort] 31 | ] 32 | 33 | fade :: String -> Int -> Int -> Int -> ByteString 34 | fade devicePrefix x y l = do -- ^ fade light level from 0 to 15 35 | encodeOSC $ OSC (pack $ devicePrefix ++ "/grid/led/level/set") 36 | [ OSC_I $ fi x, OSC_I $ fi y, OSC_I $ fi l ] 37 | 38 | onoff :: String -> Int -> Int -> Int -> ByteString 39 | onoff devicePrefix x y l = do -- ^ toggle light level, 0 or 1 40 | encodeOSC $ OSC (pack $ devicePrefix ++ "/grid/led/set") 41 | [ OSC_I $ fi x, OSC_I $ fi y, OSC_I $ fi l ] 42 | 43 | allLeds :: String -> Int -> ByteString 44 | allLeds devicePrefix l = do -- ^ toggle light level, 0 or 1 45 | encodeOSC $ OSC (pack $ devicePrefix ++ "/grid/led/all") 46 | [ OSC_I $ fi l ] 47 | -------------------------------------------------------------------------------- /mtv-lang/sketches/1/4.hs: -------------------------------------------------------------------------------- 1 | dur0 = 6 2 | evs = [ (0, m1 "freq" 0) 3 | , (1/2, m1 "freq" 1) 4 | , (1, m1 "freq" 2) 5 | , (2, m1 "freq" 3) 6 | , (3, m1 "freq" 4) 7 | , (4, m1 "freq" 5) 8 | , (5, m1 "on" 0) ] 9 | pat = mmho dur0 $ pre2 "a" evs 10 | hatPat = mmt1 6 $ map (_2 %~ f) evs where 11 | f :: M.Map String Float -> Sample 12 | f = maybe S_Sl_b (const S_Hl_cg) . M.lookup "freq" 13 | kickSnarePat = mmt1 2 [ (0, S_Kd) 14 | , (1, S_Sp_t) ] 15 | 16 | scalePat = mmh (4*dur0) $ pre2 "a" 17 | [ ( 0 , maj3 ) 18 | , ( dur0 , dim ) 19 | , ( 2*dur0, aol3 ) 20 | , ( 3*dur0, aug ) ] 21 | 22 | revPat = mmh (2*dur0) $ pre2 "a" 23 | [ (0, id) 24 | , (dur0, rev) ] 25 | 26 | toScale = nBoop 27 | . ops [("freq", (*) 300 . \p -> 2**(p/12))] 28 | . scale 12 scalePat 29 | 30 | ch $ mfl [ 31 | -- ("1", toScale $ ops [("freq",((-) 12))] $ 32 | -- meta revPat $ append pat $ dur %~ (/2) $ pat ) 33 | -- , ("2", toScale $ ops [("freq",(+ 2))] $ fast 2 $ 34 | -- meta revPat $ append pat $ dur %~ (/2) $ pat ) 35 | -- , ("3", toScale $ ops [("freq",(+ 4))] $ fast 4 $ early 2 $ 36 | -- meta revPat $ append pat $ dur %~ (/2) $ pat ) 37 | ("5", toScale $ stack $ 38 | map ($ append pat $ dur %~ (/2) $ pat) $ 39 | [ ops [("freq",((-) 12))] 40 | , ops [("freq",(+ 2))] . fast 2 41 | , ops [("freq",(+ 4))] . fast 4 . early 2 ] ) 42 | 43 | , ("4", stack [ fast 2 $ early (1/4) $ kickSnarePat 44 | , append hatPat (rev $ fast 4 hatPat) 45 | , fast 4 $ early (1/2) $ meta revPat $ hatPat 46 | , kickSnarePat ] ) 47 | ] 48 | -------------------------------------------------------------------------------- /Montevideo/JI/Thanos/SearchParams.hs: -------------------------------------------------------------------------------- 1 | -- | To configure the search. 2 | 3 | module Montevideo.JI.Thanos.SearchParams where 4 | 5 | 6 | minEdo, maxEdo, maxModulus, max12edoFretSpan_lim5, max12edoFretSpan_lim7, max12edoFretSpan_lim13, alwaysConsiderAtLeastThisManyFrets :: Int 7 | minEdo = 12 -- ^ Don't consider any edos smaller than this. 8 | maxEdo = 150 -- ^ Don't consider any edos bigger than this. 9 | maxModulus = 12 10 | max12edoFretSpan_lim5 = 6 -- ^ Drop edos for which some 13-limit interval requires a stretch greater than this many frets of 12-edo. 11 | max12edoFretSpan_lim7 = 8 -- ^ Drop edos for which some 13-limit interval requires a stretch greater than this many frets of 12-edo. 12 | max12edoFretSpan_lim13 = 8 -- ^ Drop edos for which some 13-limit interval requires a stretch greater than this many frets of 12-edo. 13 | alwaysConsiderAtLeastThisManyFrets = 5 -- ^ Even if there's a solution on the 0-fret (so probably the best), any solution on frets -10 to 10 will be considered. 14 | 15 | isForGuitar :: Bool 16 | isForGuitar = False -- ^ If searching for guitar, the ability to play a note on the same "string" as the root is excluded, because it means you can't play them both simultaneously. 17 | 18 | minFretsPerOctave, maxFretsPerOctave, minSpacingIn12edo :: Float 19 | minFretsPerOctave = 10 -- ^ when searching for guitars, this should probably be a small number. But for electronic instruments, big ones are fine -- maybe confusing, but certainly playable. 20 | maxFretsPerOctave = 35 21 | minSpacingIn12edo = 12/7 22 | -- ^ If this is 12/n, this considers only spacings that let you cover an octave in n+1 strings. 23 | -- For instance, if this is 3, consider only spacings 24 | -- between strings that are at least 3\12. 25 | -------------------------------------------------------------------------------- /Montevideo/JI/Grid.hs: -------------------------------------------------------------------------------- 1 | -- | This compares grid arrangements of EDOs, 2 | -- by showing how far your hand must stray from the 3 | -- column containing note 0 in order to reach 4 | -- (the approximations to) any of the first few harmonics. 5 | -- For instance, to reveal that the only arrangement of 87-edo 6 | -- with a maximum deviation of less than 7 is 7 | -- the one that puts 10\87 between each column: 8 | -- > myPrint $ compareGrids_filt 6 87 9 | -- (10,4,9,[1,-2,0,0,1]) 10 | -- 11 | -- TODO : Make this consider the placement of the octave, 12 | -- just like it considers the placement of 3/2. 13 | -- (That probably means modifying other modules.) 14 | 15 | {-# LANGUAGE ScopedTypeVariables #-} 16 | 17 | module Montevideo.JI.Grid where 18 | 19 | import Control.Lens 20 | 21 | import Montevideo.Util 22 | import Montevideo.JI.Lib 23 | 24 | 25 | compareGrids_filt :: Int -> Int -> [(Int,Int,Int,Int,[Int])] 26 | compareGrids_filt maxSummedDev = 27 | filter ((<= maxSummedDev) . (^. _4)) 28 | . compareGrids 29 | 30 | compareGrids :: Int -> [(Int,Int,Int,Int,[Int])] 31 | compareGrids edo0 = let 32 | width n = round 33 | (fromIntegral edo0 / fromIntegral n :: Double) 34 | als n = alignments n edo0 35 | in [ ( n -- distance (as a fraction of edo0) between columns 36 | , width n -- which column the probably-nearest octave lands in 37 | , myMod edo0 n -- which row the probably-nearest octave lands in 38 | , sum $ map abs $ als n -- sum of errors 39 | , als n) -- errors 40 | | n <- [6..20]] 41 | 42 | alignments :: Int -> Int -> [Int] 43 | alignments spacing edo0 = 44 | map ( flip myMod spacing 45 | . fromIntegral 46 | . (^. _1) 47 | . best (fromIntegral edo0) ) 48 | [3/2,5/4,7/4,11/8,13/8] 49 | -------------------------------------------------------------------------------- /mtv-lang/sketches/2/3.hs: -------------------------------------------------------------------------------- 1 | seq d e f = [ (0, d) 2 | , (1, e) 3 | , (2, d) 4 | , (2.5, f) ] 5 | patPitch = mmho 3 $ pre2 "a" $ 6 | map (_2 %~ m1 "freq") $ seq 0 1 2 7 | patJump = mmho 3 $ pre2 "b" $ 8 | map (_2 %~ m1 "freq") $ seq 0 6 12 9 | patKs = mmt1 3 $ seq S_Sm_peb S_Km S_Km 10 | patHat = mmt1 3 $ seq S_Hl_dc S_Hl_tfc S_Hl_tfc 11 | 12 | modPat f g = mmh 3 $ pre2 "c" 13 | [ (0, f . g) 14 | , (1, id) 15 | , (2, f) 16 | , (2.5, g) ] 17 | 18 | scalePat = slow 3 $ mmh 8 $ pre2 "d" 19 | [ ( 0 , (0, maj3) ) 20 | , ( 3 , (-1, loc7) ) 21 | , ( 4 , (2, aol5) ) 22 | , ( 7 , (-1, loc7) ) 23 | ] 24 | 25 | toScale = nZot 26 | . ops [("freq", (*) 200 . \p -> 2**(p/12))] 27 | . rootScale 12 scalePat 28 | 29 | ch $ mfl 30 | [ ("1", stack 31 | [ nAmpTo 0.04 $ 32 | meta ( slow 4 $ early 2 $ 33 | modPat (fast 2) (late 1)) $ 34 | append patKs $ dense 2 patKs 35 | , nAmpTo 0.05 $ 36 | meta ( slow 8 $ 37 | modPat (early $ 1/4) (early $ 1/2)) $ 38 | meta ( slow 4 $ 39 | modPat (fast 4 . early 1) (fast 2)) 40 | patHat ] ) 41 | , ("4.1", toScale $ stack $ -- this takes advantage of a bug 42 | let p = append patPitch $ rev patPitch in 43 | [ merge0 (stack2 (mm1 $ m1 "freq" $ -7) 44 | (mm1 $ m1 "freq" $ -14)) $ 45 | merge0 (fast 2 patPitch) $ 46 | meta (mmh 4 $ pre2 "e" $ seq (fast 2) (early 1) id) $ 47 | slow 2 $ p 48 | , merge0 (mm1 $ m1 "freq" 4) $ fast 2 $ 49 | merge0 (fast 2 patJump) $ rev p 50 | , merge0 (mm1 $ m1 "freq" 9) $ fast 2 $ 51 | rev p 52 | ] ) 53 | ] 54 | -------------------------------------------------------------------------------- /Montevideo/Monome/Types/Params.hs: -------------------------------------------------------------------------------- 1 | {- | This module was needed for `Zot`. 2 | For `Axe`, so far, it is unused, 3 | since `Axe` has few enough parameters 4 | to fit on the little monome at once. 5 | -} 6 | 7 | {-# LANGUAGE TemplateHaskell #-} 8 | 9 | module Montevideo.Monome.Types.Params where 10 | 11 | import Control.Lens 12 | import Data.Either.Combinators 13 | import qualified Data.Bimap as Bi 14 | 15 | import Montevideo.Monome.Types.Monome 16 | import Montevideo.Synth 17 | 18 | 19 | data ParamGroup = The_PG 20 | deriving (Eq, Ord, Show) 21 | makePrisms ''ParamGroup 22 | 23 | -- | Two parameters are omitted: "on", which is only ever 1 24 | -- (Dispatch needs it, I think, but Monome doesn't), 25 | -- and "freq", which is controlled by the "keyboards", not the "sliders". 26 | paramGroup_params :: ParamGroup -> [AxeParam] 27 | paramGroup_params The_PG = 28 | [ Axe_amp 29 | , Axe_lim 30 | , Axe_att 31 | , Axe_rel 32 | , Axe_lpf 33 | , Axe_shift 34 | 35 | , Axe_am 36 | , Axe_af 37 | , Axe_fm 38 | , Axe_ff 39 | , Axe_vm 40 | , Axe_vf 41 | , Axe_wm 42 | , Axe_wf ] 43 | 44 | paramGroup_toParam :: ParamGroup -> Int -> Either String AxeParam 45 | paramGroup_toParam pg i = 46 | mapLeft ("paramGroup_toParam: " ++) $ 47 | case drop i $ paramGroup_params pg of 48 | [] -> Left ( "ParamGroup " ++ show pg ++ 49 | " has fewer than " ++ show i ++ " parameters." ) 50 | (s:_) -> Right s 51 | 52 | -- | This is total in one direction: Keying on a ParamGroup never fails. 53 | -- (In that case it's clearer to use `paramGroup_toXy`, below.) 54 | paramGroupXys :: Bi.Bimap ParamGroup (X,Y) 55 | paramGroupXys = Bi.fromList 56 | [ (The_PG , (0,0)) ] 57 | 58 | paramGroup_toXy :: ParamGroup -> (X,Y) 59 | paramGroup_toXy = (Bi.!) paramGroupXys 60 | -------------------------------------------------------------------------------- /mtv-lang/sketches/8/2.hs: -------------------------------------------------------------------------------- 1 | seq evs = f $ zip (map RTime [0..]) evs where 2 | f [] = [] 3 | f [a] = [a] 4 | f (a:(t,ev):more) = a : (max 0 $ t-1/2, ev) : f more 5 | 6 | patKs = mmt1 4 $ seq [ S_Km 7 | , S_Sm_peb 8 | , S_Sl_blip ] 9 | patHat = nAmpTo 0.04 $ mmt1 4 $ seq [ S_Hl_et 10 | , S_Hl_tfc 11 | , S_Hl_tfc ] 12 | 13 | patFreq = mmho 4 $ [ 14 | ("" , 0, mfl [("freq",60)]) 15 | , ("" , 1, mfl [("freq",70)]) 16 | , ("" , 2, mfl [("freq",70.1)]) 17 | , ("" , 3, mfl [("freq",90)]) 18 | ] 19 | 20 | -- TODO | PITFALL | BUG: 21 | -- When first playing this file, for some reason, 22 | -- patTone has to be really simple. 23 | -- Then it can be redefined as the complex one. 24 | -- But if it is that to start, the synth diverges (loudly). 25 | patTone = fast 4 $ mmh 2 $ pre2 "" [ 26 | (0, mfl [ 27 | ("am-b",0.1), ("fm-b",0) 28 | , ("del",3/2) 29 | , ("amp",0.02) 30 | , ("lpf",55),("lpf-m",1) 31 | ]) 32 | , (1, mfl [ 33 | ("am-f",1), ("am",20), ("am-b",1/8) 34 | , ("fm-f",1), ("fm-f",1/2), ("fm-b",1) 35 | , ("lpf-m",0) 36 | , ("amp",0.01) 37 | ]) 38 | ] 39 | --patTone = fast 4 $ mmh 2 $ pre2 "" [(0, mfl [("freq",1)])] 40 | 41 | viewDurs = vec .~ mempty 42 | woop x = cat [early 1 x, rev x] 43 | 44 | ch $ mfl [ 45 | ("1", fast 2 $ woop patKs) 46 | , ("2", early (1/4) $ fast 4 $ patHat ) 47 | , ("3", nZot $ merge1 (woop $ freq (/ 75) patFreq) $ 48 | stack [ patFreq 49 | , merge1 patTone patFreq 50 | , early (1/4) $ 51 | merge0 (early (1/8) $ fast 4 patFreq) $ 52 | merge1 (late (1/4) patTone) patFreq 53 | ] ) 54 | ] 55 | -------------------------------------------------------------------------------- /Montevideo/Random/Render.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds 2 | , ExtendedDefaultRules 3 | , FlexibleContexts 4 | , ScopedTypeVariables 5 | , ConstrainedClassMethods 6 | #-} 7 | 8 | module Montevideo.Random.Render where 9 | 10 | import qualified Data.Map as M 11 | 12 | import Vivid 13 | import Random.Types 14 | 15 | 16 | type RenderTarget = SDBody' TheAbParams Signal 17 | -- ^ Rendering turns abstract signals into this type. 18 | 19 | class RenderSig a where 20 | renderSig :: a -> (M.Map AbSigName Signal -> RenderTarget) 21 | 22 | instance RenderSig AbSig where 23 | renderSig (AbSigFormula abFormula) = renderSig abFormula 24 | renderSig (AbSigGen abGen) = renderSig abGen 25 | renderSig (AbSig abSigName) = renderSig abSigName 26 | renderSig (AbV abParam) = renderSig abParam 27 | renderSig (AbConst f) = const $ toSig f 28 | 29 | instance RenderSig AbFormula where 30 | renderSig (AbProd x y) m = renderSig x m ~* renderSig y m 31 | renderSig (AbSum x y) m = renderSig x m ~+ renderSig y m 32 | 33 | instance RenderSig AbGen where 34 | renderSig (AbSin (AbSinMsg freq phase)) m = 35 | sinOsc ( freq_ $ renderSig freq m 36 | , phase_ $ renderSig phase m ) 37 | renderSig (AbSaw (AbSawMsg freq)) m = 38 | saw ( freq_ $ renderSig freq m ) 39 | 40 | instance RenderSig AbSigName where 41 | renderSig name = \m -> toSig $ (M.!) m name 42 | -- confusingly, toSig converts a signal to an SDBody' 43 | 44 | instance RenderSig AbParam where 45 | renderSig AP1 _ = toSig (V :: V "AP1") 46 | renderSig AP2 _ = toSig (V :: V "AP2") 47 | renderSig AP3 _ = toSig (V :: V "AP3") 48 | renderSig AP4 _ = toSig (V :: V "AP4") 49 | renderSig AP5 _ = toSig (V :: V "AP5") 50 | renderSig AP6 _ = toSig (V :: V "AP6") 51 | renderSig AP7 _ = toSig (V :: V "AP7") 52 | renderSig AP8 _ = toSig (V :: V "AP8") 53 | -------------------------------------------------------------------------------- /Montevideo/Random/RandomSynth.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | 3 | module Montevideo.Random.RandomSynth where 4 | 5 | import qualified Data.Map as M 6 | 7 | import Random.Types 8 | import Random.RandomSignal 9 | import Random.MentionsSig 10 | import Util (unique) 11 | 12 | 13 | randAbSynth :: RandConstraints -> IO AbSynth 14 | randAbSynth cs0 = -- TODO : prune cs <$> 15 | go cs0 M.empty where 16 | go :: RandConstraints -> AbSynth -> IO AbSynth 17 | go cs m = if namedSignals cs >= maxSignals cs 18 | then return m 19 | else do s <- randAbSig cs 20 | let namedSignals' = namedSignals cs + 1 21 | cs' = cs {namedSignals = namedSignals'} 22 | m' = M.insert (sigName cs' namedSignals') s m 23 | go cs' m' 24 | 25 | -- TODO : debug `prune`; it seems to strip everything but the last 26 | -- | After pruning, every remaining signal influences the last one 27 | prune :: RandConstraints -> AbSynth -> AbSynth 28 | prune cs m0 = 29 | let theUnused = unused cs [maximum $ M.keys m0] m0 30 | deleteKeys :: Ord k => [k] -> M.Map k a -> M.Map k a 31 | deleteKeys ks m = foldl (flip M.delete) m ks 32 | in deleteKeys (M.keys theUnused) m0 33 | 34 | -- | Produces an AbSynth containing only the unused signals 35 | unused :: RandConstraints -> [AbSigName] -> AbSynth -> AbSynth 36 | unused _ [] all0 = all0 37 | unused cs (u:used) m = 38 | let newMentions = allMentions cs u 39 | m' = M.delete u m 40 | remainingLeads = unique 41 | $ filter (flip elem $ M.keys m) -- delete irrelevant keys 42 | $ newMentions ++ used 43 | in unused cs remainingLeads m' 44 | 45 | sigName :: RandConstraints -> Int -> AbSigName 46 | sigName (namedSignals -> k) n = 47 | if n > 0 && n <= min k 8 48 | then theAbSigNames !! (n - 1) 49 | else error $ show n ++ " is not the number of an AbSigName." 50 | -------------------------------------------------------------------------------- /Montevideo/Dispatch/Lazy/Util.hs: -------------------------------------------------------------------------------- 1 | module Montevideo.Dispatch.Lazy.Util ( 2 | Time, Arc(..), addToArc, sect, 3 | lcm', gcd', 4 | div', mod', divMod' 5 | ) where 6 | 7 | import Data.Fixed (div', mod', divMod') 8 | 9 | 10 | -- ** Types 11 | 12 | type Time = Rational 13 | data Arc = Arc { start :: Time, 14 | end :: Time } 15 | deriving (Show, Eq, Ord) 16 | 17 | addToArc :: Time -> Arc -> Arc 18 | addToArc t a = Arc { start = start a + t, 19 | end = end a + t } 20 | 21 | -- | Intersection of Arcs. 22 | -- PITFALL: This is different from TidalCycles's function of the same name. 23 | -- It would be identical if not for (1) the two `not` clauses 24 | -- in the `if` statement, and (2) the Maybe. 25 | sect :: Arc -> Arc -> Maybe Arc 26 | sect a b = let 27 | s = max (start a) (start b) 28 | e = min (end a) (end b) 29 | in if s <= e 30 | -- The following two clauses ensure that if the endpoint of one Arc 31 | -- equals the start of the next, that is *not* counted as overlap, 32 | -- unless the lower Arc has duration zero. 33 | && not ( start a < end a && end a == start b ) 34 | && not ( start b < end b && end b == start a ) 35 | then Just $ Arc { start = s, end = e } 36 | else Nothing 37 | 38 | -- TODO ? Do I need these? 39 | -- data ATime = -- | Absolute time. 40 | -- ATime {unATime :: Rational} 41 | -- data RTime = -- | Relative time. 42 | -- RTime {unRTime :: Rational} 43 | -- class Time t 44 | -- instance Time ATime 45 | -- instance Time RTime 46 | 47 | 48 | -- ** Functions 49 | 50 | gcd' :: Rational -> Rational -> Rational 51 | gcd' x y = go (abs x) (abs y) 52 | where go a 0 = a 53 | go a b = go b (a `mod'` b) 54 | 55 | lcm' :: Rational-> Rational -> Rational 56 | lcm' _ 0 = 0 57 | lcm' 0 _ = 0 58 | lcm' x y = let 59 | g = gcd' x y 60 | in abs $ y * 61 | fromIntegral ( div' x g ) 62 | -------------------------------------------------------------------------------- /Montevideo/Synth/Vap.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE DataKinds 3 | , ExtendedDefaultRules 4 | , ScopedTypeVariables 5 | , GADTs #-} 6 | 7 | module Montevideo.Synth.Vap where 8 | 9 | import Vivid 10 | 11 | import Montevideo.Synth.Config 12 | 13 | 14 | type VapParams = '[ "freq", "amp" 15 | , "saw" -- between 0 and 1, else gets loud fast 16 | , "delay-freq", "delay-amp" 17 | , "fm-freq", "fm-amp" 18 | , "fm2-freq", "fm2-amp" 19 | , "nz-lpf" -- nz-amp would be collinear with fm2-amp 20 | , "on" ] -- A crude gate. Zot does it better. 21 | 22 | vap :: SynthDef VapParams 23 | vap = sd ( 0 :: I "freq" 24 | , toI maxAmp :: I "amp" 25 | , 0 :: I "saw" 26 | , 0 :: I "delay-freq" 27 | , 0 :: I "delay-amp" 28 | , 0 :: I "fm-freq" 29 | , 0 :: I "fm-amp" 30 | , 0 :: I "fm2-freq" 31 | , 0 :: I "fm2-amp" 32 | , 0 :: I "nz-lpf" 33 | , 0 :: I "on" 34 | ) $ do 35 | nz <- lpf (in_ whiteNoise, freq_ (V::V "nz-lpf")) 36 | fm <- (V::V "fm-amp") ~* (sinOsc $ freq_ (V::V "fm-freq")) 37 | fm2 <- (V::V "fm2-amp") ~* (sinOsc $ freq_ (V::V "fm2-freq")) 38 | aSin <- sinOsc (freq_ $ (V::V "freq") ~+ fm ~+ fm2 ~* nz) 39 | aSaw <- saw (freq_ $ (V::V "freq") ~+ fm ~+ fm2 ~* nz) 40 | carrier <- (V::V "amp") ~* ( ( (V :: V "saw" ) ~* aSaw) 41 | ~+ ((1 ~- (V :: V "saw")) ~* aSin) 42 | ) 43 | fb <- carrier ~+ (V :: V "delay-amp") ~* 44 | ( lpf $ in_ $ delayL (in_ carrier 45 | , maxDelaySecs_ 1 46 | , delaySecs_ (V :: V "delay-freq") ) ) 47 | out 0 [fb, fb] 48 | -------------------------------------------------------------------------------- /interactive/hearing-test.hs: -------------------------------------------------------------------------------- 1 | -- | A way to discover an ear's maximum audible frequency, 2 | -- or the minimum amplitude at which a frequency is audible. 3 | -- I'm using it to see if my hearing is coming back 4 | -- after I accidentally lodged wax against my eardrum.) 5 | 6 | {-# LANGUAGE DataKinds 7 | , ExtendedDefaultRules 8 | , ScopedTypeVariables 9 | , GADTs #-} 10 | 11 | import Control.Concurrent (forkIO, killThread) 12 | import Vivid 13 | import Montevideo.Synth.Envelope 14 | 15 | 16 | -- | Toggles the sound every 0.5 seconds until registering a keystroke. 17 | b2 :: Float -> Float -> IO () 18 | b2 kHz amp = do 19 | s <- synth sin_right ( toI kHz :: I "kHz" 20 | , toI amp :: I "amp" ) 21 | let onOff :: IO () = do 22 | set s (toI 1 :: I "on") 23 | wait 0.5 24 | set s (toI 0 :: I "on") 25 | wait 0.5 26 | pulse <- forkIO $ forever $ onOff 27 | _ <- getChar 28 | killThread pulse 29 | set s (toI 0 :: I "on") 30 | wait 0.1 31 | free s 32 | 33 | -- | Plays it just once. `b2` is better. 34 | beep :: Float -> Float -> IO () 35 | beep kHz amp = do 36 | s <- synth sin_right ( toI kHz :: I "kHz" 37 | , toI amp :: I "amp" ) 38 | wait 0.9 39 | set s (toI 0 :: I "on") 40 | wait 0.1 -- b/c the release ("rel") takes 0.05 seconds. 41 | free s 42 | 43 | sin_right = sd ( 100 :: I "kHz" 44 | , 0 :: I "amp" 45 | -- The rest are for onOffEnvelope. 46 | , 1 :: I "on" 47 | , 0.05 :: I "att" 48 | , 0.05 :: I "rel" 49 | ) $ do 50 | amp <- biOp Max 0.8 51 | $ uOp Abs (V :: V "amp") 52 | kHz <- -- It might be cpu-wasteful that this is an audio-rate signal. 53 | (V :: V "kHz") ~* 1000 54 | signal <- (V :: V "amp") 55 | ~* sinOsc (freq_ kHz) 56 | ~* onOffEnvelope -- important to avoid clicks 57 | silence <- 0 ~* signal 58 | out 0 [signal, signal] 59 | -------------------------------------------------------------------------------- /Montevideo/Dispatch-Unused/Parse/Params.hs: -------------------------------------------------------------------------------- 1 | -- everything below includes per-synth boilerplate 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | 5 | module Montevideo.Dispatch.Parse.Params ( 6 | parseBoopMsg 7 | , parseVapMsg -- TODO : unfinished, needs more params 8 | , parseSqfmMsg 9 | ) where 10 | 11 | import Text.Megaparsec 12 | import qualified Text.Megaparsec.Char as C 13 | import qualified Text.Megaparsec.Char.Lexer as L 14 | 15 | import Vivid 16 | import Dispatch.Act 17 | import Dispatch.Types 18 | import Dispatch.Parse.Utils 19 | import Synths 20 | 21 | 22 | -- | parse a Msg for a particular synthdef 23 | 24 | parseBoopMsg :: Parser (Msg' BoopParams) 25 | parseBoopMsg = tryEach [freq, amp] 26 | 27 | parseVapMsg :: Parser (Msg' VapParams) 28 | parseVapMsg = tryEach [freq, amp] 29 | 30 | parseSqfmMsg :: Parser (Msg' SqfmParams) 31 | parseSqfmMsg = tryEach [freq, amp, width, widthVibFreq, widthVibAmp] 32 | 33 | 34 | -- | parse a Msg polymorphically 35 | 36 | freq :: Elem "freq" superset => Parser (Msg' superset) 37 | freq = L.lexeme sc $ do n <- word "freq" >> signedFloat 38 | return $ Msg' (toI n :: I "freq") 39 | 40 | amp :: Elem "amp" superset => Parser (Msg' superset) 41 | amp = L.lexeme sc $ do n <- word "amp" >> signedFloat 42 | return $ Msg' (toI n :: I "amp") 43 | 44 | width :: Elem "width" superset => Parser (Msg' superset) 45 | width = L.lexeme sc $ do n <- word "width" >> signedFloat 46 | return $ Msg' (toI n :: I "width") 47 | 48 | widthVibFreq :: Elem "width-vib-freq" superset => Parser (Msg' superset) 49 | widthVibFreq = L.lexeme sc $ do n <- word "width-vib-freq" >> signedFloat 50 | return $ Msg' (toI n :: I "width-vib-freq") 51 | 52 | widthVibAmp :: Elem "width-vib-amp" superset => Parser (Msg' superset) 53 | widthVibAmp = L.lexeme sc $ do n <- word "width-vib-amp" >> signedFloat 54 | return $ Msg' (toI n :: I "width-vib-amp") 55 | -------------------------------------------------------------------------------- /mtv-lang/sketches/7/1.hs: -------------------------------------------------------------------------------- 1 | seq d e f = [ (0, d) 2 | , (1, e) 3 | , (1.5, f) ] 4 | meta1 = slow 12 $ mmh 2 $ pre2 "a" $ 5 | seq id (early (1/2)) (slow 2 . rev) 6 | meta2 = slow 4 $ mmh 2 $ pre2 "a" $ seq id 7 | (\x -> append x $ dur %~ (/2) $ x) 8 | (early $ 1/4) 9 | meta3 = mmh 2 $ pre2 "a" $ 10 | seq id (early (1/2)) (fast 2) 11 | patPitch k = mmho 2 $ pre2 "a" $ 12 | map (_2 %~ m1 "freq") $ seq 0 k $ 2*k 13 | patKs = mmt1 2 $ seq S_Km S_Sm_peb S_Sl_blip 14 | patHat = mmt1 2 $ seq S_Hl_et S_Hl_tfc S_Hl_tfc 15 | 16 | go = nZot . toHz . rootScale 12 rs where 17 | toHz = ops [("freq", (*) 200 . \p -> 2**(p/12))] 18 | rs = slow 8 $ mmh 3 $ pre2 "a" $ [ (0, (0, phr3)) 19 | , (1, (4, lyd)) 20 | , (2, (1, lyd7)) ] 21 | 22 | modDrums = nAmpTo $ maxAmp * 2.5 23 | 24 | zotTones = mergec $ 25 | mmh 2 $ pre2 "a" $ map (_2 %~ mfl) 26 | [ (0, [("amp",maxAmp / 2), ("pulse",0.1) 27 | , ("sh",1/2) , ("sh-b",0) 28 | , ("lpf",3), ("lpf-m",2) 29 | ]) 30 | , (0.5, [("rm",0)]) 31 | , (1, [("amp",maxAmp*1.5), ("pulse",0) 32 | , ("sh",-0.25), ("sh-b",-0.5) -- super-weird 33 | , ("am",1/3), ("am-f",1/3), ("am-b",1) 34 | , ("del",1000) 35 | , ("lpf-m",1) 36 | ]) 37 | , (1.5, [("rm",1/3), ("rm-b",1/4), ("rm-f",2/3)]) 38 | ] 39 | 40 | ch $ mfl 41 | [ ("1", go $ meta meta1 $ 42 | slow 2 $ merge0 (fast 3 $ patPitch 1) (patPitch 2)) 43 | , ("2", go $ (\x -> stack2 x $ amp (*0.7) $ zotTones x) $ 44 | meta meta1 $ merge0 (mm1 $ m1 "freq" 2) $ 45 | merge0 (fast 3 $ patPitch 2) (patPitch 1)) 46 | , ("d1", modDrums $ 47 | meta meta1 $ meta meta2 $ meta meta3 $ 48 | fast 2 $ stack2 patKs $ fast 2 patHat ) 49 | ] 50 | -------------------------------------------------------------------------------- /mtv-lang/docs/merge-two-patterns.hs: -------------------------------------------------------------------------------- 1 | -- This sketch merges two Museqs by multiplying their frequencies. 2 | 3 | -- This pattern is monophonic, because each note has the same label, "a". 4 | -- It plays four notes. 5 | melody = mkMuseq_holdOn 4 6 | [ ("a", 0, M.singleton "freq" 250) 7 | , ("a", 1, M.singleton "freq" 300) 8 | , ("a", 2, M.singleton "freq" 375) 9 | , ("a", 3.5, M.singleton "freq" 370) ] 10 | 11 | -- This pattern is polyphonic, because the notes have different labels. 12 | -- It plays a static chord (some transposition of C-G-D). 13 | -- Since in Hz they would be below the human range of hearing, 14 | -- these frequency values are most naturally thought of as relative, 15 | -- i.e. 2 means "twice the frequency". 16 | arpeggio = -- This has a duration of 1: the `2` arguments 17 | -- to `fast` and `mm` cancel out. 18 | fast 2 $ 19 | insertOns $ -- into messages missing an "on" instruction, insert "on=1" 20 | mm 2 21 | [ ("a", 0/4, 3/2, M.fromList [("freq",1)] ) 22 | , ("b", 1/4, 3/2, M.fromList [("freq",3/2)]) 23 | , ("c", 2/4, 3/2, M.fromList [("freq",9/4)]) 24 | , ("a", 3/2, 2, M.fromList [("on",0)] ) -- off messages 25 | , ("b", 3/2, 2, M.fromList [("on",0)] ) -- off messages 26 | , ("c", 3/2, 2, M.fromList [("on",0)] ) -- off messages 27 | ] 28 | 29 | -- Here's what the first pattern sounds like. 30 | -- chAll $ mfl [ ( "1", Note Boop <$> melody ) ] 31 | 32 | -- Here's what the second pattern sounds like (pitched up by a factor of 400). 33 | -- chAll $ mfl [ ( "1", Note Boop <$> overParams [("freq", (*400))] arpeggio ) ] 34 | 35 | -- When you merge the two patterns, the result is what you would get 36 | -- if you replaced each note in `melody` by the arpeggio in `arpeggio`. 37 | chAll $ mfl 38 | [ ( "1", Note Boop <$> -- Send the pattern to the Boop synth. 39 | merge1 melody arpeggio ) ] 40 | -- (`merge1` multiplies like parameters. 41 | -- If you used merge0 instead of merge1, the frequencies 42 | -- from the two patterns would be added instead of multiplied.) 43 | -------------------------------------------------------------------------------- /mtv-lang/sketches/7/2.hs: -------------------------------------------------------------------------------- 1 | seq d e f = [ (0, d) 2 | , (1, e) 3 | , (1.5, f) ] 4 | metaPat = ( slow 12 $ mmh 2 $ pre2 "a" $ 5 | seq id (early (1/2) . rev) (slow 2) ) 6 | patPitch k = ( mmho 2 $ pre2 "a" $ 7 | map (_2 %~ m1 "freq") $ seq 0 k $ 2*k ) 8 | patKs = mmt1 2 $ seq S_Sm_peb S_Km S_Km 9 | patHat = mmt1 2 $ seq S_Hl_dc S_Hl_tfc S_Hl_tfc 10 | 11 | go = nZot . toHz . rootScale 12 rs where 12 | toHz = ops [("freq", (*) 200 . \p -> 2**(p/12))] 13 | rs = slow 8 $ mmh 3 $ pre2 "a" $ [ (0, (0, phr3)) 14 | , (1, (4, lyd)) 15 | , (2, (1, lyd7)) ] 16 | 17 | toDrums = nAmpTo $ maxAmp * 2.5 18 | 19 | zotTones = mergec $ 20 | mmh 2 $ pre2 "a" $ map (_2 %~ mfl) 21 | [ (0, [("amp",maxAmp / 2), ("pulse",0.1) 22 | , ("sh",1/2) , ("sh-b",0) 23 | , ("lpf",3), ("lpf-m",2) 24 | ]) 25 | , (0.5, [("rm",0)]) 26 | , (1, [("amp",maxAmp*1.5), ("pulse",0) 27 | , ("sh",-0.25), ("sh-b",-0.5) -- super-weird 28 | , ("am",1/3), ("am-f",1/3), ("am-b",1) 29 | , ("del",1000) 30 | , ("lpf-m",1) 31 | ]) 32 | , (1.5, [("rm",1/3), ("rm-b",1/4), ("rm-f",2/3)]) 33 | ] 34 | 35 | ch $ mfl 36 | [ ("1", go $ meta metaPat $ 37 | slow 2 $ merge0 (fast 3 $ patPitch 1) (patPitch 2)) 38 | , ("2", go $ (\x -> stack2 x $ amp (*0.7) $ zotTones x) $ 39 | meta metaPat $ merge0 (mm1 $ m1 "freq" 2) $ 40 | merge0 (fast 3 $ patPitch 2) (patPitch 1)) 41 | , ("3", go $ 42 | meta (fast 4 metaPat) $ merge0 (mm1 $ m1 "freq" 9) $ 43 | slow 2 $ late 1 $ merge0 (fast 3 $ patPitch 1) (patPitch 2)) 44 | 45 | , ("d1", meta metaPat $ toDrums $ 46 | fast 2 $ stack2 patKs $ fast 2 patHat) 47 | , ("d2", meta metaPat $ toDrums $ 48 | meta (slow 2 $ mm 2 $ [("",1,2,id)]) $ 49 | early (1/8) patKs) 50 | ] 51 | -------------------------------------------------------------------------------- /learning/subset-constraints/earlier-fumblings,gadt-forget/close-to-vivid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses 2 | , FlexibleInstances 3 | , ScopedTypeVariables 4 | , GADTs #-} 5 | 6 | -- | In Vivid, a `Synth` can receive a message only if (1) that message is 7 | -- a member of the `VarList` type family, and (2) the message's parameters 8 | -- are a subset of the parameters of the `Synth`: 9 | -- set :: ( VividAction m 10 | -- , Subset (InnerVars params) sdArgs 11 | -- , VarList params) 12 | -- => Synth sdArgs -> params -> m () 13 | 14 | -- | Below is an impression of that situation using text instead of audio. 15 | -- Things of type `Synth x` can accept any message belonging to the 16 | -- `Messageable y` family, as long as `x == y`. 17 | 18 | type SynthName = String 19 | 20 | data Synth format where 21 | Synth :: SynthName -> Synth format 22 | 23 | data Message format where 24 | Message :: String -> Message format 25 | data PreMessageA format where 26 | PreMessageA :: String -> PreMessageA format 27 | data PreMessageB format where 28 | PreMessageB :: String -> PreMessageB format 29 | 30 | class Messageable format a where 31 | toMessage :: a -> Message format 32 | instance Messageable format (PreMessageA format) where 33 | toMessage (PreMessageA msg) = Message msg 34 | instance Messageable format (PreMessageB format) where 35 | toMessage (PreMessageB msg) = Message msg 36 | 37 | play :: forall format m 38 | . Messageable format m 39 | => Synth format -> m -> IO () 40 | play (Synth name) msg = 41 | let Message m = toMessage msg :: Message format 42 | in print $ name ++ " now sounds like " ++ m 43 | 44 | -- | After that, can we define the following? 45 | -- (1) a heterogeneous list of `Synth x`s 46 | -- where `x` varies across the members of the list. 47 | -- (2) a heterogeneous list of `msg x`s where `x` varies across members 48 | -- of the list and where `msg` can be either `MessageA` or `MessageB`. 49 | -- (3) a function that lets you send messages from the second list 50 | -- to synths from the first list. 51 | -------------------------------------------------------------------------------- /mtv-lang/docs/scale-progression.hs: -------------------------------------------------------------------------------- 1 | scaleStepPattern = 2 | mmho 3 -- Make a Museq ("mm") of duration 3, 3 | -- holding ("h") each message until the start of the next 4 | -- message with the same label, 5 | -- and adding the message on=1 ("o") to every message 6 | -- in which the "on" parameter is not mentioned. 7 | $ pre2 "" -- Give each message the same label, the empty string. 8 | -- (This is therefore a monophonic pattern.) 9 | [ (0, m1 "freq" 0) -- play frequency 0 from time 0 to time 1/2. 10 | -- These "frequencies" are (downstream) used as scale steps, 11 | -- not as Hz. values. 12 | , (1/2, m1 "freq" 1) -- play frequency 1 from time 1/2 to time 1 13 | , (1, m1 "freq" 2) -- etc. 14 | , (2, m1 "freq" 3) ] 15 | 16 | -- A scale is used to convert scale step values into halfstep values. 17 | scalePat = slow 4 $ -- This gives the `Museq` a duration of 16 instead of 2. 18 | mmh 2 $ pre2 "a" -- Make a `Museq` of scales, of duration 2, 19 | [ ( 0 -- Starting at time 0, 20 | , maj ) -- use the major scale. 21 | , ( 1 -- Starting at time 1, 22 | , [0,1,3,5,7,8,10] ) ] -- play whatever scale this is. (It's phrygian.) 23 | 24 | render = 25 | (<$>) (Note Boop) -- Send it to the Boop synth. 26 | . stepsToHz 12 300 -- Convert each "freq" value from 12-edo halfsteps to Hz, 27 | -- such that 0 halfsteps -> 300 Hz, 12 halfsteps -> 600 Hz, etc. 28 | . scale 12 scalePat -- Convert each scale 12 step value to halfsteps. 29 | 30 | chAll $ -- Change all voices at once -- i.e. play this, and only this. 31 | mfl -- Shorthand for Data.Map.fromList. 32 | [ ( "1" -- Send the following `Museq` to voice 1. 33 | , render scaleStepPattern) 34 | , ( "2" 35 | , render $ 36 | freq (+2) $ -- Play it a "musical third" (two 0-indexed scale spaces) 37 | -- higher than it would otherwise be. 38 | fast 2 $ -- Play it twice as fast. 39 | scaleStepPattern) 40 | , ( "lizard mango", -- Voice names can be whatever you want. 41 | render $ freq (+4) $ 42 | fast 4 scaleStepPattern) ] 43 | -------------------------------------------------------------------------------- /Montevideo/Monome/Network/Util.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Montevideo.Monome.Network.Util ( 5 | close -- ^ Socket -> IO () 6 | , recv -- ^ Socket -> Int -> IO ByteString 7 | , send -- ^ Socket -> ByteString -> IO Int 8 | , HostName -- ^ HostName 9 | , Socket -- ^ Socket 10 | , localhost -- ^ ByteString 11 | , toPort -- ^ Show a => a -> IO Socket 12 | , toSerialosc -- ^ IO Socket 13 | , getLocalSocket -- ^ Show a => HostName -> a -> IO (Socket, NS.AddrInfo) 14 | , sendsTo -- ^ Show a => HostName -> a -> IO Socket 15 | , receivesAt -- ^ Show a => HostName -> a -> IO Socket 16 | ) where 17 | 18 | import Data.ByteString (ByteString) 19 | import Data.ByteString.Char8 (unpack) 20 | import qualified Network.Socket as NS 21 | import qualified Network.Socket.ByteString as NSB 22 | 23 | import Montevideo.Monome.Types.Most (HostName, Socket) 24 | 25 | 26 | -- | = PITFALL: Ports 0-1024 are reserved. 27 | -- All 5-digit numbers seem to work, though. 28 | 29 | close :: Socket -> IO () 30 | close = NS.close 31 | 32 | recv :: Socket -> Int -> IO ByteString 33 | recv = NSB.recv 34 | 35 | send :: Socket -> ByteString -> IO Int 36 | send = NSB.send 37 | 38 | localhost :: ByteString 39 | localhost = "127.0.0.1" 40 | 41 | toPort :: Show a => a -> IO Socket 42 | toPort port = sendsTo (unpack localhost) port 43 | toSerialosc :: IO Socket 44 | toSerialosc = toPort 12002 45 | -- ^ https://monome.org/docs/serialosc/osc/ 46 | 47 | getLocalSocket :: Show a => HostName -> a -> IO (Socket, NS.AddrInfo) 48 | getLocalSocket host port = do 49 | (a:_) <- NS.getAddrInfo Nothing (Just host) (Just $ show port) 50 | s <- NS.socket (NS.addrFamily a) NS.Datagram NS.defaultProtocol 51 | return (s,a) 52 | 53 | sendsTo :: Show a => HostName -> a -> IO Socket 54 | sendsTo host port = do 55 | (s,a) <- getLocalSocket host port 56 | NS.connect s $ NS.addrAddress a 57 | return s 58 | 59 | receivesAt :: Show a => HostName -> a -> IO Socket 60 | receivesAt host port = do 61 | (s,a) <- getLocalSocket host port 62 | NS.bind s $ NS.addrAddress a 63 | return s 64 | -------------------------------------------------------------------------------- /learning/vivid/sched.hs: -------------------------------------------------------------------------------- 1 | import Vivid hiding (next) 2 | import Vivid.OSC 3 | import Control.Concurrent (forkIO, killThread) 4 | import Control.Concurrent.MVar 5 | 6 | 7 | unTimestamp :: Timestamp -> Double 8 | unTimestamp (Timestamp x) = x 9 | 10 | -- | proves Timestamps are ordinary numbers, measured in seconds 11 | testFomat = do 12 | x <- getTime 13 | print x 14 | wait 1 15 | y <- getTime 16 | print y 17 | print $ diffTimestamps y x 18 | 19 | -- | Do something every second, very nearly on the second 20 | -- (consistently 1 to 3 ms after the second) 21 | loop = do 22 | let loop = do x <- unTimestamp <$> getTime 23 | print x 24 | wait $ fromIntegral (ceiling x) - x 25 | unTimestamp <$> getTime >>= print 26 | print "" 27 | loop 28 | x <- forkIO loop 29 | getChar 30 | killThread x 31 | 32 | next :: RealFrac a => a -> a -> a -> a 33 | next time0 period now = 34 | fromIntegral (ceiling $ (now - time0) / period ) * period + time0 35 | 36 | -- | If you execute the following commands, with a good wait in between each: 37 | -- (l,ch) <- period 38 | -- ch 0.5 39 | -- killThread l 40 | -- you should see a print statement looped with an initial period of 1 Hz, 41 | -- which changes to 2 Hz when you run "ch 0.5". 42 | period = do 43 | time0 <- (+0.01) . unTimestamp <$> getTime >>= newMVar 44 | -- adding .01 makes it start in .01 seconds rather than 1 second 45 | period <- newMVar 1 46 | let loop = do 47 | now <- unTimestamp <$> getTime 48 | 49 | -- changes to time0 or period won't affect this cycle 50 | time0' <- readMVar time0 51 | period' <- readMVar period 52 | 53 | let nextCycle = next time0' period' now 54 | wait $ nextCycle - now 55 | print $ show now 56 | loop 57 | let chPeriod :: Double -> IO () 58 | chPeriod newPeriod = do 59 | now <- unTimestamp <$> getTime 60 | time0_value <- readMVar time0 61 | period_value <- readMVar period 62 | swapMVar time0 $ next time0_value period_value now 63 | swapMVar period newPeriod >> return () 64 | l <- forkIO loop 65 | return (l,chPeriod) 66 | -------------------------------------------------------------------------------- /Montevideo/Dispatch-Unused/Types.hs: -------------------------------------------------------------------------------- 1 | data SynthRegister' = -- per-synth boilerplate 2 | SynthRegister' { boops' :: MVar (M.Map SynthName (Synth BoopParams)) 3 | , vaps' :: MVar (M.Map SynthName (Synth VapParams)) 4 | , sqfms' :: MVar (M.Map SynthName (Synth SqfmParams)) 5 | -- , zots :: MVar (M.Map SynthName (Synth ZotParams)) 6 | } 7 | 8 | emptySynthRegister' :: IO SynthRegister 9 | emptySynthRegister' = do x <- newMVar M.empty 10 | y <- newMVar M.empty 11 | z <- newMVar M.empty 12 | -- w <- newMVar M.empty 13 | return $ SynthRegister x y z -- w 14 | 15 | -- | todo : this blocks if any MVar is empty 16 | showSynthRegister' :: SynthRegister -> IO String 17 | showSynthRegister' reg = do bs <- show <$> (readMVar $ boops reg) 18 | vs <- show <$> (readMVar $ vaps reg ) 19 | ss <- show <$> (readMVar $ sqfms reg) 20 | return $ bs ++ "\n" ++ vs ++ "\n" ++ ss 21 | 22 | data Dispatch' = Dispatch' { 23 | mTimeMuseqs' :: MVar (M.Map MuseqName (Time, Museq ScAction)) 24 | -- ^ Each `Time` here is the next time that Museq is scheduled to run. 25 | -- Rarely, briefly, those `Time` values will be in the past. 26 | , reg' :: SynthRegister 27 | , mTime0' :: MVar Time 28 | , mTempoPeriod' :: MVar Duration 29 | } 30 | 31 | -- | "new" because it's not really empty, except for `time0` 32 | newDispatch' :: IO Dispatch 33 | newDispatch' = do 34 | mTimeMuseqs <- newMVar M.empty 35 | reg <- emptySynthRegister 36 | mTime0 <- newEmptyMVar 37 | mTempoPeriod <- newMVar 1 38 | return Dispatch { mTimeMuseqs = mTimeMuseqs, reg = reg 39 | , mTime0 = mTime0 , mTempoPeriod = mTempoPeriod } 40 | 41 | data ScAction' where 42 | New' :: MVar (M.Map SynthName (Synth sdArgs)) 43 | -> SynthDef sdArgs 44 | -> SynthName -> ScAction' 45 | Free' :: MVar (M.Map SynthName (Synth sdArgs)) 46 | -> SynthName -> ScAction' 47 | Send' :: MVar (M.Map SynthName (Synth sdArgs)) 48 | -> SynthName 49 | -> Msg' sdArgs -> ScAction' 50 | 51 | -------------------------------------------------------------------------------- /mtv-lang/mtv-lang.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 34934cdc357aa3d841ae35295fb72477ba9151be3d178f49c564415c6af19b65 8 | 9 | name: mtv-lang 10 | version: 0.1.0.0 11 | description: https://github.com/JeffreyBenjaminBrown/montevideo 12 | homepage: https://github.com/JeffreyBenjaminBrown/montevideo 13 | bug-reports: https://github.com/JeffreyBenjaminBrown/montevideo/issues 14 | author: Jeffrey Benjamin Brown 15 | maintainer: jeffbrown.the@gmail.com 16 | copyright: Jeffrey Benjamin Brown 17 | license: GPL-3 18 | license-file: LICENSE 19 | build-type: Simple 20 | 21 | source-repository head 22 | type: git 23 | location: https://github.com/jeffreybenjaminbrown/montevideo/ 24 | 25 | library 26 | exposed-modules: 27 | Montevideo.Dispatch.Abbrevs 28 | , Montevideo.Dispatch.Config 29 | , Montevideo.Dispatch.Dispatch 30 | , Montevideo.Dispatch.Join 31 | , Montevideo.Dispatch.Join.Internal 32 | , Montevideo.Dispatch.Lazy.Interval 33 | , Montevideo.Dispatch.Lazy.Points 34 | , Montevideo.Dispatch.Lazy.Test.Points 35 | , Montevideo.Dispatch.Lazy.Util 36 | , Montevideo.Dispatch.Msg.Act 37 | , Montevideo.Dispatch.Museq 38 | , Montevideo.Dispatch.Museq.Mk 39 | , Montevideo.Dispatch.Recording 40 | , Montevideo.Dispatch.Time 41 | , Montevideo.Dispatch.Transform 42 | , Montevideo.Dispatch.Types 43 | , Montevideo.Dispatch.Types.Functions 44 | , Montevideo.Dispatch.Types.Many 45 | , Montevideo.Dispatch.Types.Time 46 | , Montevideo.Scale 47 | 48 | other-modules: 49 | -- Paths_montevideo 50 | build-depends: 51 | mtv-synth 52 | , mtv-util 53 | 54 | , base 55 | , bimap 56 | , bytestring 57 | , containers 58 | , either 59 | , HUnit 60 | , lens 61 | , megaparsec 62 | , pretty-simple 63 | , random 64 | , vector 65 | , vector-algorithms 66 | , vivid 67 | , vivid-osc 68 | , vivid-supercollider 69 | default-language: Haskell2010 70 | ghc-options: -Wall 71 | default-extensions: ScopedTypeVariables 72 | -------------------------------------------------------------------------------- /Montevideo/Monome/Test/JI.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-fields #-} 2 | 3 | module Montevideo.Monome.Test.JI where 4 | 5 | import Test.HUnit 6 | 7 | import Data.Either 8 | import qualified Data.Map as M 9 | 10 | import qualified Montevideo.Monome.Config.Mtv as Config 11 | import Montevideo.Monome.Types 12 | import Montevideo.Util 13 | import Montevideo.Monome.Window.JI 14 | import Montevideo.Synth 15 | import Montevideo.Synth.Msg 16 | 17 | 18 | tests :: Test 19 | tests = TestList [ 20 | TestLabel "test_jiFreq" test_jiFreq 21 | , TestLabel "test_jiKeySound" test_jiKeySound 22 | ] 23 | 24 | ja :: JiApp 25 | ja = JiApp { _jiFingers = error "meh" 26 | , _jiShifts = [1,3/2] 27 | , _jiGenerator = [1,5/4] } 28 | 29 | test_jiKeySound :: Test 30 | test_jiKeySound = TestCase $ do 31 | let f :: (X,Y) -> IO () 32 | f xy = let 33 | Right freq = jiFreq ja xy 34 | in do 35 | assertBool "sound on" $ jiKey_ScAction ja (VoiceId 3) (xy,True) 36 | == [ ScAction_New 37 | { _actionSynthDefEnum = Axe 38 | , _actionSynthName = VoiceId 3 39 | , _actionScParams = M.fromList 40 | [ ("freq", Config.freq * Config.jiTranspose * fr freq) 41 | , ("amp", Config.amp) ] } ] 42 | assertBool "sound off" $ jiKey_ScAction ja (VoiceId 4) (xy,False) 43 | == [ ScAction_Free 44 | { _actionSynthDefEnum = Axe 45 | , _actionSynthName = VoiceId 4 } ] 46 | mapM_ f [(0,0), (1,1), (1,3)] 47 | 48 | test_jiFreq :: Test 49 | test_jiFreq = TestCase $ do 50 | assertBool "nothing is out of range" $ 51 | isRight (jiFreq ja (10000,10000)) 52 | 53 | assertBool "unit" $ 54 | jiFreq ja (0,0) == Right 1 55 | assertBool "the other pitch in the generator" $ 56 | jiFreq ja (1,0) == Right (5/4) 57 | assertBool "the other (non-unity) shift" $ 58 | jiFreq ja (0,1) == Right (3/2) 59 | assertBool "shifted in both the generator and the shifts" $ 60 | jiFreq ja (1,1) == Right (15/8) 61 | 62 | assertBool "octave" $ 63 | jiFreq ja (0,2) == Right 2 64 | assertBool "octave + generator + shift" $ 65 | jiFreq ja (1,3) == Right (15/4) 66 | -------------------------------------------------------------------------------- /Montevideo/Random/RandomSignal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns, DataKinds #-} 2 | 3 | module Montevideo.Random.RandomSignal where 4 | 5 | import Vivid 6 | import Random.Types 7 | 8 | 9 | -- | This implements a maximum depth constraint and a minimum complexity one. 10 | -- The latter constraint is that a signal with a depth of 1 cannot be a or 11 | -- the name of another signal, because then it would just be a synonym. 12 | randAbSig :: RandConstraints -> IO AbSig 13 | randAbSig poss = do x <- pick $ maybeAParam ++ maybeGoDeeper ++ maybeAName 14 | x 15 | where poss' = poss {depth = depth poss + 1} 16 | maybeAParam = if depth poss > 1 17 | then [AbV <$> randAbParam poss'] else [] 18 | maybeGoDeeper = if depth poss < maxDepth poss 19 | then [ AbSigFormula <$> ranAbFormula poss' 20 | , AbSigGen <$> randAbGen poss' ] 21 | else [] 22 | maybeAName = if depth poss > 1 && namedSignals poss > 0 23 | then [AbSig <$> randAbSigName poss'] else [] 24 | 25 | ranAbFormula :: RandConstraints -> IO AbFormula 26 | ranAbFormula poss = do f <- pick [AbProd, AbSum] 27 | a <- randAbSig poss 28 | b <- randAbSig poss 29 | return $ f a b 30 | 31 | randAbGen :: RandConstraints -> IO AbGen 32 | randAbGen poss = do x <- pick [ randAbSaw poss 33 | , randAbSin poss ] 34 | x 35 | 36 | -- | = sinOsc abstraction 37 | randAbSin :: RandConstraints -> IO AbGen 38 | randAbSin poss = AbSin <$> randAbSinMsg poss 39 | 40 | randAbSinMsg :: RandConstraints -> IO AbSinMsg 41 | randAbSinMsg poss = do a <- randAbSig poss 42 | b <- randAbSig poss 43 | return $ AbSinMsg a b 44 | 45 | 46 | -- | = AbSaw 47 | randAbSaw :: RandConstraints -> IO AbGen 48 | randAbSaw poss = AbSaw <$> randAbSawMsg poss 49 | 50 | randAbSawMsg :: RandConstraints -> IO AbSawMsg 51 | randAbSawMsg poss = AbSawMsg <$> randAbSig poss 52 | 53 | randAbSigName :: RandConstraints -> IO AbSigName 54 | randAbSigName cstrs = 55 | pick $ take (namedSignals cstrs) theAbSigNames 56 | 57 | randAbParam :: RandConstraints -> IO AbParam 58 | randAbParam cs = pick $ take (nParams cs) theAbParams 59 | -------------------------------------------------------------------------------- /Montevideo/Synth/Vap.ghci.hs: -------------------------------------------------------------------------------- 1 | :set -XDataKinds 2 | s <- synth vap () 3 | 4 | 5 | -- | just sin fm 6 | set s (400 :: I "freq") 7 | set s (400 :: I "fm-amp") 8 | set s (750 :: I "fm-freq") 9 | 10 | set s (100 :: I "freq") 11 | set s (400 :: I "fm-amp") 12 | set s (750 :: I "fm-freq") 13 | 14 | set s (300 :: I "freq") 15 | set s (300 :: I "fm-amp") 16 | set s (66.66 :: I "fm-freq") 17 | 18 | set s (300 :: I "freq") 19 | set s (350 :: I "fm-amp") 20 | set s (66.66 :: I "fm-freq") 21 | 22 | 23 | -- | just sine fm with the fm scaled by noise 24 | 25 | set s (300 :: I "freq") 26 | set s (500 :: I "fm2-amp") 27 | set s (100 :: I "fm2-freq") 28 | set s (500 :: I "nz-lpf") 29 | 30 | set s (300 :: I "freq") 31 | set s (5000 :: I "fm2-amp") 32 | set s (100 :: I "fm2-freq") 33 | set s (500 :: I "nz-lpf") 34 | 35 | set s (300 :: I "freq") 36 | set s (5000 :: I "fm2-amp") 37 | set s (100 :: I "fm2-freq") 38 | set s (5 :: I "nz-lpf") 39 | 40 | -- warble, beautiful 41 | set s (300 :: I "freq") 42 | set s (10000 :: I "fm2-amp") 43 | set s (20 :: I "fm2-freq") 44 | set s (5 :: I "nz-lpf") 45 | 46 | set s (300 :: I "freq") 47 | set s (3000 :: I "fm2-amp") 48 | set s (300 :: I "fm2-freq") 49 | set s (50 :: I "nz-lpf") 50 | 51 | -- | now with some saw too 52 | set s (1 :: I "saw") 53 | set s (300 :: I "freq") 54 | set s (500 :: I "fm2-amp") 55 | set s (100 :: I "fm2-freq") 56 | set s (500 :: I "nz-lpf") 57 | 58 | set s (1 :: I "saw") 59 | set s (300 :: I "freq") 60 | set s (5000 :: I "fm2-amp") 61 | set s (100 :: I "fm2-freq") 62 | set s (500 :: I "nz-lpf") 63 | 64 | set s (1 :: I "saw") 65 | set s (300 :: I "freq") 66 | set s (5000 :: I "fm2-amp") 67 | set s (100 :: I "fm2-freq") 68 | set s (5 :: I "nz-lpf") 69 | 70 | -- ribbony, beautiful 71 | set s (1 :: I "saw") 72 | set s (300 :: I "freq") 73 | set s (10000 :: I "fm2-amp") 74 | set s (20 :: I "fm2-freq") 75 | set s (5 :: I "nz-lpf") 76 | 77 | set s (0.5 :: I "saw") 78 | set s (300 :: I "freq") 79 | set s (3000 :: I "fm2-amp") 80 | set s (300 :: I "fm2-freq") 81 | set s (50 :: I "nz-lpf") 82 | 83 | -- | with feedback 84 | set s (0.5 :: I "saw") 85 | set s (300 :: I "freq") 86 | set s (3000 :: I "fm2-amp") 87 | set s (300 :: I "fm2-freq") 88 | set s (50 :: I "nz-lpf") 89 | set s (0.4 :: I "delay-amp") 90 | set s (0.3 :: I "delay-freq") 91 | -------------------------------------------------------------------------------- /Montevideo/Dispatch-Unused/Parse/Utils.hs: -------------------------------------------------------------------------------- 1 | module Montevideo.Dispatch.Parse.Utils where 2 | 3 | import Data.Void 4 | import Text.Megaparsec 5 | import qualified Text.Megaparsec.Char as C 6 | import qualified Text.Megaparsec.Char.Lexer as L 7 | 8 | 9 | type Parser = Parsec Void String 10 | 11 | sc :: Parser () 12 | sc = L.space C.space1 empty empty 13 | 14 | tryEach :: [Parser a] -> Parser a 15 | tryEach = foldr1 (<|>) . map try 16 | 17 | parens :: Parser a -> Parser a 18 | parens = between (L.symbol sc "(") (L.symbol sc ")") 19 | 20 | brackets :: Parser a -> Parser a 21 | brackets = between (L.symbol sc "[") (L.symbol sc "]") 22 | 23 | wordChar :: Parser Char 24 | wordChar = C.alphaNumChar <|> C.char '_' <|> C.char '\'' 25 | 26 | -- | Succeeds only if the next character is not a word character. Examples: 27 | -- M.parse (word "monk") "" "monkey" -- fails 28 | -- M.parse (word "monk") "" "monk eye" -- works 29 | -- M.parse (word "monk") "" "monk. eye" -- works 30 | word :: String -> Parser String 31 | word w = try $ L.lexeme sc $ C.string w <* notFollowedBy wordChar 32 | 33 | anyWord :: Parser String 34 | anyWord = L.lexeme sc $ some wordChar <* notFollowedBy wordChar 35 | 36 | -- | Per this, negative signs must abut the numbers they negate. 37 | -- TODO: parse floats more flexibly 38 | -- actually even easier than the below would be just try three things: 39 | -- first try scientific 40 | -- if not that try decimal-int 41 | -- if not that try int 42 | -- goal: make it accept numbers without a decimal point, or with 43 | -- no digits to the right of it. 44 | -- L.scientific doesn't accept those things either. 45 | -- pseudocode: 46 | -- parse the sign, or not, using option. return for that either 1 or -1. 47 | -- parse (as a string!) an int, or not, using option, with default = "0" 48 | -- parse (as a string!) a period, or not, using option, with default = "." 49 | -- parse (as a string!) an int, or not, using option, with default = "0" 50 | -- for each of those strings that is missing, fill it with a default value 51 | -- build a new number 52 | -- parse it using a built-in function like L.float or L.scientific 53 | -- multiply that by the sign 54 | signedFloat :: Parser Float 55 | signedFloat = L.signed nothing L.float where nothing = return () 56 | -------------------------------------------------------------------------------- /Montevideo/Monome/Window/Change.hs: -------------------------------------------------------------------------------- 1 | -- | A window for changing what windows are on a monome. 2 | 3 | {-# LANGUAGE ScopedTypeVariables 4 | , TupleSections 5 | #-} 6 | 7 | module Montevideo.Monome.Window.Change ( 8 | changeWindow 9 | ) where 10 | 11 | import Prelude hiding (pred) 12 | import Control.Lens hiding (Choice) 13 | import qualified Data.List as L 14 | 15 | import Montevideo.Monome.Types.Most 16 | import Montevideo.Util 17 | 18 | 19 | -- | PITFALL: None of the `Window`s described by a `Choice` 20 | -- should overwrite the `ChangeWindow` itself. 21 | -- If it does, that `Window` will be inescapable. 22 | type Choice app = [ ( (X,Y) -- ^ the top-left corner 23 | , Window app ) ] 24 | 25 | label :: WindowId 26 | label = ChangeWindow 27 | 28 | changeWindow 29 | :: [Choice app] -- ^ PITFALL: The choices should not include 30 | -- the ChangeWindow. (If they did the recursion would never stop.) 31 | -- Instead, `handler` finds the current `ChangeWindow` 32 | -- and puts it at the front of the new list. 33 | -> Window app 34 | changeWindow choices = Window { 35 | windowLabel = label 36 | , windowContains = \(x,y) -> 37 | x == 0 38 | && numBetween 0 (length choices - 1) y 39 | , windowInitLeds = \_ _ -> Right [] 40 | , windowHandler = \x y -> return $ handler choices x y } 41 | 42 | handler :: forall app. 43 | [Choice app] 44 | -> St app -> (MonomeId, ((X,Y), Switch)) 45 | -> Either String (St app) 46 | handler _ st (_, (_, False)) = 47 | Right st 48 | 49 | handler choices st (mi, ((_,y), True )) = let 50 | c :: Choice app = choices !! y -- safe thanks to `windowContains` above 51 | Just layers = st ^. stWindowLayers . at mi 52 | Just (thisChangeWindow :: ((X,Y), Window app)) = 53 | L.find f layers where 54 | f :: ((X,Y), Window app) -> Bool 55 | f (_,window) = windowLabel window == ChangeWindow 56 | in Right $ st 57 | & ( stWindowLayers . at mi . _Just %~ 58 | const (thisChangeWindow : c) ) 59 | & ( stPending_Monome %~ 60 | flip (++) ( map ((mi,label),) 61 | $ [ ((0,y'), False) 62 | | y' <- [0 .. length choices - 1] ] 63 | ++ [((0,y), True)] ) ) 64 | -------------------------------------------------------------------------------- /Montevideo/JI/Dead.hs: -------------------------------------------------------------------------------- 1 | -- | WHAT THIS IS 2 | -- I never use these things any more, 3 | -- and probably never will again, but *just might*, 4 | -- so I'm keeping them around. 5 | -- 6 | -- They probably still worked as of 7 | -- commit 768e6798aac3b59f4cee8f35a586ff8a8994eb6b 8 | -- (which is just before they were relegated to here). 9 | 10 | looking :: Integer -> Integer -> [(Integer, [Integer])] 11 | looking minNotes maxNotes = let 12 | f (_, _errs) = 13 | ( and $ zipWith (>=) tols $ map abs _errs ) 14 | in filter f $ matrix minNotes maxNotes -- & map (_2 %~ take 5) 15 | 16 | matrix :: Integer -> Integer -> [(Integer, [Integer])] 17 | matrix minNotes maxNotes = 18 | [ (d, map (round . (^. _2 . _3)) $ bests d) 19 | | d <- [minNotes .. maxNotes] ] 20 | 21 | -- | A damage measure. 22 | -- Unless the `map (uncurry ...)` clause is commented out, 23 | -- lower primes weigh more. 24 | -- For instance, here's a way to find the best 25 | -- (by one definition) of the first 60 EDOs. 26 | -- myPrint $ filter ((< 290) . snd) $ [(n, errorSum [4..8] n) | n <- [1..60]] 27 | errorSum 28 | :: [Double] -- ^ How to weigh the first 5 primes. 29 | -- For example, if weights is [4..8], 30 | -- then prime 3 weighs twice what 13 does, with 31 | -- other primes' weights scaling linearly between. 32 | -- If zipped with (repeat 1), the weights are uniform. 33 | -> Integer 34 | -> Integer 35 | 36 | errorSum weights = 37 | round . sum . map abs 38 | . ( let 39 | mean = sum weights / fromIntegral (length weights) 40 | weights' = (/mean) <$> weights 41 | -- Normalizing by the mean makes `errorSum` 42 | -- values comparable across different weights. 43 | in map (uncurry (/)) 44 | . flip zip weights') 45 | . map (^. _2 . _3) 46 | . bests 47 | 48 | errSearch :: [Integer] -> [(Integer,Double)] 49 | errSearch edos = 50 | zip edos $ 51 | map (sum_errs $ map (\x -> 1/x**(3/2)) [2..]) edos 52 | 53 | -- | `sum_errs d` gives the sum of the absolute values of the errors 54 | -- of `d`-edo in approximating the harmonics of interest. 55 | sum_errs 56 | :: [Double] -- ^ How to weight the harmonics. 57 | -> Integer 58 | -> Double 59 | sum_errs weights d = sum $ map square $ zipWith (*) weights $ 60 | abs . err_of_best <$> bests d 61 | where 62 | square x = x*x 63 | err_of_best (_,(_,_,e)) = e 64 | -------------------------------------------------------------------------------- /Montevideo/Dispatch-Unused/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Montevideo.Dispatch.Parse where 4 | 5 | import Text.Megaparsec as M 6 | import qualified Text.Megaparsec.Char as C 7 | import qualified Text.Megaparsec.Char.Lexer as L 8 | import Control.Monad.Combinators (sepBy1) 9 | 10 | import Vivid 11 | import Dispatch.Types 12 | import Dispatch.Act 13 | import Dispatch.Parse.Params 14 | import Dispatch.Parse.Utils 15 | import Synths 16 | 17 | 18 | synthDefName :: Parser SynthDefEnum 19 | synthDefName = foldr1 (<|>) [ word "boop" >> return Boop 20 | , word "vap" >> return Vap 21 | , word "sqfm" >> return Sqfm 22 | ] 23 | 24 | msgs :: SynthRegister -> Parser [ScAction'] 25 | msgs reg = concat <$> 26 | sepBy1 (homogeneousMsgs reg) (L.lexeme sc $ C.string ",") 27 | 28 | -- | msgs all of the same type, e.g. a bunch of News, or a bunch of Frees 29 | homogeneousMsgs :: SynthRegister -> Parser [ScAction'] 30 | homogeneousMsgs reg = L.lexeme sc $ foldl1 (<|>) 31 | [ parseNews reg, parseFrees reg, parseSends reg ] 32 | 33 | -- everything below includes per-synth boilerplate 34 | 35 | parseNews :: SynthRegister -> Parser [ScAction'] 36 | parseNews reg = do 37 | word "new" 38 | synthDef <- synthDefName 39 | names <- M.many anyWord 40 | case synthDef of 41 | Boop -> return $ map (New' (boops reg) boop) names 42 | Vap -> return $ map (New' (vaps reg) vap ) names 43 | Sqfm -> return $ map (New' (sqfms reg) sqfm) names 44 | 45 | parseFrees :: SynthRegister -> Parser [ScAction'] 46 | parseFrees reg = do 47 | word "free" 48 | synthDef <- synthDefName 49 | names <- M.many $ anyWord 50 | return $ case synthDef of 51 | Boop -> map (Free' $ boops reg) names 52 | Vap -> map (Free' $ vaps reg) names 53 | Sqfm -> map (Free' $ sqfms reg) names 54 | 55 | parseSends :: SynthRegister -> Parser [ScAction'] 56 | parseSends reg = do 57 | word "send" 58 | synthDef <- synthDefName 59 | name <- anyWord 60 | case synthDef of 61 | Boop -> do msgs <- M.many $ parseBoopMsg 62 | return $ map (Send' (boops reg) name) msgs 63 | Vap -> do msgs <- M.many $ parseVapMsg 64 | return $ map (Send' (vaps reg) name) msgs 65 | Sqfm -> do msgs <- M.many $ parseSqfmMsg 66 | return $ map (Send' (sqfms reg) name) msgs 67 | -------------------------------------------------------------------------------- /Montevideo/Dispatch-Unused/Scheduling_and_CSV.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module Montevideo.Dispatch.Test.Scheduling_and_CSV where 4 | 5 | import Data.ByteString.Lazy.Char8 (unpack) 6 | import Control.Concurrent.MVar 7 | import Data.Csv 8 | import Data.List.Split (splitOn) 9 | import GHC.Generics (Generic) 10 | 11 | import Vivid 12 | import Util 13 | import Dispatch.Config 14 | import Dispatch.Types 15 | import Dispatch.Dispatch 16 | import Dispatch.Museq 17 | 18 | 19 | -- | = arc is messed up 20 | 21 | --m = museq 5 [((0,6),"a"),((2,4),"b")] 22 | -- 23 | --arcTest1 = arcIO 0 0.99 0 10 m 24 | --arcTest2 = arcIO 100 0.99 100 110 m 25 | --arcTest3 = arcIO 0 1.01 0 10 m 26 | --arcTest4 = arcIO 100 1.01 100 110 m -- TODO BUG 27 | -- -- The bug: Again, floating point error: 28 | -- -- pp0 is sometimes off by one. 29 | 30 | testChTempoPeriod :: Dispatch -> Duration -> IO Frame 31 | testChTempoPeriod disp newTempoPeriod = do 32 | time0 <- readMVar $ mTime0 disp 33 | tempoPeriod <- readMVar $ mTempoPeriod disp 34 | now <- unTimestamp <$> getTime 35 | let np0 = nextPhase0 time0 frameDuration now 36 | startRender = np0 + 2 * frameDuration 37 | startRenderInCycles = (startRender - time0) / tempoPeriod 38 | newTime0 = startRender - startRenderInCycles * newTempoPeriod 39 | return $ Frame { frameTempoPeriod = fromRational $ tempoPeriod 40 | , frameNow = fromRational $ toRational now - time0 41 | , frameNp0 = fromRational $ np0 - time0 42 | , frameStartRender = fromRational $ startRender - time0 43 | , frameStartRenderInCycles = 44 | fromRational $ startRenderInCycles 45 | , frameNewTime0 = fromRational $ newTime0 - time0 46 | } 47 | 48 | data Frame = Frame { frameTempoPeriod :: Double 49 | , frameNow :: Double 50 | , frameNp0 :: Double 51 | , frameStartRender :: Double 52 | , frameStartRenderInCycles :: Double 53 | , frameNewTime0 :: Double} deriving (Show, Generic) 54 | 55 | -- Generics magic 56 | instance FromNamedRecord Frame 57 | instance ToNamedRecord Frame 58 | instance DefaultOrdered Frame 59 | 60 | encodeExample = splitOn "\r\n" $ unpack 61 | $ encodeDefaultOrderedByName [Frame 1 1 1 1 1 1] 62 | 63 | -------------------------------------------------------------------------------- /Montevideo/Monome/Test/EdoMath.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-fields #-} 2 | 3 | module Montevideo.Monome.Test.EdoMath where 4 | 5 | import qualified Data.Map as M 6 | import Test.HUnit 7 | 8 | import Montevideo.Monome.EdoMath 9 | import Montevideo.Monome.Types 10 | 11 | 12 | tests :: Test 13 | tests = TestList [ 14 | TestLabel "test_pcToLowXY" test_pcToLowXY 15 | , TestLabel "test_pcToXys" test_pcToXys 16 | , TestLabel "test_xyChangeMonome" test_xyChangeMonome 17 | ] 18 | 19 | test_xyChangeMonome :: Test 20 | test_xyChangeMonome = TestCase $ do 21 | let app = EdoApp { _edoKeyboards = M.fromList 22 | [ (Monome_256, Keyboard { _kbdShift = (0,1) } ) 23 | , (Monome_old, Keyboard { _kbdShift = (1,0) } ) ] } 24 | assertBool "" $ xyChangeMonome app Monome_256 Monome_old 25 | (0,1) == Right (1,0) 26 | assertBool "" $ xyChangeMonome app Monome_256 Monome_old 27 | (1,1) == Right (2,0) 28 | 29 | test_pcToXys :: Test 30 | test_pcToXys = TestCase $ do 31 | let ec = MonomeEdo { _spacing = 6 32 | , _edo = 31 33 | , _skip = 1 34 | , _gridVectors = Nothing 35 | } 36 | assertBool "" $ pcToXys ec (0,0) 0 37 | == [(0,0),(5,1),(4,7),(3,13),(10,2),(9,8),(8,14),(15,3),(14,9),(13,15)] 38 | assertBool "" $ pcToXys ec (0,1) 0 39 | == [(0,1),(5,2),(4,8),(3,14),(10,3),(9,9),(8,15),(15,4),(14,10)] 40 | assertBool "" $ pcToXys ec (0,0) 0 == 41 | pcToXys ec (0,0) 31 42 | assertBool "" $ pcToXys ec (1,2) 31 == 43 | pcToXys ec (1,2) 62 44 | 45 | test_pcToLowXY :: Test 46 | test_pcToLowXY = TestCase $ do 47 | let ec = MonomeEdo { _spacing = 6 48 | , _skip = 1 49 | , _edo = 31 50 | , _gridVectors = Nothing } 51 | 52 | assertBool "pcToLowXY" $ pcToLowXY ec 0 == (0,0) 53 | assertBool "pcToLowXY" $ pcToLowXY ec (31 + 0) == (0,0) 54 | 55 | assertBool "pcToLowXY" $ pcToLowXY ec 1 == (0,1) 56 | assertBool "pcToLowXY" $ pcToLowXY ec (31 + 1) == (0,1) 57 | 58 | assertBool "pcToLowXY" $ pcToLowXY ec 6 == (0,6) 59 | assertBool "pcToLowXY" $ pcToLowXY ec (31 + 6) == (0,6) 60 | 61 | assertBool "pcToLowXY" $ pcToLowXY ec 7 == (0,7) 62 | assertBool "pcToLowXY" $ pcToLowXY ec (31 + 7) == (0,7) 63 | -------------------------------------------------------------------------------- /Montevideo/Synth/Envelope.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, ExtendedDefaultRules #-} 2 | 3 | module Montevideo.Synth.Envelope where 4 | 5 | import Vivid 6 | 7 | 8 | cheapDistortion :: ToSig i a 9 | => i -> SDBody' a Signal 10 | cheapDistortion s = s ~/ (1 ~+ abs' s) 11 | 12 | -- | PITFALL: "on" should only take on the values 0 or 1. 13 | -- | PITFALL: "on" is a little misleading, as when it switches from 1 to 0, 14 | -- the envelope does not immediately end; rather, it begins to ramp down to 0. 15 | -- | USAGE: When "on" becommes 1, the envelope swells from 0 to 1. 16 | -- When it becomes 0, the envelope falls from 1 to 0. 17 | -- The signals "att" and "rel" give the attack and release times. 18 | -- 19 | -- An ADSR envelope would be more natural (and flexible) than the 20 | -- following weird patch of two envelopes, but I couldn't figure ADSR out. 21 | 22 | onOffEnvelope :: 23 | ( Elem "on" a -- | Switch this to 0 to begin the release phase. 24 | , Elem "att" a -- | Duration of attack in seconds. 25 | , Elem "rel" a -- | Duration of release in seconds. 26 | ) => SDBody' a Signal 27 | onOffEnvelope = let 28 | onEnv = envGen_wGate -- The "on (swell) envelope". 29 | (V::V "on") 30 | (V::V "att") 31 | ( env 0 -- This initial 0 is not revisited on retriggering 32 | -- (which happens each time the gate becomes positive). 33 | [ (0,0) -- Hence this silly-looking first pair, 34 | -- which says "go to level 0 in 0 seconds". 35 | , (1,1) ] 36 | Curve_Cubed ) 37 | DoNothing 38 | offEnv = -- The "off (decay) envelope". 39 | biOp Max (V::V "on") -- Must take the Max of "on" and the envelope below, 40 | -- because once the off envelope falls to 0, 41 | -- it stays there until it is triggered again. 42 | -- In particular it is 0 even when onEnv triggers. 43 | ( envGen_wGate -- The "off envelope". 44 | ((1 :: Float) ~- (V::V "on")) 45 | (V::V "rel") 46 | (env 1 -- This initial 1 is not revisited on retriggering 47 | -- (which happens each time the gate becomes positive). 48 | [ (1,0) -- Hence this silly-looking first pair, 49 | -- which says "go to level 1 in 0 seconds". 50 | , (0,1) ] 51 | Curve_Lin) 52 | DoNothing ) 53 | in onEnv ~* offEnv 54 | -------------------------------------------------------------------------------- /common-mods/print-on-each-monome-keypress.diff: -------------------------------------------------------------------------------- 1 | diff --git a/mtv-monome/Montevideo/Monome/Main.hs b/mtv-monome/Montevideo/Monome/Main.hs 2 | index 95fdead..777d3e2 100644 3 | --- a/mtv-monome/Montevideo/Monome/Main.hs 4 | +++ b/mtv-monome/Montevideo/Monome/Main.hs 5 | @@ -300,8 +300,9 @@ doScAction st sca = 6 | let setVivid :: Synth ZotParams -> (ParamName, Float) -> IO () 7 | setVivid s (param, f) = 8 | mapM_ (set' s) $ zotScParams $ M.singleton param f 9 | - in 10 | - case sca of 11 | + tempShow = return () -- putStrLn $ show sca 12 | + 13 | + in case sca of 14 | 15 | ScAction_Send _ _ _ -> do 16 | let vid :: VoiceId = _actionSynthName sca 17 | @@ -310,7 +311,7 @@ doScAction st sca = 18 | Right $ (_stVoices st M.! vid) ^. voiceSynth 19 | let ios :: [IO ()] = -- Send each (key,val) from `sca` separately. 20 | map (setVivid s) $ M.toList $ _actionScParams sca 21 | - Right $ mapM_ id ios >> return id 22 | + Right $ tempShow >> mapM_ id ios >> return id 23 | 24 | ScAction_New _ _ _ -> do 25 | let vid :: VoiceId = _actionSynthName sca 26 | @@ -318,14 +319,15 @@ doScAction st sca = 27 | ++ " (but not yet with a synth) in _stVoices.") 28 | Right $ M.lookup vid $ _stVoices st 29 | Right $ do 30 | + tempShow 31 | s <- synth zot () -- TODO change zot to `_actionSynthDefEnum sca` 32 | let ios :: [IO ()] = map (setVivid s) $ M.toList $ _actionScParams sca 33 | mapM_ id ios 34 | return $ stVoices . at vid . _Just . voiceSynth .~ Just s 35 | 36 | -- PITFALL: If a voice is deleted right away, 37 | - -- there's usually an audible pop. 38 | - -- (It depends on how far the waveform is displaced from 0.) 39 | + -- there's an audible pop 40 | + -- (unless the waveform is barely displaced from 0). 41 | -- To avoid that, this first sends an `amp=0` message, 42 | -- and then waits for a duration defined in Monome.Config. 43 | -- That smooths the click because amp messages are responded to 44 | @@ -340,6 +342,7 @@ doScAction st sca = 45 | (Left $ "Voice " ++ show vid ++ " has no assigned synth.") 46 | Right $ _voiceSynth v 47 | Right $ do 48 | + tempShow 49 | Timestamp now <- getTime 50 | set s (0 :: I "on") 51 | doScheduledAt ( Timestamp $ now + 52 | -------------------------------------------------------------------------------- /Montevideo/Monome/Types/Edo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Montevideo.Monome.Types.Edo 4 | ( GridVectorPair(..) 5 | , gridVerticalVector, gridHorizontalVector 6 | , MonomeEdo(..) 7 | , edo, spacing, skip, octaveStretchInCents, gridVectors 8 | ) where 9 | 10 | import Control.Lens 11 | 12 | import Montevideo.Monome.Types.Monome 13 | 14 | 15 | -- ^ If _skip = 1, then the grid vectors can be left Nothing; 16 | -- the system will figure out what they should be. 17 | -- But For Thanos tunings, the grid vectors must be manually defined. 18 | -- The "vertical" vector indicates, given a pitch at (0,0), 19 | -- the nearest enharmonic pitch is in a nearby columns. 20 | -- The "horizontal" vector indicates, given a pitch at (0,0), 21 | -- the nearest octave to that pitch in a nearby row. 22 | -- 23 | -- Note that both vectors are rarely truly orthogonal to the axes. 24 | 25 | data GridVectorPair = GridVectorPair 26 | { _gridHorizontalVector :: (X,Y) 27 | , _gridVerticalVector :: (X,Y) 28 | } deriving (Show, Eq, Ord) 29 | makeLenses ''GridVectorPair 30 | 31 | -- | PITFALL: This looks like it should be defined with the other types, 32 | -- but doing that causes a cycle of imports, 33 | -- because some synth code uses this, and the other types use the synths. 34 | data MonomeEdo = MonomeEdo 35 | { _edo :: Int -- ^ The EDO. For most music, this value is 12. 36 | , _spacing :: Int -- ^ The distance in steps of the EDO between columns 37 | -- of buttons on the monome. Positive numbers only. 38 | -- For a guitar-like layout, edo=12 and spacing=5. 39 | -- Some other (edo,spacing) pairs I like: 40 | -- (31,6), (41,6), (46,7), (87,12 or 13) 41 | , _skip :: Int -- ^ You'll probably want this to be 1, in which case 42 | -- each button in a column is one EDO-step lower than the one below it. 43 | -- For the Kite Guitar tuning, set (edo,spacing,skip) = (41,13,2). 44 | , _octaveStretchInCents :: Double -- ^ Set to 0 for pure EDO (ED-2). 45 | -- For some useful recomendations re. stretch values, see 46 | -- http://x31eq.com/temper/net.html 47 | -- Some particularly good (edo, stretch) values: 48 | -- 22 edo, -1.106 cents (TET-optimal in the 11-limit) 49 | -- 31 edo, 0.502 cents (TET-optimal in the 13-limit) 50 | , _gridVectors :: Maybe GridVectorPair 51 | } deriving (Show, Eq, Ord) 52 | makeLenses ''MonomeEdo 53 | -------------------------------------------------------------------------------- /Montevideo/ReadHsAsGhci.hs: -------------------------------------------------------------------------------- 1 | -- | = Use it this like `:lexeme readHsAsGhci "folder/filename.hs"` 2 | -- or better yet, make a macro: `:def! . readHsAsGhci` 3 | -- and then call it like this: `:. folder/file.hs` 4 | -- (Note that no quotation marks surround the filepath in the macro.) 5 | 6 | -- This is a duplicate of the code in my ReadHsAsGhci repo. 7 | -- todo: the clever Git thing that avoids such repo duplication 8 | 9 | module Montevideo.ReadHsAsGhci ( 10 | readHsAsGhci 11 | -- , Line 12 | -- , line 13 | -- , ignorable 14 | -- , emptyLine 15 | -- , comment 16 | -- , start 17 | -- , more 18 | -- , hsToGhci 19 | ) where 20 | 21 | import Control.Applicative 22 | import Data.Void (Void) 23 | import Text.Megaparsec 24 | import Text.Megaparsec as Megp 25 | import Text.Megaparsec.Char (space) 26 | 27 | 28 | type Parser = Parsec Void String 29 | 30 | -- | Parse multiple indented lines of a .hs file, for the :lexeme directive 31 | data Line = Ignore | Start String | More String deriving Show 32 | 33 | line :: Parser Line 34 | line = foldl1 (<|>) $ map try [emptyLine,comment,start,more] 35 | 36 | ignorable :: Line -> Bool 37 | ignorable Ignore = True 38 | ignorable _ = False 39 | 40 | emptyLine :: Parser Line 41 | emptyLine = space >> eof >> return Ignore 42 | 43 | comment :: Parser Line 44 | comment = space >> satisfy (== '-') >> satisfy (== '-') 45 | >> skipMany anySingle >> eof >> return Ignore 46 | 47 | start :: Parser Line 48 | start = do c <- satisfy (/= ' ') 49 | rest <- Megp.many anySingle 50 | return $ Start $ c : rest 51 | 52 | more :: Parser Line 53 | more = do c <- satisfy (== ' ') 54 | rest <- Megp.many anySingle 55 | return $ More $ c : rest 56 | 57 | hsToGhci :: String -> Either (ParseErrorBundle String Void) String 58 | hsToGhci s0 = do s1 <- mapM (parse line "") $ lines s0 59 | let s2 = filter (not . ignorable) s1 60 | f (Start s) = [":}",":{",s] 61 | f (More s) = [s] 62 | f Ignore = error "impossible; we filtered these out" 63 | s3 = concatMap f s2 64 | return $ unlines $ tail s3 ++ [":}"] 65 | 66 | readHsAsGhci :: FilePath -> IO String 67 | readHsAsGhci filename = do 68 | s <- readFile $ filename ++ ".hs" 69 | case hsToGhci s of Left e -> (putStrLn $ show e) >> return "" 70 | Right s' -> return s' 71 | -------------------------------------------------------------------------------- /Montevideo/Monome/Config/Monome/HandTest.hs: -------------------------------------------------------------------------------- 1 | -- * This is for configuring the monome itself -- 2 | -- reading and writing the port that it uses, the prefix it filters by, etc. 3 | 4 | module Montevideo.Monome.Config.Monome.HandTest where 5 | 6 | import qualified Network.Socket.ByteString as NSB 7 | import Vivid.OSC 8 | 9 | import Montevideo.Monome.Network.Util 10 | import Montevideo.Monome.Types.Device 11 | 12 | 13 | -- :set -XOverloadedStrings 14 | 15 | -- | Test the monome. 16 | 17 | -- | This documentation for serialosc is critical: 18 | -- https://monome.org/docs/serialosc/osc/ 19 | -- How to interpret it: Something like `/serialosc/list si ` 20 | -- means `/serialosc/list` takes two arguments, a string and an int, 21 | -- the first being the host and the second being the port. 22 | -- 23 | -- This documentation is worse and hopefully unnecessary: 24 | -- https://monome.org/docs/serialosc/serial.txt 25 | 26 | -- | Before any of the following, run this in a separate GHCI instance, 27 | -- to read output from the commands below. 28 | -- (I don't know where the magic number 8000 comes from.) 29 | -- listenAndLogOsc 8000 30 | 31 | -- | To find all connected monomes. In particular, 32 | -- the last item in each response indicates which port that monome listens to, 33 | -- which is what makes creating the `sendsTo` instances below possible. 34 | -- toSerialosc <- sendsTo (Char8.unpack localhost) 12002 35 | -- send toSerialosc $ requestDeviceList 8000 36 | 37 | -- | To find more information about a monome, do the following. 38 | -- (It requires knowing which port number a monome listens to; 39 | -- run `requestDeviceList` as above to get that. 40 | -- toMonome128 <- sendsTo (Char8.unpack localhost) (monomePort Monome_128) 41 | -- toMonome256 <- sendsTo (Char8.unpack localhost) (monomePort Monome_256) 42 | -- send toMonome128 $ requestDeviceInfo 8000 43 | -- send toMonome256 $ requestDeviceInfo 8000 44 | 45 | -- | To change the prefix a monome filters by: 46 | -- send toMonome128 $ encodeOSC $ OSC "/sys/prefix" [ OSC_S "128" ] 47 | -- send toMonome256 $ encodeOSC $ OSC "/sys/prefix" [ OSC_S "256" ] 48 | 49 | -- | To change its rotation: 50 | -- send toMonome128 $ encodeOSC $ OSC "/sys/rotation" [ OSC_I 90 ] 51 | 52 | -- | To test a monome's LEDs: 53 | -- send toMonome $ fade "/128" 0 1 15 -- 15 is brightness 54 | -- lower nonzero brightness values are like 0 on one of the monomes 55 | -- send toMonome $ ledOsc "/256" ((6,6) , True) 56 | -------------------------------------------------------------------------------- /Montevideo/Monome/Types/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | module Montevideo.Monome.Types.Instances where 6 | 7 | import Montevideo.Monome.Types.Most 8 | 9 | 10 | instance Eq (Window app) where 11 | (==) a b = windowLabel a == windowLabel b 12 | 13 | instance Show (Window app) where 14 | show = show . windowLabel 15 | 16 | instance Show (Pitch app) => Show (Voice app) where 17 | show v = "Voice " 18 | ++ "{ _voiceSynth = " ++ show (_voiceSynth v) 19 | ++ "{ _voicePitch = " ++ show (_voicePitch v) 20 | ++ "{ _voiceParams = " ++ show (_voiceParams v) 21 | 22 | instance Eq (Pitch app) => Eq (Voice app) where 23 | a == b = and 24 | [ _voiceSynth a == _voiceSynth b 25 | , _voicePitch a == _voicePitch b 26 | , _voiceParams a == _voiceParams b ] 27 | 28 | instance (Show app, Show (Pitch app)) => Show (St app) where 29 | show app = "St " 30 | ++ "{ _stApp app = " ++ show (_stApp app) 31 | ++ ", _stWindowLayers app = " ++ show (_stWindowLayers app) 32 | ++ ", _stToMonomes app = " ++ show (_stToMonomes app) 33 | ++ ", _stVoices app = " ++ show (_stVoices app) 34 | ++ ", _stPending_Monome app = " ++ show (_stPending_Monome app) 35 | ++ ", _stPending_Vivid app = " ++ show (_stPending_Vivid app) 36 | 37 | instance (Eq app, Eq (Pitch app)) => Eq (St app) where 38 | a == b = and 39 | [ _stApp a == _stApp b 40 | , _stWindowLayers a == _stWindowLayers b 41 | , _stToMonomes a == _stToMonomes b 42 | , _stVoices a == _stVoices b 43 | , _stPending_Monome a == _stPending_Monome b 44 | , _stPending_Vivid a == _stPending_Vivid b ] 45 | 46 | instance Num EdoPitch where 47 | (+) (EdoPitch a) (EdoPitch b) = EdoPitch $ a + b 48 | (*) (EdoPitch a) (EdoPitch b) = EdoPitch $ a * b 49 | (-) (EdoPitch a) (EdoPitch b) = EdoPitch $ a - b 50 | abs (EdoPitch a) = EdoPitch $ abs a 51 | signum (EdoPitch a) = EdoPitch $ signum a 52 | fromInteger a = EdoPitch $ fromIntegral a 53 | 54 | instance Num EdoPitchClass where 55 | (+) (EdoPitchClass a) (EdoPitchClass b) = EdoPitchClass $ a + b 56 | (*) (EdoPitchClass a) (EdoPitchClass b) = EdoPitchClass $ a * b 57 | (-) (EdoPitchClass a) (EdoPitchClass b) = EdoPitchClass $ a - b 58 | abs (EdoPitchClass a) = EdoPitchClass $ abs a 59 | signum (EdoPitchClass a) = EdoPitchClass $ signum a 60 | fromInteger a = EdoPitchClass $ fromIntegral a 61 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # How to run it 2 | 3 | Montevideo is designed to be used from the REPL. 4 | Start it by running `cabal repl` from `/mtv/` 5 | (that is, probably, `mtv/mtv/`). 6 | Then, from within the resulting REPL, 7 | run `:s .ghci` to make the code available. 8 | 9 | Before using any of the sound-generating code, start JACK, 10 | and then start SuperCollider on UDP channel 57110 (`Vivid` requires that). 11 | Those are done from outside the REPL. 12 | 13 | I use `qjackctl` to start JACK, 14 | and the `./sc-start` script in this project to start SuperCollider, 15 | but there are other ways. 16 | 17 | ## In case of problems with SuperCollider / sc3-plugins / NixOS 18 | 19 | Once upon a time, 20 | NixOS did not offer a native package for installing sc3-plugins, 21 | and Cabal did not fetch the latest version of Vivid. 22 | Today those problems have been corrected, so all should be good. 23 | But should that ever stop being the case, 24 | you might need to re-enable some of the commented-out code in 25 | `sc-start.sh` and/or `cabal.project`, 26 | and make sure the rest of your system corresponds to the code enabled therein. 27 | 28 | # Montevideo is some music tools 29 | 30 | It can be used for: 31 | 32 | * [`mtv-lang`](mtv-lang/README.md): live-coding 33 | * [`mtv-monome`](mtv-monome/README.md): playing via a [monome](https://monome.org/) 34 | * `mtv-earTrain`: ear training 35 | * `mtv-ji`: Music theory, with a big focus on just intonation, and on approximating just intonation via EDOs (equal divisions of the octave). 36 | 37 | The above are all independent projects -- 38 | you don't need a monome to use the language, 39 | you don't need the language to use a monome, 40 | you don't even need SuperCollider installed to use the music theory piece. 41 | (The other three projects generate sound, hence rely on SuperCollider.) 42 | 43 | The first two projects have dedicated README files (linked above). 44 | I haven't documented the ear training and music theory modules well, 45 | but if I see evidence that anybody else wants to use them, I could. 46 | 47 | 48 | # Hacking it 49 | 50 | I'm not sure how helpful they are, 51 | but my own notes on montevideo can be found at my public org-roam knowledge graph, 52 | at https://github.com/JeffreyBenjaminBrown/notes-in-org-format-on-tech/blob/master/montevideo.org 53 | You don't need to use org-roam to read them; 54 | they are ordinary .org-formatted notes. 55 | 56 | 57 | # Why the name 58 | 59 | It's a mashup of "monome", "Tidal(Cycles)" and "Vivid". 60 | -------------------------------------------------------------------------------- /Montevideo/JI/Thanos/thanos2-handy.hs: -------------------------------------------------------------------------------- 1 | -- Specify everything, get the layout. 2 | -- Pr.pPrint $ bestLayout' oddLimit edo stringGap fretGap 3 | 4 | octaveHunt edo octave stringGap fretGap = ( let 5 | octaveInSteps = edo * octave 6 | in filter ((== 0) . flip mod' 1 . snd) $ 7 | map (\string -> 8 | ( string, 9 | (octaveInSteps - string*stringGap) 10 | / fretGap)) 11 | [-10 .. 10] ) 12 | myPrint $ octaveHunt 65 1 11 8 13 | 14 | ls = bestEdoLayouts (primesOctave1 13) [48..140] 15 | 16 | lastVisited = last $ take 30 $ drop 30 $ filter okayHarmony $ drop 120 ls 17 | 18 | -- Using this I searched the edos [50..140] 19 | -- past the 4x8s and into the 6x6s, 20 | -- excluding anything with stringWidth > 7, 21 | -- adding 2 to stringWidth for the area computation, 22 | -- letting the two gaps vary anywhere from 1 to 23 | -- round (e * (5/12) ). 24 | okayHarmony = not . flip elem [ 25 | 40, 42, 45, 47, 49, 51, 52, 54, 59, 61, 66, 71 26 | ] . (^. _1) . unTuning . etrTuning 27 | ls = bestEdoLayouts (primesOctave1 15) [24] 28 | Pr.pPrint ( 29 | reverse 30 | $ take 30 31 | $ zip [1..] 32 | $ L.sortBy (comparing $ etrArea) 33 | $ filter okayHarmony 34 | $ filter ((\x -> 0.3 <= x && x <= 0.7) . (^. _4) . unArea . etrArea) 35 | $ ls ) 36 | 37 | -- ditching 21 and 17, and using the 2nd best 11:8 38 | notes = [1 % 1,2 % 1,3 % 2,5 % 4,7 % 4,9 % 8,15/11,13 % 8,15 % 8,19 % 16,23 % 16,25 % 16,27 % 16,29 % 16,31 % 16] 39 | Pr.pPrint $ bestLayout (60,19,3) (notes ) & _2 %~ map LayoutRow 40 | 41 | -- 135: 6*(4**2) + 8**2 42 | -- 94: sum $ map (**2) [4,1,5,3,1,4] 43 | 44 | 45 | -- filter (not . flip elem [17/16,19/16]) $ 46 | -- primesOctave1 31 47 | -- ++ [ 17/16, 19/16 ] 48 | -- [ 1, 2, 3/2, 7/8, 11/8 ] 49 | goodEdos primes (edos :: [Int]) = ( let 50 | layouts = map (head . goodLayouts primes) edos 51 | in reverse 52 | $ L.sortBy (comparing (^. _3) ) -- sort on fret SSE 53 | $ layouts ) 54 | 55 | -- *maybe* I read the first 120 of these 56 | -- but I think I flubbed some of the last 60 57 | -- by reversing halfway through. 58 | -- For these ls was from 40 .. 210 59 | Pr.pPrint ( take 30 $ drop 90 60 | $ L.sortBy (comparing $ etrArea . snd) 61 | $ reverse $ L.sortBy (comparing $ etrEdo . snd) 62 | $ zip [1..] 63 | $ filter okayHarmony ls ) 64 | 65 | let 66 | lim31_sharp11 = [1 % 1,2 % 1,3 % 2,5 % 4,7 % 4,9 % 8,18/13,13 % 8,15 % 8,17 % 16,19 % 16,21 % 16,23 % 16,25 % 16,27 % 16,29 % 16,31 % 16] 67 | in Pr.pPrint $ bestLayout (75,12,5) lim31_sharp11 & _2 %~ map LayoutRow 68 | -------------------------------------------------------------------------------- /Montevideo/Dispatch/Types/Time.hs: -------------------------------------------------------------------------------- 1 | module Montevideo.Dispatch.Types.Time ( 2 | Time(..), Duration, RTime(..), RDuration 3 | , Start, End, RStart, REnd 4 | , timestamp, unTimestamp ) where 5 | 6 | import Vivid (Timestamp(..)) 7 | 8 | 9 | -- | = Time 10 | 11 | -- | Absolute times, in seconds. 12 | newtype Time = Time { _unTime :: Rational} 13 | deriving (Show, Eq, Ord) 14 | type Start = Time 15 | type End = Time 16 | type Duration = Time 17 | 18 | -- | Time relative to something, e.g. the global cycle duration. 19 | newtype RTime = RTime {_unRTime :: Rational} 20 | deriving (Show, Ord, Eq) 21 | type RStart = RTime 22 | type REnd = RTime 23 | type RDuration = RTime 24 | 25 | instance Num Time where 26 | (+) (Time t) (Time s) = Time (t + s) 27 | (-) (Time t) (Time s) = Time (t - s) 28 | (*) (Time t) (Time s) = Time (t * s) 29 | negate (Time t) = Time (negate t) 30 | abs (Time t) = Time (abs t) 31 | signum (Time t) = Time (signum t) 32 | fromInteger int = Time (fromInteger int) 33 | 34 | instance Num RTime where 35 | (+) (RTime t) (RTime s) = RTime (t + s) 36 | (-) (RTime t) (RTime s) = RTime (t - s) 37 | (*) (RTime t) (RTime s) = RTime (t * s) 38 | negate (RTime t) = RTime (negate t) 39 | abs (RTime t) = RTime (abs t) 40 | signum (RTime t) = RTime (signum t) 41 | fromInteger int = RTime (fromInteger int) 42 | 43 | instance Fractional Time where 44 | (/) (Time t) (Time s) = Time (t / s) 45 | recip (Time t) = Time (recip t) 46 | fromRational rat = Time rat 47 | 48 | instance Fractional RTime where 49 | (/) (RTime t) (RTime s) = RTime (t / s) 50 | recip (RTime t) = RTime (recip t) 51 | fromRational rat = RTime rat 52 | 53 | instance Real Time where 54 | toRational (Time t) = t 55 | 56 | instance Real RTime where 57 | toRational (RTime t) = t 58 | 59 | instance RealFrac Time where 60 | properFraction (Time r0) = let (i,r) = properFraction r0 61 | in (i,Time r) 62 | truncate (Time r) = truncate r 63 | round (Time r) = round r 64 | ceiling (Time r) = ceiling r 65 | floor (Time r) = floor r 66 | 67 | instance RealFrac RTime where 68 | properFraction (RTime r0) = let (i,r) = properFraction r0 69 | in (i,RTime r) 70 | truncate (RTime r) = truncate r 71 | round (RTime r) = round r 72 | ceiling (RTime r) = ceiling r 73 | floor (RTime r) = floor r 74 | 75 | unTimestamp :: Timestamp -> Time 76 | unTimestamp (Timestamp x) = Time $ toRational x 77 | 78 | timestamp :: Time -> Timestamp 79 | timestamp = Timestamp . fromRational . _unTime 80 | -------------------------------------------------------------------------------- /Montevideo/Test/Util.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | 3 | module Montevideo.Test.Util where 4 | 5 | import Test.HUnit 6 | 7 | import Montevideo.Util 8 | 9 | 10 | tests :: Test 11 | tests = TestList 12 | [ TestLabel "test_interleaves" test_interleaves 13 | , TestLabel "test_lcmRatios" test_lcmRatios 14 | , TestLabel "test_lines'" test_lines' 15 | , TestLabel "test_logScale" test_logScale 16 | , TestLabel "test_linScale" test_linScale 17 | , TestLabel "test_log0Scale" test_log0Scale 18 | ] 19 | 20 | test_linScale :: Test 21 | test_linScale = TestCase $ do 22 | assertBool "" $ 23 | numScale (100,110) (Lin 200 250) 102 24 | == 210 25 | assertBool "" $ 26 | numScale (-50,0) (Lin (-300) (-200)) (-10) 27 | == (-220) 28 | 29 | test_log0Scale :: Test 30 | test_log0Scale = TestCase $ do 31 | let e = error "meh" 32 | assertBool "" $ 33 | numScale (10,20) (Log0 e e) 10 == 0 34 | assertBool "" $ 35 | numScale (10,20) (Log0 15 32) 11 == 36 | numScale (11,20) (Log 15 32) 11 37 | 38 | test_logScale :: Test 39 | test_logScale = TestCase $ do 40 | let near x y = x/y > 0.9 && x/y < 1.1 41 | assertBool "logarithmically halfway from 1 to 100 is 10" $ 42 | near (numScale (0 ,10) (Log 1 100) 5) 10 43 | assertBool "logarithmically halfway from 1 to 100 is 10" $ 44 | near (numScale (10,20) (Log 1 100) 15) 10 45 | assertBool "logarithmically halfway from 10 to 1000 is 100" $ 46 | near (numScale (0 ,10) (Log 10 1000) 5) 100 47 | assertBool "logarithmically 5/8 of the way from 1 to 256 is 2**5" $ 48 | near (numScale (10,18) (Log 1 256) 15) 32 49 | 50 | test_lines' :: Test 51 | test_lines' = TestCase $ do 52 | assertBool "" $ lines' '/' "" == [] 53 | assertBool "" $ lines' '/' "abc" == ["abc"] 54 | assertBool "/abc -- note that a leading '/' is ignored" 55 | $ lines' '/' "/abc" == ["abc"] 56 | assertBool "/abc/" $ lines' '/' "/abc/" == ["abc",""] 57 | assertBool "abc/" $ lines' '/' "abc/" == ["abc",""] 58 | 59 | test_lcmRatios :: Test 60 | test_lcmRatios = TestCase $ do 61 | assertBool "lcmRatios 2 3 == 6" $ lcmRatios 2 3 == 6 62 | assertBool "lcmRatios (2/3) (3/2) == 6" $ lcmRatios (2/3) (3/2) == 6 63 | assertBool "lcmRatios (1/2) (3/4) == 3/2" $ lcmRatios (1/2) (3/4) == 3/2 64 | assertBool "lcmRatios (5/3) (4/3) == 20/3" $ lcmRatios (5/3) (4/3) == 20/3 65 | 66 | test_interleaves :: Test 67 | test_interleaves = TestCase $ do 68 | assertBool "1" $ interleaves 69 | [[1,2,3],[11,12,13],[21,22,23,24]] 70 | == [1,11,21,2,12,22,3,13,23] 71 | -------------------------------------------------------------------------------- /Montevideo/Monome/Window/Param/Group.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE ScopedTypeVariables 3 | , TypeApplications 4 | #-} 5 | 6 | module Montevideo.Monome.Window.Param.Group ( 7 | handler 8 | , paramGroupWindow 9 | , label 10 | 11 | , paramReport -- ^ St EdoApp -> AxeParam -> String 12 | , paramGroupReport -- ^ St EdoApp -> ParamGroup -> Maybe AxeParam -> [String] 13 | ) where 14 | 15 | import Control.Lens 16 | import qualified Data.Map as M 17 | import qualified Data.Bimap as Bi 18 | 19 | import Montevideo.Monome.Types 20 | import Montevideo.Synth 21 | import Montevideo.Util 22 | 23 | 24 | label :: WindowId 25 | label = ParamGroupWindow 26 | 27 | paramGroupWindow :: Window EdoApp 28 | paramGroupWindow = Window { 29 | windowLabel = label 30 | , windowContains = \(x,y) -> ( numBetween 0 2 x && 31 | numBetween 0 2 y ) 32 | || (x,y) == (0,3) 33 | , windowInitLeds = \_ _ -> Right [] 34 | , windowHandler = \x y -> return $ handler x y } 35 | 36 | handler :: St EdoApp -> (MonomeId, ((X,Y), Switch)) 37 | -> Either String (St EdoApp) 38 | handler st (_, (_, False)) = Right st 39 | handler st (mi, (xy, True)) = do 40 | pgNew :: ParamGroup <- 41 | maybe (Left $ show xy ++ " not in " ++ show label ++ ".") Right $ 42 | Bi.lookupR xy paramGroupXys 43 | let pgOld :: ParamGroup = st ^. stApp . edoParamGroup 44 | xyOld :: (X,Y) = paramGroup_toXy pgOld 45 | Right $ st & stApp . edoParamGroup .~ pgNew 46 | & ( stPending_String %~ flip (++) 47 | (paramGroupReport st pgNew Nothing) ) 48 | & ( stPending_Monome %~ flip (++) 49 | [ ((mi, label), (xyOld, False)) 50 | , ((mi, label), (xy, True)) ] ) 51 | 52 | paramReport :: St EdoApp -> AxeParam -> String 53 | paramReport st p = let 54 | zDefault :: AxeParam -> String = 55 | maybe (show (axeDefaultValues M.! (show p)) ++ " (default)") show . 56 | flip M.lookup (st ^. stAxeDefaults) 57 | in zDefault p ++ " " ++ 58 | show p 59 | 60 | paramGroupReport :: St EdoApp -> ParamGroup -> Maybe AxeParam -> [String] 61 | paramGroupReport st g mp = let 62 | zs :: [AxeParam] = paramGroup_params g 63 | zCaret :: AxeParam -> String 64 | zCaret p = case mp of 65 | Just p' -> if p == p' then " <-" else "" 66 | Nothing -> "" 67 | go :: AxeParam -> String 68 | go z = paramReport st z ++ " " ++ 69 | zCaret z 70 | in "" : map go zs -- The empty string becomes a newline under putStrLn. 71 | -------------------------------------------------------------------------------- /Montevideo/Monome/Window/Param/Val.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | === PITFALL: Monome Coordinate rotations. === 3 | 4 | Whereas `Montevideo.Monome.Window.Param.Val` 5 | is built for a 128 grid that sends in its default rotation (0 degrees), 6 | `Montevideo.Monome.Window.Param.SimpleVal` 7 | is built for one rotated by 90 degrees. 8 | The latter is more natural; 9 | the former doesn't require occasionally rotating the coordinate system 10 | (whenever the monome forgets its settings, 11 | which I believe I have witnessed a few times). 12 | -} 13 | 14 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 15 | {-# LANGUAGE ScopedTypeVariables 16 | , TypeApplications 17 | #-} 18 | 19 | module Montevideo.Monome.Window.Param.Val ( 20 | handler 21 | , paramValWindow 22 | , label 23 | ) where 24 | 25 | import Control.Lens 26 | import Data.Map as M 27 | 28 | import Montevideo.Monome.Types 29 | import qualified Montevideo.Monome.Window.Param.Group as PG 30 | import Montevideo.Synth 31 | import Montevideo.Synth.Msg 32 | import Montevideo.Util 33 | import Montevideo.Monome.Util (paramToAllVoices) 34 | 35 | 36 | label :: WindowId 37 | label = ParamVal_Window 38 | 39 | paramValWindow :: Window EdoApp 40 | paramValWindow = Window { 41 | windowLabel = label 42 | , windowContains = \(x,y) -> numBetween 0 12 x && 43 | numBetween 0 5 y 44 | , windowInitLeds = \_ _ -> Right [] 45 | , windowHandler = \st press -> return $ handler st press } 46 | 47 | handler :: St EdoApp -> (MonomeId, ((X,Y), Switch)) 48 | -> Either String (St EdoApp) 49 | handler st (_ , (_ , False )) = Right st 50 | handler st (mi , ((x,y), True )) = do 51 | let pg :: ParamGroup = st ^. stApp . edoParamGroup 52 | case paramGroup_toParam pg y :: Either String AxeParam of 53 | Left _ -> Right st 54 | Right (ap :: AxeParam) -> let 55 | 56 | ns :: NumScale = (M.!) (st ^. stAxeRanges) $ ap 57 | val :: Float = numScale (0,12) ns (fi x) 58 | 59 | st1 = st 60 | & stAxeDefaults %~ M.insert ap val 61 | & stPending_Vivid %~ flip (++) (paramToAllVoices st ap val) 62 | & ( stPending_Monome %~ flip (++) 63 | ( ((mi, label), ((x ,y), True )) 64 | : [ ((mi, label), ((x',y), False)) 65 | -- TODO ? This is wasteful. 66 | | x' <- [0..12], x' /= x ] ) ) 67 | in Right $ st1 68 | & ( stPending_String %~ flip (++) 69 | ( PG.paramGroupReport st1 70 | (st1 ^. stApp . edoParamGroup) 71 | (Just ap) 72 | ) ) 73 | -------------------------------------------------------------------------------- /Montevideo/JI/Notation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Montevideo.JI.Notation where 4 | 5 | import Data.Map (Map) 6 | import qualified Data.Map as M 7 | import qualified Data.List as L 8 | 9 | 10 | import Montevideo.JI.Lib (best) 11 | import Montevideo.Types 12 | 13 | 14 | -- | Gives every note name for every note in an Edo. 15 | noteNames :: Edo -> Map Int [String] 16 | noteNames e = 17 | foldl (M.unionWith (++)) mempty 18 | $ map ($ e) [nsf, ups, downs, doubleUps, doubleDowns] 19 | 20 | 21 | -- * Everything else in this file is intermediate to the above. 22 | 23 | ups, downs, doubleUps, doubleDowns :: Edo -> Map Edo [String] 24 | doubleDowns e = M.map (map ("vv" ++)) $ 25 | M.mapKeys (flip mod e . (+(-2))) $ 26 | nsf e 27 | doubleUps e = M.map (map ("^^" ++)) $ 28 | M.mapKeys (flip mod e . (+2)) $ 29 | nsf e 30 | downs e = M.map (map ("v" ++)) $ 31 | M.mapKeys (flip mod e . (+(-1))) $ 32 | nsf e 33 | ups e = M.map (map ("^" ++)) $ 34 | M.mapKeys (flip mod e . (+1)) $ 35 | nsf e 36 | 37 | -- | All the naturals, sharps and flats. 38 | nsf :: Edo -> Map Edo [String] 39 | nsf e = let {- Why this `let` statement: 40 | `M.unionWith` requires the maps to be joined 41 | to have the same type as its output. -} 42 | naturals', sharps', flats' :: Map Edo [String] 43 | naturals' = M.map (:[]) $ naturals e 44 | sharps' = M.map (:[]) $ sharps e 45 | flats' = M.map (:[]) $ flats e 46 | doubleSharps' = M.map (:[]) $ doubleSharps e 47 | doubleFlats' = M.map (:[]) $ doubleFlats e 48 | in foldl (M.unionWith (++)) mempty 49 | [naturals', sharps', flats', doubleSharps', doubleFlats'] 50 | 51 | doubleFlats :: Edo -> Map Edo String 52 | doubleFlats e = M.map (++ "bb") $ 53 | M.mapKeys (flip mod e . (+(-2 * sharp e))) $ 54 | naturals e 55 | 56 | flats :: Edo -> Map Edo String 57 | flats e = M.map (++ "b") $ 58 | M.mapKeys (flip mod e . (+(-sharp e))) $ 59 | naturals e 60 | 61 | doubleSharps :: Edo -> Map Edo String 62 | doubleSharps e = M.map (++ "##") $ 63 | M.mapKeys (flip mod e . (+(2 * sharp e))) $ 64 | naturals e 65 | 66 | sharps :: Edo -> Map Edo String 67 | sharps e = M.map (++ "#") $ 68 | M.mapKeys (flip mod e . (+sharp e)) $ 69 | naturals e 70 | 71 | -- | The seven naturals, A through G. 72 | naturals :: Edo -> Map Edo String 73 | naturals e = M.fromList $ 74 | zip (L.sort $ take 7 $ fifths e) $ 75 | map (:[]) $ -- changes characters to strings 76 | ['F', 'G'] ++ ['A' .. 'E'] 77 | 78 | sharp :: Edo -> Edo 79 | sharp e = fifths e !! 7 80 | 81 | fifths :: Edo -> [Int] 82 | fifths e = let (fifth,_,_) = best e $ 3/2 83 | in [ mod (i*fifth) e | i <- [0..] ] 84 | -------------------------------------------------------------------------------- /Montevideo/Dispatch/Lazy/Test/Intervals.hs: -------------------------------------------------------------------------------- 1 | module Montevideo.Dispatch.Lazy.Test.Intervals where 2 | 3 | import Control.Lens 4 | import Test.HUnit 5 | 6 | import Montevideo.Dispatch.Lazy.Intervals 7 | import Montevideo.Dispatch.Lazy.Util 8 | 9 | 10 | tests :: Test 11 | tests = TestList 12 | [ 13 | test_constantsOverInterval, 14 | test_eval, 15 | test_stack, 16 | test_append, 17 | test_join 18 | ] 19 | 20 | test_constantsOverInterval :: Test 21 | test_constantsOverInterval = TestCase $ do 22 | let c = constantsOverInterval 0 1 [()] 23 | assertBool "" $ c (Arc { start = 0, end = 1}) 24 | == [ ( Arc { start = 0, end = 1 }, [()] ) ] 25 | assertBool "" $ c (Arc { start = 2, end = 3}) == [] 26 | assertBool "" $ c (Arc { start = -3, end = -2}) == [] 27 | assertBool "" $ c (Arc { start = -10, end = 10}) 28 | == [ ( Arc { start = 0, end = 1 }, [()] ) ] 29 | assertBool "" $ c (Arc { start = 0.2, end = 0.8}) 30 | == [ ( Arc { start = 0.2, end = 0.8 }, [()] ) ] 31 | 32 | test_eval :: Test 33 | test_eval = TestCase $ do 34 | let ma = Mq { mq_dur = 2, 35 | mq_func = coi 0 1 "a" } 36 | assertBool "1" $ eval ma (Arc {start = 0, end = 1}) 37 | == [ (Arc {start = 0, end = 1}, ["a"] ) ] 38 | assertBool "2" $ eval ma (Arc {start = -0.5, end = 0}) == [] 39 | assertBool "2" $ eval ma (Arc {start = 1, end = 2}) == [] 40 | assertBool "3" $ eval ma (Arc {start = 1.5, end = 2}) == [] 41 | assertBool "4" $ eval ma (Arc {start = 2, end = 3}) 42 | == [ (Arc {start = 2, end = 3}, ["a"] ) ] 43 | 44 | test_stack :: Test 45 | test_stack = TestCase $ do 46 | let ma = Mq { mq_dur = 2, mq_func = coi 0 1 "a" } 47 | mb = Mq { mq_dur = 3, mq_func = coi 0 1 "b" } 48 | assertBool "" $ eval (stack ma mb) (Arc {start = 0, end = 1}) 49 | == [ (Arc {start = 0, end = 1}, ["a"] ), 50 | (Arc {start = 0, end = 1}, ["b"] ) ] 51 | assertBool "" $ eval (stack ma mb) (Arc {start = 1, end = 2}) == [] 52 | 53 | test_append :: Test 54 | test_append = TestCase $ do 55 | let ma = Mq { mq_dur = 2, mq_func = coi 0 1 "a" } 56 | mb = Mq { mq_dur = 3, mq_func = coi 0 1 "b" } 57 | mc = append ma mb 58 | t02 = Arc { start = 0, end = 2 } 59 | t24 = Arc { start = 2, end = 4 } 60 | t57 = Arc { start = 5, end = 7 } 61 | assertBool "" $ mq_dur mc == 5 62 | assertBool "" $ eval mc t02 == 63 | eval ma t02 64 | assertBool "" $ eval mc t24 == 65 | map (_1 %~ addToArc 2) (eval mb t02) 66 | assertBool "" $ eval mc t57 == 67 | map (_1 %~ addToArc 5) (eval ma t02) 68 | 69 | test_join :: Test 70 | test_join = TestCase $ do 71 | let ma = Mq { mq_dur = 2, mq_func = coi 0 1 "a" } 72 | mb = Mq { mq_dur = 3, mq_func = coi 0 1 "b" } 73 | assertBool "" $ eval (join (++) ma mb) (Arc {start = 0, end = 7}) 74 | == [ ( Arc { start = 0, end = 1 }, ["ab"]) 75 | , ( Arc { start = 6, end = 7 }, ["ab"]) ] 76 | -------------------------------------------------------------------------------- /learning/vivid,random/render.hs: -------------------------------------------------------------------------------- 1 | -- To use, first run `mwc <- create` once, 2 | -- Then run either of these repeatedly: 3 | -- > oneSignal mwc 4 | -- > wholeSynth mwc 5 | -- Maybe change the constraints (below). 6 | 7 | {-# LANGUAGE DataKinds 8 | , ExtendedDefaultRules 9 | , FlexibleContexts -- just for the random-fu hack 10 | #-} 11 | 12 | import qualified Data.Map as M 13 | 14 | import Data.Random 15 | import System.Random.MWC 16 | 17 | import Vivid 18 | import Vivid.Jbb.Random.Types 19 | import Vivid.Jbb.Random.RandomSignal 20 | import Vivid.Jbb.Random.RandomSynth 21 | import Vivid.Jbb.Random.Render 22 | import Vivid.Jbb.Synths 23 | 24 | 25 | -- | Max # of params, max # of signals, max depth. 26 | -- Should be in [1,8], [1,8], and >1, respectively. 27 | constraints = mkRandConstraints 3 3 2 28 | 29 | 30 | -- | Creates a value between 1 and x if log x appears in the formula below. 31 | logRandomFreq :: RVar Double 32 | logRandomFreq = exp . (* log 100) <$> stdUniform 33 | 34 | randomArgs :: RVar ( I "AP1", I "AP2", I "AP3", I "AP4" 35 | , I "AP5", I "AP6", I "AP7", I "AP8") 36 | randomArgs = do 37 | let toHz = exp . ((-)1) . (*2) -- takes [0,1] to [1,20k] 38 | a <- toI . toHz <$> stdUniform 39 | b <- toI . toHz <$> stdUniform 40 | c <- toI . toHz <$> stdUniform 41 | d <- toI . toHz <$> stdUniform 42 | e <- toI . toHz <$> stdUniform 43 | f <- toI . toHz <$> stdUniform 44 | g <- toI . toHz <$> stdUniform 45 | h <- toI . toHz <$> stdUniform 46 | return $ ( a,b,c,d,e,f,g,h ) 47 | 48 | defaultArgs = ( 0 :: I "AP1" 49 | , 0 :: I "AP2" 50 | , 0 :: I "AP3" 51 | , 0 :: I "AP4" 52 | , 0 :: I "AP5" 53 | , 0 :: I "AP6" 54 | , 0 :: I "AP7" 55 | , 0 :: I "AP8" ) 56 | 57 | abSigToSD :: AbSig -> SynthDef TheAbParams 58 | abSigToSD a = sd defaultArgs $ do 59 | s1 <- renderSig a M.empty 60 | out 0 [s1, s1] 61 | 62 | -- | Generate an mwc for this using "Data.Random.create" 63 | oneSignal mwc = do 64 | a <- randAbSig constraints 65 | print $ show a 66 | 67 | let sd = abSigToSD a 68 | s <- synth sd defaultArgs 69 | y <- sampleFrom mwc randomArgs 70 | print $ show y 71 | 72 | set s y 73 | wait 1 74 | free s 75 | 76 | -- | = Try a whole synth 77 | abSynthToSD :: AbSynth -> SynthDef TheAbParams 78 | abSynthToSD plan = sd defaultArgs $ do 79 | let m = M.empty 80 | 81 | s1 <- renderSig ((M.!) plan AS1) m 82 | let m1 = M.insert AS1 s1 m 83 | 84 | s2 <- renderSig ((M.!) plan AS2) m1 85 | let m2 = M.insert AS2 s2 m1 86 | 87 | s3 <- renderSig ((M.!) plan AS3) m2 88 | let m3 = M.insert AS3 s3 m2 89 | 90 | out 0 [s3,s3] 91 | 92 | 93 | -- | Generate an mwc for this using "Data.Random.create" 94 | wholeSynth mwc = do 95 | a <- randAbSynth constraints 96 | print $ show a 97 | 98 | let sd = abSynthToSD a 99 | s <- synth sd defaultArgs 100 | 101 | y <- sampleFrom mwc randomArgs 102 | print $ show y 103 | 104 | set s y 105 | wait 1 106 | free s 107 | -------------------------------------------------------------------------------- /Montevideo/Monome/Window/ChordBank/Bank.hs: -------------------------------------------------------------------------------- 1 | -- | A window for changing what windows are on a monome. 2 | 3 | {-# LANGUAGE ScopedTypeVariables 4 | #-} 5 | 6 | module Montevideo.Monome.Window.ChordBank.Bank ( 7 | chordBankWindow 8 | ) where 9 | 10 | import Prelude 11 | 12 | import Control.Lens 13 | import Data.Map (Map) 14 | import qualified Data.Map as M 15 | import Data.Maybe 16 | 17 | import Montevideo.Monome.Types.Most 18 | import Montevideo.Monome.Util 19 | import Montevideo.Synth 20 | import Montevideo.Synth.Msg 21 | import Montevideo.Util 22 | 23 | 24 | label :: WindowId 25 | label = ChordBankWindow 26 | 27 | chordBankWindow :: Window EdoApp 28 | chordBankWindow = Window { 29 | windowLabel = label 30 | , windowContains = \(x,y) -> 31 | numBetween 0 7 x && 32 | numBetween 0 7 y 33 | , windowInitLeds = \_ _ -> Right [] 34 | , windowHandler = \x y -> return $ handler x y } 35 | 36 | handler :: St EdoApp -> (MonomeId, ((X,Y), Switch)) 37 | -> Either String (St EdoApp) 38 | 39 | ---- | TODO: Add to LitPitches. 40 | handler st (mi, (xy, True)) = do 41 | let app = _stApp st 42 | mPitches :: Maybe [Pitch EdoApp] = 43 | app ^. edoChordBank . chords . at xy 44 | if isNothing mPitches then Right st else do 45 | 46 | let Just pitches = mPitches 47 | ec = app ^. edoConfig 48 | light :: [LedMsg] = 49 | [ ((mi, label), (xy, True)) ] 50 | pvvs :: [ (Pitch EdoApp, VoiceId, Voice EdoApp) ] = let 51 | pToV :: Pitch EdoApp -> Voice EdoApp 52 | pToV p = Voice 53 | { _voiceSynth = Nothing 54 | , _voicePitch = p 55 | , _voiceParams = mempty } -- updated by updateVoiceParams next 56 | in map (\(p,vi) -> (p, vi, pToV p)) $ 57 | zip pitches [nextVoice st..] 58 | sound :: [ScAction VoiceId] = 59 | [ monome_scActionNew ec vi (_stAxeDefaults st) p 60 | | (p,vi,_) <- pvvs ] 61 | st1 :: St EdoApp = st 62 | & stPending_Monome %~ (++ light) 63 | & stPending_Vivid %~ (++ sound) 64 | & stVoices %~ 65 | let g :: (a, VoiceId, VE) -> (Map VoiceId VE -> Map VoiceId VE) 66 | -> (Map VoiceId VE -> Map VoiceId VE) 67 | g (_,vi,v) f = f . M.insert vi v 68 | in foldr g id pvvs 69 | Right $ foldr updateVoiceParams st1 sound 70 | 71 | -- | TODO: Subtract from LitPitches. 72 | handler st (mi, (xy, False)) = 73 | if isNothing $ st ^. stApp . edoChordBank . chords . at xy 74 | then Right st 75 | else let 76 | darken :: [LedMsg] = 77 | [ ((mi, label), (xy, False)) ] 78 | silence :: [ScAction VoiceId] = 79 | [ ScAction_Free { _actionSynthDefEnum = Axe 80 | , _actionSynthName = v } 81 | | v :: VoiceId <- st ^. stApp . edoChordBank . chordPlaying ] 82 | in Right $ st 83 | & stApp . edoChordBank . chordPlaying .~ [] 84 | & stPending_Monome %~ (++ darken) 85 | & stPending_Vivid %~ (++ silence) 86 | 87 | type VE = Voice EdoApp 88 | -------------------------------------------------------------------------------- /Montevideo/Test/Hode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Montevideo.Test.Hode where 4 | 5 | import Data.Either 6 | import qualified Data.Map as M 7 | import Test.HUnit 8 | 9 | import Hode.Hode hiding (Test) 10 | import Dispatch.Abbrevs 11 | import Hode 12 | 13 | 14 | testRslt :: Rslt 15 | testRslt = mkRslt $ M.fromList $ _baseRslt ++ 16 | [ (01,Phrase' "a") 17 | , (02,Phrase' "0") 18 | , (03,Phrase' "400") 19 | , (04, Rel' $ Rel [3] (aFreq)) 20 | , (05, Rel' $ Rel [1,2,4] (aWhenPlays)) 21 | , (06,Phrase' "1") 22 | , (07,Phrase' "500") 23 | , (08, Rel' $ Rel [7] (aFreq)) 24 | , (09, Rel' $ Rel [1,6,8] (aWhenPlays)) 25 | , (10,Phrase' "song 1") 26 | , (11,Phrase' "3") 27 | , (12,Rel' $ Rel [11,1] aMmho) 28 | , (13,Rel' $ Rel [12] aNBoop) 29 | , (14,Rel' $ Rel [10,13] aSends)] 30 | 31 | test_module_hode :: Test 32 | test_module_hode = TestList [ 33 | TestLabel "testEvalSynthParam" testEvalSynthParam 34 | , TestLabel "testEvalParamEvent" testEvalParamEvent 35 | , TestLabel "testEvalEventTriples" testEvalEventTriples 36 | , TestLabel "testEvalMmho" testEvalMmho 37 | , TestLabel "testEvalToSynths" testEvalToSynths 38 | ] 39 | 40 | testEvalToSynths :: Test 41 | testEvalToSynths = TestCase $ do 42 | assertBool "1" $ evalToSynths testRslt 13 43 | == Right ( nBoop $ mmho 3 $ pre2 "a" 44 | [ (0, m1 "freq" 400) 45 | , (1, m1 "freq" 500) ] ) 46 | 47 | testEvalMmho :: Test 48 | testEvalMmho = TestCase $ do 49 | assertBool "1" $ evalMmho testRslt 12 50 | == Right ( mmho 3 $ pre2 "a" 51 | [ (0, m1 "freq" 400) 52 | , (1, m1 "freq" 500) ] ) 53 | 54 | testEvalSynthParam :: Test 55 | testEvalSynthParam = TestCase $ do 56 | let r :: Rslt 57 | r = mkRslt $ M.fromList $ _baseRslt ++ 58 | [(6,Phrase' "500") 59 | ,(7,Rel' (Rel [6] aFreq))] 60 | assertBool "1" $ evalSynthParam r 7 61 | == Right (M.singleton "freq" 500) 62 | assertBool "2" $ isLeft $ evalSynthParam r 6 63 | 64 | testEvalParamEvent :: Test 65 | testEvalParamEvent = TestCase $ do 66 | let r :: Rslt 67 | r = mkRslt $ M.fromList $ _baseRslt ++ 68 | [ (1,Phrase' "a") 69 | , (2,Phrase' "0") 70 | , (3,Phrase' "400") 71 | , (4,Rel' (Rel [3] aFreq)) 72 | , (5,Rel' (Rel [1,2,4] aWhenPlays)) ] 73 | assertBool "1" $ evalParamEvent r 5 74 | == Right ("a",0,M.singleton "freq" 400) 75 | 76 | testEvalEventTriples :: Test 77 | testEvalEventTriples = TestCase $ do 78 | let r :: Rslt = mkRslt $ M.fromList $ _baseRslt ++ 79 | [ (1,Phrase' "a") 80 | , (2,Phrase' "0") 81 | , (3,Phrase' "400") 82 | , (4,Rel' $ Rel [3] aFreq) 83 | , (5,Rel' $ Rel [1,2,4] aWhenPlays) 84 | , (6,Phrase' "1") 85 | , (7,Phrase' "500") 86 | , (8,Rel' $ Rel [7] aFreq) 87 | , (9,Rel' $ Rel [1,6,8] aWhenPlays) ] 88 | assertBool "1" $ evalEventTriples r 1 89 | == Right [("a", 0.0, M.singleton "freq" 400) 90 | ,("a", 1.0, M.singleton "freq" 500)] 91 | -------------------------------------------------------------------------------- /Montevideo/Monome/Util/OSC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings 2 | , ScopedTypeVariables 3 | , ViewPatterns 4 | #-} 5 | 6 | module Montevideo.Monome.Util.OSC ( 7 | -- * re-exports 8 | X, Y, Switch, Led, LedBecause(..) 9 | 10 | -- * This isn't really OSC-specific but it's pretty close. 11 | , allMonomeIds -- ^ [MonomeId] 12 | 13 | -- * OSC 14 | , readOSC_asSwitch -- ^ OSC -> Either String ( MonomeId, ((X,Y), Switch)) 15 | , ledOsc -- ^ MonomeId -> ((X,Y), Led) -> ByteString 16 | , allLedOsc -- ^ MonomeId -> Led -> ByteString 17 | 18 | -- * Monome-related conversions for `String`, `Int`, `Bool`, `MonomeId` 19 | , inverseShowMonome -- ^ String -> Either String MonomeId 20 | , fromBool -- ^ Num a => Bool -> a 21 | , boolFromInt -- ^ Int -> Either String Bool 22 | ) where 23 | 24 | import Data.ByteString.Char8 25 | import Data.Either.Combinators 26 | import qualified Data.List as L 27 | import Vivid.OSC 28 | 29 | import Montevideo.Monome.Network.Monome 30 | import Montevideo.Monome.Types.Most 31 | import Montevideo.Util 32 | 33 | 34 | allMonomeIds :: [MonomeId] 35 | allMonomeIds = [ Monome_128 36 | , Monome_256 37 | , Monome_old ] 38 | 39 | -- * OSC 40 | 41 | -- | Example: 42 | -- > readOSC_asSwitch $ OSC "/monome/grid/key" [OSC_I 7, OSC_I 7, OSC_I 1] 43 | -- Right ((7,7),True) 44 | readOSC_asSwitch :: OSC -> Either String ( MonomeId 45 | , ((X,Y), Switch)) 46 | readOSC_asSwitch m@(OSC str l) = 47 | mapLeft ("readOSC_asSwitch" ++) $ 48 | let ms :: [String] = lines' '/' $ unpack str 49 | err = Left $ "Unrecognized OSC message: " ++ show m 50 | in case l of 51 | [OSC_I x, OSC_I y, OSC_I s] -> do 52 | b <- boolFromInt $ fi s 53 | case ms of 54 | [t1,t2,t3] -> 55 | if t2 == "grid" && t3 == "key" 56 | then let press = ((fi x, fi y), b) 57 | in case inverseShowMonome t1 of 58 | Right monome -> Right (monome, press) 59 | Left _ -> err 60 | else err 61 | _ -> err 62 | _ -> err 63 | 64 | -- | Tells the monome to turn on an LED. See Test/HandTest.hs. 65 | ledOsc :: MonomeId -> ((X,Y), Led) -> ByteString 66 | ledOsc prefix ((x, y), led) = 67 | onoff ('/' : show prefix) x y $ fromBool led 68 | 69 | -- | Tells the monome to light or darken *every* LED. See Test/HandTest.hs. 70 | allLedOsc :: MonomeId -> Led -> ByteString 71 | allLedOsc prefix led = 72 | allLeds ('/' : show prefix) $ fromBool led 73 | 74 | 75 | -- * Monome-related conversions for `String`, `Int`, `Bool`, `MonomeId` 76 | 77 | inverseShowMonome :: String -> Either String MonomeId 78 | inverseShowMonome s = 79 | mapLeft ("inverseShowMonome: " ++) $ 80 | maybe (Left $ "MonomeId for " ++ s ++ " not found.") 81 | Right $ L.find ((==) s . show) allMonomeIds 82 | 83 | fromBool :: Num a => Bool -> a 84 | fromBool True = 1 85 | fromBool False = 0 86 | 87 | boolFromInt :: Int -> Either String Bool 88 | boolFromInt 0 = Right False 89 | boolFromInt 1 = Right True 90 | boolFromInt x = Left ( "boolFromInt: " ++ show x 91 | ++ " is niether 0 nor 1." ) 92 | -------------------------------------------------------------------------------- /mtv-lang/docs/synths.hs: -------------------------------------------------------------------------------- 1 | -- Montevideo lets you change the sound of a synthesizer 2 | -- in the middle of a note. The pattern below is not a series 3 | -- of distinct notes; it is a single synth voice, playing continuously, 4 | -- and continuously receiving instructions to change 5 | -- frequency or other parameters. 6 | 7 | patMelody = -- A melody (in Hz). 8 | mmho 4 -- This `Museq`'s duration will be 4. 9 | -- "mmho" = "mm" (make a Museq) 10 | -- + "h" (hold each note until the next one) 11 | -- + "o" (insert "on=1" messages wherever "on" is not mentioned) 12 | $ pre2 "" -- This pattern is not polyphonic, so each event can be 13 | -- given the same label -- in this case, the empty string. 14 | [ (0 -- At time 0, 15 | , mfl [("freq",140)]) -- map the "freq' parameter to 140. 16 | , (1, mfl [("freq",180)]) 17 | , (2, mfl [("freq",240)]) 18 | -- The next two events last half as long as the previous three. 19 | , (3, mfl [("on" ,0 )]) -- "on=0" means "note off" 20 | , (3.5, mfl [("freq",560)]) 21 | ] 22 | 23 | -- Another melody. Since in Hz they would be below the human range of hearing, 24 | -- these frequencies are most naturally thought of as 25 | -- relative to the Hz values in the other one. For three quarters of this 26 | -- loop (from time 0 to time 3/2), the frequency is 1, i.e. unchanged. 27 | -- For the last quarter (from time 3/2 to time 2) the frequency is 8, 28 | -- i.e. 3 octaves higher. 29 | patOctave = mmho 2 $ pre2 "" 30 | [ (0, mfl [("freq",1)]) 31 | , (3/2, mfl [("freq",8)]) ] 32 | 33 | -- A "timbre melody". It refers to parameters defined for the Zot synth. 34 | -- It's not really important what these parameters mean; 35 | -- the point is that each parameter can be updated while the synth plays. 36 | patPulse = mmh 2 $ pre2 "" 37 | [ (0, mfl [ ("pulse",1) -- The carrier is entirely a pulse wave. 38 | , ("amp", 0.02) -- Amplitude. 39 | ]) 40 | , (1, mfl [ ("pulse",0) -- The carrier is entirely a sine wave. 41 | , ("amp", 0.04) 42 | ]) 43 | ] 44 | 45 | -- Another "timbre melody", involving yet more Zot parameters. 46 | patFm = mmh 2 $ pre2 "" -- This pattern also has a duration of 2. 47 | [ ( 0 -- At time 0, 48 | , mfl [ ("fm-m",0) ] ) -- turn off the frequency modulation. 49 | , ( 1 -- At time 1, 50 | , mfl [ ("fm-f",1/4) -- The frequency of the FM signal is 1/4 the 51 | -- frequency of the carrier signal. 52 | , ("fm-m",2/3) -- The amplitude of the FM signal is 2/3 the 53 | ] ) ] -- frequency of the carrier signal. 54 | 55 | -- If this is confusing, see `docs/merge-two-patterns.hs" 56 | -- for a simpler example. 57 | -- 58 | -- The `merge1` functions below cause like parameters to be multiplied. 59 | -- Most of the patterns do not deal in the same parameters, 60 | -- so there's no multiplication, just juxtaposition. 61 | -- However, patOctave and patMelody both control `freq`, 62 | -- so `merge1` causes their values to be multiplied. 63 | chAll $ mfl 64 | [ ( "1" 65 | , nZot $ -- Send the following `Museq` to the `Zot` synth. 66 | merge1 (fast 3 patPulse) $ 67 | merge1 (fast 2 patFm) $ 68 | merge1 (fast 4 patOctave) 69 | patMelody 70 | ) ] 71 | --------------------------------------------------------------------------------