summaryrefslogtreecommitdiff
path: root/axis.hs
diff options
context:
space:
mode:
Diffstat (limited to 'axis.hs')
-rw-r--r--axis.hs55
1 files changed, 36 insertions, 19 deletions
diff --git a/axis.hs b/axis.hs
index 9046eff..e6720ad 100644
--- a/axis.hs
+++ b/axis.hs
@@ -15,7 +15,7 @@ import Graphics.UI.SDL.Keysym as SDL.Keysym
15import Graphics.UI.SDL.Primitives as SDL.Primitive 15import Graphics.UI.SDL.Primitives as SDL.Primitive
16import Data.Int (Int16) 16import Data.Int (Int16)
17import qualified System.Exit as Exit 17import qualified System.Exit as Exit
18import Data.List (elemIndex, elemIndices, filter) 18import Data.List (elemIndex, elemIndices, filter, groupBy, length, reverse)
19import GHC.Word 19import GHC.Word
20import Data.Bits 20import Data.Bits
21import qualified Sound.ALSA.Sequencer.Event as Event 21import qualified Sound.ALSA.Sequencer.Event as Event
@@ -40,7 +40,7 @@ _COLORIZE_BY_CHANNEL = True
40 40
41_AXIS_ROWS = 7 + 4 41_AXIS_ROWS = 7 + 4
42_AXIS_UNIQUE_COLS = 7 42_AXIS_UNIQUE_COLS = 7
43_AXIS_COLS_REPEAT = 2 43_AXIS_COLS_REPEAT = 1
44_AXIS_TOP_PITCH = 81 + (7 * (_AXIS_ROWS - 7) `div` 2) 44_AXIS_TOP_PITCH = 81 + (7 * (_AXIS_ROWS - 7) `div` 2)
45_AXIS_BOTTOM_PITCH = 81 - (7 * _AXIS_ROWS) - 3 45_AXIS_BOTTOM_PITCH = 81 - (7 * _AXIS_ROWS) - 3
46_OCTAVE_SQUASH = False -- it's terrible, because it draws the octave in the wrong shape 46_OCTAVE_SQUASH = False -- it's terrible, because it draws the octave in the wrong shape
@@ -115,30 +115,46 @@ pitchToColor p =
115 x | inMajorC x -> (SDL.Color 0xE0 0xE0 0xE0) -- _CGA !! 7 115 x | inMajorC x -> (SDL.Color 0xE0 0xE0 0xE0) -- _CGA !! 7
116 _ -> _CGA !! 8 116 _ -> _CGA !! 8
117 117
118smartDrawKeys reallyErase drawSet eraseSet videoSurface font axis_key_locations axis_key_size = do 118smartDrawKeys' :: (Integral a, Integral a2, Integral a1) => Bool -> Set.Set (Event.Channel, Event.Pitch) -> Set.Set (Event.Channel, Event.Pitch) -> SDL.Surface -> SDL.TTF.Font -> [(a1, a2)] -> a -> IO ()
119 119smartDrawKeys' reallyErase drawSet eraseSet videoSurface font axis_key_locations axis_key_size = do
120 let drawList = filter (\ (c, _) -> unChannel c /= 9) $ Set.toList drawSet 120 let
121 eraseList = filter (\ (c, _) -> unChannel c /= 9) $ Set.toList eraseSet 121 changroup = groupBy (\(_, n1) (_, n2) -> n1 == n2)
122 chanfilter = filter (\ (c, _) -> unChannel c /= 9)
123 drawList = changroup . chanfilter $ Set.toList drawSet
124 eraseList = changroup . chanfilter $ Set.toList eraseSet
122 125
123 forM_ [(eraseList, True), (drawList, False)] $ \ (ls, erase) -> do 126 forM_ [(eraseList, True), (drawList, False)] $ \ (ls, erase) -> do
124 forM_ ls $ \ (c, n) -> do 127 forM_ ls $ \ls' -> do
125 let text = smartShowPitch (unPitch n) 128 let chans = map (\ (c, _) -> unChannel c) ls'
129 (_, n) = head ls'
130 text = smartShowPitch (unPitch n)
126 pitch = if _OCTAVE_SQUASH then (unPitch n) `mod` 12 + 12 * 6 else (unPitch n) 131 pitch = if _OCTAVE_SQUASH then (unPitch n) `mod` 12 + 12 * 6 else (unPitch n)
127 chann = unChannel c 132 onColor = _KEY_ON_COLOR
128 onColor = if _COLORIZE_BY_CHANNEL
129 then _CHAN_TO_COLOR !! ((fromIntegral chann) `mod` 16)
130 else _KEY_ON_COLOR
131 offColor = pitchToColor pitch 133 offColor = pitchToColor pitch
132 forM_ (elemIndices pitch pitchIndex) $ \idx -> do 134 forM_ (elemIndices pitch pitchIndex) $ \idx -> do
133 drawKey idx videoSurface font axis_key_locations axis_key_size 135 drawKey' idx videoSurface font axis_key_locations axis_key_size
134 (if erase then (if reallyErase then _KB_BG_COLOR else offColor) else onColor) 136 offColor
135 (if reallyErase then _KB_BG_COLOR_PIXEL else _KEY_BORDER_COLOR_PIXEL) 137 (if reallyErase then _KB_BG_COLOR_PIXEL else _KEY_BORDER_COLOR_PIXEL)
136 (if erase then Nothing else (Just text)) 138 (if erase then Nothing else (Just text))
139 (if erase then [] else (map fromIntegral chans))
137 140
138drawKey idx videoSurface font axis_key_locations axis_key_size fillColor borderColor text = do 141drawKey' :: (Integral a1, Integral a2, Integral a) => Int -> SDL.Surface -> SDL.TTF.Font -> [(a1, a2)] -> a -> SDL.Color -> t -> Maybe String -> [Int] -> IO ()
142drawKey' idx videoSurface font axis_key_locations axis_key_size fillColor borderColor text channels = do
139 let (x, y) = axis_key_locations !! idx 143 let (x, y) = axis_key_locations !! idx
140 drawFilledHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) (colorToPixel fillColor) 144 drawFilledHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) (colorToPixel fillColor)
141 --drawHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) borderColor 145 let len = length channels
146 Control.Monad.when (len /= 0) $ do
147 forM_ [0 .. len - 1] $ \i -> do
148 let (x', y') = if len == 1 then (0, 0)
149 else (d * cos(pi/3 * fromIntegral(i)), d * sin(pi/3 * fromIntegral(i)))
150 d = (fromIntegral axis_key_size) / 4 :: Float
151 r' = (fromIntegral axis_key_size) / 2 :: Float
152 x'' = (round x') + (fromIntegral x)
153 y'' = (round y') + (fromIntegral y)
154 chan = channels !! i
155 color = _CHAN_TO_COLOR !! chan
156 SDL.Primitive.filledCircle videoSurface x'' y'' (round r') (colorToPixel color)
157
142 case text of 158 case text of
143 (Just t) -> centerText videoSurface x y font _KEY_TEXT_COLOR fillColor t 159 (Just t) -> centerText videoSurface x y font _KEY_TEXT_COLOR fillColor t
144 _ -> return () 160 _ -> return ()
@@ -146,7 +162,7 @@ drawKey idx videoSurface font axis_key_locations axis_key_size fillColor borderC
146eraseKeys_ really pitches videoSurface font axis_key_locations axis_key_size = 162eraseKeys_ really pitches videoSurface font axis_key_locations axis_key_size =
147 let pitchSet = Set.fromList $ map (\p -> (Event.Channel 1, Event.Pitch p)) pitches 163 let pitchSet = Set.fromList $ map (\p -> (Event.Channel 1, Event.Pitch p)) pitches
148 in 164 in
149 smartDrawKeys really Set.empty pitchSet videoSurface font axis_key_locations axis_key_size 165 smartDrawKeys' really Set.empty pitchSet videoSurface font axis_key_locations axis_key_size
150reallyEraseKeys = eraseKeys_ True 166reallyEraseKeys = eraseKeys_ True
151eraseKeys = eraseKeys_ False 167eraseKeys = eraseKeys_ False
152 168
@@ -209,7 +225,7 @@ main =
209 let drawThese = Set.difference midiKeysDown' ignoreThese 225 let drawThese = Set.difference midiKeysDown' ignoreThese
210 let eraseThese = Set.difference midiKeysDown ignoreThese 226 let eraseThese = Set.difference midiKeysDown ignoreThese
211 227
212 smartDrawKeys False drawThese eraseThese videoSurface font axis_key_locations axis_key_size 228 smartDrawKeys' False drawThese eraseThese videoSurface font axis_key_locations axis_key_size
213 return () 229 return ()
214 230
215 Control.Monad.when (keysDown' /= keysDown && keyDown SDL.SDLK_BACKSPACE keysDown') allKeysOFF 231 Control.Monad.when (keysDown' /= keysDown && keyDown SDL.SDLK_BACKSPACE keysDown') allKeysOFF
@@ -254,7 +270,8 @@ _drawHexagonSDL filled videoSurface centerx centery radius pixel = do
254 270
255centerText videoSurface x y font fgColor bgColor text = do 271centerText videoSurface x y font fgColor bgColor text = do
256--fontSurface <- SDL.TTF.renderUTF8Shaded font text (SDL.Color 0 255 0) (SDL.Color 80 80 80) -- useful for testing 272--fontSurface <- SDL.TTF.renderUTF8Shaded font text (SDL.Color 0 255 0) (SDL.Color 80 80 80) -- useful for testing
257 fontSurface <- SDL.TTF.renderUTF8Shaded font text fgColor bgColor 273--fontSurface <- SDL.TTF.renderUTF8Shaded font text fgColor bgColor
274 fontSurface <- SDL.TTF.renderUTF8Blended font text fgColor
258 fontClipRect <- SDL.getClipRect fontSurface 275 fontClipRect <- SDL.getClipRect fontSurface
259 let (SDL.Rect _ _ w h) = fontClipRect 276 let (SDL.Rect _ _ w h) = fontClipRect
260 _ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect (fromIntegral(x) - w `div` 2) (fromIntegral(y) - h `div` 2) w h)) 277 _ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect (fromIntegral(x) - w `div` 2) (fromIntegral(y) - h `div` 2) w h))