module Euterpea.IO.MUI.Guitar where
import FRP.UISF hiding ((~++))
import FRP.UISF.UITypes
import Euterpea.IO.MIDI
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 qualified FRP.UISF.SOE as SOE
import FRP.UISF.SOE hiding (arc, ellipse)
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)
arc ((x,y),(w,h)) = SOE.arc (x,y) (x+w,y+h)
ellipse ((x,y),(w,h)) = SOE.ellipse (x,y) (x+w,y+h)
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
fw,fh,tw,th :: Int
(fw, fh) = (90, 45)
(tw, th) = (8, 16)
type KeyType = Int
type GuitarKeyMap = [(String, Pitch, Char)]
#if MIN_VERSION_UISF(0,4,0)
drawFret :: (Color,Color,Color,Color) -> Rect -> Graphic
#endif
drawFret (to,ti,bi,bo) ((x, y), (w, h)) =
withColorC ti (line (x + 1, y + 1) (x + 1, y + h + 1)) //
withColorC bi (line (x + w 2, y + 1) (x + w 2, y + h + 1)) //
withColorC to (line (x, y) (x, y + h)) //
withColorC bo (line (x + w 1, y) (x + w 1, y + h))
drawString :: Bool -> Rect -> Graphic
drawString down ((x, y), (w, h)) =
withColor Black (if down then arc ((x,midY2),(w, 4)) (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), (2*d, 2*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 = makeLayout (Fixed fw) (Fixed fh)
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)
(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'
#if MIN_VERSION_UISF(0,4,0)
Button pt LeftButton down ->
#else
Button pt True down ->
#endif
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) $ rectangleFilled ((0,0),(10,10))
process _ s _ evt = (s', s', s /= s') where
s' = case evt of
#if MIN_VERSION_UISF(0,4,0)
Button pt LeftButton down -> down
#else
Button pt True down -> down
#endif
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]