module Euterpea.IO.MUI.Piano where
import FRP.UISF hiding ((~++))
import FRP.UISF.UITypes
import Euterpea.Music.Note.Music hiding (transpose)
import Euterpea.IO.MUI.InstrumentBase
import Euterpea.IO.MUI.MidiWidgets ((~++))
import qualified Codec.Midi as Midi
import Data.Maybe
import qualified Data.Char as Char
#if MIN_VERSION_UISF(0,4,0)
import FRP.UISF.Graphics
import FRP.UISF.Widget.Construction
import FRP.UISF.Widget
withColorC = withColor
#else
import FRP.UISF.SOE
import qualified FRP.UISF.Widget as W
import FRP.UISF.Widget hiding (pushed, popped, marked)
pushed = let [(to,bo),(ti,bi)] = W.pushed
in (to,ti,bi,bo)
popped = let [(to,bo),(ti,bi)] = W.popped
in (to,ti,bi,bo)
rectangleFilled = block
withColorC = withColor'
#endif
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 -> Point -> Rect -> 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
#if MIN_VERSION_UISF(0,4,0)
drawKey :: KeyType -> (Color,Color,Color,Color) -> Rect -> Graphic
#endif
drawKey White1 (to,ti,bi,bo) ((x, y), (w, h)) =
let val = x + w bw `div` 2
in withColorC ti (line (x + 1, y + 1) (x + 1, y + h 2) //
line (x + 1, y + 1) (val 3, y + 1) //
line (val 3, y + 1 + bh) (x + w 3, y + 1 + bh))
// withColorC bi (line (x + 2, y + h 2) (x + w 2, y + h 2) //
line (val 3, y + 1) (val 3, y + 1 + bh) //
line (x + w 2, y + 1 + bh) (x + w 2, y + h 2))
// withColorC to (line (x, y) (x, y + h 1) //
line (x, y) (val 2, y) //
line (val 2, y + bh) (x + w 2, y + bh))
// withColorC bo (line (x + 1, y + h 1) (x + w 1, y + h 1) //
line (val 2, y) (val 2, y + bh) //
line (x + w 1, y + bh) (x + w 1, y + h 1))
drawKey White2 (to,ti,bi,bo) ((x, y), (w, h)) =
let valP = x + bw `div` 2
valM = x + w bw `div` 2
in withColorC ti (line (valP + 3, y + 1) (valP + 3, y + bh) //
line (valP + 3, y + 1) (valM 3, y + 1) //
line (x 1, y + bh + 1) (valP 1, y + bh + 1) //
line (valM 3, y + bh + 1) (x + w 3, y + bh + 1))
// withColorC bi (line (x + 2, y + h 2) (x + w 2, y + h 2) //
line (valM 2, y + 1) (valM 2, y + bh + 1) //
line (x + w 2, y + bh + 1) (x + w 2, y + h 2))
// withColorC to (line (valP + 2, y) (valP + 2, y + bh 1) //
line (valP + 2, y) (valM 2, y) //
line (x 2, y + bh) (valP 2, y + bh) //
line (valM 2, y + bh) (x + w 2, y + bh))
// withColorC bo (line (x + 1, y + h 1) (x + w 1, y + h 1) //
line (valM 1, y) (valM 1, y + bh) //
line (x + w 1, y + bh) (x + w 1, y + h 1))
drawKey White3 (to,ti,bi,bo) ((x, y), (w, h)) =
let val = x + bw `div` 2
in withColorC ti (line (val + 3, y + 1) (val + 3, y + bh) //
line (val + 3, y + 1) (x + w 3, y + 1) //
line (x 1, y + bh + 1) (val 1, y + bh + 1))
// withColorC bi (line (x + 2, y + h 2) (x + w 2, y + h 2) //
line (x + w 2, y + 1) (x + w 2, y + bh + 1) //
line (x + w 2, y + bh + 1) (x + w 2, y + h 2))
// withColorC to (line (val + 2, y) (val + 2, y + bh 1) //
line (val + 2, y) (x + w 2, y) //
line (x 2, y + bh) (val 2, y + bh))
// withColorC bo (line (x + 1, y + h 1) (x + w 1, y + h 1) //
line (x + w 1, y) (x + w 1, y + bh) //
line (x + w 1, y + bh) (x + w 1, y + h 1))
drawKey Black1 (to,ti,bi,bo) ((x, y), (w, h)) =
withColorC ti (line (x + 1, y + 1) (x + 1, y + h 2) //
line (x + 1, y + 1) (x + w 3, y + 1))
// withColorC bi (line (x + 2, y + h 2) (x + w 2, y + h 2) //
line (x + w 2, y + 1) (x + w 2, y + h 2))
// withColorC to (line (x, y) (x, y + h 1) //
line (x, y) (x + w 2, y))
// withColorC bo (line (x + 1, y + h 1) (x + w 1, y + h 1) //
line (x + w 1, y) (x + w 1, y + h 1))
colorKey :: KeyType -> Rect -> Graphic
colorKey Black1 r = withColor Black $ rectangleFilled r
colorKey White1 ((x,y), (w,h)) = withColor White $
rectangleFilled ((x, y+bh), (ww, whbh))
// rectangleFilled ((x,y), (ww bw `div` 2, bh))
colorKey White2 ((x,y), (w,h)) = withColor White $
rectangleFilled ((x, y+bh), (ww, whbh))
// rectangleFilled ((x+ bw `div` 2, y), (wwbw, bh))
colorKey White3 ((x,y), (w,h)) = withColor White $
rectangleFilled ((x, y+bh), (ww, whbh))
// rectangleFilled ((x+ bw `div` 2, y), (wwbw `div` 2, bh))
mkKey :: Char -> KeyType -> UISF KeyData KeyState
mkKey c kt = mkWidget iState d process draw where
iState = (KeyState False False False 127, Nothing)
d = makeLayout (Fixed minw) (Fixed 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 (drawKey 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'
#if MIN_VERSION_UISF(0,4,0)
Button pt LeftButton down -> case (mouse kb', down, insideKey kt pt bbx) of
#else
Button pt True down -> case (mouse kb', down, insideKey kt pt bbx) of
#endif
(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 [] = constA 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#ER%T^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'