diff --git a/Graphics/Chalkboard/Viewer.hs b/Graphics/Chalkboard/Viewer.hs new file mode 100644 --- /dev/null +++ b/Graphics/Chalkboard/Viewer.hs @@ -0,0 +1,243 @@ +-- | +-- 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 ] + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2009 Andy Gill +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The names of the authors may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/chalkboard-viewer.cabal b/chalkboard-viewer.cabal new file mode 100644 --- /dev/null +++ b/chalkboard-viewer.cabal @@ -0,0 +1,26 @@ +Name: chalkboard-viewer +Version: 0.1 +Synopsis: OpenGL based viewer for chalkboard rendered images. +Description: Chalkboard is a Haskell hosted Domain Specific Language (DSL) for image generation and processing. + The basic structure is a chalk board, a two-dimensional canvas of values, typically colors. + Chalkboard provides the usual image processing functions (masking, overlaying, function mapping, + cropping, warping, rotating) as well as a few more unusual ones. + . + Chalkboard Viewer is a portal into a dynamically updatable Board, via an OpenGL window. + +Category: Graphics +License: BSD3 +License-file: LICENSE +Author: Andy Gill +Maintainer: Andy Gill +Copyright: (c) 2009 Andy Gill +Homepage: http://ittc.ku.edu/~andygill/chalkboard.php +Stability: alpha +build-type: Simple +Cabal-Version: >= 1.6 + +Library + Build-Depends: base, array, time, chalkboard==0.2, OpenGL, GLUT + Exposed-modules: + Graphics.Chalkboard.Viewer + Ghc-Options: -Wall