diff options
-rw-r--r-- | axis.hs | 55 |
1 files changed, 36 insertions, 19 deletions
@@ -15,7 +15,7 @@ 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 | 17 | import qualified System.Exit as Exit |
18 | import Data.List (elemIndex, elemIndices, filter) | 18 | import Data.List (elemIndex, elemIndices, filter, groupBy, length, reverse) |
19 | import GHC.Word | 19 | import GHC.Word |
20 | import Data.Bits | 20 | import Data.Bits |
21 | import qualified Sound.ALSA.Sequencer.Event as Event | 21 | import 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 | ||
118 | smartDrawKeys reallyErase drawSet eraseSet videoSurface font axis_key_locations axis_key_size = do | 118 | smartDrawKeys' :: (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 | 119 | smartDrawKeys' 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 | ||
138 | drawKey idx videoSurface font axis_key_locations axis_key_size fillColor borderColor text = do | 141 | drawKey' :: (Integral a1, Integral a2, Integral a) => Int -> SDL.Surface -> SDL.TTF.Font -> [(a1, a2)] -> a -> SDL.Color -> t -> Maybe String -> [Int] -> IO () |
142 | drawKey' 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 | |||
146 | eraseKeys_ really pitches videoSurface font axis_key_locations axis_key_size = | 162 | eraseKeys_ 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 |
150 | reallyEraseKeys = eraseKeys_ True | 166 | reallyEraseKeys = eraseKeys_ True |
151 | eraseKeys = eraseKeys_ False | 167 | eraseKeys = 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 | ||
255 | centerText videoSurface x y font fgColor bgColor text = do | 271 | centerText 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)) |