module Graphics.Chalkboard.Viewer
( initBoardViewer
, BoardViewerInit(..)
) where
import Data.Time.Clock
import Data.Array
import Foreign ( pokeElemOff, Storable, mallocBytes, free )
import Data.Word
import Data.IORef
import Control.Concurrent.MVar
import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL ( Color4 )
import qualified Graphics.Chalkboard as CB
data SceneState = SceneState
{ frame :: Int
, theTm :: UTCTime
, theBoard :: MVar (CB.Board CB.RGB)
, liveBoard :: (CB.Board CB.RGB)
, boardTexture :: TextureObject
, squares :: Int
, zoom :: Bool
}
data BoardViewerInit
= WindowSize Int Int
| WindowPos Int Int
| PixelSize Int
| Zoom
| Background CB.RGB
| FrameTarget Int
initBoardViewer :: [BoardViewerInit] -> MVar (CB.Board CB.RGB) -> IO ()
initBoardViewer initInfos var = do
getArgsAndInitialize
initialDisplayMode $= [ DoubleBuffered, Multisampling ]
sequence_ [
case initInfo of
WindowSize x y -> initialWindowSize $= Size (fromIntegral x) (fromIntegral y)
WindowPos x y -> initialWindowPosition $= Position (fromIntegral x) (fromIntegral y)
_ -> return ()
| initInfo <- initInfos ]
let bgColor = head $ [ Color4 r g b 1
| Background (CB.RGB r g b) <- initInfos
] ++ [Color4 1 1 1 (1 :: Float)]
let frameTarget = head $
[ frame' | FrameTarget frame' <- initInfos ] ++ [25]
let sq = head $
[ p | PixelSize p <- initInfos ] ++ [1]
let zoomQ = head $
[ True | Zoom <- initInfos ] ++ [False]
createWindow "Chalkboard Viewer"
multisample $= Enabled
textureFunction $= Replace
texture Texture2D $= Enabled
pointSmooth $= Enabled
hint PointSmooth $=Nicest
lineSmooth $= Enabled
hint LineSmooth $=Nicest
polygonSmooth $= Enabled
hint PolygonSmooth $=Nicest
polygonMode $= (Fill,Fill)
clearColor $= bgColor
Size width height <- get windowSize
tm <- getCurrentTime
[texName] <- genObjectNames 1
svar <- newIORef $ SceneState 1 tm var (CB.pure CB.white) texName sq zoomQ
displayCallback $= (drawTheScene svar)
reshapeCallback $= Just (resizeScene svar)
let anim = addTimerCallback (1000 `div` frameTarget) $ do
postRedisplay Nothing
anim
anim
resizeScene svar (Size width height)
mainLoop
resizeScene :: IORef SceneState -> Size -> IO ()
resizeScene v (Size w 0) = resizeScene v (Size w 1)
resizeScene v s@(Size width height) = do
scene <- readIORef v
viewport $= (Position 0 0, s)
matrixMode $= Projection
loadIdentity
let w = fromIntegral width / 1
h = fromIntegral height
ortho2D (w) w (h) (h)
depthFunc $= Nothing
matrixMode $= Modelview 0
loadIdentity
flush
tryPutMVar (theBoard scene) (liveBoard scene)
return ()
drawTheScene :: IORef SceneState -> IO ()
drawTheScene v = do
scene <- readIORef v
let n = frame scene
let tm = theTm scene
tm' <- getCurrentTime
if (n `mod` 100 == 0) then do
putStrLn $ show ((1 / (diffUTCTime tm' tm)) * 100) ++ " fps (" ++ show n ++ ")"
writeIORef v (scene { frame = succ n, theTm = tm' })
else writeIORef v (scene { frame = succ n })
scene' <- readIORef v
resp <- tryTakeMVar (theBoard scene')
case resp of
Nothing -> return ()
Just board -> do
writeIORef v (scene' { liveBoard = board })
Size width height <- get windowSize
let sz0 = min width height
let sz1 = 2 * fromIntegral sz0 `div` (squares scene')
let sz2 = last $ takeWhile (<= sz1) (iterate (*2) 1)
let board1 = fmap (\ (CB.RGB r g b) -> Color3 (toW8 r) (toW8 g) (toW8 b)) board
let board2 = CB.scale (fromIntegral sz2) $ CB.move (0.5,0.5) $ board1
let arr = CB.boardToArray (sz2 1,sz2 1) 2 board2
clearColor $= Color4 0 0 0 0
clear [ColorBuffer]
buildTexture (boardTexture scene') $ arr
loadIdentity
let wh = fromIntegral (min width height) / 1.0
renderPrimitive Quads $ do
texCoord (TexCoord2 0 (0 :: Float))
vertex (Vertex2 (wh) (wh :: Float))
texCoord (TexCoord2 0 (1 :: Float))
vertex (Vertex2 (wh) (wh :: Float))
texCoord (TexCoord2 1 (1 :: Float))
vertex (Vertex2 wh (wh :: Float))
texCoord (TexCoord2 1 (0 :: Float))
vertex (Vertex2 wh (wh :: Float))
swapBuffers
return ()
buildTexture :: TextureObject -> Array (Int,Int) (Color3 Word8) -> IO ()
buildTexture texName arr = do
let (width,height) = case bounds arr of
((0,0),(w,h)) -> (w+1,h+1)
_ -> error "failure in buildTexture"
p <- mallocBytes (width * height * 3)
sequence_ [ case arr ! (w,h) of
(Color3 r g b) -> do pokeElemOff p (off+0) r
pokeElemOff p (off+1) g
pokeElemOff p (off+2) b
| (off,(w,h)) <- zip [0,3 ..] [ (w,h) | h <- [ 0 .. height 1 ], w <- [ 0 .. width 1 ], True]
]
textureBinding Texture2D $= Just texName
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
textureWrapMode Texture2D S $= (Repeated, Repeat)
textureWrapMode Texture2D T $= (Repeated, Repeat)
let pd = PixelData RGB UnsignedByte p
texImage2D Nothing NoProxy 0 RGB' (TextureSize2D (fromIntegral width) (fromIntegral height)) 0 pd
free p
return ()
toW8 :: Float -> Word8
toW8 n | n > 1 = 255
| n < 0 = 0
| otherwise = round (n * 255)
instance CB.Average Word8 where
average xs = floor (CB.average $ map (fromIntegral :: Word8 -> CB.UI) xs)
instance (CB.Average c) => CB.Average (Color3 c) where
average cs = Color3 (CB.average reds) (CB.average greens) (CB.average blues)
where
reds = [ r | Color3 r _ _ <- cs ]
greens = [ g | Color3 _ g _ <- cs ]
blues = [ b | Color3 _ _ b <- cs ]