diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/audiovisual.cabal b/audiovisual.cabal new file mode 100644 --- /dev/null +++ b/audiovisual.cabal @@ -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 +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 diff --git a/data/Yasashisa-Gothic.ttf b/data/Yasashisa-Gothic.ttf new file mode 100644 # file too large to diff: data/Yasashisa-Gothic.ttf diff --git a/src/Audiovisual/Deck.hs b/src/Audiovisual/Deck.hs new file mode 100644 --- /dev/null +++ b/src/Audiovisual/Deck.hs @@ -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 +-- 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 diff --git a/src/Audiovisual/Sampler.hs b/src/Audiovisual/Sampler.hs new file mode 100644 --- /dev/null +++ b/src/Audiovisual/Sampler.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE FlexibleContexts, ConstraintKinds #-} +----------------------------------------------------------------------------- +-- | +-- Module : Call.Util.Deck +-- Copyright : (c) Fumiaki Kinoshita 2014 +-- License : BSD3 +-- +-- Maintainer : Fumiaki Kinoshita +-- 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 diff --git a/src/Audiovisual/Text.hs b/src/Audiovisual/Text.hs new file mode 100644 --- /dev/null +++ b/src/Audiovisual/Text.hs @@ -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 diff --git a/src/Data/Audio.hs b/src/Data/Audio.hs new file mode 100644 --- /dev/null +++ b/src/Data/Audio.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE BangPatterns, DeriveFunctor #-} +----------------------------------------------------------------------------- +-- | +-- Module : Call.Data.Wave +-- Copyright : (c) Fumiaki Kinoshita 2014 +-- License : BSD3 +-- +-- Maintainer : Fumiaki Kinoshita +-- 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 diff --git a/src/Data/Graphics.hs b/src/Data/Graphics.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graphics.hs @@ -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 + diff --git a/src/Data/Graphics/Bitmap.hs b/src/Data/Graphics/Bitmap.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graphics/Bitmap.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : Call.Data.Bitmap +-- Copyright : (c) Fumiaki Kinoshita 2014 +-- License : BSD3 +-- +-- Maintainer : Fumiaki Kinoshita +-- 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 (pathi) + where + notHidden ('.':_) = False + notHidden _ = True + +pathToName :: FilePath -> String +pathToName = ('_':) . map p where + p c | isAlphaNum c = c + | otherwise = '_' diff --git a/src/Data/Graphics/Class.hs b/src/Data/Graphics/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graphics/Class.hs @@ -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) diff --git a/src/Data/Graphics/Font.hs b/src/Data/Graphics/Font.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graphics/Font.hs @@ -0,0 +1,120 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Call.Data.Font +-- Copyright : (c) Fumiaki Kinoshita 2014 +-- License : BSD3 +-- +-- Maintainer : Fumiaki Kinoshita +-- 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) diff --git a/src/Data/Graphics/Sight.hs b/src/Data/Graphics/Sight.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graphics/Sight.hs @@ -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 +-- 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 + diff --git a/src/Data/Graphics/Vertex.hs b/src/Data/Graphics/Vertex.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graphics/Vertex.hs @@ -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) diff --git a/src/Data/Input/Event.hs b/src/Data/Input/Event.hs new file mode 100644 --- /dev/null +++ b/src/Data/Input/Event.hs @@ -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