diff options
author | Andrew Cady <d@jerkface.net> | 2014-01-17 03:55:49 -0500 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2014-01-17 03:55:49 -0500 |
commit | 5736ae0a30c2a4844c0f26d6847356193482ee61 (patch) | |
tree | f19315c551ceafc933585323f08a308dcc0db0ce | |
parent | f619a4c584fe6c21c234b05487e9f2259e12d4a0 (diff) |
pretty close to live key display
-rw-r--r-- | AlsaSeq.hs | 5 | ||||
-rw-r--r-- | axis.hs | 23 |
2 files changed, 18 insertions, 10 deletions
@@ -1,5 +1,5 @@ | |||
1 | {-# LANGUAGE NondecreasingIndentation #-} | 1 | {-# LANGUAGE NondecreasingIndentation #-} |
2 | module AlsaSeq (withAlsaInit, parseAlsaEvents, forwardNoteEvent, cmdlineAlsaConnect, printChordLn, showChord) where | 2 | module AlsaSeq (withAlsaInit, parseAlsaEvents, forwardNoteEvent, cmdlineAlsaConnect, printChordLn, showChord, pitchList, showPitch) where |
3 | import qualified Sound.ALSA.Exception as AlsaExc | 3 | import qualified Sound.ALSA.Exception as AlsaExc |
4 | import qualified Sound.ALSA.Sequencer.Address as Addr | 4 | import qualified Sound.ALSA.Sequencer.Address as Addr |
5 | import qualified Sound.ALSA.Sequencer as SndSeq | 5 | import qualified Sound.ALSA.Sequencer as SndSeq |
@@ -40,7 +40,8 @@ showPitch x = | |||
40 | let (octave, pitch) = Haskore.Basic.Pitch.fromInt $ fromIntegral x | 40 | let (octave, pitch) = Haskore.Basic.Pitch.fromInt $ fromIntegral x |
41 | in Haskore.Basic.Pitch.classFormat pitch (show octave) | 41 | in Haskore.Basic.Pitch.classFormat pitch (show octave) |
42 | 42 | ||
43 | pitchWords set = map (showPitch . Event.unPitch) $ Set.toList set | 43 | pitchWords set = map showPitch $ pitchList set |
44 | pitchList set = map Event.unPitch $ Set.toList set | ||
44 | 45 | ||
45 | prettyNote :: Event.Note -> String | 46 | prettyNote :: Event.Note -> String |
46 | prettyNote (Event.Note noteChannel noteNote noteVelocity noteOffVelocity noteDuration) = | 47 | prettyNote (Event.Note noteChannel noteNote noteVelocity noteOffVelocity noteDuration) = |
@@ -14,6 +14,8 @@ import Data.String | |||
14 | import Graphics.UI.SDL.Keysym as SDL.Keysym | 14 | import Graphics.UI.SDL.Keysym as SDL.Keysym |
15 | import Graphics.UI.SDL.Primitives as SDL.Primitive | 15 | import Graphics.UI.SDL.Primitives as SDL.Primitive |
16 | import Data.Int (Int16) | 16 | import Data.Int (Int16) |
17 | import qualified System.Exit as Exit | ||
18 | import Data.List (elemIndex, elemIndices) | ||
17 | 19 | ||
18 | netwireIsCool :: (Monad m) => Wire (Timed NominalDiffTime ()) () m a String | 20 | netwireIsCool :: (Monad m) => Wire (Timed NominalDiffTime ()) () m a String |
19 | netwireIsCool = | 21 | netwireIsCool = |
@@ -61,7 +63,8 @@ main = | |||
61 | 63 | ||
62 | forM_ [0 .. length axis_key_locations - 1] $ \i -> do | 64 | forM_ [0 .. length axis_key_locations - 1] $ \i -> do |
63 | let (centerx, centery) = axis_key_locations !! i | 65 | let (centerx, centery) = axis_key_locations !! i |
64 | centerText videoSurface centerx centery font (show i) | 66 | centerText videoSurface centerx centery font (showPitch $ pitchIndex !! i) |
67 | -- centerText videoSurface centerx centery font (show i) | ||
65 | 68 | ||
66 | putStrLn "Initialized." | 69 | putStrLn "Initialized." |
67 | 70 | ||
@@ -78,18 +81,19 @@ main = | |||
78 | return () | 81 | return () |
79 | 82 | ||
80 | Control.Monad.when (midiKeysDown' /= midiKeysDown) $ do | 83 | Control.Monad.when (midiKeysDown' /= midiKeysDown) $ do |
81 | let chord = showChord midiKeysDown' | 84 | --let chord = showChord midiKeysDown' |
85 | --let chord = show $ pitchList midiKeysDown' | ||
86 | let chord = show $ map (\i->elemIndices i pitchIndex) $ pitchList midiKeysDown' | ||
82 | textBand videoSurface videoClipRect (SDL.Rect 0 70 0 70) font chord | 87 | textBand videoSurface videoClipRect (SDL.Rect 0 70 0 70) font chord |
83 | return () | 88 | return () |
84 | 89 | ||
85 | Control.Monad.when (keysDown' /= keysDown) $ do | 90 | Control.Monad.when (keysDown' /= keysDown) $ do |
86 | let chord = unwords $ map (\k -> drop 5 (show k)) $ Set.toList keysDown' | 91 | let chord = unwords $ map (\k -> drop 5 (show k)) $ Set.toList keysDown' |
87 | textBand videoSurface videoClipRect (SDL.Rect 0 210 0 70) font chord | 92 | textBand videoSurface videoClipRect (SDL.Rect 0 210 0 70) font chord |
93 | textBand videoSurface videoClipRect (SDL.Rect 0 280 0 70) font $ | ||
94 | if keyDown SDL.SDLK_a keysDown' then "arpeggiate" else "" | ||
88 | return () | 95 | return () |
89 | 96 | ||
90 | textBand videoSurface videoClipRect (SDL.Rect 0 280 0 70) font $ | ||
91 | if keyDown SDL.SDLK_a keysDown' then "arpeggiate" else "" | ||
92 | |||
93 | Control.Monad.when(False) $ do | 97 | Control.Monad.when(False) $ do |
94 | 98 | ||
95 | mouse <- SDL.getRelativeMouseState | 99 | mouse <- SDL.getRelativeMouseState |
@@ -121,13 +125,16 @@ drawHexagonSDL videoSurface centerx centery radius pixel = do | |||
121 | return () | 125 | return () |
122 | 126 | ||
123 | centerText videoSurface x y font text = do | 127 | centerText videoSurface x y font text = do |
124 | fontSurface <- SDL.TTF.renderUTF8Shaded font text (SDL.Color 0 255 0) (SDL.Color 80 80 80) | 128 | --fontSurface <- SDL.TTF.renderUTF8Shaded font text (SDL.Color 0 255 0) (SDL.Color 80 80 80) -- useful for testing |
129 | fontSurface <- SDL.TTF.renderUTF8Shaded font text (SDL.Color 0 255 0) (SDL.Color 0 0 0) | ||
125 | fontClipRect <- SDL.getClipRect fontSurface | 130 | fontClipRect <- SDL.getClipRect fontSurface |
126 | let (SDL.Rect _ _ w h) = fontClipRect | 131 | let (SDL.Rect _ _ w h) = fontClipRect |
127 | _ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect (fromIntegral(x) - w `div` 2) (fromIntegral(y) - h `div` 2) w h)) | 132 | _ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect (fromIntegral(x) - w `div` 2) (fromIntegral(y) - h `div` 2) w h)) |
128 | --_ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect (fromIntegral(x) + w) (fromIntegral(y) + h `div` 2) w h)) | ||
129 | return () | 133 | return () |
130 | 134 | ||
135 | colfrom top = map (+ top) $ map (* (-7)) [0 .. 6] | ||
136 | pitchIndex = (\x -> x ++ x) $ concat $ map colfrom [81, 78, 82, 79, 83, 80, 84] | ||
137 | |||
131 | getKeyLocations (SDL.Rect offx offy totalw totalh) = | 138 | getKeyLocations (SDL.Rect offx offy totalw totalh) = |
132 | let (key_height, key_width, xys) = getKeyLocationsAbs | 139 | let (key_height, key_width, xys) = getKeyLocationsAbs |
133 | 140 | ||
@@ -160,7 +167,7 @@ getKeyLocationsAbs = | |||
160 | kb_cols = 14 :: Double | 167 | kb_cols = 14 :: Double |
161 | -- the edges of the hexagon are equal in length to its "radius" | 168 | -- the edges of the hexagon are equal in length to its "radius" |
162 | -- if the radius is 1, then horizontal movement is 1.5 and vertical movement is sqrt(3) from one center to the next | 169 | -- if the radius is 1, then horizontal movement is 1.5 and vertical movement is sqrt(3) from one center to the next |
163 | -- or else it is 2*sqrt(3) to move up | 170 | -- or else it is 2*sqrt(3) to move down |
164 | 171 | ||
165 | kw = 1 :: Double | 172 | kw = 1 :: Double |
166 | kh = kw/2 * sqrt(3) -- hexagon ratio | 173 | kh = kw/2 * sqrt(3) -- hexagon ratio |