Commit with working graphics but slow, will attempt to change text
This commit is contained in:
+36
-29
@@ -1,5 +1,5 @@
|
||||
--{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
--{-# LANGUAGE Strict #-}
|
||||
module Picture
|
||||
( module Picture.Data
|
||||
, polygon
|
||||
@@ -61,26 +61,36 @@ black = (0,0,0,1)
|
||||
polygonD :: Float -> [Point2] -> Picture
|
||||
{-# INLINE polygonD #-}
|
||||
polygonD d (a:b:c:ps) = blank
|
||||
{ _scPosTri = DL.fromList $ map (\(x,y) -> (x,y,d)) tris
|
||||
, _scColTri = DL.fromList $ map (const black) tris
|
||||
{ _scPosTri = mapVC (\(x,y) -> (x,y,d)) tris
|
||||
, _scColTri = mapVC (const black) tris
|
||||
}
|
||||
where twoPs = zip (b:c:ps) (c:ps)
|
||||
tris = concatMap (\(x,y)-> [a,x,y]) twoPs
|
||||
tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
|
||||
polygonD _ _ = blank
|
||||
|
||||
polygon :: [Point2] -> Picture
|
||||
{-# INLINE polygon #-}
|
||||
polygon (a:b:c:ps) = blank
|
||||
{ _scPosTri = DL.fromList $ map zeroZ tris
|
||||
, _scColTri = DL.fromList $ map (const black) tris
|
||||
{ _scPosTri = fmap zeroZ tris
|
||||
, _scColTri = fmap (const black) tris
|
||||
}
|
||||
where twoPs = zip (b:c:ps) (c:ps)
|
||||
tris = concatMap (\(x,y)-> [a,x,y]) twoPs
|
||||
tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
|
||||
polygon _ = blank
|
||||
|
||||
color :: RGBA -> Picture -> Picture
|
||||
{-# INLINE color #-}
|
||||
color c = over scColTri (DL.map $ const c) . over scColChar (DL.map $ const c)
|
||||
color c pic@(Scene {_scColTri = colTri,_scColChar= colChar}) =
|
||||
pic {_scColTri = mapVC (const c) colTri
|
||||
,_scColChar = mapVC (const c) colChar
|
||||
}
|
||||
|
||||
overPos :: (Point3 -> Point3) -> Picture -> Picture
|
||||
{-# INLINE overPos #-}
|
||||
overPos f pic@(Scene {_scPosTri = posTri,_scPosChar= posChar}) =
|
||||
pic {_scPosTri = mapVC f posTri
|
||||
,_scPosChar = mapVC f posChar
|
||||
}
|
||||
|
||||
translate3 :: Float -> Float -> Point3 -> Point3
|
||||
{-# INLINE translate3 #-}
|
||||
@@ -88,19 +98,13 @@ translate3 a b (x,y,z) = (x+a,y+b,z)
|
||||
|
||||
translate :: Float -> Float -> Picture -> Picture
|
||||
{-# INLINE translate #-}
|
||||
translate x y = over scPosTri (DL.map $ translate3 x y) . over scPosChar (DL.map $ translate3 x y)
|
||||
--translate x y = over scPosTri (mapVC $ translate3 x y) . over scPosChar (mapVC $ translate3 x y)
|
||||
translate x y = overPos $ translate3 x y
|
||||
|
||||
setDepth :: Float -> Picture -> Picture
|
||||
setDepth d = over scPosTri (DL.map $ (\(x,y,z)->(x,y,d)))
|
||||
. over scPosChar (DL.map $ (\(x,y,z)->(x,y,d)))
|
||||
|
||||
--overVs' :: (CPoint2 -> CPoint) -> Picture -> Picture
|
||||
----{-# INLINE overVs' #-}
|
||||
--overVs' f !(Scene a b) = let !a' = map f a
|
||||
-- !b' = map g b
|
||||
-- in Scene a' b'
|
||||
-- where g !(x,y,z) = let !(x',y') = f (x,y)
|
||||
-- in (x',y',z)
|
||||
--setDepth d = over scPosTri (mapVC $ (\(x,y,z)->(x,y,d)))
|
||||
-- . over scPosChar (mapVC $ (\(x,y,z)->(x,y,d)))
|
||||
setDepth d = overPos $ \(x,y,z) -> (x,y,d)
|
||||
|
||||
scale3 :: Float -> Float -> Point3 -> Point3
|
||||
{-# INLINE scale3 #-}
|
||||
@@ -108,7 +112,8 @@ scale3 a b (x,y,z) = (x*a,y*b,z)
|
||||
|
||||
scale :: Float -> Float -> Picture -> Picture
|
||||
{-# INLINE scale #-}
|
||||
scale x y = over scPosTri (DL.map $ scale3 x y) . over scPosChar (DL.map $ scale3 x y)
|
||||
--scale x y = over scPosTri (mapVC $ scale3 x y) . over scPosChar (mapVC $ scale3 x y)
|
||||
scale x y = overPos $ scale3 x y
|
||||
|
||||
rotate3 :: Float -> Point3 -> Point3
|
||||
{-# INLINE rotate3 #-}
|
||||
@@ -117,14 +122,16 @@ rotate3 a (x,y,z) = (x',y',z)
|
||||
|
||||
rotate :: Float -> Picture -> Picture
|
||||
{-# INLINE rotate #-}
|
||||
rotate a = over scPosTri (DL.map $ rotate3 (0 - degToRad a))
|
||||
. over scPosChar (DL.map $ rotate3 (0 - degToRad a))
|
||||
--rotate a = over scPosTri (mapVC $ rotate3 (0 - degToRad a))
|
||||
-- . over scPosChar (mapVC $ rotate3 (0 - degToRad a))
|
||||
rotate a = overPos $ rotate3 $ 0 - degToRad a
|
||||
|
||||
-- -- this rotation uses radians, and is anticlockwise
|
||||
rotateRad :: Float -> Picture -> Picture
|
||||
{-# INLINE rotateRad #-}
|
||||
rotateRad a = over scPosTri (DL.map $ rotate3 a)
|
||||
. over scPosChar (DL.map $ rotate3 a)
|
||||
--rotateRad a = over scPosTri (mapVC $ rotate3 a)
|
||||
-- . over scPosChar (mapVC $ rotate3 a)
|
||||
rotateRad a = overPos $ rotate3 a
|
||||
|
||||
pictures :: [Picture] -> Picture
|
||||
{-# INLINE pictures #-}
|
||||
@@ -161,17 +168,17 @@ text s = mconcat $ zipWith (\x -> translate x (0-dimText))
|
||||
|
||||
charToScene :: Char -> Picture
|
||||
charToScene c = Scene
|
||||
{_scPosTri = DL.empty
|
||||
,_scColTri = DL.empty
|
||||
,_scPosChar = DL.fromList [(0.0 ,0.0 ,0)
|
||||
{_scPosTri = mempty
|
||||
,_scColTri = mempty
|
||||
,_scPosChar = toVC [(0.0 ,0.0 ,0)
|
||||
,(dimText,0.0 ,0)
|
||||
,(dimText,dimText*2,0)
|
||||
,(0.0 ,0.0 ,0)
|
||||
,(dimText,dimText*2,0)
|
||||
,(0.0 ,dimText*2,0)
|
||||
]
|
||||
,_scColChar = DL.fromList $ take 6 $ repeat white
|
||||
,_scTexChar = DL.fromList $ [(s,1) ,(e,1) ,(e,0) ,(s,1) ,(e,0) ,(s,0)]
|
||||
,_scColChar = toVC $ take 6 $ repeat white
|
||||
,_scTexChar = toVC $ [(s,1) ,(e,1) ,(e,0) ,(s,1) ,(e,0) ,(s,0)]
|
||||
}
|
||||
where x = 1/128
|
||||
s = offset * x
|
||||
|
||||
+30
-9
@@ -1,9 +1,10 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
--{-# LANGUAGE Strict #-}
|
||||
module Picture.Data
|
||||
where
|
||||
import Data.Monoid
|
||||
import qualified Data.DList as DL
|
||||
import qualified Data.Vector as V
|
||||
import Geometry.Data
|
||||
|
||||
import Control.Lens
|
||||
@@ -11,21 +12,41 @@ import Control.Lens
|
||||
type RGBA = (Float,Float,Float,Float)
|
||||
type Color = (Float,Float,Float,Float)
|
||||
|
||||
|
||||
--type VerticesContainer a = DL.DList a
|
||||
--toVC = DL.fromList
|
||||
--fromVC = DL.toList
|
||||
type VerticesContainer a = [a]
|
||||
toVC = id
|
||||
fromVC = id
|
||||
|
||||
mapVC :: (a -> b) -> VerticesContainer a -> VerticesContainer b
|
||||
mapVC = fmap
|
||||
|
||||
data Shape = Shape
|
||||
{ _shPos :: VerticesContainer Point3
|
||||
, _shCol :: VerticesContainer RGBA
|
||||
}
|
||||
combineShapes :: Shape -> Shape -> Shape
|
||||
combineShapes sa sb = Shape
|
||||
{ _shPos = _shPos sa <> _shPos sb
|
||||
, _shCol = _shCol sa <> _shCol sb
|
||||
}
|
||||
|
||||
data Picture = Scene
|
||||
{ _scPosTri :: DL.DList Point3
|
||||
, _scColTri :: DL.DList RGBA
|
||||
, _scPosChar :: DL.DList Point3
|
||||
, _scColChar :: DL.DList RGBA
|
||||
, _scTexChar :: DL.DList Point2
|
||||
{ _scPosTri :: VerticesContainer Point3
|
||||
, _scColTri :: VerticesContainer RGBA
|
||||
, _scPosChar :: VerticesContainer Point3
|
||||
, _scColChar :: VerticesContainer RGBA
|
||||
, _scTexChar :: VerticesContainer Point2
|
||||
}
|
||||
|
||||
blank :: Picture
|
||||
{-# INLINE blank #-}
|
||||
blank = Scene DL.empty DL.empty DL.empty DL.empty DL.empty
|
||||
blank = Scene mempty mempty mempty mempty mempty
|
||||
|
||||
combineScenes :: Picture -> Picture -> Picture
|
||||
{-# SCC combineScenes #-}
|
||||
--{-# INLINE combineScenes #-}
|
||||
{-# INLINE combineScenes #-}
|
||||
combineScenes sa sb = Scene
|
||||
{ _scPosTri = _scPosTri sa <> _scPosTri sb
|
||||
, _scColTri = _scColTri sa <> _scColTri sb
|
||||
|
||||
@@ -1,5 +1,5 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
--{-# LANGUAGE Strict #-}
|
||||
module Picture.Preload
|
||||
where
|
||||
|
||||
@@ -130,9 +130,9 @@ doPreload' = do
|
||||
vertexAttribArray (AttribLocation 2) $= Enabled
|
||||
|
||||
-- allocate memory for vertex attributes
|
||||
ptrPosVBO <- mallocArray (3*3*5000)
|
||||
ptrColVBO <- mallocArray (3*4*5000)
|
||||
ptrTexVBO <- mallocArray (3*2*5000)
|
||||
ptrPosVBO <- mallocArray (3*3*20000)
|
||||
ptrColVBO <- mallocArray (3*4*20000)
|
||||
ptrTexVBO <- mallocArray (3*2*20000)
|
||||
|
||||
return $ PreloadData
|
||||
{ _charMap = convertRGBA8 cmap
|
||||
|
||||
+29
-36
@@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE Strict #-}
|
||||
--{-# LANGUAGE Strict #-}
|
||||
module Picture.Render
|
||||
where
|
||||
import Control.Lens
|
||||
@@ -29,63 +29,56 @@ toVec2 (x,y) = Vector2 x y
|
||||
toVec3 (x,y,z) = Vector3 x y z
|
||||
toVec4 (x,y,z,w) = Vector4 x y z w
|
||||
|
||||
flat2 (x,y) = DL.fromList [x,y]
|
||||
flat3 (x,y,z) = DL.fromList [x,y,z]
|
||||
flat4 (x,y,z,w) = DL.fromList [x,y,z,w]
|
||||
flat2 (x,y) = toVC [x,y]
|
||||
flat3 (x,y,z) = toVC [x,y,z]
|
||||
flat4 (x,y,z,w) = toVC [x,y,z,w]
|
||||
|
||||
mapFlat :: (NFData b) => (a -> DL.DList b) -> DL.DList a -> [b]
|
||||
mapFlat f = force . DL.toList . foldMap f
|
||||
mapFlat :: (NFData b) => (a -> VerticesContainer b) -> VerticesContainer a -> [b]
|
||||
mapFlat f = fromVC . foldMap f
|
||||
|
||||
--marshallVs = V.unsafeWith . V.fromList
|
||||
--marshallVs = withArray
|
||||
|
||||
renderPicture' :: PreloadData -> Picture -> IO ()
|
||||
renderPicture' pdata (Scene posTri' colTri' posChar' colChar' texChar') = do
|
||||
let posTri = DL.toList posTri'
|
||||
colTri = DL.toList colTri'
|
||||
posChar = DL.toList posChar'
|
||||
colChar = DL.toList colChar'
|
||||
texChar = DL.toList texChar'
|
||||
renderPicture' pdata (Scene posTri colTri posChar colChar texChar) = do
|
||||
currentProgram $= Just (_basicShader pdata)
|
||||
bindVertexArrayObject $= Just (_basicVAO pdata)
|
||||
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
|
||||
let firstIndex = 0
|
||||
let vertices :: [Float]
|
||||
vertices = mapFlat flat3 posTri'
|
||||
numVertices = length vertices
|
||||
vertices = mapFlat flat3 posTri
|
||||
numVertices = length posTri
|
||||
vertexSize = sizeOf (head vertices)
|
||||
pokeArray (_ptrPosVBO pdata) vertices
|
||||
bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), _ptrPosVBO pdata, StreamDraw)
|
||||
bufferData ArrayBuffer $= (fromIntegral (3 * numVertices * vertexSize), _ptrPosVBO pdata, StreamDraw)
|
||||
-- marshallVs vertices $ \ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StreamDraw)
|
||||
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
|
||||
let colVs = mapFlat flat4 colTri'
|
||||
let colVs = mapFlat flat4 colTri
|
||||
colVsize = sizeOf $ head colVs
|
||||
pokeArray (_ptrColVBO pdata) colVs
|
||||
bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), _ptrColVBO pdata, StreamDraw)
|
||||
bufferData ArrayBuffer $= (fromIntegral (4 * numVertices * colVsize), _ptrColVBO pdata, StreamDraw)
|
||||
-- marshallVs colVs $ \ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), ptr, StreamDraw)
|
||||
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVertices)
|
||||
|
||||
-- currentProgram $= Just (_textShader pdata)
|
||||
-- bindVertexArrayObject $= Just (_textVAO pdata)
|
||||
-- bindBuffer ArrayBuffer $= Just (_posVBO pdata)
|
||||
-- let vertices' = mapFlat flat3 posChar'
|
||||
-- numVertices' = length vertices'
|
||||
-- vertexSize' = sizeOf $ head vertices'
|
||||
-- withArray vertices' $ \ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (numVertices' * vertexSize'), ptr, StreamDraw)
|
||||
-- bindBuffer ArrayBuffer $= Just (_colVBO pdata)
|
||||
-- let colVsT = mapFlat flat4 colChar'
|
||||
-- colVsTsize = sizeOf $ head colVsT
|
||||
-- withArrayLen colVsT $ \numV' ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (numVertices' * colVsTsize), ptr, StreamDraw)
|
||||
-- bindBuffer ArrayBuffer $= Just (_texVBO pdata)
|
||||
-- let texVsT = mapFlat flat2 texChar'
|
||||
-- texVsTsize = sizeOf $ head texVsT
|
||||
-- withArrayLen texVsT $ \numV' ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (numVertices' * texVsTsize), ptr, StreamDraw)
|
||||
-- drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVertices')
|
||||
currentProgram $= Just (_textShader pdata)
|
||||
bindVertexArrayObject $= Just (_textVAO pdata)
|
||||
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
|
||||
let vertices' = mapFlat flat3 posChar
|
||||
numVertices' = length posChar
|
||||
vertexSize' = sizeOf $ head vertices'
|
||||
pokeArray (_ptrPosVBO pdata) vertices'
|
||||
bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), _ptrPosVBO pdata, StreamDraw)
|
||||
--withArray vertices' $ \ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), ptr, StreamDraw)
|
||||
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
|
||||
pokeArray (_ptrColVBO pdata) $ mapFlat flat4 colChar
|
||||
bufferData ArrayBuffer $= (fromIntegral (4 * numVertices' * vertexSize'), _ptrColVBO pdata, StreamDraw)
|
||||
bindBuffer ArrayBuffer $= Just (_texVBO pdata)
|
||||
pokeArray (_ptrTexVBO pdata) $ mapFlat flat2 texChar
|
||||
bufferData ArrayBuffer $= (fromIntegral (2 * numVertices' * vertexSize'), _ptrTexVBO pdata, StreamDraw)
|
||||
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVertices')
|
||||
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user