Implement window resizing.

This made the code uglier.  Need to introduce the state monad or else
actually use netwire.

1 files changed, 50 insertions, 30 deletions

diff --git a/axis.hs b/axis.hs
index 8c30a32..3b3ba8f 100644
--- a/axis.hs
+++ b/axis.hs
@@ -163,50 +163,63 @@ drawKey idx videoSurface font axis_key_locations axis_key_size fillColor text ch
 fi = fromIntegral
 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
+
 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 width = SDL.videoInfoWidth info
-      height = SDL.videoInfoHeight info
+  let sWidth = SDL.videoInfoWidth info
+      sHeight = SDL.videoInfoHeight info
       warpMouse = do
-        _ <- SDL.warpMouse (fromIntegral (width `div` 2)) (fromIntegral (height `div` 2))
+        _ <- SDL.warpMouse (fromIntegral (sWidth `div` 2)) (fromIntegral (sHeight `div` 2))
         return ()
---screen <- SDL.setVideoMode width height 32 [SDL.SWSurface, SDL.Fullscreen]
-  screen <- SDL.setVideoMode width height 32 [SDL.SWSurface]
+  _ <- SDL.setVideoMode sWidth sHeight 32 [SDL.SWSurface, SDL.Resizable]
 
   _ <- SDL.TTF.init
-  font <- SDL.TTF.openFont "LiberationMono-Bold.ttf" 30
-  videoSurface <- SDL.getVideoSurface
-  videoClipRect <- SDL.getClipRect videoSurface
+  font <- SDL.TTF.openFont "LiberationMono-Bold.ttf" (chooseFontSize sWidth sHeight)
 --_ <- SDL.showCursor False
 --_ <- SDL.grabInput True
 --warpMouse
 
+  -- 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
+--pixelFormat <- SDL.surfaceGetPixelFormat <$> SDL.createRGBSurfaceEndian [] 1 1 24
   -- _ <- SDL.setRelativeMouseMode True -- SDL2.  Should I use it?
 
-  let (axis_key_size, axis_key_locations) = getKeyLocations videoClipRect
-
-  let _ALL_PITCHES = Set.fromList $ map (\p -> (Event.Channel 1, Event.Pitch p)) [_AXIS_BOTTOM_PITCH .. _AXIS_TOP_PITCH]
-      keysOFF really = smartDrawKeys really _ALL_PITCHES Set.empty videoSurface font axis_key_locations axis_key_size
-      allKeysOFF =  keysOFF False
-      allKeysReallyOFF = keysOFF True
-  allKeysOFF
-
   putStrLn "Initialized."
 
   let parseAlsa keysDown = parseAlsaEvents h keysDown (forwardNoteEvent h q publicAddr)
-  let loop midiKeysDown keysDown s w x = do
-        keysDown' <- parseSDLEvents keysDown
+  let loop firstLoop midiKeysDown keysDown resolution font s w x = do
+        (keysDown', resolution') <- parseSDLEvents keysDown resolution
         midiKeysDown' <- parseAlsa midiKeysDown
         (ds, s') <- stepSession s
         (ex, w') <- stepWire w ds (Right x)
         let x' = either (const "") id ex
 
+        Control.Monad.when (resolution' /= resolution) $ do
+          let (w, h) = resolution
+          screen <- SDL.setVideoMode w h 32 [SDL.SWSurface, SDL.Resizable]
+          return ()
+
+        let (w, h) = resolution'
+            fontSize = chooseFontSize w h
+        font' <- (if (resolution' /= resolution) 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 videoClipRect
+
+        let _ALL_PITCHES = Set.fromList $ map (\p -> (Event.Channel 1, Event.Pitch p)) [_AXIS_BOTTOM_PITCH .. _AXIS_TOP_PITCH]
+            keysOFF really = smartDrawKeys really _ALL_PITCHES Set.empty 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 ()
@@ -217,11 +230,17 @@ main =
 --        let chord = show $ map (\i->elemIndices i pitchIndex) $ pitchList midiKeysDown'
 --        textBand videoSurface videoClipRect (SDL.Rect 0 70 0 70) font chord
 
-          smartDrawKeys False midiKeysDown midiKeysDown' videoSurface font axis_key_locations axis_key_size
+          smartDrawKeys False midiKeysDown midiKeysDown' videoSurface font' axis_key_locations axis_key_size
+          return ()
+
+        Control.Monad.when (resolution' /= resolution) $ do
+          allKeysOFF
+          smartDrawKeys False Set.empty midiKeysDown' videoSurface font' axis_key_locations axis_key_size
           return ()
 
-        Control.Monad.when (keysDown' /= keysDown && keyDown SDL.SDLK_BACKSPACE keysDown') allKeysOFF
-        Control.Monad.when (keysDown' /= keysDown && keyDown SDL.SDLK_c keysDown') allKeysReallyOFF
+        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'
@@ -244,9 +263,9 @@ main =
         let delay = 1000 `div` framerate - 1000 * (floor $ dtime ds)
         SDL.delay (delay)
         Control.Monad.when (not $ keyDown SDL.SDLK_ESCAPE keysDown) $
-          loop midiKeysDown' keysDown' s' w' x'
+          loop False midiKeysDown' keysDown' resolution' font' s' w' x'
 
-  loop Set.empty Set.empty clockSession_ netwireIsCool ""
+  loop True Set.empty Set.empty (sWidth, sHeight) font clockSession_ netwireIsCool ""
 
 zipzip ls = if (head ls) == [] then [] else (map head ls) : (zipzip $ map tail ls)
 
@@ -339,14 +358,15 @@ textBand videoSurface videoClipRect (SDL.Rect _ y _ h) font text = do
     return ()
   return ()
 
-parseSDLEvents :: Set.Set SDL.SDLKey -> IO (Set.Set SDL.Keysym.SDLKey)
-parseSDLEvents keysDown = do
+--parseSDLEvents :: Set.Set SDL.SDLKey -> Set.Set SDL.Event -> IO (Set.Set SDL.Keysym.SDLKey, Set.Set SDL.Event)
+parseSDLEvents keysDown others = do
   event <- SDL.pollEvent
   case event of
-    SDL.NoEvent -> return keysDown
-    SDL.KeyDown (SDL.Keysym k _ _) -> parseSDLEvents (Set.insert k keysDown)
-    SDL.KeyUp (SDL.Keysym k _ _) -> parseSDLEvents (Set.delete k keysDown)
-    _ -> parseSDLEvents keysDown
+    SDL.NoEvent -> return (keysDown, others)
+    SDL.KeyDown (SDL.Keysym k _ _) -> parseSDLEvents (Set.insert k keysDown) others
+    SDL.KeyUp (SDL.Keysym k _ _) -> parseSDLEvents (Set.delete k keysDown) others
+    SDL.VideoResize w h -> parseSDLEvents keysDown (w, h)
+    _ -> parseSDLEvents keysDown others
 
 keyDown :: SDL.Keysym.SDLKey -> Set.Set SDL.Keysym.SDLKey -> Bool
 keyDown k s = Set.member k s