chalkboard-viewer (empty) → 0.1
raw patch · 4 files changed
+296/−0 lines, 4 filesdep +GLUTdep +OpenGLdep +arraysetup-changed
Dependencies added: GLUT, OpenGL, array, base, chalkboard, time
Files
- Graphics/Chalkboard/Viewer.hs +243/−0
- LICENSE +25/−0
- Setup.hs +2/−0
- chalkboard-viewer.cabal +26/−0
+ Graphics/Chalkboard/Viewer.hs view
@@ -0,0 +1,243 @@+-- |+-- Module: Graphics.Chalkboard.Viewer+-- Copyright: (c) 2009 Andy Gill+-- License: BSD3+--+-- Maintainer: Andy Gill <andygill@ku.edu>+-- 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 ]+
+ LICENSE view
@@ -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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ chalkboard-viewer.cabal view
@@ -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 <andygill@ku.edu>+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