-- | -- Module: Graphics.Chalkboard.Viewer -- Copyright: (c) 2009 Andy Gill -- License: BSD3 -- -- Maintainer: Andy Gill -- Stability: unstable -- Portability: ghc -- -- Simple Viewer for Chalkboard Images, using OpenGL. 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 -- counter , theTm :: UTCTime -- to compute frame counts # , theBoard :: MVar (CB.Board CB.RGB) -- The board to write the screen using , liveBoard :: (CB.Board CB.RGB) -- The board *written* to the screen , boardTexture :: TextureObject -- where we draw the board , squares :: Int -- how big are the pixels? 1x1, 2x2, ... , zoom :: Bool -- do you want to letterbox the output, or to fix to screen? } data BoardViewerInit = WindowSize Int Int -- ^ initial window size | WindowPos Int Int -- ^ initial window position | PixelSize Int -- ^ big pixels; great for prototyping | Zoom -- ^ do we sample beyond the unit square (not yet supported) | Background CB.RGB -- ^ default background in non-zoom mode | FrameTarget Int -- ^ how many frames per second? -- | 'initBoardViewer' never returns, and must be run from the main thread. -- Two arguments should be provided; the inital window setup, and the MVar that -- will contain the Board to be displayed. 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] -- window starts at upper left corner of the screen 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) -- 25 frames per second (optimistic!) let anim = addTimerCallback (1000 `div` frameTarget) $ do postRedisplay Nothing anim anim resizeScene svar (Size width height) mainLoop -- changes state, hmm. resizeScene :: IORef SceneState -> Size -> IO () resizeScene v (Size w 0) = resizeScene v (Size w 1) -- prevent divide by zero resizeScene v s@(Size width height) = do scene <- readIORef v viewport $= (Position 0 0, s) -- the whole screen matrixMode $= Projection loadIdentity let w = fromIntegral width / 1 h = fromIntegral height ortho2D (-w) w (-h) (h) -- (fromIntegral width / sz) 0 (fromIntegral height / sz) 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 () -- no redraw required Just board -> do writeIORef v (scene' { liveBoard = board }) Size width height <- get windowSize let sz0 = min width height -- times 2, because we want the underlying surface to have details we can actually see via anti-aliasing 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] -- clear the screen buildTexture (boardTexture scene') $ arr loadIdentity -- textureFilter Texture2D $= ((Linear',Nothing),Linear') 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 () ------------------------------------------------------------------------------ -- The x direction needs to be a power of 2, both should really be a power of 2. 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) -- choice 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) -- Hmm; not sure about this. 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) -- Having this here is a bit fishy. 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 ]