myTestlll-1.0.0: Euterpea/IO/MUI/Piano.hs
{-# LANGUAGE Arrows #-}
module Euterpea.IO.MUI.Piano where
import FRP.UISF
import FRP.UISF.SOE
import FRP.UISF.UITypes (Layout(..))
import FRP.UISF.Widget
import Euterpea.Music.Note.Music hiding (transpose)
import Euterpea.IO.MUI.InstrumentBase
import qualified Codec.Midi as Midi
import Data.Maybe
import qualified Data.Char as Char
--Note, only valid for standard US keyboards:
--Also, this is an ugly hack that can't stay
--it's mostly to test the new key events
toUpper :: Char -> Char
toUpper c = fromMaybe (Char.toUpper c) (lookup c keyMap)
where keyMap = [('`', '~'), ('1', '!'), ('2', '@'), ('3', '#'), ('4', '$'),
('5', '%'), ('6', '^'), ('7', '&'), ('8', '*'), ('9', '('),
('0', ')'), ('-', '_'), ('=', '+'), ('[', '{'), (']', '}'),
('|', '\\'), ('\'', '\"'), (';', ':'), ('/', '?'), ('.', '>'),
(',', '<')]
isUpper :: Char -> Bool
isUpper c = toUpper c == c
data KeyType = White1 | White2 | White3 | Black1 deriving (Show, Eq)
defaultKeyLayout :: [KeyType]
defaultKeyLayout = cycle [White1, Black1, White2, Black1, White3, White1, Black1, White2, Black1, White2, Black1, White3]
-- Width Height of White and Black notes
ww, wh, bw, bh, tw, th :: Int
(ww, wh) = (35, 100)
(bw, bh) = (25, 60)
(tw, th) = (8, 16)
topW :: KeyType -> Int
topW Black1 = bw `div` 2
topW White1 = ww - bw `div` 2
topW White2 = ww - bw `div` 2
topW White3 = ww
insideKey :: KeyType -> (Int,Int) -> ((Int,Int),(Int,Int)) -> Bool
insideKey Black1 pt ((x, y), (w, h)) = pt `inside` ((x,y),(bw,bh))
insideKey White1 pt ((x, y), (w, h)) =
let b1 = ((x,y), (ww - bw `div` 2, bh))
b2 = ((x, y+bh), (ww, wh-bh))
in (pt `inside` b1) || (pt `inside` b2)
insideKey White2 pt ((x, y), (w, h)) =
let b1 = ((x+bw `div` 2,y), (ww - bw, bh))
b2 = ((x, y+bh), (ww, wh-bh))
in (pt `inside` b1) || (pt `inside` b2)
insideKey White3 pt ((x, y), (w, h)) =
let b1 = ((x+bw `div` 2,y), (bw `div` 2, bh))
b2 = ((x, y+bh), (ww, wh-bh))
in (pt `inside` b1) || (pt `inside` b2)
isBlack :: KeyType -> Bool
isBlack Black1 = True
isBlack _ = False
-- *****************************************************************************
-- Drawing routines for each key type
-- *****************************************************************************
-- This has a complicated type, so I'm leaving it out.
drawBox kt | kt == White1 = white1
| kt == White2 = white2
| kt == White3 = white3
| kt == Black1 = black1
drawBox _ = error "Euterpea.IO.MUI.Piano.drawBox: Unexpected input"
white1 [] _ = nullGraphic
white1 ((t, b):cs) ((x, y), (w, h)) =
let x' = x + w - bw `div` 2
y' = y + bh
in white1 cs ((x + 1, y + 1), (w - 2, h - 2)) //
withColor' t (line (x, y) (x, y + h - 1) //
line (x, y) (x' - 2, y) //
line (x' - 2, y+bh) (x + w - 2, y+bh)) //
withColor' b (line (x + 1, y + h - 1) (x + w - 1, y + h - 1) //
line (x + w - 2 - bw `div` 2, y) (x + w - 2 - bw `div` 2, y+bh) //
line (x + w - 1, y + bh) (x + w - 1, y + h - 1))
white2 [] _ = nullGraphic
white2 ((t, b):cs) ((x, y), (w, h)) =
let x1 = x + bw `div` 2
x2 = x + w - bw `div` 2
y' = y + bh
in white2 cs ((x + 1, y + 1), (w - 2, h - 2)) //
withColor' t (line (x1+2, y) (x1+2, y' - 1) //
line (x1+2, y) (x2 - 2, y) //
line (x - 2, y') (x1 - 2, y') //
line (x2- 2, y') (x + w - 2, y')) //
withColor' b (line (x + 1, y + h - 1) (x + w - 1, y + h - 1) //
line (x2 - 1, y) (x2 - 1, y') //
line (x + w - 1, y + bh) (x + w - 1, y + h - 1))
white3 [] _ = nullGraphic
white3 ((t, b):cs) ((x, y), (w, h)) =
let x1 = x + bw `div` 2
y' = y + bh
in white3 cs ((x + 1, y + 1), (w - 2, h - 2)) //
withColor' t (line (x1+2, y) (x1+2, y' - 1) //
line (x1+2, y) (x + w - 2, y) //
line (x - 2, y') (x1 - 2, y')) //
withColor' b (line (x + 1, y + h - 1) (x + w - 1, y + h - 1) //
line (x + w - 1, y) (x + w - 1, y') //
line (x + w - 1, y + bh) (x + w - 1, y + h - 1))
black1 [] _ = nullGraphic
black1 ((t, b):cs) ((x, y), (w, h)) =
black1 cs ((x + 1, y + 1), (w - 2, h - 2)) //
withColor' t (line (x, y) (x, y + h - 1) //
line (x, y) (x + w - 2, y)) //
withColor' b (line (x + 1, y + h - 1) (x + w - 1, y + h - 1) //
line (x + w - 1, y) (x + w - 1, y + h - 1))
colorKey Black1 b = withColor Black $ block b
colorKey kt ((x,y), (w,h)) = withColor White $ block ((x, y+bh), (ww, wh-bh)) // f kt
where f White1 = block ((x,y), (ww - bw `div` 2, bh))
f White2 = block ((x+ bw `div` 2, y), (ww-bw, bh))
f White3 = block ((x+ bw `div` 2, y), (ww-bw `div` 2, bh))
f _ = error "Euterpea.IO.MUI.Piano.colorKey: Unexpected input"
-- *****************************************************************************
-- Single-key widget: handles key/mouse input and check if the song is playing
-- *****************************************************************************
mkKey :: Char -> KeyType -> UISF KeyData KeyState
mkKey c kt = mkWidget iState d process draw where
iState = (KeyState False False False 127, Nothing)
d = Layout 0 0 0 minh minw minh
minw = topW kt
minh | isBlack kt = bh
| otherwise = wh
draw rect inFocus (kb, showNote) =
let isDown = isKeyDown kb
b@((x,y),(w,h)) = realBBX rect
x' = x + (w - tw) `div` 2 + if isDown then 0 else -1
y' = y + h `div` 3 + (h - th) `div` 2 + if isDown then 0 else -1
drawNotation s = withColor Red $ text (x'+(1-length s)*tw `div` 2, y'- th + 2) s
in withColor (if isBlack kt then White else Black) (text (x',y') [c])
// maybe nullGraphic drawNotation showNote
// withColor White (drawBox kt (if isDown then pushed else popped) b)
// colorKey kt b
realBBX ((x,y),(w,h)) = let (w', h') | isBlack kt = (bw,bh)
| otherwise = (ww,wh)
in ((x,y),(w',h'))
process kd (kb,_) bbx evt = (kb'', (kb'', notation kd), kb /= kb'') where
kb' = if isJust (pressed kd) then kb { song = fromJust $ pressed kd } else kb
kb'' = case evt of
Key c' ms down ->
if detectKey c' (hasShiftModifier ms)
then kb' { keypad = down, vel = 127 }
else kb'
Button pt True down -> case (mouse kb', down, insideKey kt pt bbx) of
(False, True, True) -> kb' { mouse = True, vel = getVel pt bbx }
(True, False, True) -> kb' { mouse = False, vel = getVel pt bbx }
otherwise -> kb'
MouseMove pt -> if insideKey kt pt bbx then kb' else kb' { mouse = False }
_ -> kb'
where getVel (u,v) ((x,y),(w,h)) = 40 + 87 * round (fromIntegral (v - y) / fromIntegral h)
detectKey c' s = toUpper c == toUpper c' && isUpper c == s -- This line should be more robust
-- *****************************************************************************
-- Group all keys together
-- *****************************************************************************
mkKeys :: [(Char, KeyType, AbsPitch)] -> UISF InstrumentData (SEvent [(AbsPitch, Bool, Midi.Velocity)])
mkKeys [] = proc instr -> returnA -< Nothing
mkKeys ((c,kt,ap):ckas) = proc instr -> do
msg <- unique <<< mkKey c kt -< getKeyData ap instr
let on = maybe False isKeyPlay msg
ped = pedal instr
ret | not on && not ped = [(ap, False, maybe 0 vel msg)]
| on = [(ap, True, maybe 127 vel msg)]
| otherwise = []
msgs <- mkKeys ckas -< instr
returnA -< fmap (const ret) msg ~++ msgs
-- *****************************************************************************
-- Main widget: piano that takes a map (string) of characters to map to notes
-- and the pitch of the first note
-- two default maps are provided so that two piano can be loaded concurrently
-- *****************************************************************************
type PianoKeyMap = (String, Pitch)
defaultMap1, defaultMap2, defaultMap0 :: PianoKeyMap
defaultMap1 = ("q2w3er5t6y7uQ@W#ERT^Y&U*", (C,2))
defaultMap2 = ("zsxdcvgbhnjmZSXDCVGBHNJM", (C,3))
defaultMap0 = (fst defaultMap1 ++ fst defaultMap2, (C,3))
piano :: PianoKeyMap -> Midi.Channel -> UISF (InstrumentData,EMM) EMM
piano (s,p) chn = focusable $ proc (instr,emm) -> do
let emm' = fmap (setChannel chn) emm
let instrData = instr { keyPairs = fmap mmToPair emm' }
keys <- leftRight $ mkKeys (zip3 s defaultKeyLayout (iterate (1+) (absPitch p))) -< instrData
returnA -< fmap (pairToMsg chn) keys ~++ emm'