> {-# 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 ->>