Permalink
Browse files

Code cleanup.

- no -Wall errors.
- no HLint complaints.
  • Loading branch information...
1 parent 85ccf27 commit 6b8a0b2836e0472c281b32d72e076deacfe36006 @mlesniak committed Jun 10, 2011
Showing with 54 additions and 36 deletions.
  1. +31 −19 Main.hs
  2. +9 −11 Statistics.hs
  3. +9 −1 TODO
  4. +5 −5 Window.hs
View
50 Main.hs
@@ -47,6 +47,8 @@ main = do
-- The FrameHandler is called for every frame, i.e. fps times per
-- second.
frameHandler = FrameHandler $ do
+ drawHelp
+
-- Handle Drag'n'Drop. I'm pretty sure this is not the best
-- solution, but it works for now.
v <- readMVar drag
@@ -55,7 +57,7 @@ main = do
Just (b,p) -> do
-- Reset velocity. Should we reset to the known velocity
-- before the DnD?
- velocity b $= Vector 0 (0.0)
+ velocity b $= Vector 0 0
position b $= p
-- Draw borders in red.
@@ -76,7 +78,7 @@ main = do
-- Physics-wise, this is the important step in the simulation which
-- recalculates the new positions of our objects.
- step space (1.0 / (fps wc))
+ step space (1.0 / fps wc)
-- Key handling.
, keyHandler = Just $ KeyHandler $ \key state _ ->
@@ -90,7 +92,7 @@ main = do
_ -> return ()
, mouseHandler = Just $ MouseHandler (clickBall space drag)
- , motionHandler = Just $ MotionHandler (moveBall space drag)
+ , motionHandler = Just $ MotionHandler (moveBall drag)
, title = "Ball simulation with Chipmunk in Haskell"
, size = Size 640 480
, fps = 30
@@ -163,42 +165,39 @@ clearSpace space balls = do
-- Drag'n'Drop support --
-moveBall :: Space -> MVar (Maybe (Body, Vector)) -> Position -> IO ()
-moveBall space mv (Position pos) = do
+moveBall :: MVar (Maybe (Body, Vector)) -> Position -> IO ()
+moveBall mv (Position pos) = do
v <- takeMVar mv
case v of
Nothing -> putMVar mv Nothing
- Just (b,_) -> do
- putMVar mv $ Just (b, p2v pos)
+ Just (b,_) -> putMVar mv $ Just (b, p2v pos)
where p2v (x,y) = Vector (unsafeCoerce x) (unsafeCoerce y)
clickBall :: Space -> MVar (Maybe (Body, Vector)) -> MouseButton -> Position
-> IO ()
-clickBall space mv b (Position pos) = do
+clickBall space mv _ (Position pos) = do
v <- takeMVar mv
case v of
- Nothing -> do
- shapes <- spaceQueryList space (p2v pos) (-1) 0
- if null shapes
+ Nothing -> do
+ shs <- spaceQueryList space (p2v pos) (-1) 0
+ if null shs
then putMVar mv Nothing
else do
- let s = head shapes
- b = body s
-
+ let b = body (head shs)
putMVar mv (Just (b, p2v pos))
-- Something is already dragged, user has released the button.
- Just (b,_) -> putMVar mv Nothing
+ Just _ -> putMVar mv Nothing
where p2v (x,y) = Vector (unsafeCoerce x) (unsafeCoerce y)
-- Helper functions --
-- | Draws a circle in the given color with a black border.
circle :: (CpFloat, CpFloat) -> CpFloat -> Color3 GLdouble -> IO ()
circle (x,y) r c = preservingMatrix $ do
- let poly = 24
- ang = \p -> p * 2 * pi / poly
- pos = map (\p -> (x+cos(ang p)*r, y + sin(ang p)*r)) [1,2..poly]
+ let poly = 24
+ ang p = p * 2 * pi / poly
+ pos = map (\p -> (x+cos(ang p)*r, y + sin(ang p)*r)) [1,2..poly]
color c
renderPrimitive Graphics.UI.GLUT.Polygon $
mapM_ (toVertex . conv) pos
@@ -227,9 +226,22 @@ randomColor = do
c2 <- rndC
c3 <- rndC
return (Color3 c1 c2 c3)
- where rndC :: IO (GLdouble)
+ where rndC :: IO GLdouble
rndC = unsafeCoerce `liftM` (randomRIO (0, 1) :: IO Double)
+drawHelp :: IO ()
+drawHelp = do
+ color $ Color3 0 0 (0 :: GLdouble)
+ text (0.9, 0.97) [
+ "Keys:"
+ , "b Spawn 10 balls"
+ , "v Spawn 1 big ball"
+ , "c clear box"
+ , "f Toggle FPS graph"
+ , "Escape Quit"
+ , ""
+ , "Drag'n'Drop possible." ]
+
View
@@ -11,14 +11,11 @@ module Statistics (
, toggleFPS
) where
-import Data.Maybe
import Control.Monad
import Data.IORef
import Graphics.UI.GLUT hiding (position)
-import System.Random (randomRIO)
import Unsafe.Coerce (unsafeCoerce)
import Window
-import Control.Concurrent
data FPS = FPS {
@@ -45,6 +42,7 @@ newFPS = do
-- | Shows the fps (if toggled) in a graph.
--
-- The additional string in add is shown directly after the FPS.
+drawFPS :: FPS -> Maybe String -> IO ()
drawFPS (FPS t s fpss) add = do
-- Should we display the graph at all?
toShow <- readIORef s
@@ -57,35 +55,35 @@ drawFPS (FPS t s fpss) add = do
writeIORef t tcur
runs <- readIORef fpss
let f' = take 59 runs
- writeIORef fpss $ (unsafeCoerce $ 1/tdiff) : f'
+ writeIORef fpss $ unsafeCoerce (1/tdiff) : f'
preservingMatrix $ do
-- Move to upper left corner.
- translate $ Vector3 (0.02 :: GLdouble) (0.89) (0.0)
+ translate $ Vector3 (0.02 :: GLdouble) 0.89 0.0
Graphics.UI.GLUT.scale 0.5 0.1 (0.1 :: GLdouble)
-- Draw black border.
color $ Color3 0 0 (0 :: GLdouble)
renderPrimitive LineLoop $ do
- toVertex (0.0, 1)
- toVertex (1.0, 1)
- toVertex (1.0, 0)
- toVertex (0.0, 0)
+ toVertex (0.0, 1 :: Double)
+ toVertex (1.0, 1 :: Double)
+ toVertex (1.0, 0 :: Double)
+ toVertex (0.0, 0 :: Double)
-- Show values.
values <- readIORef fpss
unless (null values) $ do
let steps = 59.0
dsteps = 1.0 / steps
color $ Color3 1 0 (0 :: GLdouble)
- renderPrimitive LineStrip $ do
+ renderPrimitive LineStrip $
forM_ (zip [1.0,(1.0-dsteps)..0] values) $ \(x,y) -> do
let b = (x, min (y/steps) 0.99)
toVertex b
-- Display textual information
color $ Color3 0 0 (0 :: GLdouble)
- let str = (take 5 $ show (head values)) ++ maybe [] (" " ++) add
+ let str = take 5 $ show (head values) ++ maybe [] (" " ++) add
text (0.04, 0.75) [str]
View
10 TODO
@@ -23,10 +23,18 @@
X move balls around using drag'n'drop
X find the correct object
X move it around as long as the user has it clicked.
- - simple help on-screen
+ - Remove warnings
+ - Run HLint
+ X simple help on-screen
- commit & push
- reddit?
+
+-- Bugs --
+- Since the walls are too thin, balls with large velocity pass through. Make the
+ walls bigger.
+
+
-- Nice to have --
- FPS module
- definable maximum range
View
@@ -211,16 +211,16 @@ drawImage (Image obj path) = do
textureBinding Texture2D $= Just tobj
renderPrimitive Quads $ do
texcoord ( 0, 0)
- toVertex ( 0, 1)
+ toVertex ( 0, 1 :: Double)
texcoord ( 1 , 0)
- toVertex ( 1.3, 1)
+ toVertex ( 1.3, 1 :: Double)
texcoord ( 1 , 1)
- toVertex ( 1.3, 0)
+ toVertex ( 1.3, 0 :: Double)
texcoord ( 0, 1)
- toVertex ( 0, 0)
+ toVertex ( 0, 0 :: Double)
textureBinding Texture2D $= old
where texcoord :: (GLdouble, GLdouble) -> IO ()
texcoord (x,y) = texCoord $ TexCoord2 x y
@@ -235,7 +235,7 @@ text (x,y) ss' = do
-- Handle different window sizes correctly by calculating the space between
-- subsequent lines:
Size _ wh <- get windowSize
- fs <- (*1.5) `liftM` fontHeight Fixed9By15
+ fs <- (*1.0) `liftM` fontHeight Fixed9By15
render (fs / fromIntegral wh) y ss'
where render _ _ [] = return ()
render h y' (s:ss) = do

0 comments on commit 6b8a0b2

Please sign in to comment.