module FRP.UISF.SOE (
runGraphics,
Title,
Size,
Window,
openWindow,
getMainWindowSize,
clearWindow,
drawInWindow,
drawInWindowNow,
setGraphic,
setGraphic',
setDirty,
closeWindow,
openWindowEx,
RedrawMode,
drawGraphic,
drawBufferedGraphic,
Graphic,
nullGraphic,
emptyGraphic,
overGraphic ,
overGraphics,
translateGraphic,
Color (..),
RGB,
RGBA,
rgb,
rgba,
withColor,
withColor',
text,
Point,
ellipse,
shearEllipse,
line,
polygon,
polyline,
polyBezier,
Angle,
arc,
scissorGraphic,
Key(..),
SpecialKey (..),
UIEvent (..),
maybeGetWindowEvent,
getWindowEvent,
Word32,
timeGetTime,
word32ToInt,
isKeyPressed
) where
import Data.Ix (Ix)
import Data.Word (Word32)
import Graphics.UI.GLFW (Key(..), SpecialKey(..), KeyButtonState(..))
import qualified Graphics.UI.GLFW as GLFW
import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL (($=), GLfloat)
import System.IO.Unsafe (unsafePerformIO)
import Control.Monad (when, unless)
import Control.Concurrent.STM.TChan
import Control.Monad.STM (atomically)
import Control.Concurrent.MVar
import Data.IORef
import Data.List (delete)
keyState :: IORef ([Char],[SpecialKey])
keyState = unsafePerformIO $ newIORef ([],[])
addCharToKeyState :: Char -> IO ()
addCharToKeyState c = atomicModifyIORef keyState $ \(cs,ss) -> ((c:cs,ss),())
addSKeyToKeyState :: SpecialKey -> IO ()
addSKeyToKeyState s = atomicModifyIORef keyState $ \(cs,ss) -> ((cs,s:ss),())
removeCharFromKeyState :: Char -> IO ()
removeCharFromKeyState c = atomicModifyIORef keyState $ \(cs,ss) -> ((delete c cs,ss),())
removeSKeyFromKeyState :: SpecialKey -> IO ()
removeSKeyFromKeyState s = atomicModifyIORef keyState $ \(cs,ss) -> ((cs,delete s ss),())
runGraphics :: IO () -> IO ()
runGraphics main = main
type Title = String
type Size = (Int, Int)
data Window = Window {
graphicVar :: MVar (Graphic, Bool),
eventsChan :: TChan UIEvent
}
newtype Graphic = Graphic (IO ())
initialized, opened :: MVar Bool
initialized = unsafePerformIO (newMVar False)
opened = unsafePerformIO (newMVar False)
initialize :: IO ()
initialize = do
i <- readMVar initialized
unless i $ do
_ <- GLFW.initialize
modifyMVar_ initialized (const $ return True)
return ()
openWindow :: Title -> Size -> IO Window
openWindow title size =
openWindowEx title Nothing (Just size) drawBufferedGraphic
openWindowEx :: Title -> Maybe Point -> Maybe Size -> RedrawMode -> IO Window
openWindowEx title _position size (RedrawMode _useDoubleBuffer) = do
let siz = maybe (GL.Size 400 300) fromSize size
initialize
gVar <- newMVar (emptyGraphic, False)
eChan <- atomically newTChan
_ <- GLFW.openWindow siz [GLFW.DisplayStencilBits 8, GLFW.DisplayAlphaBits 8] GLFW.Window
GLFW.windowTitle $= title
modifyMVar_ opened (\_ -> return True)
GL.shadeModel $= GL.Smooth
GL.lineSmooth $= GL.Enabled
GL.blend $= GL.Enabled
GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
GL.lineWidth $= 1.5
let motionCallback (GL.Position x y) = atomically $
writeTChan eChan MouseMove { pt = (fromIntegral x, fromIntegral y) }
GLFW.mousePosCallback $= motionCallback
let charCallback c Press = do
ks <- readIORef keyState
atomically $ writeTChan eChan Key{ char = c, modifiers = ks, isDown = True}
charCallBack c Release = return ()
let keyCallBack (CharKey c) Press = do
addCharToKeyState c
keyCallBack (CharKey c) Release = do
removeCharFromKeyState c
ks <- readIORef keyState
atomically $ writeTChan eChan Key{ char = c, modifiers = ks, isDown = False}
keyCallBack (SpecialKey sk) Press = do
ks <- readIORef keyState
atomically $ writeTChan eChan SKey{ skey = sk, modifiers = ks, isDown = True}
addSKeyToKeyState sk
keyCallBack (SpecialKey sk) Release = do
removeSKeyFromKeyState sk
ks <- readIORef keyState
atomically $ writeTChan eChan SKey{ skey = sk, modifiers = ks, isDown = False}
GLFW.charCallback $= charCallback
GLFW.keyCallback $= keyCallBack
GLFW.enableSpecial GLFW.KeyRepeat
GLFW.mouseButtonCallback $= (\but state -> do
GL.Position x y <- GL.get GLFW.mousePos
atomically $ writeTChan eChan Button{
pt = (fromIntegral x, fromIntegral y),
isLeft = (but == GLFW.ButtonLeft),
isDown = (state == Press)})
GLFW.windowSizeCallback $= atomically . writeTChan eChan . Resize
GLFW.windowRefreshCallback $= atomically (writeTChan eChan Refresh)
GLFW.windowCloseCallback $= (closeWindow_ eChan >> return True)
return Window {
graphicVar = gVar,
eventsChan = eChan
}
getMainWindowSize :: IO Size
getMainWindowSize = do
(GL.Size x y) <- GL.get GLFW.windowSize
return (fromIntegral x, fromIntegral y)
clearWindow :: Window -> IO ()
clearWindow win = setGraphic win (Graphic (return ()))
drawInWindow :: Window -> Graphic -> IO ()
drawInWindow win graphic =
modifyMVar_ (graphicVar win) (\ (g, _) ->
return (overGraphic graphic g, True))
updateWindowIfDirty :: Window -> IO ()
updateWindowIfDirty win = do
io <- modifyMVar (graphicVar win) (\ (g@(Graphic io), dirty) ->
return ((g, False), when dirty (io >> GLFW.swapBuffers)))
io
drawInWindowNow :: Window -> Graphic -> IO ()
drawInWindowNow win graphic = do
drawInWindow win graphic
updateWindowIfDirty win
setGraphic :: Window -> Graphic -> IO ()
setGraphic win graphic =
modifyMVar_ (graphicVar win) (\_ ->
return (overGraphic graphic emptyGraphic, True))
setGraphic' :: Window -> Graphic -> IO ()
setGraphic' win graphic =
modifyMVar_ (graphicVar win) (\(_, dirty) ->
return (overGraphic graphic emptyGraphic, dirty))
setDirty :: Window -> IO ()
setDirty win =
modifyMVar_ (graphicVar win) (\(g, _) -> return (g, True))
closeWindow :: Window -> IO ()
closeWindow win = closeWindow_ (eventsChan win)
closeWindow_ :: TChan UIEvent -> IO ()
closeWindow_ chan = do
atomically $ writeTChan chan Closed
modifyMVar_ opened (\_ -> return False)
GLFW.closeWindow
GLFW.pollEvents
newtype RedrawMode = RedrawMode Bool
drawGraphic :: RedrawMode
drawGraphic = RedrawMode False
drawBufferedGraphic :: RedrawMode
drawBufferedGraphic = RedrawMode True
data Color = Black
| Blue
| Green
| Cyan
| Red
| Magenta
| Yellow
| White
deriving (Eq, Ord, Bounded, Enum, Ix, Show, Read)
type Angle = GLfloat
nullGraphic :: Graphic
nullGraphic = Graphic $ return ()
emptyGraphic :: Graphic
emptyGraphic = Graphic $ do
GL.clearColor $= GL.Color4 (0xec/0xff) (0xe9/0xff) (0xd8/0xff) (0x00)
GL.clear [GL.ColorBuffer, GL.StencilBuffer]
translateGraphic :: (Int, Int) -> Graphic -> Graphic
translateGraphic (x, y) (Graphic g) = Graphic $ GL.preservingMatrix $ do
GL.translate (GL.Vector3 (fromIntegral x) (fromIntegral y) (0::GLfloat))
g
overGraphic :: Graphic -> Graphic -> Graphic
overGraphic (Graphic over) (Graphic base) = Graphic (base >> over)
overGraphics :: [Graphic] -> Graphic
overGraphics = foldl1 overGraphic
colorToRGB :: Color -> GL.Color3 GLfloat
colorToRGB Black = GL.Color3 0 0 0
colorToRGB Blue = GL.Color3 0 0 1
colorToRGB Green = GL.Color3 0 1 0
colorToRGB Cyan = GL.Color3 0 1 1
colorToRGB Red = GL.Color3 1 0 0
colorToRGB Magenta = GL.Color3 1 0 1
colorToRGB Yellow = GL.Color3 1 1 0
colorToRGB White = GL.Color3 1 1 1
withColor :: Color -> Graphic -> Graphic
withColor color = withColor' (colorToRGB color)
withColor' :: GL.Color a => a -> Graphic -> Graphic
withColor' color (Graphic g) = Graphic (GL.color color >> g)
type RGB = GL.Color3 GL.GLfloat
type RGBA = GL.Color4 GL.GLfloat
rgb :: (Integral r, Integral g, Integral b) => r -> g -> b -> RGB
rgb r g b = GL.Color3 (c2f r) (c2f g) (c2f b) :: RGB
rgba :: (Integral r, Integral g, Integral b, Integral a) => r -> g -> b -> a -> RGBA
rgba r g b a = GL.Color4 (c2f r) (c2f g) (c2f b) (c2f a) :: RGBA
c2f :: (Integral c, Fractional f) => c -> f
c2f i = fromIntegral i / 255
text :: Point -> String -> Graphic
text (x,y) str = Graphic $ GL.preservingMatrix $ do
GL.translate (GL.Vector3 (fromIntegral x) (fromIntegral y + 16) (0::GLfloat))
GL.scale 1 (1) (1::GLfloat)
GLFW.renderString GLFW.Fixed8x16 str
type Point = (Int, Int)
ellipse :: Point -> Point -> Graphic
ellipse pt1 pt2 = Graphic $ GL.preservingMatrix $ do
let (x, y, width, height) = normaliseBounds pt1 pt2
(r1, r2) = (width / 2, height / 2)
GL.translate (GL.Vector3 (x + r1) (y + r2) 0)
GL.renderPrimitive GL.Polygon (circle r1 r2 0 (2 * pi) (6 / (r1 + r2)))
shearEllipse :: Point -> Point -> Point -> Graphic
shearEllipse p0 p1 p2 = Graphic $
let (x0,y0) = fromPoint p0
(x1,y1, w, h) = normaliseBounds p1 p2
(x2,y2) = (x1 + w, y1 + h)
x = (x1 + x2) / 2
y = (y1 + y2) / 2
dx1 = (x1 x0) / 2
dy1 = (y1 y0) / 2
dx2 = (x2 x0) / 2
dy2 = (y2 y0) / 2
pts = [ (x + c*dx1 + s*dx2, y + c*dy1 + s*dy2)
| (c,s) <- cos'n'sins ]
cos'n'sins = [ (cos a, sin a) | a <- segment 0 (2 * pi) (40 / (w + h))]
in GL.renderPrimitive GL.Polygon $
mapM_ (\ (x, y) -> GL.vertex (vertex3 x y 0)) pts
line :: Point -> Point -> Graphic
line (x1, y1) (x2, y2) = Graphic $
GL.renderPrimitive GL.LineStrip (do
GL.vertex (vertex3 (fromIntegral x1) (fromIntegral y1) 0)
GL.vertex (vertex3 (fromIntegral x2) (fromIntegral y2) 0))
polygon :: [Point] -> Graphic
polygon ps = Graphic $
GL.renderPrimitive GL.Polygon (foldr1 (>>) (map
(\ (x, y) -> GL.vertex (vertex3 (fromIntegral x) (fromIntegral y) 0))
ps))
polyline :: [Point] -> Graphic
polyline ps = Graphic $
GL.renderPrimitive GL.LineStrip (foldr1 (>>) (map
(\ (x, y) -> GL.vertex (vertex3 (fromIntegral x) (fromIntegral y) 0))
ps))
polyBezier :: [Point] -> Graphic
polyBezier [] = Graphic $ return ()
polyBezier ps = polyline (map (bezier ps) (segment 0 1 dt))
where
dt = 1 / (lineLength ps / 8)
lineLength :: [Point] -> GLfloat
lineLength ((x1,y1):(x2,y2):ps') =
let dx = x2 x1
dy = y2 y1
in sqrt (fromIntegral (dx * dx + dy * dy)) + lineLength ((x2,y2):ps')
lineLength _ = 0
bezier :: [Point] -> GLfloat -> Point
bezier [(x1,y1)] _t = (x1, y1)
bezier [(x1,y1),(x2,y2)] t = (x1 + truncate (fromIntegral (x2 x1) * t),
y1 + truncate (fromIntegral (y2 y1) * t))
bezier ps t = bezier (map (\ (p, q) -> bezier [p,q] t) (zip ps (tail ps))) t
arc :: Point -> Point -> Angle -> Angle -> Graphic
arc pt1 pt2 start extent = Graphic $ GL.preservingMatrix $ do
let (x, y, width, height) = normaliseBounds pt1 pt2
(r1, r2) = (width / 2, height / 2)
GL.translate (GL.Vector3 (x + r1) (y + r2) 0)
GL.renderPrimitive GL.LineStrip (circle r1 r2
((start + extent) * pi / 180) (start * pi / 180) (6 / (r1 + r2)))
scissorGraphic :: (Point, Size) -> Graphic -> Graphic
scissorGraphic ((x,y), (w,h)) (Graphic g) = Graphic $ do
(_,windowY) <- getMainWindowSize
let [x', y', w', h'] = map fromIntegral [x, windowYyh, w, h]
oldScissor <- GL.get GL.scissor
GL.scissor $= Just (GL.Position x' y', GL.Size w' h')
g
GL.scissor $= oldScissor
data UIEvent =
Key {
char :: Char,
modifiers :: ([Char],[SpecialKey]),
isDown :: Bool
}
| SKey {
skey :: SpecialKey,
modifiers :: ([Char],[SpecialKey]),
isDown :: Bool
}
| Button {
pt :: Point,
isLeft :: Bool,
isDown :: Bool
}
| MouseMove {
pt :: Point
}
| Resize GL.Size
| Refresh
| Closed
| NoUIEvent
deriving Show
getWindowEvent :: Double -> Window -> IO UIEvent
getWindowEvent sleepTime win = do
event <- maybeGetWindowEvent sleepTime win
maybe (getWindowEvent sleepTime win) return event
maybeGetWindowEvent :: Double -> Window -> IO (Maybe UIEvent)
maybeGetWindowEvent sleepTime win = let winChan = eventsChan win in do
updateWindowIfDirty win
mevent <- atomically $ tryReadTChan winChan
case mevent of
Nothing -> GLFW.sleep sleepTime >> GLFW.pollEvents >> return Nothing
Just Refresh -> do
(Graphic io, _) <- readMVar (graphicVar win)
io
GLFW.swapBuffers
maybeGetWindowEvent sleepTime win
Just (e@(Resize _)) -> do
(Resize size@(GL.Size w h)) <- getLastResizeEvent winChan e
GL.viewport $= (GL.Position 0 0, size)
GL.matrixMode $= GL.Projection
GL.loadIdentity
GL.ortho2D 0 (realToFrac w) (realToFrac h) 0
atomically $ writeTChan winChan Refresh
maybeGetWindowEvent sleepTime win
Just e -> return (Just e)
getLastResizeEvent :: TChan UIEvent -> UIEvent -> IO UIEvent
getLastResizeEvent ch prev = do
mevent <- atomically $ tryReadTChan ch
case mevent of
Nothing -> return prev
Just (e@(Resize _)) -> getLastResizeEvent ch e
Just Refresh -> getLastResizeEvent ch prev
Just e -> atomically (unGetTChan ch e) >> return prev
timeGetTime :: IO Double
timeGetTime = GL.get GLFW.time
word32ToInt :: Word32 -> Int
word32ToInt = fromIntegral
isKeyPressed :: Enum a => a -> IO Bool
isKeyPressed k = do
kbs <- GLFW.getKey k
return $ case kbs of
Press -> True
Release -> False
vertex3 :: GLfloat -> GLfloat -> GLfloat -> GL.Vertex3 GLfloat
vertex3 = GL.Vertex3
normaliseBounds :: Point -> Point -> (GLfloat,GLfloat,GLfloat,GLfloat)
normaliseBounds (x1,y1) (x2,y2) = (x, y, width, height)
where x = fromIntegral $ min x1 x2
y = fromIntegral $ min y1 y2
width = fromIntegral $ abs $ x1 x2
height = fromIntegral $ abs $ y1 y2
fromPoint :: Point -> (GLfloat, GLfloat)
fromPoint (x1, x2) = (fromIntegral x1, fromIntegral x2)
fromSize :: Size -> GL.Size
fromSize (x, y) = GL.Size (fromIntegral x) (fromIntegral y)
circle :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
circle r1 r2 start stop step =
let vs = [ (r1 * cos i, r2 * sin i) | i <- segment start stop step ]
in mapM_ (\(x, y) -> GL.vertex (vertex3 x y 0)) vs
segment :: (Num t, Ord t) => t -> t -> t -> [t]
segment start stop step = ts start
where ts i = if i >= stop then [stop] else i : ts (i + step)