audiovisual (empty) → 0.0

raw patch · 15 files changed

+990/−0 lines, 15 filesdep +JuicyPixelsdep +JuicyPixels-utildep +WAVEsetup-changed

Dependencies added: JuicyPixels, JuicyPixels-util, WAVE, base, boundingboxes, colors, deepseq, directory, filepath, free, freetype2, hashable, lens, linear, mtl, objective, random, template-haskell, transformers, vector, void

Files

LICENSE +30/−0
Setup.hs +2/−0
audiovisual.cabal +62/−0
data/Yasashisa-Gothic.ttf too large to diff
src/Audiovisual/Deck.hs +54/−0
src/Audiovisual/Sampler.hs +48/−0
src/Audiovisual/Text.hs +55/−0
src/Data/Audio.hs +58/−0
src/Data/Graphics.hs +12/−0
src/Data/Graphics/Bitmap.hs +150/−0
src/Data/Graphics/Class.hs +32/−0
src/Data/Graphics/Font.hs +120/−0
src/Data/Graphics/Sight.hs +164/−0
src/Data/Graphics/Vertex.hs +39/−0
src/Data/Input/Event.hs +164/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2014, Fumiaki Kinoshita
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * 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.
+
+    * Neither the name of Fumiaki Kinoshita nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"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 COPYRIGHT
+OWNER OR CONTRIBUTORS 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

+ audiovisual.cabal view

@@ -0,0 +1,62 @@+name:                audiovisual+version:             0.0+synopsis:            A battery-included audiovisual framework+homepage:            https://github.com/fumieval/audiovisual+bug-reports:         http://github.com/fumieval/audiovisual/issues+description:         Types and utilities for audio and graphic stuff+license:             BSD3+license-file:        LICENSE+author:              Fumiaki Kinoshita+maintainer:          Fumiaki Kinoshita <fumiexcel@gmail.com>+copyright:           Copyright (C) 2015 Fumiaki Kinoshita+category:            Data, Records+build-type:          Simple+stability:           provisional++extra-source-files: data/*.ttf+data-files: data/*.ttf+cabal-version:       >=1.10++source-repository head+  type: git+  location: https://github.com/fumieval/extensible.git++library+  exposed-modules:+    Data.Audio+    Data.Graphics+    Data.Graphics.Bitmap+    Data.Graphics.Sight+    Data.Graphics.Class+    Data.Graphics.Font+    Data.Graphics.Vertex+    Data.Input.Event+    Audiovisual.Sampler+    Audiovisual.Deck+    Audiovisual.Text+  other-modules:+    Paths_audiovisual+  build-depends:       base >= 4.7 && <5+    , template-haskell+    , linear+    , objective >= 1 && <1.1+    , free >= 4.8 && <5+    , colors+    , deepseq+    , mtl+    , filepath+    , directory+    , freetype2+    , hashable+    , random+    , boundingboxes+    , JuicyPixels-util+    , JuicyPixels+    , vector+    , lens+    , void+    , transformers+    , WAVE+  hs-source-dirs:      src+  ghc-options: -Wall+  default-language:    Haskell2010

+ data/Yasashisa-Gothic.ttf view

file too large to diff

+ src/Audiovisual/Deck.hs view

@@ -0,0 +1,54 @@+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ConstraintKinds #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Util.Deck
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- The deck for a single stream
+--
+-----------------------------------------------------------------------------
+module Audiovisual.Deck (Deck(..), empty, source, pos, playing, playback) where
+import Control.Lens
+import Control.Monad.State.Strict
+import Data.Audio
+import Foreign.Storable
+import qualified Data.Vector.Storable as V
+
+data Deck a = Deck
+  { _src :: Source a
+  , _pos :: !Time
+  , _playing :: !Bool }
+
+empty :: Num a => Deck a
+empty = Deck (Source $ const 0) 0 False
+
+source :: Lens' (Deck a) (Source a)
+source f s = f (_src s) <&> \a -> s { _src = a }
+
+pos :: Lens' (Deck a) Time
+pos f s = f (_pos s) <&> \a -> s { _pos = a }
+
+playing :: Lens' (Deck a) Bool
+playing f s = f (_playing s) <&> \a -> s { _playing = a }
+
+playback :: (Num a, Storable a, MonadState (Deck a) m) => Time -> Int -> m (V.Vector a)
+playback dt n = do
+  Source s <- use source
+  pl <- use playing
+  t0 <- use pos
+  if pl
+    then do
+      pos += dt
+      return $ V.fromList $ take n $ map s [t0,t0 + dt / fromIntegral n..]
+    else return $ V.replicate n 0

+ src/Audiovisual/Sampler.hs view

@@ -0,0 +1,48 @@+{-# LANGUAGE FlexibleContexts, ConstraintKinds #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Util.Deck
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Polyphonic sampler
+--
+-----------------------------------------------------------------------------
+module Audiovisual.Sampler where
+import qualified Data.Vector.Storable as V
+import qualified Data.Vector.Storable.Mutable as MV
+import Control.Monad.ST
+import Control.Monad.State.Strict
+import Data.Audio
+import Foreign.Storable
+
+data Sampler a = Sampler [(Sample a, Time)]
+
+empty :: Sampler a
+empty = Sampler []
+
+playback :: (Num a, Storable a, MonadState (Sampler a) m) => Time -> Int -> m (V.Vector a)
+playback dt n = do
+  Sampler vs <- get
+  let (vs'', r) = runST $ do
+        v <- MV.new n
+        vs' <- forM vs $ \(s0@(Sample d (Source s)), t0) -> do
+          if d > t0 then return []
+            else do
+              forM_ [0..n-1] $ \i -> do
+                z <- MV.unsafeRead v i
+                MV.unsafeWrite v i $ z + s (t0 + f * fromIntegral i)
+              return [(s0, t0 + dt)]
+        v' <- V.unsafeFreeze v
+        return (vs', v')
+  put $ Sampler $ concat vs''
+  return r
+  where
+    f = dt / fromIntegral n
+
+play :: MonadState (Sampler a) m => Sample a -> m ()
+play s = modify $ \(Sampler xs) -> Sampler $ (s, 0) : xs

+ src/Audiovisual/Text.hs view

@@ -0,0 +1,55 @@+{-# LANGUAGE ConstraintKinds, FlexibleContexts, BangPatterns, DeriveFunctor #-}
+module Audiovisual.Text (renderer, Typewriting(..), typewriter, putStr, clear, simple) where
+import Prelude hiding (putStr)
+import Data.Graphics.Bitmap (Bitmap(..))
+import Data.Graphics.Font
+import Data.Graphics.Sight
+import Control.Lens hiding (simple)
+import Control.Monad.Free
+import Control.Monad.State.Class
+import Control.Monad.Trans
+import Control.Applicative
+import Control.Object
+import Data.Monoid
+import Linear
+import Control.DeepSeq
+
+data Typewriting a = Render (Picture -> a) | Type Char a deriving Functor
+
+renderer :: (MonadIO m, Applicative m) => Font -> Float -> Object (Request Char (Bitmap, V2 Float, V2 Float)) m
+renderer font size = flyweight (liftIO . renderChar font size)
+
+typewriter :: MonadIO m => Float -> (Char -> m (Bitmap, V2 Float, V2 Float)) -> Object (Free Typewriting) m
+typewriter l req = iterative $ stateful go (V2 0 0, mempty) where
+  go (Type '\3' cont) = do
+    put (V2 0 0, mempty)
+    return cont
+  go (Type '\r' cont) = return cont
+  go (Type '\n' cont) = do
+    _1 . _y += l
+    _1 . _x .= 0
+    return cont
+  go (Type ch cont) = do
+    (pos, pic) <- get
+    (!bmp@(Bitmap img _ _), !ofs, !adv) <- lift $ req ch
+    return $! rnf img
+    put (pos + adv, pic <> translate (pos + ofs) (bitmap bmp))
+    return cont
+  go (Render cont) = uses _2 cont
+
+putStr :: String -> Free Typewriting ()
+putStr [] = return ()
+putStr (c:cs) = wrap (Type c (putStr cs))
+
+clear :: Free Typewriting ()
+clear = liftF $ Type '\3' ()
+
+simple :: MonadIO m => Font -> Float -> m (String -> Picture)
+simple font size = liftIO $ do
+  r <- new $ renderer font size
+  t <- new $ typewriter (size * 1.2) ((r.-) . request)
+  return $ \s -> Picture $ applyVFX $ EmbedIO $ do
+    t .- putStr s
+    p <- t .- liftF (Render id)
+    t .- clear
+    return $! unPicture p

+ src/Data/Audio.hs view

@@ -0,0 +1,58 @@+{-# LANGUAGE BangPatterns, DeriveFunctor #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Data.Wave
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-----------------------------------------------------------------------------
+module Data.Audio (
+  Source(..),
+  Sample(..),
+  Stereo,
+  Time,
+  readWAVE
+) where
+
+import Data.WAVE
+import Linear
+import Control.Monad.IO.Class
+import qualified Data.Vector.Unboxed as V
+import GHC.Float
+import Data.Monoid
+import Control.Applicative
+
+type Time = Float
+type Stereo = V2 Float
+
+newtype Source a = Source (Time -> a) deriving Functor
+
+instance Applicative Source where
+  pure a = Source (const a)
+  Source f <*> Source g = Source (f <*> g)
+
+instance Num a => Monoid (Source a) where
+  mempty = pure 0
+  mappend = liftA2 (+)
+
+readWAVE :: MonadIO m => FilePath -> m (Sample Stereo)
+readWAVE path = liftIO $ do
+  WAVE h ss <- getWAVEFile path
+  let vec = V.fromList (map fr ss)
+      rate = fromIntegral (waveFrameRate h)
+      !dur = fromIntegral (V.length vec) / rate
+      sample t
+        | t < 0 || t >= dur - (1/rate) = zero
+        | otherwise = vec V.! round (t * rate)
+  return $ Sample dur (Source sample)
+  where
+    fr [a, b] = V2 (double2Float $ sampleToDouble a) (double2Float $ sampleToDouble b)
+    fr _ = zero
+
+data Sample a = Sample { sampleLength :: Time ,sampleSource :: Source a}
+
+-- TODO: Lazy processing

+ src/Data/Graphics.hs view

@@ -0,0 +1,12 @@+module Data.Graphics (
+  module Data.Graphics.Bitmap
+  , module Data.Graphics.Class
+  , module Data.Graphics.Sight
+  , module Data.Graphics.Font
+  , module Data.Graphics.Vertex) where
+import Data.Graphics.Bitmap (Bitmap(..))
+import Data.Graphics.Class
+import Data.Graphics.Sight
+import Data.Graphics.Font
+import Data.Graphics.Vertex
+

+ src/Data/Graphics/Bitmap.hs view

@@ -0,0 +1,150 @@+{-# LANGUAGE TemplateHaskell #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Data.Bitmap
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-----------------------------------------------------------------------------
+module Data.Graphics.Bitmap (
+  Bitmap(Blank, Bitmap)
+  ,image
+  ,offset
+  ,hash
+  ,liftImage
+  ,liftImage'
+  ,size
+  ,clip
+  ,bbox
+  ,readFile
+  ,writeFile
+  ,loadBitmapsWith
+  ) where
+
+
+import Control.Applicative
+import Control.Lens
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.ST
+import Data.Char
+import Data.Monoid
+import Language.Haskell.TH
+import Linear
+import Prelude hiding (readFile, writeFile)
+import qualified Codec.Picture as C
+import qualified Codec.Picture.RGBA8 as C
+import qualified Codec.Picture.Types as C
+import qualified Data.BoundingBox as B
+import qualified Data.Hashable as H
+import qualified Data.Vector.Storable as V
+import System.Directory
+import System.FilePath
+import System.IO.Unsafe
+import System.Random
+
+data Bitmap = Blank | Bitmap { _image :: !(C.Image C.PixelRGBA8), _offset :: !(V2 Int), _hash :: !Int }
+
+image :: Traversal' Bitmap (C.Image C.PixelRGBA8)
+image _ Blank = pure Blank
+image f (Bitmap i o h) = f i <&> \i' -> Bitmap i' o h
+
+offset :: Traversal' Bitmap (V2 Int)
+offset _ Blank = pure Blank
+offset f (Bitmap i o h) = f o <&> \o' -> Bitmap i o' h
+
+hash :: Traversal' Bitmap Int
+hash _ Blank = pure Blank
+hash f (Bitmap i o h) = f h <&> \h' -> Bitmap i o h'
+
+-- | `mappend` stitches the right operand to the left
+instance Monoid Bitmap where
+  mempty = Blank
+  mappend base@(Bitmap b (V2 x0 y0) h0) lay@(Bitmap l (V2 x1 y1) h1) = runST $ do
+    let box = B.union (bbox base) (bbox lay)
+    let V2 w h = box ^. B.size 0
+    img <- C.createMutableImage w h (C.PixelRGBA8 0 0 0 0) >>= C.unsafeFreezeImage
+    let ox = max 0 (x0 - x1)
+    let oy = max 0 (y0 - y1)
+    return $ Bitmap
+      (C.patchImage (C.patchImage img (ox, oy) b) (max 0 (x1 - x0), max 0 (y1 - y0)) l)
+      (V2 (x0 + ox) (y0 + oy))
+      (H.hash (h0, h1))
+  mappend Blank b = b
+  mappend b Blank = b
+
+clip :: Bitmap -> B.Box V2 Int -> Bitmap
+clip (Bitmap b (V2 ox oy) k) (B.Box (V2 x0 y0) (V2 x1 y1)) = Bitmap
+  (C.trimImage b (x1 - x0, y1 - y0) (x0 - ox, y0 - oy))
+  (V2 ox oy)
+  (H.hash (x0, y0, x1, y1, k))
+
+clip Blank _ = Blank
+
+bbox :: Bitmap -> B.Box V2 Int
+bbox (Bitmap (C.Image w h _) (V2 x y) _) = B.Box (V2 x y) (V2 (x+w) (y+h))
+bbox Blank = B.Box zero zero
+
+size :: Bitmap -> V2 Int
+size (Bitmap (C.Image w h _) _ _) = V2 w h
+size Blank = zero
+
+liftImage :: C.Image C.PixelRGBA8 -> Bitmap
+liftImage b@(C.Image _ _ r) = Bitmap b zero (V.foldl H.hashWithSalt 0 r)
+
+liftImage' :: MonadIO m => C.Image C.PixelRGBA8 -> m Bitmap
+liftImage' b = liftIO $ Bitmap b zero <$> randomIO
+
+-- | Load an image file.
+readFile :: MonadIO m => FilePath -> m Bitmap
+readFile path = liftIO $ Bitmap <$> C.readImageRGBA8 path <*> pure zero <*> randomIO
+
+-- | Save 'Bitmap' into a file.
+writeFile :: MonadIO m => FilePath -> Bitmap -> m ()
+writeFile path (Bitmap p _ _) = liftIO $ C.writePng path p
+writeFile _ Blank = fail "Blank bitmap"
+
+-- | The type of the given 'ExpQ' must be @FilePath -> IO FilePath@
+-- FIXME: This may cause name duplication if there are multiple non-alphanumeric file names.
+loadBitmapsWith :: ExpQ -> FilePath -> Q [Dec]
+loadBitmapsWith getFullPath path = do
+    loc <- (</>path) <$> takeDirectory <$> loc_filename <$> location
+    paths <- runIO $ getFileList loc
+
+    sequence $ do
+        p <- paths
+        let name = pathToName p
+        [ return $ SigD (mkName name) (ConT ''Bitmap)
+            , funD (mkName name) [clause [] (normalB $ load name $ loc </> p) []]
+            ]
+    where
+        load name fp = do
+            runIO $ putStrLn $ "Defined: " ++ fp ++ " as `" ++ name ++ "'"
+
+            appE (varE 'unsafePerformIO) $ uInfixE (appE getFullPath $ litE $ StringL fp)
+                (varE '(>>=))
+                (varE 'readFile)
+
+-- | Load and define all pictures in the specified directory.
+-- On base >= 4.6, file paths to actually load will be respect to the directory of the executable. Otherwise it will be based on the current directory.
+
+
+getFileList :: FilePath -> IO [FilePath]
+getFileList path = do
+    allContents <- filter notHidden `fmap` getDirectoryContents path
+
+    files <- filterM (doesFileExist . (path</>)) allContents
+    dirs <- filterM (doesDirectoryExist . (path</>)) allContents
+    fmap ((files++).concat) $ forM dirs $ \i -> map (i</>) `fmap` getFileList (path</>i)
+    where
+        notHidden ('.':_) = False
+        notHidden _ = True
+
+pathToName :: FilePath -> String
+pathToName = ('_':) . map p where
+    p c | isAlphaNum c = c
+        | otherwise = '_'

+ src/Data/Graphics/Class.hs view

@@ -0,0 +1,32 @@+{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}+module Data.Graphics.Class where+import Data.Typeable+import Linear++data PrimitiveMode = LineStrip | TriangleFan | TriangleStrip | LineLoop deriving (Enum, Eq, Ord, Read, Show, Typeable)++class Affine a where+  type Vec a :: *+  type Normal a :: *+  rotateOn :: Normal a -> a -> a+  scale :: Vec a -> a -> a+  translate :: Vec a -> a -> a++class Affine a => Figure a where+  primitive :: PrimitiveMode -> [Vec a] -> a+  color :: V4 Float -> a -> a+  line :: [Vec a] -> a+  polygon :: [Vec a] -> a+  polygonOutline :: [Vec a] -> a+  circle :: Normal a -> a+  circleOutline :: Normal a -> a++opacity :: Figure a => Float -> a -> a+opacity p = color (V4 1 1 1 p)++data BlendMode = Normal+    | Inverse+    | Add+    | Multiply+    | Screen+    deriving (Enum, Eq, Ord, Read, Show, Typeable)

+ src/Data/Graphics/Font.hs view

@@ -0,0 +1,120 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Data.Font
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Font rendering
+--
+-----------------------------------------------------------------------------
+module Data.Graphics.Font
+  ( Font
+  , readFont
+  , defaultFont
+  , fontBoundingBox
+  , metricsAscent
+  , metricsDescent
+  , renderChar
+  ) where
+
+import Control.Applicative
+import Control.Monad.IO.Class
+import Control.Monad
+import Data.BoundingBox
+import qualified Data.Vector.Storable as V
+import Linear
+import Data.Graphics.Bitmap
+import Graphics.Rendering.FreeType.Internal
+import qualified Graphics.Rendering.FreeType.Internal.GlyphSlot as GS
+import qualified Graphics.Rendering.FreeType.Internal.Vector as V
+import Graphics.Rendering.FreeType.Internal.Bitmap as B
+import Graphics.Rendering.FreeType.Internal.PrimitiveTypes as PT
+import Graphics.Rendering.FreeType.Internal.Face as F
+import Graphics.Rendering.FreeType.Internal.Library as L
+import Graphics.Rendering.FreeType.Internal.BBox as BB
+import Foreign.Marshal.Alloc
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.Storable
+import Foreign.ForeignPtr
+import Foreign.Ptr
+import System.IO.Unsafe
+import Codec.Picture
+import Codec.Picture.RGBA8
+import Paths_audiovisual
+
+-- | Font object
+data Font = Font FT_Face (Float, Float) (Box V2 Float)
+
+defaultFont :: Font
+defaultFont = unsafePerformIO $ do
+  path <- getDataFileName "data/Yasashisa-Gothic.ttf"
+  readFont path
+
+-- | Create a 'Font' from the given file.
+readFont :: MonadIO m => FilePath -> m Font
+readFont path = liftIO $ alloca $ \p -> do
+    runFreeType $ withCString path $ \str -> ft_New_Face freeType str 0 p
+    f <- peek p
+    b <- peek (F.bbox f)
+    asc <- peek (ascender f)
+    desc <- peek (descender f)
+    u <- fromIntegral <$> peek (units_per_EM f)
+    let box = fmap ((/u).fromIntegral) $ Box
+            (V2 (xMin b) (yMin b))
+            (V2 (xMax b) (yMax b))
+    return $ Font f (fromIntegral asc/u, fromIntegral desc/u) box
+
+-- | Get the font's metrics.
+metricsAscent :: Font -> Float
+metricsAscent (Font _ (a, _) _) = a
+
+-- | Get the font's metrics.
+metricsDescent :: Font -> Float
+metricsDescent (Font _ (_, d) _) = d
+
+-- | Get the font's bounding box.
+fontBoundingBox :: Font -> Box V2 Float
+fontBoundingBox (Font _ _ b) = b
+
+runFreeType :: IO CInt -> IO ()
+runFreeType m = do
+    r <- m
+    unless (r == 0) $ fail $ "FreeType Error:" Prelude.++ show r
+
+freeType :: FT_Library
+freeType = unsafePerformIO $ alloca $ \p -> do
+  runFreeType $ ft_Init_FreeType p
+  peek p
+
+renderChar :: Font -> Float -> Char -> IO (Bitmap, V2 Float, V2 Float)
+renderChar (Font face _ _) pixel ch = do
+  let dpi = 300
+
+  runFreeType $ ft_Set_Char_Size face 0 (floor $ pixel * 72 / fromIntegral dpi * 64) dpi dpi
+
+  ix <- ft_Get_Char_Index face (fromIntegral $ fromEnum ch)
+  runFreeType $ ft_Load_Glyph face ix ft_LOAD_DEFAULT
+
+  slot <- peek $ glyph face
+  runFreeType $ ft_Render_Glyph slot ft_RENDER_MODE_NORMAL
+
+  bmp <- peek $ GS.bitmap slot
+  left <- fmap fromIntegral $ peek $ GS.bitmap_left slot
+  top <- fmap fromIntegral $ peek $ GS.bitmap_top slot
+
+  let h = fromIntegral $ B.rows bmp
+      w = fromIntegral $ B.width bmp
+
+  fptr <- newForeignPtr_ $ castPtr $ buffer bmp
+
+  adv <- peek $ GS.advance slot
+  b <- liftImage' $ fromColorAndOpacity (PixelRGB8 255 255 255)
+        $ Image w h $ V.unsafeFromForeignPtr0 fptr $ h * w
+  return (b
+    , V2 (left + fromIntegral w / 2) (-top + fromIntegral h / 2)
+    , V2 (fromIntegral (V.x adv) / 64) 0)

+ src/Data/Graphics/Sight.hs view

@@ -0,0 +1,164 @@+{-# LANGUAGE TypeFamilies+  , FlexibleContexts+  , BangPatterns+  , DeriveFunctor+  , Rank2Types+  , FlexibleInstances+  , UndecidableInstances+  , ViewPatterns+  , ScopedTypeVariables+  , GeneralizedNewtypeDeriving #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Call.Scene+-- Copyright   :  (c) Fumiaki Kinoshita 2014+-- License     :  BSD3+--+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-----------------------------------------------------------------------------+module Data.Graphics.Sight (Affine(..)+    , Figure(..)+    , Picture(..)+    , opacity+    , bitmap+    , toward+    , Scene(..)+    , transformScene+    , vertices+    , Sight(..)+    , viewPicture+    , viewScene+    , fromPerspective+    , VFX(..)+    , applyVFX+    ) where+import qualified Data.Graphics.Bitmap as B+import qualified Data.BoundingBox as X+import Data.Monoid+import Linear+import qualified Data.Vector.Storable as V+import Control.Lens+import Data.Color+import Data.Graphics.Class+import Data.Graphics.Vertex++bitmap :: B.Bitmap -> Picture+bitmap bmp = Picture $ Scene+  $ \_ _ f _ _ -> f bmp TriangleStrip+    (V.fromList [V3 (-w/2) (-h/2) 0 `positionUV` V2 0 0+        , V3 (w/2) (-h/2) 0 `positionUV` V2 1 0+        , V3 (-w/2) (h/2) 0 `positionUV` V2 0 1+        , V3 (w/2) (h/2) 0 `positionUV` V2 1 1]) where+  V2 w h = fmap fromIntegral $ B.size bmp++toward :: Vec3 -> Picture -> Scene+toward n@((^/norm n) -> V3 x y z) (Picture s) = transformScene+  (m33_to_m44 $ fromQuaternion $ axisAngle (V3 (-y) x 0) $ acos $ z / norm n)+  s++newtype Scene = Scene { unScene :: forall r.+  r+  -> (r -> r -> r)+  -> (B.Bitmap -> PrimitiveMode -> V.Vector Vertex -> r)+  -> (VFX r -> r)+  -> (M44 Float -> r -> r)+  -> r+  }++data VFX r = SphericalAdd B.Bitmap r+  | SphericalMultiply B.Bitmap r+  | Diffuse (V4 Float) r+--  | Specular (V3 Float) r+--  | Ambient (V3 Float) r+  | NormalMap B.Bitmap r+  | EmbedIO (IO r)+  deriving Functor++instance Affine Scene where+  type Vec Scene = V3 Float+  type Normal Scene = V3 Float+  rotateOn v = transformScene $ m33_to_m44 $ fromQuaternion $ axisAngle v (norm v)+  scale (V3 x y z) = transformScene $ V4+    (V4 x 0 0 0)+    (V4 0 y 0 0)+    (V4 0 0 z 0)+    (V4 0 0 0 1)+  translate v = transformScene $ translation .~ v $ eye4++instance Figure Scene where+  primitive m vs = Scene $ \_ _ f _ _ -> f B.Blank m (V.fromList $ map positionOnly vs)+  color col (Scene s) = Scene $ \e a f b t -> b (Diffuse col (s e a f b t))+  line = primitive LineStrip+  polygon = primitive TriangleFan+  polygonOutline = primitive LineLoop+  circle v = toward v $ circle $ norm v+  circleOutline v = toward v $ circleOutline $ norm v++unit_circle :: Int -> [V2 Float]+unit_circle n = map angle [0,2*pi/fromIntegral n..2*pi]++instance Monoid Scene where+  mempty = Scene $ \e _ _ _ _ -> e+  mappend (Scene x) (Scene y) = Scene $ \e a f b t -> a (x e a f b t) (y e a f b t)++v2ToV3 :: Num a => V2 a -> V3 a+v2ToV3 (V2 x y) = V3 x y 0++vertices :: B.Bitmap -> PrimitiveMode -> V.Vector Vertex -> Scene+vertices b m v = Scene $ \_ _ f _ _ -> f b m v++transformScene :: M44 Float -> Scene -> Scene+transformScene m (Scene pic) = Scene $ \e a f b t -> t m (pic e a f b t)++applyVFX :: VFX Scene -> Scene+applyVFX vf = Scene $ \e a f b t -> b $ fmap (\(Scene s) -> s e a f b t) vf++newtype Picture = Picture { unPicture :: Scene } deriving Monoid++instance Affine Picture where+  type Vec Picture = V2 Float+  type Normal Picture = Float+  rotateOn t (Picture s) = Picture (transformScene m s) where+    m = V4 (V4 (cos t) (-sin t) 0 0) (V4 (sin t) (cos t) 0 0) (V4 0 0 1 0) (V4 0 0 0 1)+  translate (V2 x y) (Picture s) = Picture $ transformScene (translation .~ V3 x y 0 $ eye4) s+  scale (V2 x y) (Picture s) = Picture (transformScene m s) where+    m = V4 (V4 x 0 0 0) (V4 0 y 0 0) (V4 0 0 1 0) (V4 0 0 0 1)++instance Figure Picture where+  primitive m v = Picture $ primitive m $ map v2ToV3 v+  color col (Picture s) = Picture (color col s)+  line = primitive LineStrip+  polygon = primitive TriangleFan+  polygonOutline = primitive LineLoop+  circle r = polygon $ map (^*r) $ unit_circle 33+  circleOutline r = polygonOutline $ map (^*r) $ unit_circle 33++newtype Sight = Sight { unSight+  :: forall r.+  X.Box V2 Float+  -> r+  -> (r -> r -> r)+  -> (X.Box V2 Float -> M44 Float -> Bool -> Scene -> r)+  -> r+  }++instance Monoid Sight where+  mempty = Sight $ \_ e _ _ -> e+  mappend (Sight x) (Sight y) = Sight $ \b e a f -> a (x b e a f) (y b e a f)++viewPicture :: Picture -> Sight+viewPicture (Picture s) = Sight $ \box@(X.Box (V2 x0 y0) (V2 x1 y1)) _ _ f -> f box (ortho x0 x1 y1 y0 (-1) 1) False s++viewScene :: Float -- ^ FOV+  -> Float -- ^ Near plane+  -> Float -- ^ Far plane+  -> Scene -- ^ The scene+  -> Sight+viewScene fov near far = fromPerspective $ \box -> perspective fov (let V2 w h = box ^. X.size 0 in w/h) near far++fromPerspective :: (X.Box V2 Float -> M44 Float) -> Scene -> Sight+fromPerspective mat s = Sight $ \box _ _ f -> f box (mat box) True s+

+ src/Data/Graphics/Vertex.hs view

@@ -0,0 +1,39 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Data.Graphics.Vertex where+import Foreign.Storable+import Foreign.Ptr+import Data.Typeable+import Control.Applicative+import Linear++type Vec2 = V2 Float+type Vec3 = V3 Float++data Vertex = Vertex { vPos :: {-# UNPACK #-} !Vec3+  , vUV :: {-# UNPACK #-} !Vec2+  , vNormal :: {-# UNPACK #-} !Vec3 }+  deriving (Show, Eq, Ord, Read, Typeable)++align1 :: Int+align1 = sizeOf (vPos undefined)++align2 :: Int+align2 = align1 + sizeOf (vUV undefined)++instance Storable Vertex where+  sizeOf _ = sizeOf (undefined :: Vec3) + sizeOf (undefined :: Vec2) + sizeOf (undefined :: Vec3)+  alignment _ = 0+  peek ptr = Vertex+    <$> peek (castPtr ptr)+    <*> peek (castPtr $ ptr `plusPtr` align1)+    <*> peek (castPtr $ ptr `plusPtr` align2)+  poke ptr (Vertex v t n) = do+    poke (castPtr ptr) v+    poke (castPtr ptr `plusPtr` align1) t+    poke (castPtr ptr `plusPtr` align2) n++positionUV :: Vec3 -> Vec2 -> Vertex+positionUV v p = Vertex v p (V3 0 0 1)++positionOnly :: Vec3 -> Vertex+positionOnly v = Vertex v zero (V3 0 0 1)

+ src/Data/Input/Event.hs view

@@ -0,0 +1,164 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Data.Input.Event where+import Data.Typeable+import Data.Char+import Linear++data Chatter a = Up a | Down a deriving (Show, Eq, Ord, Read, Typeable)++data MouseEvent = Button (Chatter Int)+  | Cursor (V2 Float)+  | Scroll (V2 Float)+  deriving (Show, Eq, Ord, Read, Typeable)++data Gamepad = Gamepad Int String deriving (Show, Eq, Ord, Read, Typeable)++data GamepadEvent = PadButton Gamepad (Chatter Int)+  | PadAxis Gamepad Int Float+  | PadConnection (Chatter Gamepad)+  deriving (Show, Eq, Ord, Read, Typeable)++data Key =+      KeyUnknown+    | KeySpace+    | KeyApostrophe+    | KeyComma+    | KeyMinus+    | KeyPeriod+    | KeySlash+    | Key0+    | Key1+    | Key2+    | Key3+    | Key4+    | Key5+    | Key6+    | Key7+    | Key8+    | Key9+    | KeySemicolon+    | KeyEqual+    | KeyA+    | KeyB+    | KeyC+    | KeyD+    | KeyE+    | KeyF+    | KeyG+    | KeyH+    | KeyI+    | KeyJ+    | KeyK+    | KeyL+    | KeyM+    | KeyN+    | KeyO+    | KeyP+    | KeyQ+    | KeyR+    | KeyS+    | KeyT+    | KeyU+    | KeyV+    | KeyW+    | KeyX+    | KeyY+    | KeyZ+    | KeyLeftBracket+    | KeyBackslash+    | KeyRightBracket+    | KeyGraveAccent+    | KeyWorld1+    | KeyWorld2+    | KeyEscape+    | KeyEnter+    | KeyTab+    | KeyBackspace+    | KeyInsert+    | KeyDelete+    | KeyRight+    | KeyLeft+    | KeyDown+    | KeyUp+    | KeyPageUp+    | KeyPageDown+    | KeyHome+    | KeyEnd+    | KeyCapsLock+    | KeyScrollLock+    | KeyNumLock+    | KeyPrintScreen+    | KeyPause+    | KeyF1+    | KeyF2+    | KeyF3+    | KeyF4+    | KeyF5+    | KeyF6+    | KeyF7+    | KeyF8+    | KeyF9+    | KeyF10+    | KeyF11+    | KeyF12+    | KeyF13+    | KeyF14+    | KeyF15+    | KeyF16+    | KeyF17+    | KeyF18+    | KeyF19+    | KeyF20+    | KeyF21+    | KeyF22+    | KeyF23+    | KeyF24+    | KeyF25+    | KeyPad0+    | KeyPad1+    | KeyPad2+    | KeyPad3+    | KeyPad4+    | KeyPad5+    | KeyPad6+    | KeyPad7+    | KeyPad8+    | KeyPad9+    | KeyPadDecimal+    | KeyPadDivide+    | KeyPadMultiply+    | KeyPadSubtract+    | KeyPadAdd+    | KeyPadEnter+    | KeyPadEqual+    | KeyLeftShift+    | KeyLeftControl+    | KeyLeftAlt+    | KeyLeftSuper+    | KeyRightShift+    | KeyRightControl+    | KeyRightAlt+    | KeyRightSuper+    | KeyMenu+    deriving (Enum, Eq, Ord, Read, Show, Typeable, Bounded)++charToKey :: Char -> Key+charToKey ch+    | isAlpha ch = toEnum $ fromEnum KeyA + fromEnum ch - fromEnum 'A'+    | isDigit ch = toEnum $ fromEnum Key0 + fromEnum ch - fromEnum '0'+charToKey '-' = KeyMinus+charToKey ',' = KeyComma+charToKey '.' = KeyPeriod+charToKey '/' = KeySlash+charToKey ' ' = KeySpace+charToKey '\'' = KeyApostrophe+charToKey '\\' = KeyBackslash+charToKey '=' = KeyEqual+charToKey ';' = KeySemicolon+charToKey '[' = KeyLeftBracket+charToKey ']' = KeyRightBracket+charToKey '`' = KeyGraveAccent+charToKey '\n' = KeyEnter+charToKey '\r' = KeyEnter+charToKey '\t' = KeyTab+charToKey _ = KeyUnknown