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
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]
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, whbh))
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, whbh))
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, whbh))
in (pt `inside` b1) || (pt `inside` b2)
isBlack :: KeyType -> Bool
isBlack Black1 = True
isBlack _ = False
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, whbh)) // f kt
where f White1 = block ((x,y), (ww bw `div` 2, bh))
f White2 = block ((x+ bw `div` 2, y), (wwbw, bh))
f White3 = block ((x+ bw `div` 2, y), (wwbw `div` 2, bh))
f _ = error "Euterpea.IO.MUI.Piano.colorKey: Unexpected input"
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'+(1length 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
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
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'