Skip to content
Browse files

switched to ortho mode

  • Loading branch information...
1 parent 993e321 commit 5e82feeef371729a6bedc548fb397e9f3f928627 Nik Nyby committed Feb 26, 2010
Showing with 106 additions and 185 deletions.
  1. +19 −21 Bindings.hs
  2. +33 −50 Main.hs
  3. +19 −8 Render.hs
  4. +35 −8 State.hs
  5. +0 −2 TODO
  6. +0 −96 p.hs
View
40 Bindings.hs
@@ -1,38 +1,39 @@
module Bindings (
+ keyboardMouse,
motion,
- passiveMotion,
- processEnv,
) where
import Data.IORef
import Graphics.UI.GLUT
import State
+keyboardMouse _ env key state modifiers pos = do
+ e <- get env
+ print $ sprites e
+ env $= userAction e key state
+
motion :: IORef Env -> Position -> IO ()
motion env pos = do
e <- get env
- --pos $= oglToGlut pos
- print $ sprites e
env $= mouseMotion e pos
-passiveMotion :: IORef Env -> Position -> IO ()
-passiveMotion env pos = do
- e <- get env
- --pos $= oglToGlut pos
- env $= passiveMouseMotion e pos
-processEnv :: Key -> Env -> Env
-processEnv k e = case k of
- (MouseButton LeftButton)
- -> e { sprites = (Square (mousePos $ vars $ e) [] False) : sprites e }
- _ -> e
+userAction :: Env -> Key -> KeyState -> Env
+
+-- place a sprite
+userAction e (MouseButton RightButton) Down =
+ e { sprites = (makeSprite (mousePos $ vars $ e)) : sprites e }
-- start dragging a sprite
---userAction (Env v sprts)
--- (MouseButton LeftButton) _ = Env v $
--- map toggleSticky (filter (isMouseOverSprite v) sprts)
--- ++ filter (not . isMouseOverSprite v) sprts
+userAction e (MouseButton LeftButton) Down =
+ let pos = (mousePos $ vars $ e) in
+ e { sprites =
+ (map toggleSticky (filter (isMouseOverSprite pos) (sprites e))
+ ++ filter (not . isMouseOverSprite pos) (sprites e))
+ }
+
+userAction e _ _ = e
mouseMotion :: Env -> Position -> Env
@@ -44,6 +45,3 @@ mouseMotion (Env v s) pos = Env v{mousePos = pos}
if sticky q
then q{ currentPos = pos }
else q
-
-passiveMouseMotion :: Env -> Position -> Env
-passiveMouseMotion (Env v s) pos = Env v{mousePos = pos} s
View
83 Main.hs
@@ -3,7 +3,6 @@ import Data.IORef
import Graphics.UI.GLUT
import Bindings
-import MetaGL (render)
import Render
import State
@@ -12,46 +11,55 @@ main = do
env <- newIORef initialEnvironment
-- make the GL window
+ initialWindowSize $= Size 640 480
(_,_) <- getArgsAndInitialize
- _ <- initGL
+ initialDisplayMode $= [DoubleBuffered]
+ wnd <- createWindow "mma"
-- callbacks
- displayCallback $= (display env)
+ displayCallback $= (glRunAs2D $ do
+ clearColor $= Color4 1 0 1 1
+ clear [ColorBuffer, DepthBuffer]
+ readIORef env >>= drawWorld
+ flush
+ swapBuffers)
idleCallback $= Just (idle env)
let
moveCursor p = do
(Env v sp) <- readIORef env
+ print p
writeIORef env $ Env v{mousePos = p} sp
+ trans :: Position -> IO Position
+ trans (Position x y) = do
+ (_, Size _ h) <- get viewport
+ return ( Position x (conv h - y) )
- keyboardMouseCallback $= Just (\k st _ pos ->
- do
- --translate pos >>= moveCursor
- moveCursor pos
- when (st == Down) $
- modifyIORef env $ processEnv k
- postRedisplay Nothing)
-
- motionCallback $= Just (motion env)
+ keyboardMouseCallback $= Just (keyboardMouse wnd env)
- passiveMotionCallback $= Just (passiveMotion env)
+ motionCallback $= Just (\pos ->
+ trans pos >>= motion env)
- -- just distort it on reshaping, to make sure it's at least still all on
- -- the screen
- --reshapeCallback $= Just reshape
+ passiveMotionCallback $= Just (\pos ->
+ trans pos >>= moveCursor >> postRedisplay Nothing)
mainLoop
---__----__----__
--- display callbacks
---__----__----__----_
-display :: IORef Env -> IO ()
-display env = do
- clear [ColorBuffer, DepthBuffer]
- e <- get env
- render $ world e
- swapBuffers
+glRunAs2D :: IO () -> IO ()
+glRunAs2D draw = do
+ matrixMode $= Modelview 0
+ loadIdentity
+
+ --matrixMode $= Projection
+ --loadIdentity
+
+ (_, Size w h) <- get viewport
+
+ --ortho (-50) 50 (-50) (50) (-1000) 1000
+ ortho 0 (conv w) 0 (conv h) (-1000) 1000
+
+ preservingMatrix draw
idle :: IORef Env -> IO ()
idle env = do
@@ -60,34 +68,9 @@ idle env = do
env $= tick time e
postRedisplay Nothing
-reshape :: Size -> IO ()
-reshape s@(Size x y) = do
- viewport $= (Position 0 0 , s)
-
- matrixMode $= Projection
- loadIdentity
- perspective 45 ((fromIntegral x)/(fromIntegral y)) 0.1 100
- matrixMode $= Modelview 0
---__----__----__----__----__----__----__----__----__----__----__----__--
-
-
tick :: Int -> Env -> Env
tick tnew (Env v sprs) = Env v{clock = clock v+elapsed} s
where
s = map idleSprite sprs
elapsed = fromIntegral $ tnew - clock v
idleSprite z = z
-
-initGL :: IO Window
-initGL = do
- initialDisplayMode $= [DoubleBuffered]
- initialWindowSize $= Size 640 480
- window <- createWindow "mma"
- clearColor $= Color4 0 0 0 0
-
- -- make sure the viewport and perspective are correct when
- -- initialWindowSize is ignored
- s <- get screenSize
- reshape s
-
- return window
View
27 Render.hs
@@ -1,14 +1,13 @@
module Render (
- world,
- renderSprite,
+ drawWorld,
) where
+import Graphics.UI.GLUT (($=))
import qualified Graphics.UI.GLUT as GL
-import MetaGL
import State
-world :: Env -> GLC
+{-world :: Env -> GLC
world (Env v s) = serial $ concat $ renderMenu v : map renderSprite s
renderSprite :: Sprite -> [GLC]
@@ -41,9 +40,21 @@ renderButton i = [
vertex 9 5 ]
]
where
- x = [-30,-20 ..]
+ x = [-30,-20 ..]-}
+drawWorld :: Env -> IO ()
+drawWorld e = do
+ GL.currentColor $= GL.Color4 1 0.25 0.5 0
+ mapM_ (drawSprite) $ sprites e
--- distance from camera
-dist :: GL.GLdouble
-dist = (-50)
+drawSprite :: Sprite -> IO ()
+drawSprite s = GL.renderPrimitive GL.Quads $ mapM_ GL.vertex $ spritePoints s
+ where
+ squarePoints :: [GL.Vertex2 GL.GLdouble]
+ squarePoints =
+ [(GL.Vertex2 0 sz)
+ , (GL.Vertex2 0 0)
+ , (GL.Vertex2 sz 0)
+ , (GL.Vertex2 sz sz)]
+
+ sz = size s
View
43 State.hs
@@ -5,8 +5,12 @@ module State (
Vars(..),
Sprite(..),
+ makeSprite,
+ spritePoints,
toggleSticky,
isMouseOverSprite,
+
+ conv,
) where
import qualified Graphics.UI.GLUT as GL
@@ -19,7 +23,7 @@ data Env = Env
initialEnvironment :: Env
initialEnvironment = Env
( Vars 0 (GL.Position 0 0) False False initialMenu )
- [ Square (GL.Position 0 0) [] False ]
+ [ ]
data Vars = Vars
{
@@ -59,20 +63,43 @@ data Sprite =
Square {
currentPos :: GL.Position,
+ size :: GL.GLdouble,
+
-- recorded path
spritePath :: [GL.Position],
-- is it being dragged?
sticky :: Bool
} deriving (Show)
+makeSprite :: GL.Position -> Sprite
+makeSprite pos = Square pos 10 [] False
+
+spritePoints :: Sprite -> [GL.Vertex2 GL.GLdouble]
+spritePoints s =
+ [(GL.Vertex2 (x-sz) (y+sz))
+ , (GL.Vertex2 (x-sz) (y-sz))
+ , (GL.Vertex2 (x+sz) (y-sz))
+ , (GL.Vertex2 (x+sz) (y+sz))]
+ where
+ -- TODO: better way to do this
+ x = conv px; y = conv py
+ (GL.Position px py) = currentPos s
+ sz :: GL.GLdouble
+ sz = 10
+
toggleSticky :: Sprite -> Sprite
-toggleSticky (Square pos path s) = Square pos path $ not s
+toggleSticky (Square pos sz path s) = Square pos sz path $ not s
-isMouseOverSprite :: Vars -> Sprite -> Bool
-isMouseOverSprite v s = (sx >= vx - size) && (sx <= vx + size)
- && (sy >= vy - size) && (sy <= sy + size)
+isMouseOverSprite :: GL.Position -> Sprite -> Bool
+isMouseOverSprite p s = (sx >= px - sz) && (sx <= px + sz)
+ && (sy >= py - sz) && (sy <= py + sz)
where
- (GL.Position sx sy) = currentPos s
- (GL.Position vx vy) = mousePos v
- size = 40
+ sx = conv csx; sy = conv csy; px = conv ppx; py = conv ppy
+ (GL.Position csx csy) = currentPos s
+ (GL.Position ppx ppy) = p
+ sz = size s
+
+-- generalize an Integral
+conv :: (Integral a, Num b) => a -> b
+conv = fromInteger . toInteger
View
2 TODO
@@ -1,2 +0,0 @@
-* Picking: http://gpwiki.org/index.php/OpenGL:Tutorials:Picking
-* Image loading
View
96 p.hs
@@ -1,96 +0,0 @@
-type ScreenBuf = [ [Char] ]
-
-class Shape a where
- -- is this point inside the shape?
- is_in :: a -> Point -> Bool
-
-data Point = Point {
- x :: Int,
- y :: Int
- } deriving (Show)
-
-{-
- - b
- - / \
- - / \
- - / \
- - / \
- - a---------c
- -}
-data Triangle = Triangle {
- tri_pa :: Point,
- tri_pb :: Point,
- tri_pc :: Point
- } deriving (Show)
-
-{-
- - a------------*
- - | |
- - *------------b
- -}
-data Rectangle = Rectangle {
- rect_pa :: Point,
- rect_pb :: Point
- } deriving (Show)
-
-{-
- - _. ~ ._
- - / \
- -
- - ( a )
- - b
- - \ /
- - `~-_-~`
- -}
-data Circle = Circle {
- circ_pa :: Point,
- circ_pb :: Point
- } deriving (Show)
-
-instance Shape Triangle where
- is_in (Triangle (Point x1 y1) (Point x2 y2) (Point x3 y3) )
- (Point a b) = True
-
-instance Shape Rectangle where
- is_in ( Rectangle (Point x1 y1) (Point x2 y2) ) (Point x y) =
- (x >= x1 && x <= x2) && (y >= y1 && y <= y2)
-
-instance Shape Circle where
- is_in ( Circle (Point x1 y1) (Point x2 y2) ) (Point x y) = True
-
--- blit a Shape to screen....
-blit :: Shape a => a -> ScreenBuf
-blit sh = [[ ch sh x y
- | x <- take screen_width [0 ..]]
- | y <- take screen_height [0 ..]]
- where
- ch sh x y = if is_in sh (Point x y) then 'r' else ' '
-
-screen_width = 80
-screen_height = 24
-
--- merge two ScreenBufs
-screen_merge :: ScreenBuf -> ScreenBuf -> ScreenBuf
-screen_merge x y = zipWith max x y
-
--- empty ScreenBuf
-screen_buffer_empty :: ScreenBuf
-screen_buffer_empty = replicate screen_height $ replicate screen_width ' '
-
--- print out screen_buffer
-screen_update :: ScreenBuf -> IO ()
-screen_update s = mapM_ putStrLn s
-
-main :: IO ()
-main = do
- let pa = Point 3 5
- let pb = Point 50 20
- screen_update $ screen_merge (blit (Rectangle pa pb)) (blit (Circle pa pb))
-
-getPt :: String -> IO Point
-getPt s = do
- numberString <- getLine
- let x = read numberString :: Int
- numberString <- getLine
- let y = read numberString :: Int
- return (Point x y)

0 comments on commit 5e82fee

Please sign in to comment.
Something went wrong with that request. Please try again.