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 (..),
hasShiftModifier, hasCtrlModifier, hasAltModifier,
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
hasShiftModifier :: ([Char],[SpecialKey]) -> Bool
hasShiftModifier (_, sks) = elem LSHIFT sks || elem RSHIFT sks
hasCtrlModifier :: ([Char],[SpecialKey]) -> Bool
hasCtrlModifier (_, sks) = elem LCTRL sks || elem RCTRL sks
hasAltModifier :: ([Char],[SpecialKey]) -> Bool
hasAltModifier (_, sks) = elem LALT sks || elem RALT sks
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)