> {-# LANGUAGE Arrows #-} > module HSoM.Examples.IntervalTrainer where > import HSoM > import Euterpea > import FRP.UISF > import System.Random (randomRIO) > import Codec.Midi (Message(ProgramChange)) > import FRP.UISF.AuxFunctions (concatA, evMap) > import Data.Monoid > main = runMUI (defaultMUIParams {uiSize=(600,700), uiTitle="Interval Trainer"}) intervalTrainer > -- music theory name for intervals: > intNameList :: [String] > intNameList = > ["uni","min2","Maj2","min3","Maj3","4th","aug4", > "5th","min6","Maj6","min7","Maj7","oct"] States of the MUI's internal Finite State Machine: > data State = Start | Base | Guessed > deriving (Eq,Ord,Show) State transition table: | Next | Repeat | Giveup | Guess | Reset | ----------------------------------------------------------- Start | Base | Start | Start | Start | Start | Base | Base | Base | Guessed | Guessed | Start | Guessed | Base | Guessed | Guessed | Guessed | Start | State variables: total: number ofintervals generated correct: number guessed correctly repeats: number of repeat requests prior to making a guess answer: a pair, the random root note and the random interval state: the durrect FSA state (see above) State variable updates: Variable | Event : action ------------------------------------------------------------------------ total | Next (Base) : incr, Guess (Base) : incr, Giveup (Base) : incr correct | Guess (Base) /\ match : incr repeats | Repeat (Base) : incr answer | Next : generate and save new random root and interval state | see State Transition Table Also, Reset forces total, correct, and repeats to 0, and answer to (0,0). The main UI: > intervalTrainer :: UISF () () > intervalTrainer = proc _ -> do > -- MIDI output select: > mo <- setSize (600,90) $ selectOutput -< () > -- Play note: > pns <- setSize (600,60) . title "Play notes" . leftRight $ > radio ["Together","Low then high","High then low"] 0 -< () > -- Note length: > dur <- setSize (600,60) . title "Note length" . leftRight $ > radio ["Whole","Half","Quarter","Eighth"] 2 -< () > -- Max interval > maxInt <- (| (setSize (600,60) . title "Maximum interval" . leftRight) (do > max <- shiSlider 1 (1,12) 12 -< () > sDisplay -< intNameList !! max > returnA -< max )|) > -- Range: > range <- (| (setSize (600,60) . title "Range in octaves" . leftRight) (do > range <- shiSlider 1 (2,10) 4 -< () > sDisplay -< take 3 $ show $ fromIntegral range / 2 > returnA -< range )|) > -- Lowest octave: > lowOct <- (| (setSize (600,60) . title "Lowest octave" . leftRight) (do > low <- shiSlider 1 (1,8) 4 -< () > sDisplay -< show low > returnA -< low )|) > -- Instrument: > instr <- setSize (600,60) . title "Instrument" . leftRight $ > radio ["Acous Piano","Elec Piano","Violin","Saxophone","Flute"] 0 -< () > -- Control: > (nextE,repeatE,giveUpE,resetE) <- (| (setSize (600,60) . title "Control" . leftRight) (do > next <- edge <<< button "Next" -< () > repeat <- edge <<< button "Repeat" -< () > giveUp <- edge <<< button "Give Up" -< () > reset <- edge <<< button "Reset" -< () > returnA -< (next,repeat,giveUp,reset) )|) > -- User Input: > guesses <- (| (setSize (600,90) . title "Guess the interval") (do > g1 <- leftRight $ > concatA $ map (\s -> edge <<< button s) > ["uni","min2","Maj2","min3","Maj3","4th","aug4"] -< repeat () > g2 <- leftRight $ > concatA $ map (\s -> edge <<< button s) > ["5th","min6","Maj6","min7","Maj7","oct"] -< repeat () > returnA -< g1++g2) |) > -- edge-detect pushbuttons: > let guessesE = foldl1 (.|.) $ zipWith (->>) guesses intNameList > rec -- the state > state <- delay Start <<< accum Start -< updates > -- event filter based on MUI state > let whileIn' :: SEvent a -> State -> SEvent a > e `whileIn'` s = if s == state then e else Nothing > updates = (giveUpE `whileIn'` Base ->> const Guessed) .|. > (nextE ->> const Base) .|. (resetE ->> const Start) .|. > (guessesE `whileIn'` Base ->> const Guessed) > let whileIn :: SEvent a -> State -> SEvent a > e `whileIn` s = if s == state then e else Nothing > > -- Random intervals: > randIntE <- evMap (liftAIO mkRandInt) -< snapshot_ nextE (maxInt, lowOct, range) > interval <- hold (0,0) -< randIntE > let trigger = snapshot randIntE (dur, instr) .|. > snapshot_ repeatE (interval, (dur, instr)) > -- state variables: > let matchE = snapshot (guessesE `whileIn` Base) interval =>> > \(g,(r,i)) -> if g==intNameList!!i then succ else id > total <- delay 0 <<< accum 0 -< ((guessesE `whileIn` Base ->> succ) .|. > (nextE `whileIn` Base ->> succ) .|. > (giveUpE `whileIn` Base ->> succ) .|. > (resetE ->> const 0) ) > correct <- delay 0 <<< accum 0 -< (matchE .|. (resetE ->> const 0)) > repeats <- delay 0 <<< accum 0 -< ((repeatE `whileIn` Base ->> succ) .|. > (resetE ->> const 0) ) > -- Note delays > let f n pn dur = if pn==n then 1 / fromIntegral (2 ^ dur) else 0 > del0 = f 2 pns dur -- lo note delay only when "hi then lo" > del1 = f 1 pns dur -- hi note delay only when "lo then hi" > -- Random interval & Midi signals: > note0 <- vdelay -< (del0, (trigger =>> mkNote 0)) > note1 <- vdelay -< (del1, (trigger =>> mkNote 1)) > nowE <- now -< () > let progChan = nowE ->> (map Std $ > zipWith ProgramChange [0,1,2,3,4] [0,4,40,66,73]) > midiMsgs = progChan .|. (note0 `mappend` note1) > -- Display results: > (| (setSize (600,30) . leftRight) (do > title "Score:" $ display -< showScore correct total > title "Repeats:" $ display -< show repeats > title "Answer:" $ display -< > if state==Guessed then intNameList!!(snd interval) else "" > returnA -< () )|) > -- Midi output > midiOut -< (mo, midiMsgs) > returnA -< () Auxilliary Functions: > sDisplay = setSize (50,25) display > shiSlider inc ran pre = setSize (300,25) $ hiSlider inc ran pre > sButton str = setSize (75,25) $ button str > showScore :: Int -> Int -> String > showScore c 0 = "0" > showScore c t = show c ++ "/" ++ show t ++ " = " ++ > take 5 (show (100 * fromIntegral c / fromIntegral t)) ++ "%" > mkRandInt :: (Int,Int,Int) -> IO (Int,Int) > mkRandInt (maxInt,lowOct,range) = > do > let low = lowOct*12 > int <- randomRIO (0,maxInt) :: IO Int > root <- randomRIO (low, low + range*6 - int) :: IO Int > return (root,int) > mkNote :: Int -> ((Int,Int),(Int,Int)) -> [MidiMessage] > mkNote n ((root,int),(dur,instr)) = > let durT = 1 / fromIntegral (2 ^ dur) > in if n==0 then [ANote instr root 100 durT] > else [ANote instr (root+int) 100 durT] 0 whole 1 sec 1/2^0 1 half 1/2 sec 1/2^1 2 quarter 1/4 sec 1/2^2 3 eighth 1/8 sec 1/2^3 at 60 BPM a whole note is 1 sec ANote :: Channel -> Key -> Velocity -> Time -> MidiMessage -------------------------------------- -- Yampa-style utilities -------------------------------------- > (=>>) :: SEvent a -> (a -> b) -> SEvent b > (=>>) = flip fmap > (->>) :: SEvent a -> b -> SEvent b > (->>) = flip $ fmap . const > (.|.) :: SEvent a -> SEvent a -> SEvent a > (.|.) = flip $ flip maybe Just > > snapshot :: SEvent a -> b -> SEvent (a,b) > snapshot = flip $ fmap . flip (,) > snapshot_ :: SEvent a -> b -> SEvent b > snapshot_ = flip $ fmap . const -- same as ->>