Permalink
Browse files

added a texture... not working yet, though

  • Loading branch information...
1 parent b192353 commit 1e14306a97857280747e56811a74df6a978a2f44 Nik Nyby committed Mar 2, 2010
Showing with 149 additions and 52 deletions.
  1. +11 −4 Main.hs
  2. +1 −1 README
  3. +13 −9 Render.hs
  4. +124 −38 State.hs
  5. BIN play.png
View
@@ -8,6 +8,7 @@ import State
main :: IO ()
main = do
+ -- make pointer to world state
env <- newIORef initialEnvironment
-- make the GL window
@@ -16,11 +17,17 @@ main = do
initialDisplayMode $= [DoubleBuffered]
wnd <- createWindow "mma"
- -- callbacks
+ -- textures need to be in the IO monad, so they aren't part of the Env
+ -- textures <- initTextures
+ textures <- loadTexture "play.png"
+
+ -- set up callbacks
displayCallback $= (glRunAs2D $ do
clearColor $= Color4 1 0 1 1
clear [ColorBuffer, DepthBuffer]
- readIORef env >>= drawWorld
+ e <- readIORef env
+ drawWorld e textures
+ --readIORef env >>= drawWorld
flush
swapBuffers)
@@ -51,8 +58,8 @@ glRunAs2D draw = do
matrixMode $= Modelview 0
loadIdentity
- --matrixMode $= Projection
- --loadIdentity
+ matrixMode $= Projection
+ loadIdentity
(_, Size w h) <- get viewport
View
@@ -6,7 +6,7 @@ Marlon Moonglow's Animator ***
Just messing around with OpenGL right now...
To build it with `make' you'll need ghc (probably >= 6.8.x) with the OpenGL and
-GLUT bindings.
+GLUT bindings, and also SDL and SDL-image.
Influences:
* Raincat: http://bysusanlin.com/raincat/
View
@@ -5,20 +5,24 @@ import Graphics.UI.GLUT
import State
-drawWorld :: Env -> IO ()
-drawWorld e = do
+drawWorld :: Env -> MmaTexture -> IO ()
+drawWorld e t = do
currentColor $= Color4 0.2 0 0.3 0
mapM_ (drawSprite) $ sprites e
- currentColor $= Color4 0.8 0.1 0.65 0
- drawMenu (menu $ vars $ e)
+ --currentColor $= Color4 0.8 0.1 0.65 0
+ drawMenu (menu $ vars $ e) t
drawSprite :: Sprite -> IO ()
drawSprite s = renderPrimitive Quads $ mapM_ vertex $ spritePoints s
-drawMenu :: MmaMenu -> IO ()
-drawMenu _ = mapM_ drawButton [0..5]
+drawMenu :: MmaMenu -> MmaTexture -> IO ()
+--drawMenu _ = mapM_ drawButton [0..5]
+drawMenu m t = drawButton (playMmaButton m) t
+
+drawButton :: MmaButton -> MmaTexture -> IO ()
+drawButton (MmaButton r _) tex = do
+ drawTexture (rectX r) (rectY r) tex 1
-drawButton :: Int -> IO ()
-drawButton i = do
--loadIdentity
- renderPrimitive Quads $ mapM_ vertex $ vertexRect (conv i*85+60,50) 80 55
+ --renderPrimitive Quads $ mapM_ vertex $ vertexRect (conv i*85+60,50) 80 55
+
View
@@ -5,112 +5,198 @@ module State (
Vars(..),
MmaMenu(..),
+ MmaButton(..),
Sprite(..),
makeSprite,
spritePoints,
toggleSticky,
within,
+ MmaTexture(..),
+ loadTexture,
+ freeTexture,
+ drawTexture,
+ drawTextureFlip,
+
-- misc functions that belong.... elsewhere???
+ Rectangle(..),
vertexRect,
vertexRect',
conv,
) where
-import qualified Graphics.UI.GLUT as GL
+import Control.Monad
+import Graphics.UI.GLUT
+import Graphics.UI.SDL.Image as SDLImage
+import Graphics.UI.SDL.Types
+import Graphics.UI.SDL.Video (freeSurface)
data Env = Env
{
vars :: Vars,
sprites :: [Sprite]
- } deriving (Show, Eq)
+ } deriving Show
initialEnvironment :: Env
initialEnvironment = Env
- ( Vars 0 (GL.Position 0 0) False False initialMenu )
+ ( Vars 0 (Position 0 0) False False initialMenu )
[ ]
data Vars = Vars
{
clock :: Int,
- mousePos :: GL.Position,
+ mousePos :: Position,
playing :: Bool,
recording :: Bool,
menu :: MmaMenu
- } deriving (Show, Eq)
+ } deriving Show
data MmaMenu = MmaMenu
{
- playButton :: Button,
- recButton :: Button,
+ playMmaButton :: MmaButton
+ {-
+ recMmaButton :: MmaButton,
-- stepper
- prevFrameButton :: Button,
- nextFrameButton :: Button,
+ prevFrameMmaButton :: MmaButton,
+ nextFrameMmaButton :: MmaButton,
-- sprite chooser
- prevSpriteButton :: Button,
- nextSpriteButton :: Button
- } deriving (Show, Eq)
+ prevSpriteMmaButton :: MmaButton,
+ nextSpriteMmaButton :: MmaButton
+ -}
+ } deriving Show
-type Button = Bool
initialMenu :: MmaMenu
-initialMenu = MmaMenu {
- playButton = False,
- recButton = False,
- prevFrameButton = False,
- nextFrameButton = False,
- prevSpriteButton = False,
- nextSpriteButton = False
-}
+initialMenu = MmaMenu b
+ where
+ b = MmaButton (Rectangle 20 20 50 70) False
+
+data MmaButton = MmaButton
+ {
+ buttonRect :: Rectangle,
+
+ --buttonTex :: MmaTexture,
+
+ buttonState :: Bool
+ } deriving Show
data Sprite =
Square {
- currentPos :: GL.Position,
+ currentPos :: Position,
- size :: GL.GLdouble,
+ size :: GLdouble,
-- recorded path
- spritePath :: [GL.Position],
+ spritePath :: [Position],
-- is it being dragged?
sticky :: Bool
} deriving (Show, Eq)
-makeSprite :: GL.Position -> Sprite
+makeSprite :: Position -> Sprite
makeSprite pos = Square pos 10 [] False
-spritePoints :: Sprite -> [GL.Vertex2 GL.GLdouble]
+spritePoints :: Sprite -> [Vertex2 GLdouble]
spritePoints s = vertexRect' (currentPos s) 10 10
toggleSticky :: Sprite -> Sprite
toggleSticky (Square pos sz path s) = Square pos sz path $ not s
-- returns True if the point lies within the sprite's area
-within :: GL.Position -> Sprite -> Bool
-within (GL.Position ppx ppy) s = (sx >= px - sz) && (sx <= px + sz)
+within :: Position -> Sprite -> Bool
+within (Position ppx ppy) s = (sx >= px - sz) && (sx <= px + sz)
&& (sy >= py - sz) && (sy <= py + sz)
where
sx = conv csx; sy = conv csy; px = conv ppx; py = conv ppy
- (GL.Position csx csy) = currentPos s
+ (Position csx csy) = currentPos s
sz = size s
+data MmaTexture = MmaTexture
+ {
+ textureWidth :: GLsizei,
+ textureHeight :: GLsizei,
+ -- textures have to be in the IO monad
+ textureObject :: TextureObject
+ } deriving Show
+
+loadTexture :: String -> IO MmaTexture
+loadTexture filepath = do
+ surface <- SDLImage.loadTyped filepath SDLImage.PNG
+
+ let width = fromIntegral (surfaceGetWidth surface)
+ let height = fromIntegral (surfaceGetHeight surface)
+ let surfaceSize = TextureSize2D width height
+
+ textureObj <- liftM head (genObjectNames 1)
+ textureBinding Texture2D $= Just textureObj
+ textureWrapMode Texture2D S $= (Repeated, Repeat)
+ textureWrapMode Texture2D T $= (Repeated, Repeat)
+ textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
+ surfacePixels <- surfaceGetPixels surface
+
+ let pixelData = PixelData RGBA UnsignedByte surfacePixels
+ texImage2D Nothing NoProxy 0 RGBA' surfaceSize 0 pixelData
+
+ --freeSurface surface
+
+ return (MmaTexture width height textureObj)
+
+freeTexture :: MmaTexture -> IO ()
+freeTexture tex = do
+ deleteObjectNames ([textureObject tex])
+
+drawTexture :: GLdouble -> GLdouble -> MmaTexture -> GLdouble -> IO ()
+drawTexture x y tex alpha = do
+ drawTextureFlip x y tex alpha False
+
+drawTextureFlip :: GLdouble -> GLdouble -> MmaTexture -> GLdouble -> Bool -> IO ()
+drawTextureFlip x y tex alpha flp = do
+ texture Texture2D $= Enabled
+ textureBinding Texture2D $= Just (textureObject tex)
+
+ let
+ texWidth = fromIntegral $ textureWidth tex
+ texHeight = fromIntegral $ textureHeight tex
+
+ texCoord2f = texCoord :: TexCoord2 GLdouble -> IO ()
+ vertex3f = vertex :: Vertex3 GLdouble -> IO ()
+ color4f = color :: Color4 GLdouble -> IO ()
+ col = color4f (Color4 (1.0::GLdouble) (1.0::GLdouble) (1.0::GLdouble) alpha)
+
+ texCoordX = if flp then (-1) else 1
+
+ renderPrimitive Quads $ do
+ texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 x y 0.0); col
+ texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 x (y + texHeight) 0.0); col
+ texCoord2f (TexCoord2 texCoordX 0); vertex3f (Vertex3 (x + texWidth) (y + texHeight) 0.0); col
+ texCoord2f (TexCoord2 texCoordX 1); vertex3f (Vertex3 (x + texWidth) y 0.0); col
+
+ texture Texture2D $= Disabled
+
+data Rectangle = Rectangle
+ {
+ rectX :: GLdouble,
+ rectY :: GLdouble,
+ rectWidth :: GLdouble,
+ rectHeight :: GLdouble
+ } deriving (Show, Eq)
+
-- return a list of four vertices for a rectangle, given position and size
-vertexRect :: (GL.GLdouble,GL.GLdouble) -> GL.GLdouble -> GL.GLdouble
- -> [GL.Vertex2 GL.GLdouble]
+vertexRect :: (GLdouble,GLdouble) -> GLdouble -> GLdouble
+ -> [Vertex2 GLdouble]
vertexRect (x,y) width height =
- [(GL.Vertex2 (x-w) (y+h))
- , (GL.Vertex2 (x-w) (y-h))
- , (GL.Vertex2 (x+w) (y-h))
- , (GL.Vertex2 (x+w) (y+h))]
+ [(Vertex2 (x-w) (y+h))
+ , (Vertex2 (x-w) (y-h))
+ , (Vertex2 (x+w) (y-h))
+ , (Vertex2 (x+w) (y+h))]
where
w = width / 2
h = height / 2
- --gld z = z :: GL.GLdouble
-- same thing with different point format
-vertexRect' :: GL.Position -> GL.GLdouble -> GL.GLdouble -> [GL.Vertex2 GL.GLdouble]
-vertexRect' (GL.Position x y) w h = vertexRect (conv x,conv y) w h
+vertexRect' :: Position -> GLdouble -> GLdouble -> [Vertex2 GLdouble]
+vertexRect' (Position x y) w h = vertexRect (conv x,conv y) w h
-- generalize an Integral
conv :: (Integral a, Num b) => a -> b
View
Sorry, something went wrong. Reload?
Sorry, we cannot display this file.
Sorry, this file is invalid so it cannot be displayed.

0 comments on commit 1e14306

Please sign in to comment.