module Euterpea.IO.MUI.Guitar where
import FRP.UISF
import FRP.UISF.SOE
import FRP.UISF.UITypes (Layout(..), nullLayout)
import FRP.UISF.Widget
import Euterpea.IO.MIDI
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
fw,fh,tw,th :: Int
(fw, fh) = (90, 45)
(tw, th) = (8, 16)
type KeyType = Int
type GuitarKeyMap = [(String, Pitch, Char)]
drawFret [] ((x, y), (w, h)) = nullGraphic
drawFret ((t, b):cs) ((x, y), (w, h)) =
drawFret cs ((x + 1, y + 1), (w 2, h )) //
withColor' t (line (x, y) (x, y + h)) //
withColor' b (line (x + w 1, y) (x + w 1, y + h))
drawString down ((x, y), (w, h)) =
withColor Black (if down then arc (x,midY+2) (x+w, midY2) (180) 180
else line (x1, y+ h `div` 2) (x+w, y+h `div` 2)) //
if down then withColor Blue (ellipse (midX d, midY d) (midX + d, midY + d)) else nullGraphic
where d = 10
midX = x + w `div` 2
midY = y + h `div` 2
drawHead :: Int -> UISF () ()
drawHead n = topDown $ constA (repeat ()) >>>
concatA (map (mkBasicWidget layout . draw) [n,n1..1]) >>>
constA ()
where draw k ((x,y),(w,h)) = withColor Black $ line (x, y + h `div` 2 + 5 * (3 k)) (x + w, y + h `div` 2)
layout = Layout 0 0 fw fh fw fh
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
(minh, minw) = (fh, fw kt * 3)
draw box@((x,y),(w,h)) _ (kb, showNote) =
let isDown = isKeyDown kb
x' = x + (w tw) `div` 2 + if isDown then 0 else 1
y' = y + h `div` 5 + (h th) `div` 2 + if isDown then 0 else 1
drawNotation s = withColor Red $ text (x' + (1 length s) * tw `div` 2, y' th) s
in withColor Blue (text (x', y') [c])
// maybe nullGraphic drawNotation showNote
// drawString isDown box
// drawFret popped box
process kd (kb,_) box 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, pt `inside` box) of
(False, True, True) -> kb' { mouse = True, vel = getVel pt box }
(True, False, True) -> kb' { mouse = False, vel = getVel pt box }
otherwise -> kb'
MouseMove pt ->
if pt `inside` box
then kb'
else kb' { mouse = False }
otherwise -> kb'
where getVel (u,v) ((x,y),(w,h)) = 127 round (87 * (abs (fromIntegral u fromIntegral (2 * x + w) / 2) / (fromIntegral w / 2)))
detectKey c' s = toUpper c == toUpper c' && isUpper c == s
mkKeys :: AbsPitch -> [(Char, KeyType, AbsPitch)] -> UISF (Bool, InstrumentData) (SEvent [(AbsPitch, Bool, Midi.Velocity)])
mkKeys _ [] = proc _ -> returnA -< Nothing
mkKeys free ((c,kt,ap):ckas) = proc (pluck, instr) -> do
msg <- unique <<< mkKey c kt -< getKeyData ap instr
let on = maybe False isKeyPlay msg
ret | pluck = if on then [(ap, True, maybe 127 vel msg)] else [(free, True, 127)]
| otherwise = [(ap, False, maybe 0 vel msg)]
msgs <- mkKeys free ckas -< (pluck, instr)
returnA -< fmap (const ret) msg ~++ msgs
mkString :: (String, Pitch, Char) -> UISF InstrumentData (SEvent [(AbsPitch, Bool, Midi.Velocity)])
mkString (frets, freePitch, p) = leftRight $ proc insData -> do
isPluck <- pluckString p -< ()
msgs <- mkKeys freeap (zip3 frets [1..] [freeap+1..]) -< (isPluck, insData)
returnA -< msgs
where freeap = absPitch freePitch
pluckString :: Char -> UISF () Bool
pluckString c = mkWidget False nullLayout process draw where
draw ((x,y),(w,h)) _ down =
let x' = x + (w tw) `div` 2 + if down then 0 else 1
y' = y + (h th) `div` 2 + if down then 0 else 1
in withColor (if down then White else Black) $ block ((0,0),(10,10))
process _ s _ evt = (s', s', s /= s') where
s' = case evt of
Button pt True down -> down
Key c' _ down ->
down && c == c'
_ -> s
guitar :: GuitarKeyMap -> Midi.Channel -> UISF (InstrumentData,EMM) EMM
guitar spcList chn = focusable $ leftRight $ proc (instr, emm) -> do
let emm' = fmap (setChannel chn) emm
h <- drawHead (length spcList) -< ()
frets <- mkStrings spcList -< instr { keyPairs = fmap mmToPair emm' }
returnA -< fmap (pairToMsg chn) frets ~++ emm'
where mkStrings [] = proc _ -> returnA -< Nothing
mkStrings (spc:spcs) = topDown $ proc instrData -> do
msg <- mkString spc -< instrData
msgs <- mkStrings spcs -< instrData
returnA -< msg ~++ msgs
string1, string2, string3, string4, string5, string6 :: (String, Pitch, Char)
string6 = ("1qaz__________", (E,5), '\b')
string5 = ("2wsx__________", (B,4), '=')
string4 = ("3edc__________", (G,4), '-')
string3 = ("4rfv__________", (D,4), '0')
string2 = ("5tgb__________", (A,3), '9')
string1 = ("6yhn__________", (E,3), '8')
sixString :: GuitarKeyMap
sixString = reverse [string1, string2, string3, string4, string5, string6]