{-# LANGUAGE Arrows, CPP #-} 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 --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 -- first fret's width and height fw,fh,tw,th :: Int (fw, fh) = (90, 45) (tw, th) = (8, 16) type KeyType = Int type GuitarKeyMap = [(String, Pitch, Char)] -- Draws an individual fret #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)) -- Draws the string on top of each fret drawString :: Bool -> Rect -> Graphic drawString down ((x, y), (w, h)) = withColor Black (if down then arc ((x,midY-2),(w, 4)) (-180) 180 else line (x-1, 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 -- Draws just the guitar head, not interactive drawHead :: Int -> UISF () () drawHead n = topDown $ constA (repeat ()) >>> concatA (map (mkBasicWidget layout . draw) [n,n-1..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) --drawHead :: Int -> UISF () () --drawHead 0 = proc _ -> returnA -< () --drawHead n = topDown $ proc _ -> do -- ui <- mkBasicWidget layout draw -< () -- ui' <- drawHead (n-1) -< () -- returnA -< () -- where draw ((x,y),(w,h)) = withColor Black $ line (x, y + h `div` 2 + 5 * (3 - n)) (x + w, y + h `div` 2) -- layout = Layout 0 0 fw fh fw fh -- Given a character to respond to, and which fret it is, draws and displays a single interactive fret 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 -- This line should be more robust -- Makes all of the frets on a string, returning the combined list of their outputs 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 -- Creates the whole string, including the response to the strum key 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 -- Invisible widget that responds to a single character -- There should really be built-in behavior for this sort of thing 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 -- Assembles the whole guitar according to a given key map and channel -- Requires a persistent instrument data object to be passed in. -- Any midi messages passed to the guitar will be played on all applicable frets -- Outputs its midi messages as generated by its inputs and user interaction 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 -- The default six string keymap. The first in the tuple determines how many frets -- will be displayed and what their activator keys are. The second in the tuple -- is the open pitch (that is, the note that is played when no frets are pressed) -- and the final entry is the strum key. 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]