diff options
-rw-r--r-- | axis.hs | 54 |
1 files changed, 41 insertions, 13 deletions
@@ -1,5 +1,6 @@ | |||
1 | {-# LANGUAGE StandaloneDeriving #-} | ||
1 | import FRP.Netwire hiding (when) | 2 | import FRP.Netwire hiding (when) |
2 | import Prelude hiding ((.), id) | 3 | import Prelude hiding ((.), id, null, filter) |
3 | import Data.Time.Clock | 4 | import Data.Time.Clock |
4 | import Control.Wire hiding (when) | 5 | import Control.Wire hiding (when) |
5 | import Control.Wire.Session | 6 | import Control.Wire.Session |
@@ -21,17 +22,44 @@ netwireIsCool = | |||
21 | holdFor 0.5 . periodic 1 . pure "Hoo..." <|> | 22 | holdFor 0.5 . periodic 1 . pure "Hoo..." <|> |
22 | pure "...ray!" | 23 | pure "...ray!" |
23 | 24 | ||
24 | main = SDL.withInit [SDL.InitVideo, SDL.InitTimer, SDL.InitJoystick] $ | 25 | main = |
25 | withAlsaInit $ \h public private q publicAddr privateAddr -> do | 26 | withAlsaInit $ \h public private q publicAddr privateAddr -> do |
27 | cmdlineAlsaConnect h public -- fail early if bad command lines | ||
28 | |||
29 | SDL.withInit [SDL.InitVideo, SDL.InitTimer, SDL.InitJoystick] $ do | ||
30 | info <- SDL.getVideoInfo | ||
31 | let width = SDL.videoInfoWidth info | ||
32 | height = SDL.videoInfoHeight info | ||
33 | --screen <- SDL.setVideoMode width height 32 [SDL.SWSurface, SDL.Fullscreen] | ||
34 | screen <- SDL.setVideoMode width height 32 [SDL.SWSurface] | ||
26 | putStrLn "Initialized." | 35 | putStrLn "Initialized." |
27 | loop clockSession_ netwireIsCool "" | 36 | |
28 | where | 37 | let parseAlsa keysDown = parseAlsaEvents h keysDown (forwardNoteEvent h q publicAddr) |
29 | loop s w x = do | 38 | let loop midiKeysDown keysDown s w x = do |
30 | (ds, s') <- stepSession s | 39 | keysDown' <- parseSDLEvents keysDown |
31 | (ex, w') <- stepWire w ds (Right x) | 40 | midiKeysDown' <- parseAlsa midiKeysDown |
32 | let x' = either (const "") id ex | 41 | (ds, s') <- stepSession s |
33 | Control.Monad.when (x /= x' && x' /= "") $ putStrLn x' | 42 | (ex, w') <- stepWire w ds (Right x) |
34 | let framerate = 30 | 43 | let x' = either (const "") id ex |
35 | let delay = 1000 `div` framerate - 1000 * (floor $ dtime ds) | 44 | Control.Monad.when (x /= x' && x' /= "") $ putStrLn x' |
36 | SDL.delay (delay) | 45 | let framerate = 30 |
37 | loop s' w' x' | 46 | let delay = 1000 `div` framerate - 1000 * (floor $ dtime ds) |
47 | SDL.delay (delay) | ||
48 | Control.Monad.when (not $ keyDown SDL.SDLK_ESCAPE keysDown) $ | ||
49 | loop midiKeysDown' keysDown' s' w' x' | ||
50 | |||
51 | loop Set.empty Set.empty clockSession_ netwireIsCool "" | ||
52 | |||
53 | parseSDLEvents :: Set.Set SDL.Keysym -> IO (Set.Set SDL.Keysym) | ||
54 | parseSDLEvents keysDown = do | ||
55 | event <- SDL.pollEvent | ||
56 | case event of | ||
57 | SDL.NoEvent -> return keysDown | ||
58 | SDL.KeyDown k -> parseSDLEvents (Set.insert k keysDown) | ||
59 | SDL.KeyUp k -> parseSDLEvents (Set.delete k keysDown) | ||
60 | _ -> parseSDLEvents keysDown | ||
61 | |||
62 | keyDown :: SDL.SDLKey -> Set.Set SDL.Keysym -> Bool | ||
63 | keyDown k = not . Set.null . Set.filter ((== k) . SDL.symKey) | ||
64 | |||
65 | deriving instance Ord SDL.Keysym | ||