add sdl-gfx hexgaonal grid

1 files changed, 88 insertions, 1 deletions

diff --git a/axis.hs b/axis.hs
index 293e11d..6774ef5 100644
--- a/axis.hs
+++ b/axis.hs
@@ -12,6 +12,8 @@ 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)
 
 netwireIsCool :: (Monad m) => Wire (Timed NominalDiffTime ()) () m a String
 netwireIsCool =
@@ -48,6 +50,9 @@ main =
   warpMouse
   -- _ <- SDL.setRelativeMouseMode True -- SDL2.  Should I use it?
 
+  let (axis_key_size, axis_key_locations) = getKeyLocations videoClipRect
+  print axis_key_locations
+
   putStrLn "Initialized."
 
   let parseAlsa keysDown = parseAlsaEvents h keysDown (forwardNoteEvent h q publicAddr)
@@ -72,11 +77,21 @@ main =
           textBand videoSurface videoClipRect (SDL.Rect 0 210 0 70) font chord
           return ()
 
+        textBand videoSurface videoClipRect (SDL.Rect 0 280 0 70) font $
+          if keyDown SDL.SDLK_a keysDown' then "arpeggiate" else ""
+
         mouse <- SDL.getRelativeMouseState
         let (x, y, button) = mouse
         textBand videoSurface videoClipRect (SDL.Rect 0 140 0 70) font ((show x) ++ " " ++ (show y) ++ " " ++ (show button))
         Control.Monad.when (x /= 0 || y /= 0) warpMouse
-        _ <- SDL.updateRect videoSurface videoClipRect
+
+        let pixelFormat = SDL.surfaceGetPixelFormat videoSurface
+        blue <- SDL.mapRGB pixelFormat 0 255 255 -- why is it blue???
+        forM_ axis_key_locations $ \(x, y) -> do
+          --SDL.Primitive.filledCircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) blue >>= return
+          drawHexagonSDL videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) blue >>= return
+
+        _ <- SDL.updateRect videoSurface videoClipRect -- draw it all!
 
         let framerate = 30
         let delay = 1000 `div` framerate - 1000 * (floor $ dtime ds)
@@ -86,6 +101,78 @@ main =
 
   loop Set.empty Set.empty clockSession_ netwireIsCool ""
 
+drawHexagonSDL videoSurface centerx centery radius pixel = do
+  let r = fromIntegral radius
+--let points = map (\(x, y) -> (centerx + x + radius `div` 2, centery + y + radius `div` 2)) $
+  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]
+  --filledPolygon :: Surface -> [(Int16, Int16)] -> Pixel -> IO Bool
+  SDL.Primitive.polygon videoSurface points pixel >>= return
+
+  let pixelFormat = SDL.surfaceGetPixelFormat videoSurface
+  blue <- SDL.mapRGB pixelFormat 0 255 255 -- why is it blue???
+  SDL.Primitive.filledCircle videoSurface (fromIntegral centerx) (fromIntegral centery) 10 blue >>= return
+  SDL.Primitive.filledCircle videoSurface 0 0 10 blue >>= return
+
+  font <- SDL.TTF.openFont "LiberationMono-Bold.ttf" 30
+  centerText videoSurface centerx centery font "OK!"
+  return ()
+
+centerText videoSurface x y font text = do
+  fontSurface <- SDL.TTF.renderUTF8Shaded font text (SDL.Color 0 255 0) (SDL.Color 80 80 80)
+  fontClipRect <- SDL.getClipRect fontSurface
+  let (SDL.Rect _ _ w h) = fontClipRect
+  _ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect (fromIntegral(x) - w `div` 2) (fromIntegral(y) - h `div` 2) w h))
+--_ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect (fromIntegral(x) + w) (fromIntegral(y) + h `div` 2) w h))
+  return ()
+
+
+getKeyLocations (SDL.Rect offx offy totalw totalh) =
+  let (kb_rows, kb_cols) = (7, 14) :: (Int, Int)
+      -- 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 up
+      -- 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
+      -- thus the keyboard is radius * (numkeys * 1.5 + 1)
+      key_width = 2000
+      key_height = key_width * toRational(sqrt(3)) -- hexagon ratio
+      keyboard_width = (toRational(kb_cols) * 1.5) * key_width
+      keyboard_height = (toRational(kb_rows) + 2) * key_height -- half of the keyboard is offset down one key
+
+      fit_width = toRational(totalh) / toRational(totalw) > keyboard_height / keyboard_width
+
+      scale = if fit_width
+              then toRational(totalw) / keyboard_width
+              else toRational(totalh) / keyboard_height
+
+      centerx = floor(toRational(totalw) - keyboard_width * scale) `div` 2
+      centery = floor(toRational(totalh) - keyboard_height * scale) `div` 2
+
+      kh = floor(key_height * scale)
+      kw = floor(key_width * scale)
+      scaled_horiz_offset = floor(scale * 0.5 * key_width)
+
+      radius = kw * 31 `div` 32
+      --radius = kw
+
+      xys = 
+            map (\(x, y) -> (x + centerx + kw, y + centery + kh)) $
+            concat $
+            map (\y -> map (\i -> (
+
+                i * kw * 3 `div` 2,
+
+                y + kh `div` 2 * (i `mod` 2) +
+
+                  (if (i >= kb_cols `div` 2) then kh * ((i+1) `mod` 2) else 0)
+
+              )) [0 .. kb_cols - 1]) $
+            map (\i -> kh * i)
+                [0..kb_rows - 1]
+    in
+      (radius, xys)
+
 -- clear a band the width of the videoClipRect and print the text within it, centered
 textBand videoSurface videoClipRect (SDL.Rect _ y _ h) font text = do
   let (SDL.Rect vx _ vw _) = videoClipRect