Search code examples
haskellopenglglut

Is there any way I can use GLUT to meet this requirement in a Haskell program?


I'm developing an open source 3D game engine using Haskell and OpenGL. The code that initialises a window and OpenGL context, as well as the code to get user input currently uses direct WinAPI calls. I now want to make the application multiplatform and initially thought GLUT could be used to replace the above solution, but have run into a problem related to call backs.

In my application the function update_play (within the IO monad) has the following line.

control <- messagePump (hwnd_ io_box)

where messagePump is an IO action that checks the window message queue for keyboard input and returns an Int to indicate either that a certain valid key is pressed or no valid input. update_play branches on the result and recurses to update the game state. If you'd like some more context, this link is to the relevant module on Github: https://github.com/Mushy-pea/Game-Dangerous/blob/master/Game_logic.hs

The problem I have with GLUT is that it handles keyboard input with callbacks and the one closest to my requirement (binding within Graphics.UI.GLUT on Hackage) is defined as follows.

type KeyboardCallback = Char -> Position -> IO ()

Below is a test program I'd hoped would prove this approach would work. As the callback (handle_input below) is called by the GLUT event loop with arguments that represent the user input, it seems impossible to get any information into it from the rest of my program. It therefore seems impossible for my program to get a result from it, as any IO action it might perform to do this (such as writing to an IORef) would require it to have a reference to such an object.

In the example I've tried using exceptions to communicate but they don't get caught, which I suspect is due to handle_input being called by a foreign library. If anyone can suggest how I might solve this (i.e. get an Int back from the callback, like I do from messagePump in my actual application) I'd be grateful. Thanks.

module Main where

import System.IO
import Data.Bits
import Control.Exception
import Graphics.GL.Core33
import Graphics.UI.GLUT

data ControlButton = W_key | S_key | A_key | D_key | Default_control deriving (Eq, Show)

instance Exception ControlButton

main = do
  initialize "test.exe" []
  initialWindowSize $= (Size 800 800)
  initialDisplayMode $= [RGBAMode, WithAlphaComponent, WithDepthBuffer, DoubleBuffered]
  window_id <- createWindow "Test"
  actionOnWindowClose $= Exit
  displayCallback $= repaint_window
  keyboardCallback $= (Just handle_input)
  glClearColor 0 0 0.75 0
  iteration 0

iteration :: Int -> IO ()
iteration c = do
  threadDelay 33333
  putStr ("\nc: " ++ show c)
  control <- catch check_events (\e -> map_control e)
  if control == 1 then putStr "\nW pressed"
  else if control == 2 then putStr "\nS pressed"
  else if control == 3 then putStr "\nA pressed"
  else if control == 4 then putStr "\nD pressed"
  else return ()
  iteration (c + 1)

check_events :: IO Int
check_events = do
  mainLoopEvent
  return 0

map_control :: ControlButton -> IO Int
map_control e = do
  if e == W_key then return 1
  else if e == S_key then return 2
  else if e == A_key then return 3
  else if e == D_key then return 4
  else return 0

repaint_window :: IO ()
repaint_window = do
  glClear (GL_COLOR_BUFFER_BIT .|. GL_DEPTH_BUFFER_BIT)
  swapBuffers

handle_input :: Char -> Position -> IO ()
handle_input key position = do
  if key == 'w' then throw W_key
  else if key == 's' then throw S_key
  else if key == 'a' then throw A_key
  else if key == 'd' then throw D_key
  else throw Default_control

Steven


Solution

  • You say

    any IO action it might perform to do this (such as writing to an IORef) would require it to have a reference to such an object

    so give it a reference to such an object!

    handle_input :: IORef ControlButton -> Char -> Position -> IO ()
    handle_input = {- I bet you can write this yourself -}
    
    iteration :: IORef ControlButton -> Int -> IO ()
    iteration = {- same -}
    
    main = do
        {- ... -}
        ref <- newIORef Default_control
        keyboardCallback $= Just (handle_input ref)
        {- ... -}
        iteration ref 0