diff options
-rw-r--r-- | axis-of-eval.cabal | 2 | ||||
-rw-r--r-- | axis.hs | 89 |
2 files changed, 89 insertions, 2 deletions
diff --git a/axis-of-eval.cabal b/axis-of-eval.cabal index 73f9265..161575f 100644 --- a/axis-of-eval.cabal +++ b/axis-of-eval.cabal | |||
@@ -18,7 +18,7 @@ executable axis-of-eval | |||
18 | default-language: Haskell2010 | 18 | default-language: Haskell2010 |
19 | hs-source-dirs: . | 19 | hs-source-dirs: . |
20 | build-depends: | 20 | build-depends: |
21 | base >= 4.5 && < 4.7, time, SDL, SDL-ttf, containers, haskore, alsa-seq, alsa-core, netwire (>= 5.0.0) | 21 | base >= 4.5 && < 4.7, time, SDL, SDL-ttf, SDL-gfx, containers, haskore, alsa-seq, alsa-core, netwire (>= 5.0.0) |
22 | main-is: axis.hs | 22 | main-is: axis.hs |
23 | 23 | ||
24 | executable midi-dump | 24 | executable midi-dump |
@@ -12,6 +12,8 @@ import qualified Data.Set as Set | |||
12 | import qualified Graphics.UI.SDL.TTF as SDL.TTF | 12 | import qualified Graphics.UI.SDL.TTF as SDL.TTF |
13 | import Data.String | 13 | 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 | ||
16 | import Data.Int (Int16) | ||
15 | 17 | ||
16 | netwireIsCool :: (Monad m) => Wire (Timed NominalDiffTime ()) () m a String | 18 | netwireIsCool :: (Monad m) => Wire (Timed NominalDiffTime ()) () m a String |
17 | netwireIsCool = | 19 | netwireIsCool = |
@@ -48,6 +50,9 @@ main = | |||
48 | warpMouse | 50 | warpMouse |
49 | -- _ <- SDL.setRelativeMouseMode True -- SDL2. Should I use it? | 51 | -- _ <- SDL.setRelativeMouseMode True -- SDL2. Should I use it? |
50 | 52 | ||
53 | let (axis_key_size, axis_key_locations) = getKeyLocations videoClipRect | ||
54 | print axis_key_locations | ||
55 | |||
51 | putStrLn "Initialized." | 56 | putStrLn "Initialized." |
52 | 57 | ||
53 | let parseAlsa keysDown = parseAlsaEvents h keysDown (forwardNoteEvent h q publicAddr) | 58 | let parseAlsa keysDown = parseAlsaEvents h keysDown (forwardNoteEvent h q publicAddr) |
@@ -72,11 +77,21 @@ main = | |||
72 | textBand videoSurface videoClipRect (SDL.Rect 0 210 0 70) font chord | 77 | textBand videoSurface videoClipRect (SDL.Rect 0 210 0 70) font chord |
73 | return () | 78 | return () |
74 | 79 | ||
80 | textBand videoSurface videoClipRect (SDL.Rect 0 280 0 70) font $ | ||
81 | if keyDown SDL.SDLK_a keysDown' then "arpeggiate" else "" | ||
82 | |||
75 | mouse <- SDL.getRelativeMouseState | 83 | mouse <- SDL.getRelativeMouseState |
76 | let (x, y, button) = mouse | 84 | let (x, y, button) = mouse |
77 | textBand videoSurface videoClipRect (SDL.Rect 0 140 0 70) font ((show x) ++ " " ++ (show y) ++ " " ++ (show button)) | 85 | textBand videoSurface videoClipRect (SDL.Rect 0 140 0 70) font ((show x) ++ " " ++ (show y) ++ " " ++ (show button)) |
78 | Control.Monad.when (x /= 0 || y /= 0) warpMouse | 86 | Control.Monad.when (x /= 0 || y /= 0) warpMouse |
79 | _ <- SDL.updateRect videoSurface videoClipRect | 87 | |
88 | let pixelFormat = SDL.surfaceGetPixelFormat videoSurface | ||
89 | blue <- SDL.mapRGB pixelFormat 0 255 255 -- why is it blue??? | ||
90 | forM_ axis_key_locations $ \(x, y) -> do | ||
91 | --SDL.Primitive.filledCircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) blue >>= return | ||
92 | drawHexagonSDL videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) blue >>= return | ||
93 | |||
94 | _ <- SDL.updateRect videoSurface videoClipRect -- draw it all! | ||
80 | 95 | ||
81 | let framerate = 30 | 96 | let framerate = 30 |
82 | let delay = 1000 `div` framerate - 1000 * (floor $ dtime ds) | 97 | let delay = 1000 `div` framerate - 1000 * (floor $ dtime ds) |
@@ -86,6 +101,78 @@ main = | |||
86 | 101 | ||
87 | loop Set.empty Set.empty clockSession_ netwireIsCool "" | 102 | loop Set.empty Set.empty clockSession_ netwireIsCool "" |
88 | 103 | ||
104 | drawHexagonSDL videoSurface centerx centery radius pixel = do | ||
105 | let r = fromIntegral radius | ||
106 | --let points = map (\(x, y) -> (centerx + x + radius `div` 2, centery + y + radius `div` 2)) $ | ||
107 | let points = map (\(x, y) -> (centerx + x, centery + y)) $ | ||
108 | map (\(x, y) -> (round x, round y)) $ | ||
109 | map (\i -> (r * cos(pi/3 * (i)), r * sin(pi/3 * (i)))) $ map fromIntegral [0 .. 5] | ||
110 | --filledPolygon :: Surface -> [(Int16, Int16)] -> Pixel -> IO Bool | ||
111 | SDL.Primitive.polygon videoSurface points pixel >>= return | ||
112 | |||
113 | let pixelFormat = SDL.surfaceGetPixelFormat videoSurface | ||
114 | blue <- SDL.mapRGB pixelFormat 0 255 255 -- why is it blue??? | ||
115 | SDL.Primitive.filledCircle videoSurface (fromIntegral centerx) (fromIntegral centery) 10 blue >>= return | ||
116 | SDL.Primitive.filledCircle videoSurface 0 0 10 blue >>= return | ||
117 | |||
118 | font <- SDL.TTF.openFont "LiberationMono-Bold.ttf" 30 | ||
119 | centerText videoSurface centerx centery font "OK!" | ||
120 | return () | ||
121 | |||
122 | centerText videoSurface x y font text = do | ||
123 | fontSurface <- SDL.TTF.renderUTF8Shaded font text (SDL.Color 0 255 0) (SDL.Color 80 80 80) | ||
124 | fontClipRect <- SDL.getClipRect fontSurface | ||
125 | let (SDL.Rect _ _ w h) = fontClipRect | ||
126 | _ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect (fromIntegral(x) - w `div` 2) (fromIntegral(y) - h `div` 2) w h)) | ||
127 | --_ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect (fromIntegral(x) + w) (fromIntegral(y) + h `div` 2) w h)) | ||
128 | return () | ||
129 | |||
130 | |||
131 | getKeyLocations (SDL.Rect offx offy totalw totalh) = | ||
132 | let (kb_rows, kb_cols) = (7, 14) :: (Int, Int) | ||
133 | -- the edges of the hexagon are equal in length to its "radius" | ||
134 | -- if the radius is 1, then horizontal movement is 1.5 and vertical movement is sqrt(3) from one center to the next | ||
135 | -- or else it is 2*sqrt(3) to move up | ||
136 | -- there are 14 keys (13 steps) from the far left to the far right of the axis, each step is 1.5 horizontal, plus 2 to fill to the edges | ||
137 | -- thus the keyboard is radius * (numkeys * 1.5 + 1) | ||
138 | key_width = 2000 | ||
139 | key_height = key_width * toRational(sqrt(3)) -- hexagon ratio | ||
140 | keyboard_width = (toRational(kb_cols) * 1.5) * key_width | ||
141 | keyboard_height = (toRational(kb_rows) + 2) * key_height -- half of the keyboard is offset down one key | ||
142 | |||
143 | fit_width = toRational(totalh) / toRational(totalw) > keyboard_height / keyboard_width | ||
144 | |||
145 | scale = if fit_width | ||
146 | then toRational(totalw) / keyboard_width | ||
147 | else toRational(totalh) / keyboard_height | ||
148 | |||
149 | centerx = floor(toRational(totalw) - keyboard_width * scale) `div` 2 | ||
150 | centery = floor(toRational(totalh) - keyboard_height * scale) `div` 2 | ||
151 | |||
152 | kh = floor(key_height * scale) | ||
153 | kw = floor(key_width * scale) | ||
154 | scaled_horiz_offset = floor(scale * 0.5 * key_width) | ||
155 | |||
156 | radius = kw * 31 `div` 32 | ||
157 | --radius = kw | ||
158 | |||
159 | xys = | ||
160 | map (\(x, y) -> (x + centerx + kw, y + centery + kh)) $ | ||
161 | concat $ | ||
162 | map (\y -> map (\i -> ( | ||
163 | |||
164 | i * kw * 3 `div` 2, | ||
165 | |||
166 | y + kh `div` 2 * (i `mod` 2) + | ||
167 | |||
168 | (if (i >= kb_cols `div` 2) then kh * ((i+1) `mod` 2) else 0) | ||
169 | |||
170 | )) [0 .. kb_cols - 1]) $ | ||
171 | map (\i -> kh * i) | ||
172 | [0..kb_rows - 1] | ||
173 | in | ||
174 | (radius, xys) | ||
175 | |||
89 | -- clear a band the width of the videoClipRect and print the text within it, centered | 176 | -- clear a band the width of the videoClipRect and print the text within it, centered |
90 | textBand videoSurface videoClipRect (SDL.Rect _ y _ h) font text = do | 177 | textBand videoSurface videoClipRect (SDL.Rect _ y _ h) font text = do |
91 | let (SDL.Rect vx _ vw _) = videoClipRect | 178 | let (SDL.Rect vx _ vw _) = videoClipRect |