Hi,
last few days I spent making remake of glxgears. Nothing
fancy, I just wanted easily configurable gears. The current
performance is only about 70% of glxgears.
But I have a problem with shading. Whatever I have been trying,
I still don't understand how the shading can be activated. I have
light, I have color, but not even Flat shading.
Please can you give me a hand?
Thanks,
Martin
PS: I didn't find any attachment size policy for this list, so I hope
that the attachment is small enough.
-----------------------------------------------------------------------------
--
-- Copyright (c) 2008 Martin 'Trin' Kudlvasr
-- All rights reserved.
--
-- Redistribution and use in sourse and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by Martin Kudlvasr. The name of Martin Kudlvasr
-- may not be used to endorse or promote products derived from this
-- software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED 'AS IS' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
--
-------------------------------------------------------------------------------
-----------------------------------------------------------------------------
--
-- Author -
-- Martin 'Trin' Kudlvasr
-- www.trinpad.eu
-- November, 2008
module Gear where
import Graphics.Rendering.OpenGL
import Data.List
data ToothDim = ToothDim { top :: GLfloat, -- width at the top of a tooth
bottom :: GLfloat, -- width at the base of a tooth
height :: GLfloat } -- height of the tooth
data Gear = Gear { bottomRadius, -- from center to tooth bottom corner
topRadius, -- from center to tooth top corner
bottomAngle, -- angle that tooth bottom line takes
topAngle, -- angle that tooth top line takes
betweenAngle, -- angle between top and bottom tooth line
innerRadius, -- inner circle of gear
thickness :: GLfloat, -- z axis thickness
gColor :: Color4 GLfloat
}
-- angles of gear contour points
angles gear = 0 : takeWhile (<2*pi) [ sum $ take i as | i <- [1..] ] ++ [0]
where
as = cycle $ map (\f -> f gear) [ bottomAngle, betweenAngle, topAngle, betweenAngle ]
-- angle of 1 phase
toothAngle gear = sum $ map (\f -> f gear) [bottomAngle, betweenAngle, topAngle, betweenAngle]
-- radius depends on teeth amount and dimensions. This is error with which radius is calculated
_MAX_ERROR = 0.001
calculateGearRadius toothDim teethCount =
calculateGearRadius' toothDim teethCount 1000 0.5
calculateGearRadius' toothDim targetTeeth tmpRadius factor =
case countTeeth top bottom newRadius of
tmpTeeth
| tmpTeeth > targetTeeth + _MAX_ERROR -> calculateGearRadius' toothDim targetTeeth newRadius factor
| tmpTeeth < targetTeeth -> calculateGearRadius' toothDim targetTeeth tmpRadius (factor/2)
| otherwise -> newRadius
where
ToothDim top bottom height = toothDim
newRadius = tmpRadius*(1-factor)
countTeeth top bottom radius =
pi / ( asin (top / (2*radius)) + asin(bottom / (2*radius) ) )
newTeethCountGear toothDim teethCount innerR thickness c =
Gear bottomR topR bottomA topA betweenA innerR thickness c
where
bottomR = calculateGearRadius toothDim teethCount
topR = sqrt ( (bottomR*bottomR) - (bottom*bottom/4) ) + height
ToothDim top bottom height = toothDim
bottomA = 2 * asin (top / (2*bottomR))
topA = 2 * asin (top / (2*(bottomR+height)))
totalA = 2 * pi / teethCount
betweenA= (totalA - topA - bottomA) / 2
newGear = newTeethCountGear
newMinimumRadiusGear toothDim minRadius innerR thickness c =
newGear toothDim (fromIntegral teethCount + 1) innerR thickness c
where
ToothDim top bottom height = toothDim
toothA = 2 * ( asin (top / (2*minRadius)) + asin (bottom / (2*minRadius)) )
(teethCount, _) = properFraction ( 2 * pi / toothA )
gearContourPoints gear =
zipWith3 zipF [0,1..] inCircle outCircle
where
zipF i inP outP | i `mod` 4 == 0 = inP
| i `mod` 4 == 1 = inP
| otherwise = outP
inCircle = angleCirclePoints as $ bottomRadius gear
outCircle = angleCirclePoints as $ topRadius gear
as = angles gear
gearFacePoints gear =
concat $ zipWith (\x y -> [x,y]) contourPs innerPs
where
contourPs = gearContourPoints gear
innerPs = angleCirclePoints (angles gear) (innerRadius gear)
setZ ps newZ =
map (\(x,y,z) -> (x,y,newZ)) ps
gearTeethPoints gear =
concat $ zipWith (\x y -> [x,y]) (setZ contourPs (-0.5)) (setZ contourPs 0.5)
where
contourPs = gearContourPoints gear
gearInsidePoints gear =
concat $ zipWith (\x y -> [x,y]) (setZ contourPs (-0.5)) (setZ contourPs 0.5)
where
contourPs = angleCirclePoints (angles gear) (innerRadius gear)
angleCirclePoints angles radius =
map (\a -> point a radius) angles
where
point a r = ( r*(cos a) , r*(sin a), 0 )
-- general rendering
makeVertexes = mapM_ ( \(x,y,z) -> vertex $ Vertex3 x y z)
renderQuads ps = renderPrimitive QuadStrip $ makeVertexes ps
fromRad r = 360 * r / 2 / pi
uncurry3 f (x,y,z) = f x y z
drawGear g preparedStrips = do
preservingMatrix $ do
materialAmbientAndDiffuse FrontAndBack $= gColor g
scale 1 1 (thickness g)
-- renderPrimitive Lines $ makeVertexes $ [(0,0,0), (1,0,0)]
rotate (fromRad $ bottomAngle g * (-0.5)) $ Vector3 0 0 (1::GLfloat)
case preparedStrips of
Just qss -> mapM_ (\qs -> renderPrimitive QuadStrip $ mapM_ vertex qs) qss
Nothing -> do
preservingMatrix $ do
renderQuads $ gearTeethPoints g
renderQuads $ gearInsidePoints g
translate $ Vector3 (0::GLfloat) 0 (-0.5)
renderQuads $ gearFacePoints g
preservingMatrix $ do
translate $ Vector3 0 0 (0.5::GLfloat)
renderQuads $ gearFacePoints g
type Point = (GLfloat, GLfloat, GLfloat)
data PlacedGear = PlacedGear {
gear :: Gear,
pos :: Point,
basePhase :: GLfloat,
direction :: Direction,
quadStrips :: Maybe ([[Vertex3 GLfloat]])
}
-- i have only recently found about DisplayList. Maybe precompilation would be faster.
precomputeQuads pg =
pg { quadStrips = Just $ map (map (uncurry3 Vertex3)) [ teethP, insideP, setZ faceP 0.5, setZ faceP (-0.5) ] }
where
teethP = gearTeethPoints g
insideP = gearInsidePoints g
faceP = gearFacePoints g
g = gear pg
-- direction in which a gear rotates. used for automatic connection of gears
data Direction = ClockWise | CounterClockWise deriving (Eq,Show)
numDirection ClockWise = -1
numDirection CounterClockWise = 1
oppositeDirection ClockWise = CounterClockWise
oppositeDirection CounterClockWise = ClockWise
-- connects gear2 to gear1. Does not solve the distance, only finds out needed phase
-- of gear2
getCorespondingPhase pg1 pg2 =
newPhase
where
(_,newPhase) = properFraction $ (angle2/(toothAngle g2)) + phaseOfTouch + 0.5
(_,phaseOfTouch) = properFraction $ (angle1/(toothAngle g1)) - (basePhase pg1)
angle1 = (2*pi) + atan2 (y2-y1) (x2-x1)
angle2 = (2*pi) + atan2 (y1-y2) (x1-x2)
(x1, y1, _) = pos pg1
(x2, y2, _) = pos pg2
g1 = gear pg1
g2 = gear pg2
rotateGearToCorespond pg1 pg2 =
pg2 { basePhase = getCorespondingPhase pg1 pg2, direction = oppositeDirection $ direction pg1 }
-- places gear2 to minimum distance and sets phase do that teeth fit
connectGear pg1 angle g2 =
rotateGearToCorespond pg1 $ PlacedGear g2 (x2,y2,0) 0 ClockWise Nothing
where
g1 = gear pg1
distance = (topRadius g1) + (bottomRadius g2)
x2 = cos angle * distance + x1
y2 = sin angle * distance + y1
(x1,y1,_) = pos pg1
drawPlacedGear pg phase = do
preservingMatrix $ do
translate $ uncurry3 Vector3 (pos pg)
rotate angle $ Vector3 0 0 (1::GLfloat)
drawGear (gear pg) (quadStrips pg)
where
angle = fromRad $ (dirPhase + basePhase pg) * (toothAngle $ gear pg)
dirPhase = phase * (numDirection $ direction pg)
-----------------------------------------------------------------------------
--
-- Copyright (c) 2008 Martin 'Trin' Kudlvasr
-- All rights reserved.
--
-- Redistribution and use in sourse and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by Martin Kudlvasr. The name of Martin Kudlvasr
-- may not be used to endorse or promote products derived from this
-- software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED 'AS IS' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
--
-------------------------------------------------------------------------------
-----------------------------------------------------------------------------
--
-- Author -
-- Martin 'Trin' Kudlvasr
-- www.trinpad.eu
-- November, 2008
import Gear
import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT as GLUT
import Data.IORef
import Time
-- gears setup
-- gear teeth count is 11,20,9 to show, that my Gear.hs toolbox is well parametrized.
-- just try to change placement of the gears, add some more or change number and shape of teeth
td = ToothDim 0.05 0.10 0.1
g1 = newGear td 11 0.1 0.05 blue
pg1 = PlacedGear g1 (-0.4,0.4,0) 0 ClockWise Nothing
g2 = newGear td 20 0.1 0.1 red
pg2 = connectGear pg1 (-pi/2) g2
g3 = newGear td 9 0.1 0.2 green
pg3 = connectGear pg2 0 g3
red = Color4 0.8 0.1 0.0 (1.0::GLfloat)
green = Color4 0.0 0.8 0.2 (1.0::GLfloat)
blue = Color4 0.2 0.2 1.0 (1.0::GLfloat)
gears = map precomputeQuads [pg1, pg2, pg3]
data GearState = GearState { lastTime :: ClockTime,
gsDirection :: Integer, -- +1 or -1
phase :: GLfloat,
frameCount :: Integer }
main = do
time <- getClockTime
gst <- newIORef $ GearState time 1 0 0
(progName,_) <- getArgsAndInitialize
initialDisplayMode $= [RGBMode, WithDepthBuffer,DoubleBuffered]
createWindow progName
-- lighting
lighting $= Enabled
position (Light 0) $= Vertex4 5.0 5.0 10.0 0.0
light (Light 0) $= Enabled
depthFunc $= Just Less
-- callbacks
displayCallback $= display gst
keyboardMouseCallback $= Just (keyboard gst)
idleCallback $= Just (timeStep gst)
addTimerCallback (floor _FPS_MEASURE_INTERVAL * 1000) (measureFPS gst)
reshapeCallback $= Just reshape
mainLoop
-- reshape and display rotation were copied from Shawn P. Garbett
-- I wanted to be near the glxgears without much work
reshape s@(Size w h) =
do
let r = (fromIntegral h)/(fromIntegral w)
viewport $= (Position 0 0, s)
matrixMode $= Projection
loadIdentity
frustum (-1.0) 1.0 (-r) r 5.0 60.0
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-40.0::GLfloat))
display gst = do
gState <- get gst
clear [ColorBuffer,DepthBuffer]
preservingMatrix $ do
scale 7 7 (7::GLfloat)
rotate 20 $ Vector3 (1.0::GLfloat) 0 0
rotate 30 $ Vector3 0 (1.0::GLfloat) 0
mapM_ (\pg -> drawPlacedGear pg (phase gState)) gears
-- renderPrimitive Lines $ makeVertexes [pos pg1, pos pg2]
-- drawPlacedGear pg3 curPhase
swapBuffers
-- wheels are rotating with constant speed, only FPS varies
-- phase is a unit of rotation measured in angles of 1 tooth
-- phase == 1 means different angles for different gears
_PHASE_PER_SECOND = 5 :: GLfloat
diffSec ct1 ct2 =
fromTimeDiff $ diffClockTimes ct1 ct2
fromTimeDiff td =
(fromInteger . toInteger) (sum [secD, secH, secM, (tdSec td)]) + ((fromInteger . toInteger) (tdPicosec td) * 1e-12)
where
secM = 60 * (tdMin td)
secH = 60 * 60 * (tdHour td)
secD = 24 * 60 * 60 * (tdDay td)
timeStep gst = do
gState <- get gst
time <- getClockTime
diffPhase <- return $ _PHASE_PER_SECOND * (fromInteger $ toInteger $ gsDirection gState) * (diffSec (lastTime gState) time)
gst $= gState { phase = (phase gState) + diffPhase, lastTime = time, frameCount = frameCount gState + 1 }
postRedisplay Nothing
-- FPS measuring is done by counting timeSteps and stoping every 5 seconds to calculate FPS
measureFPS gst = do
gState <- get gst
print $ "FPS: " ++ (show $ (fromInteger $ frameCount gState)/_FPS_MEASURE_INTERVAL)
gst $= gState { frameCount = 0 }
addTimerCallback (floor _FPS_MEASURE_INTERVAL*1000) (measureFPS gst)
_FPS_MEASURE_INTERVAL = 5 :: GLfloat
keyboard phase c _ _ _ = keyboardRot phase c
-- change gear rotation
keyboardRot gst (Char 'r') = do
gState <- get gst
gst $= gState { gsDirection = (gsDirection gState) * (-1) }
keyboardRot gst _ = return ()
_______________________________________________
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe
