From 4c1e311e6b267eacee2b1a240024d9210827538b Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Thu, 17 Dec 2015 16:52:55 -0500 Subject: Clean up axis.hs lint errors, formatting, etc. (No semantic changes.) --- axis-of-eval.cabal | 2 +- axis.hs | 343 ++++++++++++++++++++++++++--------------------------- 2 files changed, 169 insertions(+), 176 deletions(-) diff --git a/axis-of-eval.cabal b/axis-of-eval.cabal index f09386a..da7a2a8 100644 --- a/axis-of-eval.cabal +++ b/axis-of-eval.cabal @@ -18,7 +18,7 @@ executable axis default-language: Haskell2010 hs-source-dirs: . build-depends: - base, time, SDL, SDL-ttf, SDL-gfx, containers, haskore, alsa-seq, alsa-core + base, time, SDL, SDL-ttf, SDL-gfx, containers, haskore, alsa-seq, alsa-core, base-prelude main-is: axis.hs other-modules: AlsaSeq diff --git a/axis.hs b/axis.hs index c784865..b093414 100644 --- a/axis.hs +++ b/axis.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE StandaloneDeriving #-} -import Prelude hiding ((.), id, null, filter) +import Prelude () +import BasePrelude import Data.Time.Clock import Control.Monad import qualified Graphics.UI.SDL as SDL @@ -19,7 +19,7 @@ import qualified Sound.ALSA.Sequencer.Event as Event import qualified Graphics.UI.SDL.Utilities as SDL.Util import qualified Data.Map as Map -smartShowPitch p = showPitch p -- TODO: use flat for Eb, Bb; use unicode flat/sharp chars +smartShowPitch = showPitch -- TODO: use flat for Eb, Bb; use unicode flat/sharp chars _USE_HEXAGONS = True _LABEL_WHILE_PLAYING = True @@ -33,10 +33,10 @@ _AXIS_BOTTOMLEFT_PITCH = _AXIS_TOPLEFT_PITCH - (_AXIS_ROWS * 7) _AXIS_TOPRIGHT_PITCH = _AXIS_TOPLEFT_PITCH + _AXIS_UNIQUE_COLS `div` 2 --_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 = 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 = colorToPixel _KEY_BORDER_COLOR _KB_BG_COLOR_PIXEL = colorToPixel _KB_BG_COLOR @@ -61,24 +61,24 @@ http://en.wikipedia.org/wiki/Enhanced_Graphics_Adapter 15 – bright white (#FFFFFF) 111111 63 -} -_CGA = [ (SDL.Color 0x00 0x00 0x00), --black - (SDL.Color 0x00 0x00 0xAA), --blue - (SDL.Color 0x00 0xAA 0x00), --green - (SDL.Color 0x00 0xAA 0xAA), --cyan - (SDL.Color 0xAA 0x00 0x00), --red - (SDL.Color 0xAA 0x00 0xAA), --magenta - (SDL.Color 0xAA 0x55 0x00), --brown - (SDL.Color 0xAA 0xAA 0xAA), --white / light gray - (SDL.Color 0x55 0x55 0x55), --dark gray / bright black - (SDL.Color 0x55 0x55 0xFF), --bright blue - (SDL.Color 0x55 0xFF 0x55), --bright green - (SDL.Color 0x55 0xFF 0xFF), --bright cyan - (SDL.Color 0xFF 0x55 0x55), --bright red - (SDL.Color 0xFF 0x55 0xFF), --bright magenta - (SDL.Color 0xFF 0xFF 0x55), --bright yellow - (SDL.Color 0xFF 0xFF 0xFF)] --bright white - -_CHAN_TO_COLOR = _KEY_ON_COLOR : (tail _CGA) +_CGA = [ SDL.Color 0x00 0x00 0x00, --black + SDL.Color 0x00 0x00 0xAA, --blue + SDL.Color 0x00 0xAA 0x00, --green + SDL.Color 0x00 0xAA 0xAA, --cyan + SDL.Color 0xAA 0x00 0x00, --red + SDL.Color 0xAA 0x00 0xAA, --magenta + SDL.Color 0xAA 0x55 0x00, --brown + SDL.Color 0xAA 0xAA 0xAA, --white / light gray + SDL.Color 0x55 0x55 0x55, --dark gray / bright black + SDL.Color 0x55 0x55 0xFF, --bright blue + SDL.Color 0x55 0xFF 0x55, --bright green + SDL.Color 0x55 0xFF 0xFF, --bright cyan + SDL.Color 0xFF 0x55 0x55, --bright red + SDL.Color 0xFF 0x55 0xFF, --bright magenta + SDL.Color 0xFF 0xFF 0x55, --bright yellow + SDL.Color 0xFF 0xFF 0xFF] --bright white + +_CHAN_TO_COLOR = _KEY_ON_COLOR : tail _CGA _drawHexircle f v x y s c = if _USE_HEXAGONS @@ -97,42 +97,42 @@ inMajorC pclass = not (pclass == 1 || pclass == 3 || pclass == 6 || pclass == 8 pitchToColor p = case p `mod` 12 of - 2 -> (SDL.Color 0xC0 0xC0 0xFF) -- D - 8 -> (SDL.Color 0x33 0x33 0x66) -- G# - x | inMajorC x -> (SDL.Color 0xE0 0xE0 0xE0) -- _CGA !! 7 + 2 -> SDL.Color 0xC0 0xC0 0xFF -- D + 8 -> SDL.Color 0x33 0x33 0x66 -- G# + x | inMajorC x -> SDL.Color 0xE0 0xE0 0xE0 -- _CGA !! 7 _ -> _CGA !! 8 smartDrawKeys :: (Enum a, Integral a1, Integral a3, Integral a2, Num a) => a -> Bool -> Set.Set (Event.Channel, Event.Pitch) -> Set.Set (Event.Channel, Event.Pitch) -> SDL.Surface -> SDL.TTF.Font -> [(a2, a3)] -> a1 -> IO () smartDrawKeys colsRepeat reallyErase beforeKeys_ nowKeys_ videoSurface font axis_key_locations axis_key_size = do let - chanfilter = Set.filter (\ (c, _) -> c /= (Event.Channel 9)) + chanfilter = Set.filter (\ (c, _) -> c /= Event.Channel 9) beforeKeys = chanfilter beforeKeys_ nowKeys = chanfilter nowKeys_ - changedPitches = Set.map (\ (_, p) -> p) $ Set.union (Set.difference nowKeys beforeKeys) (Set.difference beforeKeys nowKeys) - playingNowChans n = Set.map (\ (c, _) -> c) $ Set.filter (\ (_, p) -> p == n) nowKeys + changedPitches = Set.map snd $ Set.union (Set.difference nowKeys beforeKeys) (Set.difference beforeKeys nowKeys) + playingNowChans n = Set.map fst $ Set.filter (\ (_, p) -> p == n) nowKeys actions = Set.toList $ Set.map (\p -> (p, Set.toList $ playingNowChans p)) changedPitches forM_ actions $ \ (n, chans) -> do let text = smartShowPitch (unPitch n) pitch = unPitch n indices = elemIndices pitch $ pitchIndex colsRepeat - off = length chans == 0 + off = null chans forM_ indices $ \idx -> do - let showLabel = (not reallyErase) && (_LABEL_ALL_KEYS || (_LABEL_WHILE_PLAYING && (not off))) + let showLabel = not reallyErase && (_LABEL_ALL_KEYS || (_LABEL_WHILE_PLAYING && not off)) drawKey idx videoSurface font axis_key_locations axis_key_size (if reallyErase then _KB_BG_COLOR else pitchToColor pitch) - (if showLabel then (Just text) else Nothing) + (if showLabel then Just text else Nothing) chans 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 + showLabel = not reallyErase && _LABEL_ALL_KEYS forM_ indices $ \idx -> do let pitch = pitchIndex colsRepeat !! idx bgColor = if reallyErase then _KB_BG_COLOR else pitchToColor pitch text = smartShowPitch pitch - label = (if showLabel then (Just text) else Nothing) + label = if showLabel then Just text else Nothing drawKey idx videoSurface font axis_key_locations axis_key_size bgColor label [] -- OK, what we need to do now... @@ -155,16 +155,16 @@ drawKey idx videoSurface font axis_key_locations axis_key_size fillColor text ch 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) $ do + Control.Monad.when (len /= 0) $ forM_ [0 .. len - 1] $ \i -> do let (x', y') = if len == 1 then (0, 0) else (d * cos(2*pi/lenf * ifi), d * sin(2*pi/lenf * ifi)) ifi = fromIntegral i lenf = fromIntegral len - d = (fromIntegral axis_key_size) / 4 :: Float - r' = (fromIntegral axis_key_size) / 2 :: Float - x'' = (round x') + (fromIntegral x) - y'' = (round y') + (fromIntegral y) + d = fromIntegral axis_key_size / 4 :: Float + r' = fromIntegral axis_key_size / 2 :: Float + x'' = round x' + fromIntegral x + y'' = round y' + fromIntegral y chan = channels' !! i color = _CHAN_TO_COLOR !! fromIntegral(unChannel chan) SDL.Primitive.filledCircle videoSurface x'' y'' (round r') (colorToPixel color) @@ -174,7 +174,7 @@ drawKey idx videoSurface font axis_key_locations axis_key_size fillColor text ch _ -> return () fi = fromIntegral -rgbColor r g b = SDL.Pixel (shiftL (fi r) 24 .|. shiftL (fi g) 16 .|. shiftL (fi b) 8 .|. (fi 255)) +rgbColor r g b = SDL.Pixel (shiftL (fi r) 24 .|. shiftL (fi g) 16 .|. shiftL (fi b) 8 .|. fi 255) chooseFontSize h w = 30 * d `div` 1024 where d = min h w @@ -190,120 +190,114 @@ firstDigitDown k = if Set.null digitsDown then Nothing else Just $ (-48 +) $ fro main = withAlsaInit $ \h public private q publicAddr privateAddr -> do - cmdlineAlsaConnect h public -- fail early if bad command lines - - SDL.withInit [SDL.InitVideo, SDL.InitTimer, SDL.InitJoystick] $ do - info <- SDL.getVideoInfo - let sWidth = SDL.videoInfoWidth info - sHeight = SDL.videoInfoHeight info - 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 sWidth sHeight - - _ <- SDL.TTF.init - font <- SDL.TTF.openFont "LiberationMono-Bold.ttf" (chooseFontSize sWidth sHeight) ---_ <- SDL.showCursor False ---_ <- SDL.grabInput True ---warpMouse - -- _ <- SDL.setRelativeMouseMode True -- SDL2. Should I use it? - - -- using the pixelFormat methods gives the wrong color, with both the - -- real pixelFormat or the faked one, so fuck it. See colorToPixel ---let pixelFormat = SDL.surfaceGetPixelFormat videoSurface ---pixelFormat <- SDL.surfaceGetPixelFormat <$> SDL.createRGBSurfaceEndian [] 1 1 24 - - putStrLn "Initialized." - - let parseAlsa keysDown = parseAlsaEvents h keysDown (forwardNoteEvent h q publicAddr) - let loop state midiKeysDown keysDown resolution font = do - let (LoopState firstLoop colsRepeat) = state - - (keysDown', resolution') <- parseSDLEvents keysDown resolution - midiKeysDown' <- parseAlsa midiKeysDown - let colsRepeat' = case firstDigitDown keysDown' of Nothing -> colsRepeat; (Just 0) -> colsRepeat; (Just n) -> n; - - let restartVideo = resolution' /= resolution || colsRepeat' /= colsRepeat - - Control.Monad.when restartVideo $ do - let (w, h) = resolution' - _ <- setVideoMode w h - return () - - let (w, h) = resolution' - fontSize = chooseFontSize w h - font' <- (if (restartVideo) then SDL.TTF.openFont "LiberationMono-Bold.ttf" fontSize else return font) - - videoSurface <- SDL.getVideoSurface - videoClipRect <- SDL.getClipRect videoSurface - 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 - allKeysOFF = keysOFF False - allKeysReallyOFF = keysOFF True - - Control.Monad.when(firstLoop) allKeysOFF - --- Control.Monad.when (x /= x' && x' /= "") $ do --- textBand videoSurface videoClipRect (SDL.Rect 0 0 0 70) font x' --- return () - - let - chanfilter = Set.filter (\ (c, _) -> c /= (Event.Channel 9)) - beforeKeys = chanfilter midiKeysDown - nowKeys = chanfilter midiKeysDown' - - changedPitches = Set.map (\ (_, p) -> p) $ Set.union (Set.difference nowKeys beforeKeys) (Set.difference beforeKeys nowKeys) - playingNowChans n = Set.map (\ (c, _) -> c) $ Set.filter (\ (_, p) -> p == n) nowKeys - actions = Set.toList $ Set.map (\p -> (p, Set.toList $ playingNowChans p)) changedPitches - chanPitches = Map.fromListWith (++) $ map (\ (c, p) -> (c, [p])) $ Set.toList nowKeys - - Control.Monad.when (midiKeysDown' /= midiKeysDown) $ do --- let chord = showChord midiKeysDown' --- 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 - - smartDrawKeys colsRepeat' False midiKeysDown midiKeysDown' videoSurface font' axis_key_locations axis_key_size - return () - - Control.Monad.when (restartVideo) $ do - allKeysOFF - smartDrawKeys colsRepeat' False Set.empty midiKeysDown' videoSurface font' axis_key_locations axis_key_size - return () - - Control.Monad.when (keysDown' /= keysDown) $ do - Control.Monad.when (keyDown SDL.SDLK_BACKSPACE keysDown') allKeysOFF - Control.Monad.when (keyDown SDL.SDLK_c keysDown') allKeysReallyOFF - --- Control.Monad.when (keysDown' /= keysDown) $ do --- let chord = unwords $ map (\k -> drop 5 (show k)) $ Set.toList keysDown' --- textBand videoSurface videoClipRect (SDL.Rect 0 210 0 70) font chord --- textBand videoSurface videoClipRect (SDL.Rect 0 280 0 70) font $ --- if keyDown SDL.SDLK_a keysDown' then "arpeggiate" else "" --- return () - --- Control.Monad.when(False) $ do --- --- mouse <- SDL.getRelativeMouseState --- let (x, y, button) = mouse --- let text = ((show x) ++ " " ++ (show y) ++ " " ++ (show button)) --- textBand videoSurface videoClipRect (SDL.Rect 0 140 0 70) font text --- Control.Monad.when (x /= 0 || y /= 0) warpMouse - - _ <- SDL.flip videoSurface - - let framerate = 30 - let delay = 1000 `div` framerate -- TODO: subtract delta - SDL.delay (delay) - Control.Monad.when (not $ keyDown SDL.SDLK_ESCAPE keysDown) $ - loop (LoopState False colsRepeat') midiKeysDown' keysDown' resolution' font' - - loop (LoopState True _AXIS_COLS_REPEAT) Set.empty Set.empty (sWidth, sHeight) font - -zipzip ls = if (head ls) == [] then [] else (map head ls) : (zipzip $ map tail ls) + cmdlineAlsaConnect h public -- fail early if bad command lines + + SDL.withInit [SDL.InitVideo, SDL.InitTimer, SDL.InitJoystick] $ do + info <- SDL.getVideoInfo + let sWidth = SDL.videoInfoWidth info + sHeight = SDL.videoInfoHeight info + 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 sWidth sHeight + + _ <- SDL.TTF.init + font <- SDL.TTF.openFont "LiberationMono-Bold.ttf" (chooseFontSize sWidth sHeight) + -- _ <- SDL.showCursor False _ <- SDL.grabInput True warpMouse _ <- SDL.setRelativeMouseMode True -- + -- SDL2. Should I use it? using the pixelFormat methods gives the wrong color, with both the real + -- pixelFormat or the faked one, so fuck it. See colorToPixel let pixelFormat = + -- SDL.surfaceGetPixelFormat videoSurface pixelFormat <- SDL.surfaceGetPixelFormat <$> + -- SDL.createRGBSurfaceEndian [] 1 1 24 + putStrLn "Initialized." + + let parseAlsa keysDown = parseAlsaEvents h keysDown (forwardNoteEvent h q publicAddr) + let loop state midiKeysDown keysDown resolution font = do + let LoopState firstLoop colsRepeat = state + + (keysDown', resolution') <- parseSDLEvents keysDown resolution + midiKeysDown' <- parseAlsa midiKeysDown + let colsRepeat' = + case firstDigitDown keysDown' of + Nothing -> colsRepeat + (Just 0) -> colsRepeat + (Just n) -> n + + let restartVideo = resolution' /= resolution || colsRepeat' /= colsRepeat + + when restartVideo $ do + let (w, h) = resolution' + _ <- setVideoMode w h + return () + + let (w, h) = resolution' + fontSize = chooseFontSize w h + font' <- if restartVideo + then SDL.TTF.openFont "LiberationMono-Bold.ttf" fontSize + else return font + + videoSurface <- SDL.getVideoSurface + videoClipRect <- SDL.getClipRect videoSurface + 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 + allKeysOFF = keysOFF False + allKeysReallyOFF = keysOFF True + + when firstLoop allKeysOFF + + -- when (x /= x' && x' /= "") $ do + -- textBand videoSurface videoClipRect (SDL.Rect 0 0 0 70) font x' + -- return () + let chanfilter = Set.filter (\(c, _) -> c /= Event.Channel 9) + beforeKeys = chanfilter midiKeysDown + nowKeys = chanfilter midiKeysDown' + + changedPitches = Set.map snd $ Set.union (Set.difference nowKeys beforeKeys) (Set.difference beforeKeys nowKeys) + playingNowChans n = Set.map fst $ Set.filter (\(_, p) -> p == n) nowKeys + actions = Set.toList $ Set.map (\p -> (p, Set.toList $ playingNowChans p)) changedPitches + chanPitches = Map.fromListWith (++) $ map (\(c, p) -> (c, [p])) $ Set.toList nowKeys + + when (midiKeysDown' /= midiKeysDown) $ do + -- let chord = showChord midiKeysDown' + -- 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 + smartDrawKeys colsRepeat' False midiKeysDown midiKeysDown' videoSurface font' axis_key_locations axis_key_size + + when restartVideo $ do + allKeysOFF + smartDrawKeys colsRepeat' False Set.empty midiKeysDown' videoSurface font' axis_key_locations axis_key_size + + when (keysDown' /= keysDown) $ do + when (keyDown SDL.SDLK_BACKSPACE keysDown') allKeysOFF + when (keyDown SDL.SDLK_c keysDown') allKeysReallyOFF + + -- Control.Monad.when (keysDown' /= keysDown) $ do + -- let chord = unwords $ map (\k -> drop 5 (show k)) $ Set.toList keysDown' + -- textBand videoSurface videoClipRect (SDL.Rect 0 210 0 70) font chord + -- textBand videoSurface videoClipRect (SDL.Rect 0 280 0 70) font $ + -- if keyDown SDL.SDLK_a keysDown' then "arpeggiate" else "" + -- return () + -- Control.Monad.when(False) $ do + -- + -- mouse <- SDL.getRelativeMouseState + -- let (x, y, button) = mouse + -- let text = ((show x) ++ " " ++ (show y) ++ " " ++ (show button)) + -- textBand videoSurface videoClipRect (SDL.Rect 0 140 0 70) font text + -- Control.Monad.when (x /= 0 || y /= 0) warpMouse + + _ <- SDL.flip videoSurface + let framerate = 30 + let delay = 1000 `div` framerate -- TODO: subtract delta + SDL.delay delay + unless (keyDown SDL.SDLK_ESCAPE keysDown) $ + loop (LoopState False colsRepeat') midiKeysDown' keysDown' resolution' font' + + loop (LoopState True _AXIS_COLS_REPEAT) Set.empty Set.empty (sWidth, sHeight) font + +zipzip ls = if null (head ls) then [] else map head ls : zipzip (map tail ls) drawHexagonSDL = _drawHexagonSDL False drawFilledHexagonSDL = _drawHexagonSDL True @@ -312,7 +306,7 @@ _drawHexagonSDL filled videoSurface centerx centery radius pixel = do let r = fromIntegral radius let points = map (\(x, y) -> (centerx + x, centery + y)) $ map (\(x, y) -> (round x, round y)) $ - map (\i -> (r * cos(pi/3 * (i)), r * sin(pi/3 * (i)))) $ map fromIntegral [0 .. 5] + 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 videoSurface x y font fgColor bgColor text = do @@ -324,17 +318,17 @@ 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 colsRepeat = concat $ map (\x -> unique) [0 .. colsRepeat - 1] +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) $ map (* (-7)) [0 .. _AXIS_ROWS - 1] - unique = concat $ map colfrom toprow + 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 colsRepeat (SDL.Rect offx offy totalw totalh) = let (key_height, key_width, xys) = getKeyLocationsAbs colsRepeat - screenw = fromIntegral(totalw) - screenh = fromIntegral(totalh) + screenw = fromIntegral totalw + screenh = fromIntegral totalh kb_rows = length xys kb_cols = length (head xys) @@ -358,29 +352,28 @@ getKeyLocations colsRepeat (SDL.Rect offx offy totalw totalh) = (floor(kw/2 * 15/16), map (\(x, y) -> (floor(scale * x + centerx + kw/2), floor(scale * y + centery + kh/2))) $ concat $ zipzip xys) getKeyLocationsAbs colsRepeat = - let kb_rows = (fromIntegral _AXIS_ROWS) :: Double - kb_cols = (fromIntegral colsRepeat) * (fromIntegral _AXIS_UNIQUE_COLS) :: Double + let kb_rows = fromIntegral _AXIS_ROWS :: Double + kb_cols = fromIntegral colsRepeat * fromIntegral _AXIS_UNIQUE_COLS :: Double -- the edges of the hexagon are equal in length to its "radius" -- if the radius is 1, then horizontal movement is 1.5 and vertical movement is sqrt(3) from one center to the next -- or else it is 2*sqrt(3) to move down kw = 1 :: Double - kh = kw/2 * sqrt(3) -- hexagon ratio + kh = kw/2 * sqrt 3 -- hexagon ratio xys = - map (\y -> map (\i -> + map ((\y -> map (\i -> - let repetition = i `div` fromIntegral(_AXIS_UNIQUE_COLS) + let repetition = i `div` fromIntegral _AXIS_UNIQUE_COLS odd = 1 == i `mod` 2 - dropBy = if odd then kh / 2 + kh * fromInteger(repetition `div` 2) - else kh * fromInteger((repetition + 1) `div` 2) + dropBy = if odd then kh / 2 + kh * fromInteger (repetition `div` 2) + else kh * fromInteger ((repetition + 1) `div` 2) in ( - fromInteger(i) * kw * 3 / 4, + fromInteger i * kw * 3 / 4, y + dropBy - )) [0 .. round(kb_cols) - 1]) $ - map (\i -> kh * fromIntegral(i)) - [0..round(kb_rows) - 1] + )) [0 .. round kb_cols - 1]) . (\i -> kh * fromIntegral i)) + [0..round kb_rows - 1] in (kh, kw, xys) @@ -407,6 +400,6 @@ parseSDLEvents keysDown others = do _ -> parseSDLEvents keysDown others keyDown :: SDL.Keysym.SDLKey -> Set.Set SDL.Keysym.SDLKey -> Bool -keyDown k s = Set.member k s +keyDown = Set.member deriving instance Ord SDL.Keysym -- cgit v1.2.3