~alcinnz/Typograffiti

9ed93aa25420ca19fbc7288e50c46810a827c503 — Adrian Cochrane 1 year, 11 months ago 5879469
Start refactoring to resemble existing Typograffiti structure.
A app/Main.hs => app/Main.hs +47 -0
@@ 0,0 1,47 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where

import System.Environment (getArgs)
import Graphics.Text.Font.Render (makeDrawText', GlyphSize(..), TextTransform(..),
                                    AllocatedRendering(..), SpatialTransform(..))
import SDL hiding (rotate)
import Graphics.GL.Core32

import Data.Function (fix)
import Data.Text.Lazy (pack)
import Control.Monad (unless)

main :: IO ()
main = do
    SDL.initializeAll

    let openGL = defaultOpenGL { glProfile = Core Debug 3 3 }
        wcfg = defaultWindow {
            windowInitialSize = V2 640 480,
            windowGraphicsContext = OpenGLContext openGL,
            windowResizable = True
          }
    w <- createWindow "Typograffiti" wcfg
    _ <- glCreateContext w

    let ttfName = "assets/Lora-Regular.ttf"
    text <- pack <$> unwords <$> getArgs
    drawText <- makeDrawText' ttfName 0 (PixelSize 15 15) [] text
    drawText' <- drawText text

    fix $ \loop -> do
        events <- fmap eventPayload <$> pollEvents
        glClearColor 0 0 0 1
        glClear GL_COLOR_BUFFER_BIT

        sz@(V2 dw dh) <- glGetDrawableSize w
        glViewport 0 0 (fromIntegral dw) (fromIntegral dh)

        let offset = V2 0 $ fromIntegral dy
            V2 _ dy = arSize drawText'
        arDraw drawText' [
            TextTransformSpatial $ SpatialTransformTranslate offset
          ] sz

        glSwapWindow w
        unless (QuitEvent `elem` events) loop

A assets/Lora-Bold.ttf => assets/Lora-Bold.ttf +0 -0
A assets/Lora-BoldItalic.ttf => assets/Lora-BoldItalic.ttf +0 -0
A assets/Lora-Italic.ttf => assets/Lora-Italic.ttf +0 -0
A assets/Lora-Regular.ttf => assets/Lora-Regular.ttf +0 -0
A assets/Neuton-Regular.ttf => assets/Neuton-Regular.ttf +0 -0
A assets/OFL.txt => assets/OFL.txt +94 -0
@@ 0,0 1,94 @@
Copyright (c) 2010, 2011, Brian Zick (artistenator@gmail.com www.21326.info),
with Reserved Font Name "Neuton" "Neuton Italic" "Neuton Cursive"

This Font Software is licensed under the SIL Open Font License, Version 1.1.
This license is copied below, and is also available with a FAQ at:
http://scripts.sil.org/OFL


-----------------------------------------------------------
SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007
-----------------------------------------------------------

PREAMBLE
The goals of the Open Font License (OFL) are to stimulate worldwide
development of collaborative font projects, to support the font creation
efforts of academic and linguistic communities, and to provide a free and
open framework in which fonts may be shared and improved in partnership
with others.

The OFL allows the licensed fonts to be used, studied, modified and
redistributed freely as long as they are not sold by themselves. The
fonts, including any derivative works, can be bundled, embedded, 
redistributed and/or sold with any software provided that any reserved
names are not used by derivative works. The fonts and derivatives,
however, cannot be released under any other type of license. The
requirement for fonts to remain under this license does not apply
to any document created using the fonts or their derivatives.

DEFINITIONS
"Font Software" refers to the set of files released by the Copyright
Holder(s) under this license and clearly marked as such. This may
include source files, build scripts and documentation.

"Reserved Font Name" refers to any names specified as such after the
copyright statement(s).

"Original Version" refers to the collection of Font Software components as
distributed by the Copyright Holder(s).

"Modified Version" refers to any derivative made by adding to, deleting,
or substituting -- in part or in whole -- any of the components of the
Original Version, by changing formats or by porting the Font Software to a
new environment.

"Author" refers to any designer, engineer, programmer, technical
writer or other person who contributed to the Font Software.

PERMISSION & CONDITIONS
Permission is hereby granted, free of charge, to any person obtaining
a copy of the Font Software, to use, study, copy, merge, embed, modify,
redistribute, and sell modified and unmodified copies of the Font
Software, subject to the following conditions:

1) Neither the Font Software nor any of its individual components,
in Original or Modified Versions, may be sold by itself.

2) Original or Modified Versions of the Font Software may be bundled,
redistributed and/or sold with any software, provided that each copy
contains the above copyright notice and this license. These can be
included either as stand-alone text files, human-readable headers or
in the appropriate machine-readable metadata fields within text or
binary files as long as those fields can be easily viewed by the user.

3) No Modified Version of the Font Software may use the Reserved Font
Name(s) unless explicit written permission is granted by the corresponding
Copyright Holder. This restriction only applies to the primary font name as
presented to the users.

4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font
Software shall not be used to promote, endorse or advertise any
Modified Version, except to acknowledge the contribution(s) of the
Copyright Holder(s) and the Author(s) or with their explicit written
permission.

5) The Font Software, modified or unmodified, in part or in whole,
must be distributed entirely under this license, and must not be
distributed under any other license. The requirement for fonts to
remain under this license does not apply to any document created
using the Font Software.

TERMINATION
This license becomes null and void if any of the above conditions are
not met.

DISCLAIMER
THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT
OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE
COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM
OTHER DEALINGS IN THE FONT SOFTWARE.

A assets/SIL Open Font License.txt => assets/SIL Open Font License.txt +44 -0
@@ 0,0 1,44 @@
Copyright (c) 2011-2013, Cyreal (www.cyreal.org a@cyreal.org), with
Reserved Font Name 'Lora'

This Font Software is licensed under the SIL Open Font License, Version 1.1.
This license is copied below, and is also available with a FAQ at: http://scripts.sil.org/OFL

-----------------------------------------------------------
SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007
-----------------------------------------------------------

PREAMBLE
The goals of the Open Font License (OFL) are to stimulate worldwide development of collaborative font projects, to support the font creation efforts of academic and linguistic communities, and to provide a free and open framework in which fonts may be shared and improved in partnership with others.

The OFL allows the licensed fonts to be used, studied, modified and redistributed freely as long as they are not sold by themselves. The fonts, including any derivative works, can be bundled, embedded, redistributed and/or sold with any software provided that any reserved names are not used by derivative works. The fonts and derivatives, however, cannot be released under any other type of license. The requirement for fonts to remain under this license does not apply to any document created using the fonts or their derivatives.

DEFINITIONS
"Font Software" refers to the set of files released by the Copyright Holder(s) under this license and clearly marked as such. This may include source files, build scripts and documentation.

"Reserved Font Name" refers to any names specified as such after the copyright statement(s).

"Original Version" refers to the collection of Font Software components as distributed by the Copyright Holder(s).

"Modified Version" refers to any derivative made by adding to, deleting, or substituting -- in part or in whole -- any of the components of the Original Version, by changing formats or by porting the Font Software to a new environment.

"Author" refers to any designer, engineer, programmer, technical writer or other person who contributed to the Font Software.

PERMISSION & CONDITIONS
Permission is hereby granted, free of charge, to any person obtaining a copy of the Font Software, to use, study, copy, merge, embed, modify, redistribute, and sell modified and unmodified copies of the Font Software, subject to the following conditions:

1) Neither the Font Software nor any of its individual components, in Original or Modified Versions, may be sold by itself.

2) Original or Modified Versions of the Font Software may be bundled, redistributed and/or sold with any software, provided that each copy contains the above copyright notice and this license. These can be included either as stand-alone text files, human-readable headers or in the appropriate machine-readable metadata fields within text or binary files as long as those fields can be easily viewed by the user.

3) No Modified Version of the Font Software may use the Reserved Font Name(s) unless explicit written permission is granted by the corresponding Copyright Holder. This restriction only applies to the primary font name as presented to the users.

4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font Software shall not be used to promote, endorse or advertise any Modified Version, except to acknowledge the contribution(s) of the Copyright Holder(s) and the Author(s) or with their explicit written permission.

5) The Font Software, modified or unmodified, in part or in whole, must be distributed entirely under this license, and must not be distributed under any other license. The requirement for fonts to remain under this license does not apply to any document created using the Font Software.

TERMINATION
This license becomes null and void if any of the above conditions are not met.

DISCLAIMER
THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM OTHER DEALINGS IN THE FONT SOFTWARE.
\ No newline at end of file

A src/Typograffiti.hs => src/Typograffiti.hs +0 -0
A src/Typograffiti/Atlas.hs => src/Typograffiti/Atlas.hs +0 -0
A src/Typograffiti/Cache.hs => src/Typograffiti/Cache.hs +0 -0
A src/Typograffiti/GL.hs => src/Typograffiti/GL.hs +367 -0
@@ 0,0 1,367 @@
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase        #-}
module Typograffiti.GL where

import           Control.Exception      (assert)
import           Control.Monad          (forM_, replicateM, when)
import           Control.Monad.Fail     (MonadFail)
import           Control.Monad.IO.Class (MonadIO (..))
import           Data.ByteString        (ByteString)
import qualified Data.ByteString.Char8  as B8
import qualified Data.Foldable          as F
import qualified Data.Vector.Storable   as SV
import           Data.Vector.Unboxed    (Unbox)
import qualified Data.Vector.Unboxed    as UV
import           Foreign.C.String       (peekCAStringLen, withCString)
import           Foreign.Marshal.Array
import           Foreign.Marshal.Utils
import           Foreign.Ptr
import           Foreign.Storable
import           GHC.TypeLits           (KnownNat)
import           Graphics.GL.Core32
import           Graphics.GL.Types
import           Linear
import           Linear.V               (Finite, Size, dim, toV)


allocAndActivateTex :: (MonadIO m, MonadFail m) => GLenum -> m GLuint
allocAndActivateTex u = do
  [t] <- liftIO $ allocaArray 1 $ \ptr -> do
    glGenTextures 1 ptr
    peekArray 1 ptr
  glActiveTexture u
  glBindTexture GL_TEXTURE_2D t
  return t


clearErrors :: MonadIO m => String -> m ()
clearErrors str = do
  err' <- glGetError
  when (err' /= 0) $ do
    liftIO $ putStrLn $ unwords [str, show err']
    assert False $ return ()


newBoundVAO :: (MonadIO m, MonadFail m) => m GLuint
newBoundVAO = do
  [vao] <- liftIO $ allocaArray 1 $ \ptr -> do
      glGenVertexArrays 1 ptr
      peekArray 1 ptr
  glBindVertexArray vao
  return vao



withVAO :: MonadIO m => (GLuint -> IO b) -> m b
withVAO f = liftIO $ do
  vao <- newBoundVAO
  r <- f vao
  clearErrors "withVAO"
  glBindVertexArray 0
  return r


newBuffer
  :: MonadIO m
  => m GLuint
newBuffer = liftIO $ do
  [b] <- allocaArray 1 $ \ptr -> do
    glGenBuffers 1 ptr
    peekArray 1 ptr
  return b


withBuffers :: MonadIO m => Int -> ([GLuint] -> m b) -> m b
withBuffers n = (replicateM n newBuffer >>=)


-- | Buffer some geometry into an attribute.
-- The type variable 'f' should be V0, V1, V2, V3 or V4.
bufferGeometry
  :: ( Foldable f
     , Unbox (f Float)
     , Storable (f Float)
     , Finite f
     , KnownNat (Size f)
     , MonadIO m
     )
  => GLuint
  -- ^ The attribute location.
  -> GLuint
  -- ^ The buffer identifier.
  -> UV.Vector (f Float)
  -- ^ The geometry to buffer.
  -> m ()
bufferGeometry loc buf as
  | UV.null as = return ()
  | otherwise = do
    let v     = UV.head as
        asize = UV.length as * sizeOf v
        n     = fromIntegral $ dim $ toV v
    glBindBuffer GL_ARRAY_BUFFER buf
    liftIO $ SV.unsafeWith (convertVec as) $ \ptr ->
      glBufferData GL_ARRAY_BUFFER (fromIntegral asize) (castPtr ptr) GL_STATIC_DRAW
    glEnableVertexAttribArray loc
    glVertexAttribPointer loc n GL_FLOAT GL_FALSE 0 nullPtr
    clearErrors "bufferGeometry"


convertVec
  :: (Unbox (f Float), Foldable f) => UV.Vector (f Float) -> SV.Vector GLfloat
convertVec =
  SV.convert . UV.map realToFrac . UV.concatMap (UV.fromList . F.toList)


-- | Binds the given textures to GL_TEXTURE0, GL_TEXTURE1, ... in ascending
-- order of the texture unit, runs the IO action and then unbinds the textures.
withBoundTextures :: MonadIO m => [GLuint] -> m a -> m a
withBoundTextures ts f = do
  liftIO $ mapM_ (uncurry bindTex) (zip ts [GL_TEXTURE0 ..])
  a <- f
  liftIO $ glBindTexture GL_TEXTURE_2D 0
  return a
  where bindTex tex u = glActiveTexture u >> glBindTexture GL_TEXTURE_2D tex


drawVAO
  :: MonadIO m
  => GLuint
  -- ^ The program
  -> GLuint
  -- ^ The vao
  -> GLenum
  -- ^ The draw mode
  -> GLsizei
  -- ^ The number of vertices to draw
  -> m ()
drawVAO program vao mode num = liftIO $ do
  glUseProgram program
  glBindVertexArray vao
  clearErrors "drawBuffer:glBindVertex"
  glDrawArrays mode 0 num
  clearErrors "drawBuffer:glDrawArrays"


compileOGLShader
  :: MonadIO m
  => ByteString
     -- ^ The shader source
  -> GLenum
  -- ^ The shader type (vertex, frag, etc)
  -> m (Either String GLuint)
  -- ^ Either an error message or the generated shader handle.
compileOGLShader src shType = do
  shader <- liftIO $ glCreateShader shType
  if shader == 0
    then return $ Left "Could not create shader"
    else do
      success <- liftIO $ do
        withCString (B8.unpack src) $ \ptr ->
          with ptr $ \ptrptr -> glShaderSource shader 1 ptrptr nullPtr

        glCompileShader shader
        with (0 :: GLint) $ \ptr -> do
          glGetShaderiv shader GL_COMPILE_STATUS ptr
          peek ptr

      if success == GL_FALSE
        then do
          err <- liftIO $ do
            infoLog <- with (0 :: GLint) $ \ptr -> do
                glGetShaderiv shader GL_INFO_LOG_LENGTH ptr
                logsize <- peek ptr
                allocaArray (fromIntegral logsize) $ \logptr -> do
                    glGetShaderInfoLog shader logsize nullPtr logptr
                    peekArray (fromIntegral logsize) logptr

            return $ unlines [ "Could not compile shader:"
                             , B8.unpack src
                             , map (toEnum . fromEnum) infoLog
                             ]
          return $ Left err
        else return $ Right shader


compileOGLProgram
  :: MonadIO m
  => [(String, Integer)]
  -> [GLuint]
  -> m (Either String GLuint)
compileOGLProgram attribs shaders = do
  (program, success) <- liftIO $ do
     program <- glCreateProgram
     forM_ shaders (glAttachShader program)
     forM_ attribs
       $ \(name, loc) ->
         withCString name
           $ glBindAttribLocation program
           $ fromIntegral loc
     glLinkProgram program

     success <- with (0 :: GLint) $ \ptr -> do
       glGetProgramiv program GL_LINK_STATUS ptr
       peek ptr
     return (program, success)

  if success == GL_FALSE
  then liftIO $ with (0 :: GLint) $ \ptr -> do
    glGetProgramiv program GL_INFO_LOG_LENGTH ptr
    logsize <- peek ptr
    infoLog <- allocaArray (fromIntegral logsize) $ \logptr -> do
      glGetProgramInfoLog program logsize nullPtr logptr
      peekArray (fromIntegral logsize) logptr
    return
      $ Left
      $ unlines
          [ "Could not link program"
          , map (toEnum . fromEnum) infoLog
          ]
  else do
    liftIO $ forM_ shaders glDeleteShader
    return $ Right program


--------------------------------------------------------------------------------
-- Uniform marshaling functions
--------------------------------------------------------------------------------


getUniformLocation :: MonadIO m => GLuint -> String -> m GLint
getUniformLocation program ident = liftIO
  $ withCString ident
  $ glGetUniformLocation program


class UniformValue a where
  updateUniform
    :: MonadIO m
    => GLuint
    -- ^ The program
    -> GLint
    -- ^ The uniform location
    -> a
    -- ^ The value.
    -> m ()


clearUniformUpdateError :: (MonadIO m, Show a) => GLuint -> GLint -> a -> m ()
clearUniformUpdateError prog loc val = glGetError >>= \case
  0 -> return ()
  e -> do
    let buf = replicate 256 ' '
    ident <- liftIO $ withCString buf
      $ \strptr -> with 0
      $ \szptr  -> do
        glGetActiveUniformName prog (fromIntegral loc) 256 szptr strptr
        sz <- peek szptr
        peekCAStringLen (strptr, fromIntegral sz)
    liftIO
      $ putStrLn
      $ unwords
          [ "Could not update uniform"
          , ident
          , "with value"
          , show val
          , ", encountered error (" ++ show e ++ ")"
          , show (GL_INVALID_OPERATION :: Integer, "invalid operation" :: String)
          , show (GL_INVALID_VALUE :: Integer, "invalid value" :: String)
          ]
    assert False $ return ()


instance UniformValue Bool where
  updateUniform p loc bool = liftIO $ do
    glUniform1i loc $ if bool then 1 else 0
    clearUniformUpdateError p loc bool

instance UniformValue Int where
  updateUniform p loc enum = liftIO $ do
    glUniform1i loc $ fromIntegral $ fromEnum enum
    clearUniformUpdateError p loc enum

instance UniformValue Float where
  updateUniform p loc float = liftIO $ do
    glUniform1f loc $ realToFrac float
    clearUniformUpdateError p loc float

instance UniformValue Double where
  updateUniform p loc d = liftIO $ do
    glUniform1f loc $ realToFrac d
    clearUniformUpdateError p loc d

instance UniformValue (V2 Float) where
  updateUniform p loc v = liftIO $ do
    let V2 x y = fmap realToFrac v
    glUniform2f loc x y
    clearUniformUpdateError p loc v

instance UniformValue (V3 Float) where
  updateUniform p loc v = liftIO $ do
    let V3 x y z = fmap realToFrac v
    glUniform3f loc x y z
    clearUniformUpdateError p loc v

instance UniformValue (V4 Float) where
  updateUniform p loc v = liftIO $ do
    let (V4 r g b a) = realToFrac <$> v
    glUniform4f loc r g b a
    clearUniformUpdateError p loc v

instance UniformValue (M44 Float) where
  updateUniform p loc val = liftIO $ do
    with val $ glUniformMatrix4fv loc 1 GL_TRUE . castPtr
    clearUniformUpdateError p loc val

instance UniformValue (V2 Int) where
  updateUniform p loc v = liftIO $ do
    let V2 x y = fmap fromIntegral v
    glUniform2i loc x y
    clearUniformUpdateError p loc v

instance UniformValue (Int,Int) where
  updateUniform p loc = updateUniform p loc . uncurry V2


--------------------------------------------------------------------------------
-- Matrix helpers
--------------------------------------------------------------------------------


mat4Translate :: Num a => V3 a -> M44 a
mat4Translate = mkTransformationMat identity


mat4Rotate :: (Num a, Epsilon a, Floating a) => a -> V3 a -> M44 a
mat4Rotate phi v = mkTransformation (axisAngle v phi) (V3 0 0 0)


mat4Scale :: Num a => V3 a -> M44 a
mat4Scale (V3 x y z) =
    V4 (V4 x 0 0 0)
       (V4 0 y 0 0)
       (V4 0 0 z 0)
       (V4 0 0 0 1)


orthoProjection
  :: Integral a
  => V2 a
  -- ^ The window width and height
  -> M44 Float
orthoProjection (V2 ww wh) =
  let (hw,hh) = (fromIntegral ww, fromIntegral wh)
  in ortho 0 hw hh 0 0 1


boundingBox :: (Unbox a, Real a, Fractional a) => UV.Vector (V2 a) -> (V2 a, V2 a)
boundingBox vs
  | UV.null vs = (0,0)
  | otherwise = UV.foldl' f (br,tl) vs
  where mn a = min a . realToFrac
        mx a = max a . realToFrac
        f (a, b) c = (mn <$> a <*> c, mx <$> b <*> c)
        inf = 1/0
        ninf = (-1)/0
        tl = V2 ninf ninf
        br = V2 inf inf

A src/Typograffiti/Glyph.hs => src/Typograffiti/Glyph.hs +0 -0
A src/Typograffiti/Store.hs => src/Typograffiti/Store.hs +0 -0