>
> 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
>
> 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
>
> mo <- setSize (600,90) $ selectOutput -< ()
>
> pns <- setSize (600,60) . title "Play notes" . leftRight $
> radio ["Together","Low then high","High then low"] 0 -< ()
>
> dur <- setSize (600,60) . title "Note length" . leftRight $
> radio ["Whole","Half","Quarter","Eighth"] 2 -< ()
>
> maxInt <- (| (setSize (600,60) . title "Maximum interval" . leftRight) (do
> max <- shiSlider 1 (1,12) 12 -< ()
> sDisplay -< intNameList !! max
> returnA -< max )|)
>
> 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 )|)
>
> lowOct <- (| (setSize (600,60) . title "Lowest octave" . leftRight) (do
> low <- shiSlider 1 (1,8) 4 -< ()
> sDisplay -< show low
> returnA -< low )|)
>
> instr <- setSize (600,60) . title "Instrument" . leftRight $
> radio ["Acous Piano","Elec Piano","Violin","Saxophone","Flute"] 0 -< ()
>
> (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) )|)
>
> 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) |)
>
> let guessesE = foldl1 (.|.) $ zipWith (->>) guesses intNameList
> rec
> state <- delay Start <<< accum Start -< updates
>
> 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
>
>
> 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))
>
> 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) )
>
> let f n pn dur = if pn==n then 1 / fromIntegral (2 ^ dur) else 0
> del0 = f 2 pns dur
> del1 = f 1 pns dur
>
> 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)
>
> (| (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 -< () )|)
>
> 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