From 11bc93662f77a13f4842066fcf40f83b3d3e2ece Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Thu, 17 Dec 2015 22:44:06 -0500 Subject: Fix GHC/HLint warnings. No semantic changes. --- axis.hs | 76 +++++++++++++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 53 insertions(+), 23 deletions(-) diff --git a/axis.hs b/axis.hs index 89ba636..bd57573 100644 --- a/axis.hs +++ b/axis.hs @@ -2,20 +2,14 @@ {-# LANGUAGE FlexibleContexts #-} import Prelude () import BasePrelude -import Data.Time.Clock +-- import Data.Time.Clock import Control.Monad import qualified Graphics.UI.SDL as SDL import AlsaSeq import qualified Data.Set as Set import qualified Graphics.UI.SDL.TTF as SDL.TTF -import Data.String import Graphics.UI.SDL.Keysym as SDL.Keysym import Graphics.UI.SDL.Primitives as SDL.Primitive -import Data.Int (Int16) -import qualified System.Exit as Exit -import Data.List (elemIndex, elemIndices, filter, groupBy, length, reverse, sort) -import GHC.Word -import Data.Bits import qualified Sound.ALSA.Sequencer.Event as Event import qualified Graphics.UI.SDL.Utilities as SDL.Util import qualified Data.Map as Map @@ -27,25 +21,34 @@ import qualified Sound.ALSA.Sequencer.Address import AlsaShutUp +smartShowPitch :: Word8 -> String smartShowPitch = showPitch -- TODO: use flat for Eb, Bb; use unicode flat/sharp chars +_USE_HEXAGONS, _LABEL_WHILE_PLAYING, _LABEL_ALL_KEYS :: Bool _USE_HEXAGONS = True _LABEL_WHILE_PLAYING = True _LABEL_ALL_KEYS = False +_AXIS_ROWS, _AXIS_UNIQUE_COLS, _AXIS_TOPLEFT_PITCH, _AXIS_BOTTOMLEFT_PITCH, _AXIS_TOPRIGHT_PITCH :: Word8 _AXIS_ROWS = 7 + 4 _AXIS_UNIQUE_COLS = 7 + +_AXIS_COLS_REPEAT :: Integer _AXIS_COLS_REPEAT = 2 + _AXIS_TOPLEFT_PITCH = 81 + (7 * (_AXIS_ROWS - 7) `div` 2) _AXIS_BOTTOMLEFT_PITCH = _AXIS_TOPLEFT_PITCH - (_AXIS_ROWS * 7) _AXIS_TOPRIGHT_PITCH = _AXIS_TOPLEFT_PITCH + _AXIS_UNIQUE_COLS `div` 2 +_KEY_BORDER_COLOR, _KEY_ON_COLOR, _KB_BG_COLOR, _KEY_TEXT_COLOR :: SDL.Color + --_KEY_BORDER_COLOR = (SDL.Color 0 0 255) _KEY_BORDER_COLOR = SDL.Color 0 0 0 _KEY_ON_COLOR = SDL.Color 0xAA 0x00 0xFF _KB_BG_COLOR = SDL.Color 0 0 0 _KEY_TEXT_COLOR = SDL.Color 128 128 0 +_KEY_BORDER_COLOR_PIXEL, _KB_BG_COLOR_PIXEL :: SDL.Pixel _KEY_BORDER_COLOR_PIXEL = colorToPixel _KEY_BORDER_COLOR _KB_BG_COLOR_PIXEL = colorToPixel _KB_BG_COLOR @@ -69,6 +72,7 @@ http://en.wikipedia.org/wiki/Enhanced_Graphics_Adapter 15 – bright white (#FFFFFF) 111111 63 -} +_CGA :: [SDL.Color] _CGA = [ SDL.Color 0x00 0x00 0x00, --black SDL.Color 0x00 0x00 0xAA, --blue SDL.Color 0x00 0xAA 0x00, --green @@ -86,23 +90,32 @@ _CGA = [ SDL.Color 0x00 0x00 0x00, --black SDL.Color 0xFF 0xFF 0x55, --bright yellow SDL.Color 0xFF 0xFF 0xFF] --bright white +_CHAN_TO_COLOR :: [SDL.Color] _CHAN_TO_COLOR = _KEY_ON_COLOR : tail _CGA +_drawHexircle :: Bool -> SDL.Surface -> Int16 -> Int16 -> Int16 -> SDL.Pixel -> IO Bool _drawHexircle f v x y s c = if _USE_HEXAGONS then _drawHexagonSDL f v x y s c else (if f then SDL.Primitive.filledCircle else SDL.Primitive.circle) v x y (s * 7 `div` 9) c +drawHexircle :: SDL.Surface -> Int16 -> Int16 -> Int16 -> SDL.Pixel -> IO Bool drawHexircle = _drawHexircle False + +drawFilledHexircle :: SDL.Surface -> Int16 -> Int16 -> Int16 -> SDL.Pixel -> IO Bool drawFilledHexircle = _drawHexircle True + +colorToPixel :: SDL.Color -> SDL.Pixel colorToPixel x = let (SDL.Color r g b) = x in rgbColor r g b +inMajorC :: (Eq a, Num a) => a -> Bool inMajorC pclass = not (pclass == 1 || pclass == 3 || pclass == 6 || pclass == 8 || pclass == 10) -- TODO: color schemes with per-key {bg, border, hilightcolor, textcolor} -- TODO: try hilighting like in the app, where only part of the key is colored -- TODO: idea: for the channels, draw a dot. offset the dot from the center of the key at an angle determined by the channel number +pitchToColor :: Integral a => a -> SDL.Color pitchToColor p = case p `mod` 12 of 2 -> SDL.Color 0xC0 0xC0 0xFF -- D @@ -133,6 +146,7 @@ smartDrawKeys colsRepeat reallyErase beforeKeys_ nowKeys_ videoSurface font axis (if showLabel then Just text else Nothing) chans +allKeysOff :: (Enum b, Integral a, Integral a1, Integral a2, Num b) => b -> Bool -> SDL.Surface -> SDL.TTF.Font -> [(a1, a2)] -> a -> IO () allKeysOff colsRepeat reallyErase videoSurface font axis_key_locations axis_key_size = do let indices = [0 .. length axis_key_locations - 1] showLabel = not reallyErase && _LABEL_ALL_KEYS @@ -157,10 +171,10 @@ allKeysOff colsRepeat reallyErase videoSurface font axis_key_locations axis_key_ -- Next order of business: ---drawKey :: (Integral a1, Integral a2, Integral a) => Int -> SDL.Surface -> SDL.TTF.Font -> [(a1, a2)] -> a -> SDL.Color -> t -> Maybe String -> [Int] -> IO () +drawKey :: (Integral a, Integral a1, Integral a2) => Int -> SDL.Surface -> SDL.TTF.Font -> [(a1, a2)] -> a -> SDL.Color -> Maybe String -> [Event.Channel] -> IO () drawKey idx videoSurface font axis_key_locations axis_key_size fillColor text channels = do let (x, y) = axis_key_locations !! idx - drawFilledHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) (colorToPixel fillColor) + void $ drawFilledHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) (colorToPixel fillColor) let len = length channels let channels' = sort channels Control.Monad.when (len /= 0) $ @@ -181,12 +195,18 @@ drawKey idx videoSurface font axis_key_locations axis_key_size fillColor text ch (Just t) -> centerText videoSurface x y font _KEY_TEXT_COLOR fillColor t _ -> return () -fi = fromIntegral +rgbColor :: Word8 -> Word8 -> Word8 -> SDL.Pixel rgbColor r g b = SDL.Pixel (shiftL (fi r) 24 .|. shiftL (fi g) 16 .|. shiftL (fi b) 8 .|. fi 255) + where + fi = fromIntegral + fi :: Word8 -> Word32 +chooseFontSize :: Integral a => a -> a -> a chooseFontSize h w = 30 * d `div` 1024 where d = min h w +_SDL_DIGITS :: Set.Set SDLKey _SDL_DIGITS = Set.fromList [SDL.SDLK_1, SDL.SDLK_2, SDL.SDLK_3, SDL.SDLK_4, SDL.SDLK_5, SDL.SDLK_6, SDL.SDLK_7, SDL.SDLK_8, SDL.SDLK_9, SDL.SDLK_0] + firstDigitDown :: Set.Set SDL.Keysym.SDLKey -> Maybe Integer firstDigitDown k = if Set.null digitsDown then Nothing else Just $ (-48 +) $ fromIntegral $ SDL.Util.fromEnum $ Set.findMin digitsDown where digitsDown = Set.intersection _SDL_DIGITS k @@ -207,6 +227,7 @@ data Env = Env { _setVideoMode :: Int -> Int -> IO SDL.Surface } +main :: IO () main = withAlsaInit $ \h public private q publicAddr privateAddr -> do cmdlineAlsaConnect h public -- fail early if bad command lines @@ -218,7 +239,7 @@ main = warpMouse = do _ <- SDL.warpMouse (fromIntegral (sWidth `div` 2)) (fromIntegral (sHeight `div` 2)) return () - setVideoMode w h = SDL.setVideoMode w h 32 [SDL.HWSurface, SDL.Resizable, SDL.DoubleBuf] + setVideoMode wid hei = SDL.setVideoMode wid hei 32 [SDL.HWSurface, SDL.Resizable, SDL.DoubleBuf] _ <- setVideoMode sWidth sHeight _ <- SDL.TTF.init @@ -228,7 +249,7 @@ main = -- pixelFormat or the faked one, so fuck it. See colorToPixel let pixelFormat = -- SDL.surfaceGetPixelFormat videoSurface pixelFormat <- SDL.surfaceGetPixelFormat <$> -- SDL.createRGBSurfaceEndian [] 1 1 24 - shutUp + void $ shutUp putStrLn "Initialized." (_, ()) <- execRWST mainLoop @@ -236,13 +257,14 @@ main = (LoopState True _AXIS_COLS_REPEAT Set.empty Set.empty (sWidth, sHeight) font) return () +setFont :: (MonadIO m, MonadState LoopState m) => (Int, Int) -> m () setFont resolution' = do - font <- gets _sdlFont let (w, h) = resolution' fontSize = chooseFontSize w h font' <- liftIO $ SDL.TTF.openFont "LiberationMono-Bold.ttf" fontSize modify $ \s -> s { _sdlFont = font' } +parseEvents :: RWST Env () LoopState IO (Bool, Set.Set SDLKey, MidiPitchSet, (Int, Int), Integer) parseEvents = do Env h q publicAddr setVideoMode <- ask LoopState _ colsRepeat midiKeysDown keysDown resolution _ <- get @@ -264,22 +286,22 @@ mainLoop = do Env h q publicAddr setVideoMode <- ask LoopState firstLoop _ midiKeysDown keysDown _ _ <- get - (restartVideo, keysDown', midiKeysDown', resolution', colsRepeat') <- parseEvents + (restartVideo, keysDown', midiKeysDown', resolution, colsRepeat) <- parseEvents when restartVideo $ do - let (w, h) = resolution' - void $ liftIO $ setVideoMode w h - setFont resolution' + let (wid, hei) = resolution + void $ liftIO $ setVideoMode wid hei + setFont resolution - font' <- gets _sdlFont + font <- gets _sdlFont videoSurface <- liftIO SDL.getVideoSurface videoClipRect <- liftIO $ SDL.getClipRect videoSurface - let (axis_key_size, axis_key_locations) = getKeyLocations colsRepeat' videoClipRect + let (axis_key_size, axis_key_locations) = getKeyLocations colsRepeat videoClipRect let _ALL_PITCHES = Set.fromList $ map (\p -> (Event.Channel 1, Event.Pitch p)) [_AXIS_BOTTOMLEFT_PITCH .. _AXIS_TOPRIGHT_PITCH] - keysOFF really = allKeysOff colsRepeat' really videoSurface font' axis_key_locations axis_key_size + keysOFF really = allKeysOff colsRepeat really videoSurface font axis_key_locations axis_key_size allKeysOFF = keysOFF False allKeysReallyOFF = keysOFF True @@ -303,11 +325,11 @@ mainLoop = do -- let chord = show $ pitchList midiKeysDown' -- let chord = show $ map (\i->elemIndices i pitchIndex) $ pitchList midiKeysDown' -- textBand videoSurface videoClipRect (SDL.Rect 0 70 0 70) font chord - liftIO $ smartDrawKeys colsRepeat' False midiKeysDown midiKeysDown' videoSurface font' axis_key_locations axis_key_size + liftIO $ smartDrawKeys colsRepeat False midiKeysDown midiKeysDown' videoSurface font axis_key_locations axis_key_size when restartVideo $ do liftIO allKeysOFF - liftIO $ smartDrawKeys colsRepeat' False Set.empty midiKeysDown' videoSurface font' axis_key_locations axis_key_size + liftIO $ smartDrawKeys colsRepeat False Set.empty midiKeysDown' videoSurface font axis_key_locations axis_key_size when (keysDown' /= keysDown) $ do when (keyDown SDL.SDLK_BACKSPACE keysDown') $ liftIO allKeysOFF @@ -331,14 +353,17 @@ mainLoop = do let delay = 1000 `div` framerate -- TODO: subtract delta liftIO $ SDL.delay delay unless (keyDown SDL.SDLK_ESCAPE keysDown) $ do - put (LoopState False colsRepeat' midiKeysDown' keysDown' resolution' font') + put (LoopState False colsRepeat midiKeysDown' keysDown' resolution font) mainLoop +zipzip :: [[b]] -> [[b]] zipzip ls = if null (head ls) then [] else map head ls : zipzip (map tail ls) +drawHexagonSDL, drawFilledHexagonSDL :: SDL.Surface -> Int16 -> Int16 -> Integer -> SDL.Pixel -> IO Bool drawHexagonSDL = _drawHexagonSDL False drawFilledHexagonSDL = _drawHexagonSDL True +_drawHexagonSDL :: Integral a => Bool -> SDL.Surface -> Int16 -> Int16 -> a -> SDL.Pixel -> IO Bool _drawHexagonSDL filled videoSurface centerx centery radius pixel = do let r = fromIntegral radius let points = map (\(x, y) -> (centerx + x, centery + y)) $ @@ -346,6 +371,7 @@ _drawHexagonSDL filled videoSurface centerx centery radius pixel = do map (\i -> (r * cos(pi/3 * (i)), r * sin(pi/3 * (i)))) [0 .. 5] (if not filled then SDL.Primitive.polygon else SDL.Primitive.filledPolygon) videoSurface points pixel +centerText :: (Integral a, Integral a1) => SDL.Surface -> a -> a1 -> SDL.TTF.Font -> SDL.Color -> t -> String -> IO () centerText videoSurface x y font fgColor bgColor text = do --fontSurface <- SDL.TTF.renderUTF8Shaded font text (SDL.Color 0 255 0) (SDL.Color 80 80 80) -- useful for testing --fontSurface <- SDL.TTF.renderUTF8Shaded font text fgColor bgColor @@ -355,12 +381,14 @@ centerText videoSurface x y font fgColor bgColor text = do _ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect (fromIntegral(x) - w `div` 2) (fromIntegral(y) - h `div` 2) w h)) return () +pitchIndex :: (Enum b, Num b) => b -> [Word8] pitchIndex colsRepeat = concatMap (const unique) [0 .. colsRepeat - 1] where toprow = map (\i -> if i `mod` 2 == 0 then _AXIS_TOPLEFT_PITCH + i `div` 2 else _AXIS_TOPLEFT_PITCH - 3 + i `div` 2) [0 .. _AXIS_UNIQUE_COLS - 1] colfrom top = map ((+ top) . (* (-7))) [0 .. _AXIS_ROWS - 1] unique = concatMap colfrom toprow +getKeyLocations :: (Integral a, Integral t, Integral t1, Integral t2) => a -> SDL.Rect -> (t, [(t1, t2)]) getKeyLocations colsRepeat (SDL.Rect offx offy totalw totalh) = let (key_height, key_width, xys) = getKeyLocationsAbs colsRepeat @@ -388,6 +416,7 @@ getKeyLocations colsRepeat (SDL.Rect offx offy totalw totalh) = in (floor(kw/2 * 15/16), map (\(x, y) -> (floor(scale * x + centerx + kw/2), floor(scale * y + centery + kh/2))) $ concat $ zipzip xys) +getKeyLocationsAbs :: Integral a => a -> (Double, Double, [[(Double, Double)]]) getKeyLocationsAbs colsRepeat = let kb_rows = fromIntegral _AXIS_ROWS :: Double kb_cols = fromIntegral colsRepeat * fromIntegral _AXIS_UNIQUE_COLS :: Double @@ -415,6 +444,7 @@ getKeyLocationsAbs colsRepeat = (kh, kw, xys) -- clear a band the width of the videoClipRect and print the text within it, centered +textBand :: SDL.Surface -> SDL.Rect -> SDL.Rect -> SDL.TTF.Font -> [Char] -> IO () textBand videoSurface videoClipRect (SDL.Rect _ y _ h) font text = do let (SDL.Rect vx _ vw _) = videoClipRect _ <- SDL.fillRect videoSurface (Just (SDL.Rect 0 y vw h)) (SDL.Pixel 0) -- cgit v1.2.3