stunts (empty) → 0.1.0
raw patch · 13 files changed
+1859/−0 lines, 13 filesdep +Codec-Image-DevILdep +GLFW-bdep +basesetup-changedbinary-added
Dependencies added: Codec-Image-DevIL, GLFW-b, base, binary, bullet, bytestring, containers, directory, elerea, lambdacube-bullet, lambdacube-engine, mtl, random, vector
Files
- LICENSE +28/−0
- README +32/−0
- Setup.hs +2/−0
- media/newstunts.zip binary
- src/GameData.hs +320/−0
- src/GamePhysics.hs +176/−0
- src/Main.hs +227/−0
- src/Stunts/Color.hs +202/−0
- src/Stunts/Loader.hs +364/−0
- src/Stunts/Track.hs +253/−0
- src/Stunts/Unpack.hs +88/−0
- src/Utils.hs +103/−0
- stunts.cabal +64/−0
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2011, Csaba Hruska+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of its contributors may be+ used to endorse or promote products derived from this software without+ specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,32 @@+Stunts example for LambdaCube+=============================++Original game: http://downloads.pigsgrame.de/STUNTS11.ZIP++Copy the above zip file wherever the program asks you to.++You can compile a version that looks for resources in the current+directory with --flags=portable.++Command line arguments (both optional):++--car=n - select car (n should be between 0 and 10)+--track=<trackfile> - track to ride on++Tracks readily available in the original game:++ BERNIES.TRK+ CHERRIS.TRK+ DEFAULT.TRK+ HELENS.TRK+ JOES.TRK+ SKIDS.TRK++In-game controls:++W/A/S/D - control car+R - rescue car+1-3 - switch camera (1 - close, 2 - distant, 3 - user)+arrows+mouse - control user camera+right shift - faster movement with user camera+P - start/stop screen capture (only if installed with --flags=capture)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ media/newstunts.zip view
binary file changed (absent → 2226 bytes)
+ src/GameData.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE NoMonomorphismRestriction, ParallelListComp #-}++module GameData where++import Control.Applicative+import Control.Arrow+import Control.Monad+import Control.Monad.Trans+import Data.Binary.Get as B+import Data.Bits+import qualified Data.IntMap as IM+import Data.List+import qualified Data.Map as M+import Data.Maybe+import Data.Ord+import Graphics.LambdaCube as LC+import Graphics.LambdaCube.Material as LC hiding (Material)+import Graphics.LambdaCube.Pass as LC+import Graphics.LambdaCube.Technique as LC+import Graphics.LambdaCube.World as LC+import Stunts.Color+import Stunts.Loader+import Stunts.Track+import Stunts.Unpack+import System.Random+import qualified Data.Vector as V++{-+TODO: load all resources:+ - build resource Map+ - model Map+ - car Map+ - opponent Map++data StuntsData+ = StuntsData+ { terrainMap :: ModelMap+ , trackMap :: ModelMap+ }+-}++cube :: VMesh+cube = VMesh [sm] $ Just vvb+ where+ quads = [[6,2,3,7]+ ,[5,1,0,4]+ ,[7,3,1,5]+ ,[4,0,2,6]+ ,[3,2,0,1]+ ,[6,7,5,4]]+ mkVertex :: Int -> Vec3+ mkVertex n = Vec3 x y z+ where+ x = if testBit n 2 then 1 else -1+ y = if testBit n 1 then 1 else -1+ z = if testBit n 0 then 1 else -1+ vvb = V.fromList [VVD_POSITION $ V.fromList [mkVertex i | i <- [0..7]]]+ vib = V.fromList $ concat [[a,b,c,c,d,a] | [a,b,c,d] <- quads]+ sm = VSubMesh "SimpleMaterial" OT_TRIANGLE_LIST Nothing $ Just vib++wheelBase :: Int -> Model+wheelBase n = Model vl pl+ where+ fi = 2 * pi / fromIntegral n+ mkVertex :: FloatType -> FloatType -> Int -> (Float,Float,Float)+ mkVertex x r i = (x,r*sin j,r*cos j)+ where+ j = fi * fromIntegral i+ vl = [mkVertex z r i | r <- [1,0.55], z <- [-0.5,0.5], i <- [0..n-1]]+ pl = side ++ tread+ side = [Primitive Polygon True (col == 40) [col] (rev [n0..n0+n-1]) |+ (n0,rev,col) <- [(0,id,39),(n,reverse,39),(n*2,id,40),(n*3,reverse,40)]]+ tread = [Primitive Polygon True False [38] [i,i+n,i'+n,i'] |+ i <- [0..n-1], let i' = if i == n-1 then 0 else i+1]++{-+ - generate normal for each vertex+ - group faces by material+ - map stunts material to LC material+ - generate extra vertex attributes if necessary (e.g. texcoord)+ - make face triangulation+-}+toVMesh :: Model -> VMesh+toVMesh md = VMesh ({- debugNormals: -} sml) $ Just vvb+ where+ groupToSubMesh prs@(pr:_) = case prType pr of+ Particle -> vsm OT_POINT_LIST (vib id)+ Line -> vsm OT_LINE_LIST (vib id)+ Polygon -> vsm OT_TRIANGLE_LIST (vib triangulate)+ _ -> vsm OT_TRIANGLE_LIST V.empty+ where+ --mat = "StuntsMaterial" ++ (if True {- prTwoSided pr -} then "TwoSided" else "") ++ show (head (prMaterials pr))+ mid = head (prMaterials pr)+ mat = "StuntsMaterial" ++ (if mid `elem` [16,101,102,103,104,105] then "InverseBiased" else if prZBias pr then "Biased" else "") ++ show mid+ vsm pty = VSubMesh mat pty Nothing . Just+ vib fun = V.fromList $ fun . prIndices =<< prs+ triangulate (v0:vs@(_:_)) = concat [[v0,v1,v2] | v1 <- tail vs | v2 <- vs]+ triangulate _ = []++ f a = realToFrac a+ v = V.fromList [Vec3 (f x) (f y) (f z) | (x,y,z) <- mdVertices md]+ vvb = if V.length n == V.length v+ then V.fromList [VVD_POSITION v, VVD_NORMAL n]+ else error $ "not matching sizes: " ++ show (V.length n) ++ " " ++ show (V.length v)+ sml = map groupToSubMesh $ groupSetBy (comparing (prMaterials &&& prType)) $ mdPrimitives md++ -- Temp code:+ genNormal (a:b:c:_) = normalize $ (vc &- va) &^ (vb &- va)+ where+ va = v V.! a+ vb = v V.! b+ vc = v V.! c+ genNormal _ = zero+ -- normal calculation+ nf = V.fromList [genNormal (prIndices f) | f <- mdPrimitives md]+ n = V.backpermute nf $ V.fromList [ix | (ix,pr) <- zip [0..] (mdPrimitives md), _ <- prIndices pr]+ --n = V.fromList $ IM.elems $ nM `IM.union` (IM.fromList [(i,zero) | i <- [0..V.length v-1]])+ --nM = IM.fromList [(fst $ head g,avg g) | g <- groupSetBy (comparing fst) [(i,fi) | (fi,fc) <- zip [0..] $ mdPrimitives md, i <- prIndices fc]]+ --avg a = foldl' (\r (_,b) -> r &+ (nf V.! b)) zero a &* (1 / (fromIntegral $ length a))+ -- Normal debugging+ --debugNormals = VSubMesh "StuntsMaterial60" OT_LINE_LIST dv di+ --dv = Just $ V.fromList [VVD_POSITION $ v V.++ V.zipWith (\a b -> a &+ (b &* 40)) v n]+ --vl = V.length v+ --di = Just $ V.fromList $ concat [[i,i+vl] | i <- [0..vl-1]]++separateFaces :: Model -> Model+separateFaces md = Model { mdVertices = vs', mdPrimitives = prs' }+ where+ vs = V.fromList (mdVertices md)+ vs' = [vs V.! ix | pr <- mdPrimitives md, ix <- prIndices pr]+ prs' = go 0 (mdPrimitives md)+ where+ go _ [] = []+ go n (pr:prs) = n' `seq` pr' : go n' prs+ where+ l = length (prIndices pr)+ n' = n+l+ pr' = pr { prIndices = take l [n..] }++prepareMaterials :: RenderSystem r vb ib q t p lp => String -> LCM (World r vb ib q t p lp) e ()+prepareMaterials base = do+ mat <- loadMaterialResources =<< fromJust <$> getLoadedMaterial base+ let Just (tch:tchs) = mtSupportedTechniques mat+ pass:passes = tchPasses tch++ forM_ (IM.toList materialMap) $ \(i, Material pattern rgb _) -> do+ let name' = base ++ show i+ mat' = mat { mtName = name', mtSupportedTechniques = Just (tch':tchs) }+ tch' = tch { tchPasses = pass':passes }+ pass' = pass { psAmbient = (r,g,b,1), psDiffuse = (d,0,0,1) }+ r = fromIntegral (rgb `shiftR` 16) / 255+ g = fromIntegral ((rgb `shiftR` 8) .&. 0xff) / 255+ b = fromIntegral (rgb .&. 0xff) / 255+ d = case pattern of+ Grate -> 0.5+ Transparent -> 0+ _ -> 1+ updateResource $ \rl -> rl { rlMaterialMap = M.insert name' mat' (rlMaterialMap rl) }++readStuntsData :: RenderSystem r vb ib q t p lp => Int -> String -> LCM (World r vb ib q t p lp) e (VMesh, [(Vec3,Float,Float,VMesh)], VMesh, VMesh,(FloatType,Vec3),Car)+readStuntsData carNum trkFile = do+ prepareMaterials "StuntsMaterial"+ prepareMaterials "StuntsMaterialBiased"+ prepareMaterials "StuntsMaterialInverseBiased"+ --prepareMaterials "StuntsMaterialTwoSided"++ let loadRes n = readResources <$> unpackResource <$> LC.readFile n+ loadVMesh n = M.map (toVMesh . separateFaces . runGet getModel) <$> loadRes n+ loadCarVMesh n = M.mapWithKey (\k -> toVMesh . separateFaces . fixOp k . runGet getModel) <$> loadRes n+ where+ fixOp k = if k == "car0" then addBottom . fixLambo else id++ -- Remove stray faces from the bottom of the Lamborghini model+ fixLambo md = if n /= "STCOUN.P3S" then md else md'+ where+ miny = minimum [y | (_,y,_) <- mdVertices md]+ ixs = findIndices (\(_,y,_) -> y == miny) (mdVertices md)+ md' = md { mdPrimitives =+ [pr | pr <- mdPrimitives md,+ prType pr /= Polygon || null (intersect ixs (prIndices pr))]+ }++ -- Add some faces to fill the hole on the bottom of the car models+ addBottom md = md { mdPrimitives = newFaces ++ mdPrimitives md }+ where+ cutHeight = case n of+ "STJAGU.P3S" -> 160+ "STLM02.P3S" -> 320+ "STLANC.P3S" -> 250+ "STP962.P3S" -> 180+ "STPMIN.P3S" -> 100+ _ -> 270++ vs = V.fromList (mdVertices md)+ vec i = let (x,y,z) = vs V.! i in Vec3 x y z++ edges = [e | Primitive { prType = Polygon, prIndices = ixs } <- mdPrimitives md,+ all ((0 <=) . _1 . vec) ixs, e <- zip ixs (last ixs : ixs)]++ uniqueEdges = go edges+ where+ go [] = []+ go ((i1,i2):es) = case findIndex sameEdge es of+ Just _ -> go (filter (not . sameEdge) es)+ Nothing -> (i1,i2) : go es+ where+ sameEdge (i1',i2') = (i1,i2) == (i1',i2') || (i2,i1) == (i1',i2')++ newFaces = [Primitive Polygon False False [57] ixs |+ (i1,i2) <- uniqueEdges,+ let (x1,y1,z1) = vs V.! i1,+ let (x2,y2,z2) = vs V.! i2,+ y1 < cutHeight || y2 < cutHeight,+ z1 >= z2,+ i1' <- V.toList $ V.findIndices (==(-x1,y1,z1)) vs,+ i2' <- V.toList $ V.findIndices (==(-x2,y2,z2)) vs,+ let ixs = [i1,i2,i2',i1'],+ isNewFace ixs]++ isNewFace (i1:i2:i3:_) = (_2 v < 40 && abs (n &. Vec3 0 1 0) > 0.999) || all notOverlapping ps+ where+ notOverlapping (n', v') = abs (n &. n') < 0.999 || abs (n &. normalize (v' &- v)) > 0.001+ (n, v) = plane i1 i2 i3+ ps = [plane i1 i2 i3 | Primitive { prType = Polygon, prIndices = i1:i2:i3:_ } <- mdPrimitives md]+ plane i1 i2 i3 = (normalize ((v2 &- v1) &^ (v3 &- v1)), v1)+ where+ v1 = vec i1+ v2 = vec i2+ v3 = vec i3+ scaleFactor = 0.3048 * 205 / 1024+ car0ScaleFactor = scaleFactor / 20+ loadCarWheels n = do+ m <- M.map (runGet getModel) <$> loadRes n+ -- wheel pos, wheel width, wheel radius+ let wheel vl [p1,p2,p3,p4,p5,p6] = ((v p1 + v p4) &* (0.5 * car0ScaleFactor),car0ScaleFactor * (len $ v p1 - v p4),car0ScaleFactor * (len $ v p2 - v p1))+ where+ v i = let (a,b,c) = vl !! i in Vec3 a b c+ return [wheel vl $ prIndices p | let Model vl pl = m M.! "car0", p <- pl, prType p == Wheel]++ loadCar n = do+ vmesh <- loadCarVMesh $ "ST" ++ n ++ ".P3S"+ carRes <- loadRes $ "CAR" ++ n ++ ".RES"+ wheels <- loadCarWheels $ "ST" ++ n ++ ".P3S"+ return $ (vmesh,runGet getCar $ carRes M.! "simd",wheels)++ game1Map <- loadVMesh "GAME1.P3S"+ game2Map <- loadVMesh "GAME2.P3S"+ cars <- mapM loadCar ["ANSX","COUN","JAGU","LM02","PC04","VETT","AUDI","FGTO","LANC","P962","PMIN"]++ (terrainItems,trackItems) <- readTrack <$> LC.readFile' trkFile++ let modelIdToMesh ("GAME1.P3S",n) = game1Map M.! n+ modelIdToMesh ("GAME2.P3S",n) = game2Map M.! n+ modelIdToMesh (n,_) = error $ "Unknown resource file: " ++ n+ f (a,b,c) = (map modelIdToMesh a, map modelIdToMesh b,c)++ terrainMap = IM.map f terrainModelMap+ trackMap = IM.map f trackModelMap++ edgeSize = 1024 :: FloatType+ hillHeight = 450 :: FloatType+ toVec3 x y e = Vec3 (edgeSize * fromIntegral x) (if e then hillHeight else 0) (edgeSize * fromIntegral y)+ toVec3' i x y e = Vec3 (edgeSize * x') (1 + if e then hillHeight else 0) (edgeSize * y')+ where+ f = fromIntegral :: Int -> FloatType+ (iw,ih) = trackModelSizeMap IM.! i+ x' = f x + (f iw - 1) * 0.5+ y' = f y + (f ih - 1) * 0.5+ toU o = rotU (Vec3 0 1 0) $ realToFrac o++ toProj4 :: Float -> Int -> Int -> Bool -> Proj4+ toProj4 o x y e = (orthogonal $ rightOrthoU $ toU o) .*. translation (toVec3 x y e) .*. scalingUniformProj4 scaleFactor++ toProj4' :: Float -> Int -> Int -> Int -> Bool -> Proj4+ toProj4' o i x y e = (orthogonal $ rightOrthoU $ toU o) .*. translation (toVec3' i x y e) .*. scalingUniformProj4 scaleFactor++ terrain = [(toProj4 o x y e,m) | (i,x,y,e) <- terrainItems, let (ml,_,o) = terrainMap IM.! i, m <- ml] -- U Vec3 VMesh+ track = [(toProj4' o i x y e,m) | (i,x,y,e) <- trackItems, let (ml,_,o) = trackMap IM.! i, m <- ml] -- U Vec3 VMesh++ startOrientation (c,x,y,e)+ | elem c [0x01, 0x86, 0x93] = Just (pi,toVec3' c x y e &* scaleFactor) -- North+ | elem c [0xB3, 0x87, 0x94] = Just (0,toVec3' c x y e &* scaleFactor) -- South+ | elem c [0xB4, 0x88, 0x95] = Just (pi/2,toVec3' c x y e &* scaleFactor) -- East+ | elem c [0xB5, 0x89, 0x96] = Just (-pi/2,toVec3' c x y e &* scaleFactor) -- West+ | otherwise = Nothing+ startPos = head [i | Just i <- map startOrientation trackItems]++ --carsMesh0 = [(toProj4 0 i 2 True,m M.! "car0") | (i,(m,_)) <- zip [0..] cars]+ --carsMesh1 = [(toProj4 0 i 3 True,m M.! "car1") | (i,(m,_)) <- zip [0..] cars]++ fenc = game1Map M.! "fenc"+ cfen = game1Map M.! "cfen"+ fence = [(toProj4 o x y False, fenc) | x <- [1..28], (o,y) <- [(0,0),(pi,29)]] +++ [(toProj4 o x y False, fenc) | y <- [1..28], (o,x) <- [(pi/2,0),(-pi/2,29)]] +++ [(toProj4 o x y False, cfen) | (o,x,y) <- [(pi/2,0,0), (0,29,0), (-pi/2,29,29), (pi,0,29)]]++ clouds <- liftIO $ replicateM 70 $ do+ let getCloudMesh n = game2Map M.! ("cld" ++ show (1 + n `mod` 3 :: Int))+ getCoord a d = (a', c sin, c cos)+ where+ a' = a*2*pi+ c t = ((50+200*d)*t a'+15)*edgeSize*scaleFactor+ m <- getCloudMesh <$> randomIO+ (a,x,z) <- getCoord <$> randomIO <*> randomIO+ y <- randomIO+ return (scalingUniformProj4 (y*0.4+0.3) .*. rotMatrixProj4 a (Vec3 0 1 0) .*. translation (Vec3 x (y*1500+600) z), m)+ {-+ - read car sim data+ - collect these data:+ - wheel sizes+ - wheel position+ -}+ let (carModel,carSim,carWheels) = cars !! (carNum `mod` 11)+ return $ (mkVMesh' [(scalingUniformProj4 (1/20) .*. toProj4 pi 0 0 False,carModel M.! "car0")],+ [(p,w,r,mkVMesh' [(scaling $ Vec3 w r r,toVMesh $ separateFaces $ wheelBase 16)]) | (p,w,r) <- carWheels],+ mkVMesh' (terrain ++ clouds ++ fence),+ mkVMesh' track,+ startPos,+ carSim+ )
+ src/GamePhysics.hs view
@@ -0,0 +1,176 @@+module GamePhysics where++import Control.Monad+import Graphics.LambdaCube+import Graphics.LambdaCube.Bullet+import Physics.Bullet.Raw+import Physics.Bullet.Raw.Class+import Physics.Bullet.Raw.Types+import Physics.Bullet.Raw.Utils++{-+ enum DebugDrawModes+ {+ DBG_NoDebug=0,+ DBG_DrawWireframe = 1,+ DBG_DrawAabb=2,+ DBG_DrawFeaturesText=4,+ DBG_DrawContactPoints=8,+ DBG_NoDeactivation=16,+ DBG_NoHelpText = 32,+ DBG_DrawText=64,+ DBG_ProfileTimings = 128,+ DBG_EnableSatComparison = 256,+ DBG_DisableBulletLCP = 512,+ DBG_EnableCCD = 1024,+ DBG_DrawConstraints = (1 << 11),+ DBG_DrawConstraintLimits = (1 << 12),+ DBG_FastWireframe = (1<<13),+ DBG_MAX_DEBUG_DRAW_MODE+ };+-}+mkPhysicsWorld :: IO BtDiscreteDynamicsWorld+--mkPhysicsWorld :: IO BtContinuousDynamicsWorld+mkPhysicsWorld = do+ -- create physics world+ --dynamicsWorld <- simpleBtContinuousDynamicsWorldM+ dynamicsWorld <- simpleBtDiscreteDynamicsWorldM++ -- setup debug drawer+ debugDrawer <- btGLDebugDrawer+ btIDebugDraw_setDebugMode debugDrawer (1+4+64)+ btCollisionWorld_setDebugDrawer dynamicsWorld debugDrawer+ return dynamicsWorld++addStaticPlane :: BtDynamicsWorldClass bc => bc -> Vec3 -> FloatType -> FloatType -> FloatType -> IO ()+addStaticPlane dynamicsWorld (Vec3 x y z) dist friction restitution = do+ shape <- btStaticPlaneShape (Vector3 x y z) dist+ motionState <- btDefaultMotionState idTransform idTransform+ body <- btRigidBody1 0 motionState shape nullVector3+ --btCollisionObject_setFriction body friction+ --btCollisionObject_setRestitution body restitution+ btDynamicsWorld_addRigidBody dynamicsWorld body++addStaticShape :: BtDynamicsWorldClass bc => bc -> VMesh -> FloatType -> FloatType -> IO ()+addStaticShape dynamicsWorld mesh friction restitution = do+ shape <- mkStaticTriangleMeshShapeM mesh+ motionState <- btDefaultMotionState idTransform idTransform+ body <- btRigidBody1 0 motionState shape nullVector3+ --btCollisionObject_setFriction body friction+ --btCollisionObject_setRestitution body restitution+ btDynamicsWorld_addRigidBody dynamicsWorld body++addCar :: BtDynamicsWorldClass bc => bc -> VMesh -> [(Vec3,Float,Float,VMesh)] -> Proj4 -> IO BtRaycastVehicle+addCar dynamicsWorld carChassisMesh wheels transform = do+ carChassisShape <- mkConvexTriangleMeshShapeM carChassisMesh+ (_carMotionState,carChassisBody,carVehicle) <- mkVehicle dynamicsWorld carChassisShape 800 wheels+ btRigidBody_proceedToTransform carChassisBody $ proj4ToTransform transform+ return carVehicle++updateCar :: BtRaycastVehicleClass bc => bc -> IO [Proj4]+updateCar carVehicle = forM [0..3] $ \i -> do+ btRaycastVehicle_updateWheelTransform carVehicle i True+ wi <- btRaycastVehicle_getWheelInfo carVehicle i+ wt <- btWheelInfo_m_worldTransform_get wi+ return $ transformToProj4 wt+ --s <- btRaycastVehicle_getCurrentSpeedKmHour carVehicle+ --putStrLn $ "car speed: " ++ show s++steerCar :: BtRaycastVehicleClass bc => Float -> bc -> [Bool] -> IO ()+steerCar dt carVehicle [left,up,down,right,restore] = do+ when restore $ do+ carBody <- btRaycastVehicle_getRigidBody carVehicle+ btRigidBody_applyTorque carBody (Vector3 10000 0 10000)+ return ()++ let (gEngineForce, gBrakingForce) = case (up,down) of+ (False,True) -> (0,dt*500*120)+ (True,False) -> (dt*1500*120,0)+ _ -> (0,0)+ btRaycastVehicle_applyEngineForce carVehicle gEngineForce 2+ btRaycastVehicle_setBrake carVehicle gBrakingForce 2++ btRaycastVehicle_applyEngineForce carVehicle gEngineForce 3+ btRaycastVehicle_setBrake carVehicle gBrakingForce 3++ steering <- btRaycastVehicle_getSteeringValue carVehicle 0+ let fi = 1.2 * dt+ steering' = case (left,right) of+ (False,True) -> max (-0.45) (steering-fi)+ (True,False) -> min 0.45 (steering+fi)+ _ -> case steering > 0 of+ True -> max 0 (steering-fi)+ False -> min 0 (steering+fi)+ btRaycastVehicle_setSteeringValue carVehicle steering' 0+ btRaycastVehicle_setSteeringValue carVehicle steering' 1++rigidBodyProj4 :: BtRigidBody -> IO Proj4+rigidBodyProj4 rigidBody = do+ motionState <- btRigidBody_getMotionState rigidBody+ t <- btMotionState_getWorldTransform motionState idTransform+ return $ transformToProj4 t++proj4ToTransform :: Proj4 -> Transform+proj4ToTransform p = Transform (Matrix3x3 (Vector3 a1 a2 a3) (Vector3 b1 b2 b3) (Vector3 c1 c2 c3)) (Vector3 p1 p2 p3)+ where+ Mat4 (Vec4 a1 b1 c1 _) (Vec4 a2 b2 c2 _) (Vec4 a3 b3 c3 _) (Vec4 p1 p2 p3 _) = fromProjective p++transformToProj4 :: Transform -> Proj4+transformToProj4 t = toProjectiveUnsafe $ Mat4 (Vec4 a1 b1 c1 0) (Vec4 a2 b2 c2 0) (Vec4 a3 b3 c3 0) (Vec4 p1 p2 p3 1)+ where+ Transform (Matrix3x3 (Vector3 a1 a2 a3) (Vector3 b1 b2 b3) (Vector3 c1 c2 c3)) (Vector3 p1 p2 p3) = t++mkVehicle :: (BtDynamicsWorldClass bc, BtCollisionShapeClass p1) => bc -> p1 -> Float -> [(Vec3,Float,Float,VMesh)] -> IO (BtDefaultMotionState, BtRigidBody, BtRaycastVehicle)+mkVehicle dw chassisShape mass wheels = do+ compound <- btCompoundShape True+ let localTrans = Transform idMatrix3x3 $ Vector3 0 0 0+ btCompoundShape_addChildShape compound localTrans chassisShape++ (carMotionSate,carChassis) <- localCreateRigidBodyM dw mass idTransform compound+ --(carMotionSate,carChassis) <- localCreateRigidBody dw 8 (Transform idMatrix3x3 $ Vector3 480.0 20.3 (-520.0)) compound+ --wheelShape <- btCylinderShapeX $ Vector3 wheelWidth wheelRadius wheelRadius+ btRigidBody_setCenterOfMassTransform carChassis idTransform+ btRigidBody_setLinearVelocity carChassis nullVector3+ btRigidBody_setAngularVelocity carChassis nullVector3++ tuning <- btRaycastVehicle_btVehicleTuning+ vehicleRayCaster <- btDefaultVehicleRaycaster dw+ vehicle <- btRaycastVehicle tuning carChassis vehicleRayCaster+ btCollisionObject_setActivationState carChassis 4 -- #define DISABLE_DEACTIVATION 4+ btDynamicsWorld_addVehicle dw vehicle++ btRaycastVehicle_setCoordinateSystem vehicle 0 1 2+ let wheelDirectionCS0 = Vector3 0 (-1) 0+ wheelAxleCS = Vector3 (-1) 0 0+ suspensionRestLength = 0.1+ suspensionStiffness = 40+ suspensionDamping = 2.3+ suspensionCompression = 1.4+ rollInfluence = 0.2+ wheelFriction = 3+ + m_maxSuspensionTravelCm = 20+ m_maxSuspensionForce = 6000++ forM_ wheels $ \(Vec3 x y z,w,r,_) -> btRaycastVehicle_addWheel vehicle (Vector3 x y (-z)) wheelDirectionCS0 wheelAxleCS suspensionRestLength r tuning True+ numWheels <- btRaycastVehicle_getNumWheels vehicle+ forM_ [0..numWheels-1] $ \i -> do+ wheel <- btRaycastVehicle_getWheelInfo vehicle i+ when (i < 2) $ btWheelInfo_m_bIsFrontWheel_set wheel False+ btWheelInfo_m_suspensionStiffness_set wheel suspensionStiffness+ btWheelInfo_m_wheelsDampingRelaxation_set wheel suspensionDamping+ btWheelInfo_m_wheelsDampingCompression_set wheel suspensionCompression+ btWheelInfo_m_frictionSlip_set wheel wheelFriction+ btWheelInfo_m_rollInfluence_set wheel rollInfluence+ btWheelInfo_m_maxSuspensionTravelCm_set wheel m_maxSuspensionTravelCm+ btWheelInfo_m_maxSuspensionForce_set wheel m_maxSuspensionForce+ {-+ forM_ [0..numWheels-1] $ \i -> do+ wheel <- btRaycastVehicle_getWheelInfo vehicle i+ print =<< btWheelInfo_m_suspensionStiffness_get wheel+ print =<< btWheelInfo_m_wheelsDampingRelaxation_get wheel+ print =<< btWheelInfo_m_wheelsDampingCompression_get wheel+ print =<< btWheelInfo_m_frictionSlip_get wheel+ print =<< btWheelInfo_m_rollInfluence_get wheel+ -}+ return (carMotionSate,carChassis,vehicle)
+ src/Main.hs view
@@ -0,0 +1,227 @@+import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Data.IORef+import Data.List+import FRP.Elerea.Param+import Graphics.UI.GLFW as GLFW++import Graphics.LambdaCube as LC+import Graphics.LambdaCube.Bullet+import Graphics.LambdaCube.RenderSystem.GL+import qualified Graphics.LambdaCube.Loader.StbImage as Stb+import Graphics.LambdaCube.World (SceneObject(..), Camera(..), Viewport(..), peekLCM, wrRenderSystem)++import Physics.Bullet.Raw+import Physics.Bullet.Raw.Class++#ifdef CAPTURE+import Codec.Image.DevIL+import Graphics.LambdaCube.RenderSystem+import Text.Printf+#endif++import System.Directory+import System.Environment+import System.Exit++import Paths_Stunts (getDataFileName)++import GameData+import GamePhysics+import Utils++type Sink a = a -> IO ()++data CameraMode = FollowNear | FollowFar | UserControl++captureRate :: Float+captureRate = 30++main :: IO ()+main = do+#ifdef PORTABLE+ let mediaPath = "."+#else+ mediaPath <- getDataFileName "media"+#endif++ gameOk <- doesFileExist (mediaPath ++ "/STUNTS11.ZIP")+ unless gameOk $ do+ putStrLn "Missing game file! Please download the original game from"+ putStrLn "<http://downloads.pigsgrame.de/STUNTS11.ZIP> and move it to"+#ifdef PORTABLE+ putStrLn "the same folder as this executable."+#else+ putStrLn mediaPath+#endif+ putStrLn "For reference, the above file should be 1077864 bytes."+ exitFailure++ args <- getArgs++ let carNum = case filter ("--car=" `isPrefixOf`) args of+ [] -> 4+ n:_ -> read (drop 6 n)++ trkFile = case filter ("--track=" `isPrefixOf`) args of+ [] -> "zct114.trk"+ n:_ -> drop 8 n++#ifdef CAPTURE+ ilInit+#endif+ windowSize <- initCommon "Stunts NextGen powered by LambdaCube Engine"++ (mousePosition,mousePositionSink) <- external (0,0)+ (_mousePress,mousePressSink) <- external False+ (debugPress,debugPressSink) <- external False+ (capturePress,capturePressSink) <- external False+ (fblrPress,fblrPressSink) <- external (False,False,False,False,False)+ (cameraPress,cameraPressSink) <- external (False,False,False)+ (carPos,carPosSink) <- external idmtx+ (wheelPos,wheelPosSink) <- external []++ physicsWorld <- mkPhysicsWorld+ renderSystem <- mkGLRenderSystem+ runLCM renderSystem [Stb.loadImage] $ do+ let addSkyColour = fmap (\vp -> vp { vpBackColour = (0.36,0.99,0.99,1) })+ fixCameraClip = fmap (\(SO_Camera cm) -> SO_Camera cm { cmFar = 50000 })+ -- inLCM $ addConfig "resources.cfg"+ addResourceLibrary [("General", [(PathDir, mediaPath)])+ ,("General", [(PathZip, mediaPath ++ "/STUNTS11.ZIP")])+ ,("General", [(PathZip, mediaPath ++ "/newstunts.zip")])+ ,("General", [(PathDir, ".")])+ ]+ (car,wheels,terrain,track,startPos,carSim) <- readStuntsData carNum trkFile+ addVMesh "TrackMesh" track+ addVMesh "TerrainMesh" terrain+ addVMesh "CarMesh" car+ mapM_ (\((_,_,_,m),i) -> addVMesh ("Wheel" ++ show i) m) $ zip wheels [1..]+ addScene $+ [ node "Root" "CameraNode2" idmtx [fixCameraClip (simpleCamera "Camera2")]+ , node "Root" "Track" idmtx [mesh defaultRQP Nothing "TrackMesh", mesh defaultRQP Nothing "TerrainMesh"]+ , node "Root" "Car" idmtx [mesh defaultRQP Nothing "CarMesh"]+ , node "Root" "Wheel1" idmtx [mesh defaultRQP Nothing "Wheel1"]+ , node "Root" "Wheel2" idmtx [mesh defaultRQP Nothing "Wheel2"]+ , node "Root" "Wheel3" idmtx [mesh defaultRQP Nothing "Wheel3"]+ , node "Root" "Wheel4" idmtx [mesh defaultRQP Nothing "Wheel4"]+ , node "Root" "CameraNode1" idmtx [fixCameraClip (simpleCamera "Camera1")]+ , node "Root" "Light" (translation (Vec3 400 800 400)) [defaultLight]+ ]+ addRenderWindow "MainWindow" 640 480 $ map addSkyColour+ [{-viewport 0 0.5 1 0.5 "Camera1" [], viewport 0 0 1 0.5 "Camera2" []-} viewport 0 0 1 1 "Camera1" []]++ -- setup physics+ trackMesh <- getVMesh "TrackMesh"+ terrainMesh <- getVMesh "TerrainMesh"+ carMesh <- getVMesh "CarMesh"+ car <- liftIO $ do+ addStaticPlane physicsWorld (Vec3 0 1 0) 0 1 1+ addStaticShape physicsWorld trackMesh 1 1+ addStaticShape physicsWorld terrainMesh 1000 1000+ let (sO,Vec3 sX sY sZ) = startPos+ addCar physicsWorld carMesh wheels $ translateAfter4 (Vec3 sX (sY + 1) sZ) $ rotMatrixProj4 sO (Vec3 0 1 0)++ capRef <- liftIO $ newIORef False++ s <- liftIO fpsState+ sc <- liftIO $ start $ scene physicsWorld carPos wheelPos windowSize mousePosition fblrPress cameraPress debugPress capturePress capRef++ driveNetwork sc (readInput physicsWorld car s carPosSink wheelPosSink+ mousePositionSink mousePressSink fblrPressSink+ cameraPressSink debugPressSink capturePressSink capRef)++ closeWindow+ terminate++scene :: (RenderSystem r vb ib q t p lp, BtDynamicsWorldClass bc)+ => bc -> Signal Proj4 -> Signal [Proj4] -> Signal (Int, Int) -> Signal (FloatType, FloatType)+ -> Signal (Bool, Bool, Bool, Bool, Bool) -> Signal (Bool, Bool, Bool) -> Signal Bool -> Signal Bool -> IORef Bool+ -> SignalGen FloatType (Signal (LCM (World r vb ib q t p lp) e ()))+scene physicsWorld carPos wheelPos windowSize mousePosition fblrPress cameraPress debugPress capturePress capRef = do+ time <- stateful 0 (+)+ frameCount <- stateful (0 :: Int) (\_ c -> c + 1)++ last2 <- transfer ((0,0),(0,0)) (\_ n (_,b) -> (b,n)) mousePosition+ let mouseMove = (\((ox,oy),(nx,ny)) -> (nx-ox,ny-oy)) <$> last2++ pickMode _ (True,_,_) _ = FollowNear+ pickMode _ (_,True,_) _ = FollowFar+ pickMode _ (_,_,True) _ = UserControl+ pickMode _ _ mode = mode++ selectCam FollowNear (cam,dir) _ _ = lookat cam (cam &+ dir) (Vec3 0 1 0)+ selectCam FollowFar _ (cam,dir) _ = lookat cam (cam &+ dir) (Vec3 0 1 0)+ selectCam UserControl _ _ (cam,dir,up,_) = lookat cam (cam &+ dir) up++ followCamNear <- followCamera 2 4 6 carPos+ followCamFar <- followCamera 20 40 60 carPos+ userCam <- userCamera (Vec3 (-4) 0 0) mouseMove fblrPress+ camMode <- transfer FollowNear pickMode cameraPress+ let camera = selectCam <$> camMode <*> followCamNear <*> followCamFar <*> userCam++ capturePress' <- delay False capturePress+ capture <- transfer2 False (\_ cp cp' cap -> cap /= (cp && not cp')) capturePress capturePress'++ return $ drawGLScene physicsWorld capRef <$> windowSize <*> camera <*> time <*> carPos <*> wheelPos <*> debugPress <*> capture <*> frameCount++drawGLScene :: (RenderSystem r vb ib q t1 p lp, BtDynamicsWorldClass bc)+ => bc -> IORef Bool -> (Int, Int) -> Proj4 -> FloatType -> Proj4 -> [Proj4] -> Bool -> Bool -> Int+ -> LCM (World r vb ib q t1 p lp) e ()+#ifdef CAPTURE+drawGLScene physicsWorld capRef (w,h) camMat time carPos [wheel1,wheel2,wheel3,wheel4] debugPress capturing frameCount = do+#else+drawGLScene physicsWorld capRef (w,h) camMat time carPos [wheel1,wheel2,wheel3,wheel4] debugPress _capturing _frameCount = do+#endif+ updateTransforms $+ [ ("CameraNode1", inverse camMat)+-- , ("CameraNode2", inverse camMat2)+ , ("Car", carPos)+-- , ("Light", (translation cam))+ , ("Wheel1", wheel1)+ , ("Wheel2", wheel2)+ , ("Wheel3", wheel3)+ , ("Wheel4", wheel4)+ ]+ updateTargetSize "MainWindow" w h+ renderWorld time "MainWindow"+#ifdef CAPTURE+ rs <- wrRenderSystem <$> peekLCM+#endif+ when debugPress $ debugDrawPhysics physicsWorld camMat+ liftIO $ do+#ifdef CAPTURE+ when capturing $ withFrameBuffer rs 0 0 w h $ \p -> writeImageFromPtr (printf "frame%08d.png" frameCount) (h,w) p+ writeIORef capRef capturing+#endif+ swapBuffers++readInput :: (BtDynamicsWorldClass dw, BtRaycastVehicleClass v)+ => dw -> v -> State -> Sink Proj4 -> Sink [Proj4] -> Sink (FloatType, FloatType) -> Sink Bool+ -> Sink (Bool, Bool, Bool, Bool, Bool) -> Sink (Bool, Bool, Bool) -> Sink Bool -> Sink Bool -> IORef Bool+ -> IO (Maybe FloatType)+readInput physicsWorld car s carPos wheelPos mousePos mouseBut fblrPress cameraPress debugPress capturePress capRef = do+ t <- getTime+ resetTime++ (x,y) <- getMousePosition+ mousePos (fromIntegral x,fromIntegral y)++ mouseBut =<< mouseButtonIsPressed MouseButton0+ fblrPress =<< (,,,,) <$> keyIsPressed KeyLeft <*> keyIsPressed KeyUp <*> keyIsPressed KeyDown <*> keyIsPressed KeyRight <*> keyIsPressed KeyRightShift+ cameraPress =<< (,,) <$> keyIsPressed (CharKey '1') <*> keyIsPressed (CharKey '2') <*> keyIsPressed (CharKey '3')+ debugPress =<< keyIsPressed KeySpace+ capturePress =<< keyIsPressed (CharKey 'P')+ k <- keyIsPressed KeyEsc++ -- step physics+ isCapturing <- readIORef capRef+ let dt = if isCapturing then recip captureRate else realToFrac t+ steerCar dt car =<< forM "AWSDR" (\c -> keyIsPressed (CharKey c))+ btDynamicsWorld_stepSimulation physicsWorld dt 10 (1 / 200)+ wheelPos =<< updateCar car++ carPos =<< rigidBodyProj4 =<< btRaycastVehicle_getRigidBody car+ updateFPS s t+ return $ if k then Nothing else Just dt
+ src/Stunts/Color.hs view
@@ -0,0 +1,202 @@+module Stunts.Color where++import Data.Bits+import Data.IntMap (IntMap)+import qualified Data.IntMap as IM+import Data.Word++data Pattern+ = Opaque+ | Grate+ | Transparent+ | Grille+ | InverseGrille+ | Glass+ | InverseGlass++data Material+ = Material+ { pattern :: Pattern+ , color :: Word32+ , colorIndex :: Int+ }++toRGBA :: Word32 -> [Word8]+toRGBA c = [f 16, f 8, f 0, 0xFF]+ where+ f i = fromIntegral $ (c `shiftR` i) .&. 0xFF :: Word8++{-+checkFun m = vgaPal IM.! (colorIndex m) == (toRGB $ color m)+check = foldl (&&) True $ IM.elems $ IM.map checkFun materialMap+-}++-- MaterialIndex Pattern Color ColorIndexOnPalette+materialMap :: IntMap Material+materialMap = IM.fromList+ [ ( 0, (Material Opaque 0x000000 0)) -- Black+ , ( 1, (Material Opaque 0x0000A8 1)) -- Blue+ , ( 2, (Material Opaque 0x00A800 2)) -- Green+ , ( 3, (Material Opaque 0x00A8A8 3))+ , ( 4, (Material Opaque 0xA80000 4)) -- Highway light / cork l/r wall+ , ( 5, (Material Opaque 0xA800A8 5))+ , ( 6, (Material Opaque 0xA85400 6)) -- Barn roof+ , ( 7, (Material Opaque 0xA8A8A8 7)) -- Gas station doors+ , ( 8, (Material Opaque 0x545454 8))+ , ( 9, (Material Opaque 0x5454FC 9))+ , ( 10, (Material Opaque 0x54FC54 10)) -- Tree (pine)+ , ( 11, (Material Opaque 0x54FCFC 11))+ , ( 12, (Material Opaque 0xFC5454 12)) -- Highway split light+ , ( 13, (Material Opaque 0xFC54FC 13))+ , ( 14, (Material Opaque 0xFCFC54 14)) -- Sharp turn sign+ , ( 15, (Material Opaque 0xFCFCFC 15)) -- Tennis court lines+ , ( 16, (Material Opaque 0x246820 108)) -- Grass+ , ( 17, (Material Opaque 0x5CFCFC 116)) -- Sky+ , ( 18, (Material Opaque 0xFCFCFC 15)) -- Highway centerline+ , ( 19, (Material Opaque 0x484848 28)) -- Asphalt pavement+ , ( 20, (Material Opaque 0x383838 29)) -- Tunnel centerline+ , ( 21, (Material Opaque 0xFCFC54 14)) -- Asphalt centerline+ , ( 22, (Material Grate 0x484848 28)) -- Loop / Elev. road surface+ , ( 23, (Material Grate 0x202020 31)) -- Pipe surface+ , ( 24, (Material Grate 0xFCFC54 14))+ , ( 25, (Material Opaque 0x9C6438 200)) -- Dirt pavement+ , ( 26, (Material Opaque 0xB48054 198))+ , ( 27, (Material Opaque 0xCCA080 196)) -- Dirt centerline+ , ( 28, (Material Opaque 0xD8FCFC 112)) -- Ice pavement+ , ( 29, (Material Opaque 0x9CFCFC 114))+ , ( 30, (Material Opaque 0x5CFCFC 116)) -- Ice centerline+ , ( 31, (Material Opaque 0xE4C4AC 194)) -- Bridges, buildings, etc.+ , ( 32, (Material Opaque 0xC0906C 197)) -- Bridges, buildings, etc.+ , ( 33, (Material Opaque 0x9C6438 200)) -- Bridges, buildings, etc.+ , ( 34, (Material Grate 0x9C9CFC 146))+ , ( 35, (Material Opaque 0xFC4040 37)) -- Banked road outer side+ , ( 36, (Material Opaque 0xFC7C7C 35)) -- Tunnel walls / Bankings+ , ( 37, (Material Opaque 0xFC40FC 181)) -- Bridge cables+ , ( 38, (Material Opaque 0x383838 29)) -- Wheel (tyre tread)+ , ( 39, (Material Opaque 0x202020 31)) -- Wheel (tyre sidewall)+ , ( 40, (Material Opaque 0xC0C0C0 19)) -- Wheel ("rim")+ , ( 41, (Material Opaque 0x00A8A8 3)) -- Windows (LM002 car1)+ , ( 42, (Material Opaque 0x54FCFC 11)) -- Gas station windows+ , ( 43, (Material Opaque 0x545454 8)) -- Windows and windshields+ , ( 44, (Material Opaque 0x000000 0)) -- Windows and windshields+ , ( 45, (Material Opaque 0xA80000 4))+ , ( 46, (Material Opaque 0xA80000 4))+ , ( 47, (Material Opaque 0xFC5454 12))+ , ( 48, (Material Opaque 0x00007C 156)) -- Blue 1 Car body+ , ( 49, (Material Opaque 0x0000A8 1)) -- Blue 2 Car body+ , ( 50, (Material Opaque 0x0000D0 152)) -- Blue 3 Car body+ , ( 51, (Material Opaque 0x0004FC 150)) -- Blue 4 Car body+ , ( 52, (Material Opaque 0xB40000 42)) -- Red 1 Car body+ , ( 53, (Material Opaque 0xE40000 40)) -- Red 2 Car body+ , ( 54, (Material Opaque 0xFC2020 38)) -- Red 3 Car body+ , ( 55, (Material Opaque 0xFC4040 37)) -- Red 4 Car body+ , ( 56, (Material Opaque 0x545454 8)) -- Graphite 1 Car body+ , ( 57, (Material Opaque 0x606060 26)) -- Graphite 2 Car body+ , ( 58, (Material Opaque 0x707070 25)) -- Graphite 3 Car body+ , ( 59, (Material Opaque 0x7C7C7C 24)) -- Graphite 4 Car body+ , ( 60, (Material Opaque 0xE4D800 72)) -- Yellow 1 Car body+ , ( 61, (Material Opaque 0xFCF420 70)) -- Yellow 2 Car body+ , ( 62, (Material Opaque 0xFCF85C 68)) -- Yellow 3 Car body+ , ( 63, (Material Opaque 0xFCFC9C 66)) -- Yellow 4 Car body+ , ( 64, (Material Opaque 0x009C9C 123)) -- Cyan 1 Car body+ , ( 65, (Material Opaque 0x00CCCC 121)) -- Cyan 2 Car body+ , ( 66, (Material Opaque 0x00E4E4 120)) -- Cyan 3 Car body+ , ( 67, (Material Opaque 0x40FCFC 117)) -- Cyan 4 Car body+ , ( 68, (Material Opaque 0x508400 92)) -- Green 1 Car body / Tree (palm)+ , ( 69, (Material Opaque 0x74B400 90)) -- Green 2 Car body / Tree (palm)+ , ( 70, (Material Opaque 0x90E400 88)) -- Green 3 Car body / Tree (palm)+ , ( 71, (Material Opaque 0xA0FC00 87)) -- Green 4 Car body+ , ( 72, (Material Opaque 0x440070 173)) -- Purple 1 Car body+ , ( 73, (Material Opaque 0x60009C 171)) -- Purple 2 Car body+ , ( 74, (Material Opaque 0x8000CC 169)) -- Purple 3 Car body+ , ( 75, (Material Opaque 0xA800FC 167)) -- Purple 4 Car body+ , ( 76, (Material Opaque 0xB0B0B0 20)) -- Silver 1 Car body+ , ( 77, (Material Opaque 0xC0C0C0 19)) -- Silver 2 Car body+ , ( 78, (Material Opaque 0xCCCCCC 18)) -- Silver 3 Car body+ , ( 79, (Material Opaque 0xDCDCDC 17)) -- Silver 4 Car body+ , ( 80, (Material Opaque 0x6C5800 77)) -- Golden 1 Car body+ , ( 81, (Material Opaque 0x847400 76)) -- Golden 2 Car body+ , ( 82, (Material Opaque 0xB4A400 74)) -- Golden 3 Car body+ , ( 83, (Material Opaque 0xCCC000 73)) -- Golden 4 Car body+ , ( 84, (Material Opaque 0x700000 45)) -- Burgundy 1 Car body+ , ( 85, (Material Opaque 0x840000 44)) -- Burgundy 2 Car body+ , ( 86, (Material Opaque 0xB40000 42)) -- Burgundy 3 Car body+ , ( 87, (Material Opaque 0xCC0000 41)) -- Burgundy 4 Car body+ , ( 88, (Material Opaque 0x000040 159)) -- Violet 1 Car body+ , ( 89, (Material Opaque 0x280040 175)) -- Violet 2 Car body+ , ( 90, (Material Opaque 0x340058 174)) -- Violet 3 Car body+ , ( 91, (Material Opaque 0x500084 172)) -- Violet 4 Car body+ , ( 92, (Material Opaque 0x383838 29))+ , ( 93, (Material Opaque 0x484848 28))+ , ( 94, (Material Grate 0xCCCCCC 18)) -- Tennis net+ , ( 95, (Material Opaque 0x74B400 90)) -- Tennis grass+ , ( 96, (Material Opaque 0xFCFCFC 15)) -- Clouds+ , ( 97, (Material Opaque 0xA8A8A8 7)) -- Clouds+ , ( 98, (Material Opaque 0x9C6438 200)) -- Pinetree trunk+ , ( 99, (Material Opaque 0xC0602C 219)) -- Pinetree trunk+ , (100, (Material Opaque 0x0080D0 136)) -- Water+ , (101, (Material Opaque 0x84E084 99)) -- Grass (hilltop)+ , (102, (Material Opaque 0x70C46C 101)) -- Grass (hill slope)+ , (103, (Material Opaque 0x58A858 103)) -- Grass (angled slope)+ , (104, (Material Opaque 0x509C4C 104)) -- Grass (angled slope)+ , (105, (Material Opaque 0x388034 106)) -- Grass (angled slope)+ , (106, (Material Opaque 0xDCDCDC 17)) -- Gas station / Joe's+ , (107, (Material Opaque 0xB0B0B0 20)) -- Gas station / Joe's+ , (108, (Material Opaque 0x905410 60)) -- Trunk (palmtree)+ , (109, (Material Opaque 0x6C5800 77)) -- Trunk (palmtree)+ , (110, (Material Opaque 0x580000 46)) -- Joe's roof+ , (111, (Material Opaque 0x744008 61)) -- Windmill (base)+ , (112, (Material Opaque 0x700000 45)) -- Windmill (base)+ , (113, (Material Opaque 0x80542C 202)) -- Windmill (blades)+ , (114, (Material Opaque 0x540054 190)) -- Joe's flashing sign+ , (115, (Material Opaque 0xA400A4 186)) -- Joe's flashing sign+ , (116, (Material Opaque 0xE000E4 183)) -- Joe's flashing sign+ , (117, (Material Opaque 0xFC5CFC 180)) -- Joe's flashing sign+ , (118, (Material Transparent 0xFFFFFF 255)) -- Windmill animation mask+ , (119, (Material Grille 0x484848 28))+ , (120, (Material InverseGrille 0x2C2C2C 30))+ , (121, (Material Glass 0xFCFCFC 15))+ , (122, (Material InverseGlass 0xB0B0B0 20))+ , (123, (Material Glass 0xFCF85C 68))+ , (124, (Material InverseGlass 0xFCAC54 54))+ , (125, (Material Glass 0xFC0000 39))+ , (126, (Material InverseGlass 0x9C0000 43))+ , (127, (Material Opaque 0xFC5454 12)) -- Corner kerbs+ , (128, (Material Opaque 0xDCDCDC 17)) -- Corner kerbs+ ]++vgaPal :: IntMap [Word8]+vgaPal = IM.fromList $ zip [0,1..] $ map toRGBA [+ 0x000000, 0x0000A8, 0x00A800, 0x00A8A8, 0xA80000, 0xA800A8, 0xA85400, 0xA8A8A8,+ 0x545454, 0x5454FC, 0x54FC54, 0x54FCFC, 0xFC5454, 0xFC54FC, 0xFCFC54, 0xFCFCFC,+ 0xFCFCFC, 0xDCDCDC, 0xCCCCCC, 0xC0C0C0, 0xB0B0B0, 0xA4A4A4, 0x989898, 0x888888,+ 0x7C7C7C, 0x707070, 0x606060, 0x545454, 0x484848, 0x383838, 0x2C2C2C, 0x202020,+ 0xFCD8D8, 0xFCB8B8, 0xFC9C9C, 0xFC7C7C, 0xFC5C5C, 0xFC4040, 0xFC2020, 0xFC0000,+ 0xE40000, 0xCC0000, 0xB40000, 0x9C0000, 0x840000, 0x700000, 0x580000, 0x400000,+ 0xFCE8D8, 0xFCDCC0, 0xFCD4AC, 0xFCC894, 0xFCC080, 0xFCB868, 0xFCAC54, 0xFCA43C,+ 0xFC9C28, 0xE08820, 0xC4781C, 0xA86414, 0x905410, 0x744008, 0x583004, 0x402000,+ 0xFCFCD8, 0xFCFCB8, 0xFCFC9C, 0xFCFC7C, 0xFCF85C, 0xFCF440, 0xFCF420, 0xFCF400,+ 0xE4D800, 0xCCC000, 0xB4A400, 0x9C8C00, 0x847400, 0x6C5800, 0x544000, 0x402800,+ 0xF8FCD8, 0xF4FCB8, 0xE8FC9C, 0xE0FC7C, 0xD0FC5C, 0xC4FC40, 0xB4FC20, 0xA0FC00,+ 0x90E400, 0x80CC00, 0x74B400, 0x609C00, 0x508400, 0x447000, 0x345800, 0x284000,+ 0xD8FCD8, 0x9CFC9C, 0x90EC90, 0x84E084, 0x78D078, 0x70C46C, 0x64B864, 0x58A858,+ 0x509C4C, 0x449040, 0x388034, 0x2C742C, 0x246820, 0x185814, 0x0C4C08, 0x044000,+ 0xD8FCFC, 0xB8FCFC, 0x9CFCFC, 0x7CFCF8, 0x5CFCFC, 0x40FCFC, 0x20FCFC, 0x00FCFC,+ 0x00E4E4, 0x00CCCC, 0x00B4B4, 0x009C9C, 0x008484, 0x007070, 0x005858, 0x004040,+ 0xD8ECFC, 0xB8E0FC, 0x9CD4FC, 0x7CC8FC, 0x5CBCFC, 0x40B0FC, 0x009CFC, 0x008CE4,+ 0x0080D0, 0x0074BC, 0x0064A8, 0x005890, 0x004C7C, 0x003C68, 0x003054, 0x002440,+ 0xD8D8FC, 0xB8BCFC, 0x9C9CFC, 0x7C80FC, 0x5C60FC, 0x4040FC, 0x0004FC, 0x0000E4,+ 0x0000D0, 0x0000BC, 0x0000A8, 0x000090, 0x00007C, 0x000068, 0x000054, 0x000040,+ 0xF0D8FC, 0xE4B8FC, 0xD89CFC, 0xD07CFC, 0xC85CFC, 0xBC40FC, 0xB420FC, 0xA800FC,+ 0x9800E4, 0x8000CC, 0x7400B4, 0x60009C, 0x500084, 0x440070, 0x340058, 0x280040,+ 0xFCD8FC, 0xFCB8FC, 0xFC9CFC, 0xFC7CFC, 0xFC5CFC, 0xFC40FC, 0xFC20FC, 0xE000E4,+ 0xCC00CC, 0xB800B8, 0xA400A4, 0x900090, 0x7C007C, 0x680068, 0x540054, 0x400040,+ 0xFCE8DC, 0xF0D4C4, 0xE4C4AC, 0xD8B498, 0xCCA080, 0xC0906C, 0xB48054, 0xAC7040,+ 0x9C6438, 0x8C5C34, 0x80542C, 0x704C28, 0x604020, 0x54381C, 0x443014, 0x382810,+ 0xFCD8CC, 0xF8CCB8, 0xF4C0A8, 0xF0B494, 0xECA884, 0xE89C74, 0xE49464, 0xE08C58,+ 0xD8804C, 0xD47840, 0xC86C34, 0xC0602C, 0xB45424, 0xA8481C, 0x9C3C14, 0x94300C,+ 0xF4C0A8, 0xF0BCA0, 0xF0B89C, 0xF0B494, 0xECB090, 0xECAC88, 0xECA884, 0xE8A480,+ 0xE8A078, 0xE89C74, 0xE4986C, 0xE49468, 0xE49464, 0xFC9C9C, 0xFC9494, 0xFC9090,+ 0xFC8C8C, 0xFC8484, 0xFC8080, 0xFC7C7C, 0xD8B498, 0xD0AC8C, 0xCCA484, 0xC89C7C,+ 0xC49474, 0xC0906C, 0xC0C0C0, 0xBCBCBC, 0xB8B8B8, 0xB4B4B4, 0xB0B0B0, 0xFFFFFF+ ]
+ src/Stunts/Loader.hs view
@@ -0,0 +1,364 @@+module Stunts.Loader where++import Control.Applicative+import Control.Monad+import Data.Binary as B+import Data.Binary.Get as B+import Data.Bits+import qualified Data.ByteString as SB+import qualified Data.ByteString.Char8 as SB8+import qualified Data.ByteString.Lazy as LB+import Data.Int+import Data.IntMap (Key)+import qualified Data.IntMap as IM+import Data.List+import qualified Data.Map as M+import qualified Data.Vector as V++import Stunts.Color++getString :: Int -> Get String+getString = fmap (SB8.unpack . SB8.takeWhile (/= '\0')) . getByteString++getWord :: Get Word32+getWord = getWord32le++getUByte :: Get Word8+getUByte = B.get :: Get Word8++getInt8 :: Get Int+getInt8 = fromIntegral <$> getUByte :: Get Int++getInt16' :: Get Int16+getInt16' = fromIntegral <$> getWord16le :: Get Int16++getInt16 :: Get Int+getInt16 = fromIntegral <$> getInt16' :: Get Int++getInt' :: Get Int32+getInt' = fromIntegral <$> getWord32le :: Get Int32++getInt :: Get Int+getInt = fromIntegral <$> getInt' :: Get Int++data PrimitiveType+ = Particle+ | Line+ | Polygon+ | Sphere+ | Wheel+ | Ignored+ deriving (Eq,Ord,Show)++data Primitive+ = Primitive+ { prType :: PrimitiveType+ , prTwoSided :: Bool+ , prZBias :: Bool+ , prMaterials :: [Int]+ , prIndices :: [Int]+ }+ deriving Show++data Model+ = Model+ { mdVertices :: [(Float,Float,Float)]+ , mdPrimitives :: [Primitive]+ }+ deriving Show++getVertex :: Get (Float, Float, Float)+getVertex = do+ x <- getInt16+ y <- getInt16+ z <- getInt16+ let aspectCorrection = 1 -- 6.0/5.0+ f = fromIntegral :: Int -> Float+ y' = aspectCorrection * f y+ return (f x,y',-f z)++getPrimitive :: Int -> Get Primitive+getPrimitive numPaintJobs = do+ let convertType c+ | c == 1 = (1,Particle)+ | c == 2 = (2,Line)+ | 3 <= c &&+ c <= 10 = (c,Polygon)+ | c == 11 = (2,Sphere)+ | c == 12 = (6,Wheel)+ | otherwise = (0,Ignored)+ (cnt,ptype) <- convertType <$> getInt8+ (twosided,zbias) <- (\i -> (testBit i 0,testBit i 1)) <$> getUByte+ materials <- replicateM numPaintJobs getInt8+ indices <- replicateM cnt getInt8+ return $ Primitive ptype twosided zbias materials indices++getModel :: Get Model+getModel = do+ numVertices <- getInt8+ numPrimitives <- getInt8+ numPaintJobs <- getInt8+ getInt8+ vertices <- replicateM numVertices getVertex+ _cullFront <- replicateM numPrimitives getWord+ _cullBack <- replicateM numPrimitives getWord+ primitives <- replicateM numPrimitives (getPrimitive numPaintJobs)+ return $ Model vertices primitives++getResources :: Get [(String, LB.ByteString)]+getResources = do+ _fileLength <- getInt+ numResources <- getInt16+ ids' <- replicateM numResources $ getString 4+ offsets' <- map fromIntegral <$> replicateM numResources getInt+ dat <- getRemainingLazyByteString+ let (ids,offsets) = unzip $ sortBy (\(_,a) (_,b) -> compare a b) $ zip ids' offsets'+ lens = snd $ foldl' (\(p,l) o -> (o,(p-o):l)) ((LB.length dat),[]) $ reverse offsets+ return [(i,LB.take l $ LB.drop o dat) | (i,o,l) <- zip3 ids offsets lens]++readResources :: LB.ByteString -> M.Map String LB.ByteString+readResources dat = M.fromList $ runGet getResources dat++-- bitmap+data Bitmap+ = Bitmap+ { width :: Int+ , height :: Int+ , positionX :: Int+ , positionY :: Int+ , image :: SB.ByteString -- RGB data+ }+{-+uint16 width+uint16 height+uint16 unknown1[2]+uint16 positionX+uint16 positionY+uint8 unknown2[4]++uint8 image[width * height]+-}+getBitmap :: Get Bitmap+getBitmap = do+ width <- getInt16+ height <- getInt16+ getInt16+ getInt16+ positionX <- getInt16+ positionY <- getInt16+ getInt8+ getInt8+ getInt8+ getInt8+ image <- replicateM (width * height) ((vgaPal IM.!) <$> getInt8)+ return $ Bitmap width height positionX positionY $ SB.pack $ concat image++data Car+ = Car+ -- Number of gears.+ { gears :: Int++ -- The gear ratios are overall values, representing the effects both the gearbox+ -- and the final drive gears as well as those of the wheel radius.+ -- car_speed_mph = 256*engine_speed_rpm/gear_ratio+ , gearRatios :: [Int]++ -- Every byte navigated forward corresponds to increments of 128rpm,+ -- so that byte 61h covers 0...127rpm; 62h, 128...255rpm and so on+ -- There are 103 bytes in total, and so the engine can deliver power over a range of 13184rpm.+ , torqueCurve :: [Int]++ -- The main function of the parameter is to define up to which rpm value+ -- the "idle rpm torque" will be used instead of the regular torque curve for the second gear and above.+ , idleRpm :: Int++ -- This may be thought as a special point in the torque curve.+ -- It overrides a section of the curve at low rpms,+ -- in order to better represent the car launch from a standstill.+ , idleRpmTorque :: Int++ -- This is the downshift rpm point used by the automatic transmission.+ , downshiftRpm :: Int++ -- This is the upshift rpm point used by the automatic transmission.+ , upshiftRpm :: Int++ -- This parameter is the maximum rpm (the "redline") of the engine.+ , maxRpm :: Int++ -- Car mass.+ , mass :: Int++ -- Tells how powerful the car brakes will be.+ , braking :: Int++ -- This elusive parameter controls aerodynamic resistance encountered by the car when accelerating down a straight.+ , aeroResistance :: Int++ -- This is the primary handling parameter. Higher values make it possible to take corners at higher speeds without skidding,+ -- and thus raise cornering speeds as well as lower the risk of loss of control+ -- (at the rather small cost of making controlled sliding harder, which sometimes can be an inconvenience in competition racing).+ , grip :: Int++ -- These values are responsible for modifying the car grip according to the kind of surface it is on.+ -- The four integer values correspond to the four kinds of surface of Stunts+ -- asphalt, dirt, ice and grass, in that order.+ , surfaceGrip :: [Int]++ -- These four integers set half-width, height and two half-length values for the car.+ -- These are only used for the detection of car-car collisions.+ , collision :: [Int]++ -- The first triplet corresponds to the front/left wheel;+ -- the other three stand for the remaining ones, ordered clockwise.+ , wheelPos :: [(Int,Int,Int)]++ -- graphical properties++ , cockpitHeight :: Int -- This sets the apparent height from the ground on the inside (F1) view.+ , shiftingKnobPos :: [(Int,Int)] -- shifting knob coordinates+ , steeringDot :: [(Int,Int)] -- 1+33 pairs+-- , speedometerNeedle :: [(Int,Int)]+ , digitalSpeedometer :: [(Int,Int)]+-- , revMeterNeedle :: [(Int,Int)]++ -- text properties+-- , infoText :: String+-- , scoreboardName :: String+ }+++getCar :: Get Car+getCar = do+ let pos i g = lookAhead $ do+ skip i+ g+ gears <- pos 0x26 getInt8+ mass <- pos 0x28 getInt16+ braking <- pos 0x2A getInt16+ idleRpm <- pos 0x2C getInt16+ downshiftRpm <- pos 0x2E getInt16+ upshiftRpm <- pos 0x30 getInt16+ maxRpm <- pos 0x32 getInt16+ gearRatios <- pos 0x36 (replicateM 6 getInt16)+ shiftingKnobPos <- pos 0x44 (replicateM 6 ((,) <$> getInt16 <*> getInt16))+ aeroResistance <- pos 0x5D getInt16+ idleRpmTorque <- pos 0x60 getInt16+ torqueCurve <- pos 0x61 (replicateM 105 getInt8)+ grip <- pos 0xCA getInt16+ surfaceGrip <- pos 0xDC (replicateM 4 getInt16)+ collision <- pos 0xEE (replicateM 4 getInt16)+ cockpitHeight <- pos 0xF6 getInt16+ wheelPos <- pos 0xF8 (replicateM 4 ((,,) <$> getInt16 <*> getInt16 <*> getInt16))+ steeringDot <- pos 0x110 (replicateM 34 ((,) <$> getInt8 <*> getInt8))+-- speedometerNeedle <- pos 0x14E (replicateM 34 ((,) <$> getInt8 <*> getInt8)+ digitalSpeedometer <- pos 0x154 (replicateM 3 ((,) <$> getInt8 <*> getInt8))+ return $ Car+ { gears = gears+ , gearRatios = gearRatios+ , torqueCurve = torqueCurve+ , idleRpm = idleRpm+ , idleRpmTorque = idleRpmTorque+ , downshiftRpm = downshiftRpm+ , upshiftRpm = upshiftRpm+ , maxRpm = maxRpm+ , mass = mass+ , braking = braking+ , aeroResistance = aeroResistance+ , grip = grip+ , surfaceGrip = surfaceGrip+ , collision = collision+ , wheelPos = wheelPos+ , cockpitHeight = cockpitHeight+ , shiftingKnobPos = shiftingKnobPos+ , steeringDot = steeringDot+ , digitalSpeedometer = digitalSpeedometer+ }++{-+opponent data:+ - files:+ sdosel.pvs (bitmaps)+ opp0 - opp6 : opponent portraits (opp0 is actually the chronometer for the time trial option)+ scrn+ clip+ opponent animations:+ opp?win.pvs, opp?lose.pvs - bitmaps+ op01 - op08 : the actual number of frames within a file varies from 3 to 8+ opp?.pre+ winn, lose - Each byte in these NULL-terminated resources is a numerical index to the op01 ... op08 bitmaps,+ and the overall sequence is the succession of frames.+ sped - Opponent performance+ path - (186 bytes) numerical data resource which function is not yet understood.+-}++{-+data OpponentData+ = OpponentData+ { screen :: Bitmap+ , clip :: Bitmap+ , opponents :: [Opponent]+ }++data Opponent+ = Opponent+ { avatar :: Bitmap+ , winAnim :: [Bitmap]+ , looseAnim :: [Bitmap]+ , speed :: OpponentPerformance+ }+data OpponentPerformance+ = OpponentPerformance+ { road :: Int3 -- paved, dirt and icy road+ , smallCorner :: Int3 -- paved, dirt and icy small corner+ , largeCorner :: Int3 -- paved, dirt and icy large corner+ , bankedCorner :: Int+ , bridge :: Int+ , slalom :: Int+ , corkUpDown :: Int+ , chicane :: Int+ , loop :: Int+ , corkLeftRight :: Int+ }+get3Int8 :: Get (Int, Int, Int)+get3Int8 = (,,) <$> getInt8 <*> getInt8 <*> getInt8++getOpponentPerformance :: Get OpponentPerformance+getOpponentPerformance = OpponentPerformance <$> get3Int8 <*> get3Int8 <*> get3Int8+ <*> getInt8 <*> getInt8 <*> getInt8 <*> getInt8+ <*> getInt8 <*> getInt8 <*> getInt8+-}++readTrack :: SB8.ByteString -> ([(Int, Int, Int, Bool)], [(Key, Int, Int, Bool)])+readTrack dat = (filter filterTerrainItem (idx (@/)), mapTrackItem =<< idx (@=))+ where+ trkData = map fromEnum (SB.unpack dat)+ idx sel = [(sel x y,x,y,x @/ y == 0x06) | y <- [0..29], x <- [0..29]]+ x @/ y = V.fromList ter V.! (y*30+x)+ x @= y = V.fromList trk V.! ((29-y)*30+x)+ (trk,_:ter) = splitAt 900 trkData++ roadV = [0x04,0x0E,0x18]+ roadH = [0x05,0x0F,0x19]+ map07 = IM.fromList $ [(i,0x67) | i <- [0x27,0x3B,0x62]] ++ zip roadV [0xD0,0xD4,0xD8]+ map09 = IM.fromList $ [(i,0x67) | i <- [0x26,0x3A,0x61]] ++ zip roadV [0xD2,0xD6,0xDA]+ map08 = IM.fromList $ [(i,0x68) | i <- [0x24,0x38,0x5F]] ++ zip roadH [0xD1,0xD5,0xD9]+ map0A = IM.fromList $ [(i,0x68) | i <- [0x25,0x39,0x60]] ++ zip roadH [0xD3,0xD7,0xDB]++ mapTrackItem i@(c,x,y,e)+ -- remove filler elements+ | elem c [0x00,0xFE,0xFD,0xFF] = []+ -- this is composed from two elements+ | c == 0x65 = [(0x67,x,y,e),(0x05,x,y,e)]+ | c == 0x66 = [(0x68,x,y,e),(0x04,x,y,e)]+ -- ramp on brae is replaced with elevated road+ | x @/ y == 0x07 && IM.member c map07 = [(map07 IM.! c,x,y,e)]+ | x @/ y == 0x09 && IM.member c map09 = [(map09 IM.! c,x,y,e)]+ | x @/ y == 0x08 && IM.member c map08 = [(map08 IM.! c,x,y,e)]+ | x @/ y == 0x0A && IM.member c map0A = [(map0A IM.! c,x,y,e)]+ | otherwise = [i]++ filterTerrainItem (c,x,y,_)+ | elem c [0x07,0x09] && elem (x @= y) roadV = False+ | elem c [0x08,0x0A] && elem (x @= y) roadH = False+ | otherwise = True
+ src/Stunts/Track.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE ParallelListComp #-}++module Stunts.Track(terrainModelMap,trackModelMap,trackModelSizeMap) where++import Data.IntMap (IntMap, (!))+import qualified Data.IntMap as IM++trackOrientation :: [a] -> [Float]+trackOrientation l+ | n == 2 = [0, 3*a]+ | n == 4 = [0, a, 2*a, 3*a]+ | otherwise = [0]+ where+ a = pi / 2+ n = length l++terrainOrientation :: [Float]+terrainOrientation = [0, a, 2*a, 3*a]+ where+ a = pi / 2++type ModelID = (String,String) -- FileName ModelName+type ModelMap = IntMap ([ModelID],[ModelID],Float) -- Graphics, Collision, Orientation++meshMap :: String -> [String] -> [(String,String)]+meshMap r l = [(r,n) | n <- l]++trackModels :: IntMap ([ModelID],[ModelID])+trackModels = IM.map (\(a,b) -> (meshMap "GAME1.P3S" a,meshMap "GAME1.P3S" b)) trackModelsGame1P3S `IM.union`+ IM.map (\(a,b) -> (meshMap "GAME2.P3S" a,meshMap "GAME2.P3S" b)) trackModelsGame2P3S++terrainModels :: IntMap ([ModelID],[ModelID])+terrainModels = IM.map (\l -> let ml = meshMap "GAME2.P3S" l in (ml,ml)) terrainModelsGame2P3S++addModel :: [Float] -> IntMap ([ModelID],[ModelID]) -> [Int] -> [(Int,([ModelID],[ModelID],Float))]+addModel ol m l@ ~(i0:_) = [(i,(ma,mb,o)) | i <- l | o <- ol]+ where+ (ma,mb) = m ! i0++addMultiMaterialModel :: [Float] -> IntMap ([ModelID],[ModelID]) -> [(Int,Int,Int)] -> [(Int,([ModelID],[ModelID],Float))]+addMultiMaterialModel ol m l@ ~((i0,_,_):_) = concat [[(a,(ma,mb,o)), (b,(ma,mb,o)), (c,(ma,mb,o))] | (a,b,c) <- l | o <- ol]+ where+ (ma,mb) = m ! i0++trackModelMap :: ModelMap+trackModelMap = IM.fromList $ concat $+ [addModel (trackOrientation m) trackModels m | m <- track] +++ [addMultiMaterialModel (trackOrientation m) trackModels m | m <- variableMaterialTrack]++terrainModelMap :: ModelMap+terrainModelMap = IM.fromList $ addModel terrainOrientation terrainModels =<< terrain++-- rotate the list items, the first item will satisfy the given condition+sortFun :: (a -> Bool) -> [a] -> [a]+sortFun g l = take n $ dropWhile g $ take (2*n) $ cycle l+ where n = length l++-- anti-clockwise rotation from left to right+terrain :: [[Int]]+terrain = map (sortFun (`IM.notMember` terrainModels))+ [ [0x00]+ , [0x01]+ , [0x05, 0x02, 0x03, 0x04]+ , [0x06]+ , [0x07, 0x08, 0x09, 0x0A]+ , [0x0B, 0x0C, 0x0D, 0x0E]+ , [0x11, 0x12, 0x0F, 0x10]+ ]++--GAME2.P3S+terrainModelsGame2P3S :: IntMap [String]+terrainModelsGame2P3S = IM.fromList+ [ (0x0F, ["goui"])+ , (0x0B, ["gouo", "high"]) -- needs a ground square+ , (0x07, ["goup"])+ , (0x01, ["lake"])+ , (0x00, ["high"])+ , (0x06, ["high"])+ , (0x02, ["lakc", "high"]) -- 0x02 or 0x04 Terrain ???+ ]+{-+--GAME2.P3S+,"hig1" - ??? nagyobb mint egy negyzet 0x06 Terrain ???+,"hig2" - ??? nagyobb mint egy negyzet 0x ???+,"hig3" - ??? nagyobb mint egy negyzet 0x ???+-}++track :: [[Int]]+track = map (sortFun (`IM.notMember` trackModels))+ [ [0x00]+ , [0x22, 0x23]+ , [0x63, 0x64]+ , [0x65, 0x66]+ , [0x67, 0x68]+ , [0x26, 0x25, 0x27, 0x24]+ , [0x3A, 0x39, 0x3B, 0x38]+ , [0x61, 0x60, 0x62, 0x5F]+ , [0x75, 0x76, 0x77, 0x78]+ , [0x79, 0x7A, 0x7B, 0x7C]+ , [0x40, 0x41]+ , [0x55, 0x56]+ , [0x42, 0x43]+ , [0x73, 0x74]+ , [0x44, 0x45]+ , [0x53, 0x54]+ , [0x46, 0x48, 0x47, 0x49]+ , [0x6D, 0x6E]+ , [0x6F, 0x72, 0x71, 0x70]+ , [0x32, 0x30, 0x33, 0x31]+ , [0x34, 0x36, 0x37, 0x35]+ , [0x69, 0x6B, 0x6C, 0x6A]+ , [0x3C, 0x3F]+ , [0x3D, 0x3E]+ , [0x28, 0x2B, 0x2A, 0x29]+ , [0x2F, 0x2E, 0x2D, 0x2C]+ , [0x02]+ , [0x03]+ , [0x97]+ , [0x98]+ , [0x99]+ , [0x9A]+ , [0x9B, 0x9D, 0x9C, 0x9E]+ , [0x9F, 0xA1, 0xA0, 0xA2]+ , [0xA3, 0xA5, 0xA4, 0xA6]+ , [0xA7, 0xA9, 0xA8, 0xAA]+ , [0xAD, 0xAC, 0xAE, 0xAB]+ , [0xAF, 0xB1, 0xB0, 0xB2]+ , [0x5B, 0x5C, 0x5D, 0x5E]+ , [0x58, 0x59, 0x5A, 0x57]+ ]++-- (paved, dirt, icy)+variableMaterialTrack :: [[(Int,Int,Int)]]+variableMaterialTrack = map (sortFun (\(i,_,_) -> IM.notMember i trackModelsGame1P3S && IM.notMember i trackModelsGame2P3S)) $+ map (\(a,b,c) -> zip3 a b c)+ [ ([0x01, 0xB5, 0xB3, 0xB4], [0x86, 0x89, 0x87, 0x88], [0x93, 0x96, 0x94, 0x95])+ , ([0x04, 0x05], [0x0E, 0x0F], [0x18, 0x19])+ , ([0x4A], [0x7D], [0x8A])+ , ([0x06, 0x08, 0x09, 0x07], [0x10, 0x12, 0x13, 0x11], [0x1A, 0x1C, 0x1D, 0x1B])+ , ([0x0A, 0x0C, 0x0D, 0x0B], [0x14, 0x16, 0x17, 0x15], [0x1E, 0x20, 0x21, 0x1F])+ , ([0x4F, 0x50, 0x51, 0x52], [0x82, 0x83, 0x84, 0x85], [0x8F, 0x90, 0x91, 0x92])+ , ([0x4C, 0x4D, 0x4E, 0x4B], [0x7F, 0x80, 0x81, 0x7E], [0x8C, 0x8D, 0x8E, 0x8B])+ -- special element+ , ([0xD0, 0xD1, 0xD2, 0xD3], [0xD4, 0xD5, 0xD6, 0xD7], [0xD8, 0xD9, 0xDA, 0xDB])+ ]++trackModelSizeMap :: IntMap (Int,Int)+trackModelSizeMap = IM.union sizeMap $ IM.map (const (1,1)) trackModelMap+ where+ sizeMap = IM.fromList [(i,s) | (is,s) <- [(s2x2,(2,2)),(s1x2,(1,2)),(s2x1,(2,1))], i <- is]+ s2x2 =+ [ 0x0A, 0x0B, 0x0C, 0x0D+ , 0x14, 0x15, 0x16, 0x17+ , 0x1E, 0x1F, 0x20, 0x21+ , 0x34, 0x35, 0x36, 0x37+ , 0x3C, 0x3D, 0x3E, 0x3F+ , 0x57, 0x58, 0x59, 0x5A+ , 0x5B, 0x5C, 0x5D, 0x5E+ , 0x69, 0x6A, 0x6B, 0x6C+ , 0x75, 0x76, 0x77, 0x78+ , 0x79, 0x7A, 0x7B, 0x7C+ ]+ s1x2 = [ 0x40, 0x55 ]+ s2x1 = [ 0x41, 0x56 ]++trackModelsGame1P3S :: IntMap ([String],[String])+trackModelsGame1P3S = IM.fromList+ -- simple+ [ (0x31, (["bank"], ["zban"]))+ , (0x3E, (["chi1"], ["zch1"]))+ , (0x3C, (["chi2"], ["zch2"]))+ , (0x6F, (["gwro"], ["zgwr"]))+ , (0x53, (["hpip"], ["zhpi"]))+ , (0x4A, (["inte"], ["zint"]))+ , (0x2C, (["lban"], ["zlba"]))+ , (0xA3, (["offi"], ["zoff"]))+ , (0x4B, (["offl"], ["zofl"]))+ , (0x4F, (["offr"], ["zofr"]))+ , (0x28, (["rban"], ["zrba"]))+ , (0x57, (["sofl"], ["zsol"]))+ , (0x5B, (["sofr"], ["zsor"]))+ , (0x46, (["spip"], ["zspi"]))+ , (0x0B, (["stur"], ["zstu"]))+ , (0x07, (["turn"], ["ztur"]))+ , (0x6D, (["wroa"], ["zwro"]))+ , (0x04, (["road"], ["zroa"]))++ -- complex+ , (0x42, (["tunn", "tun2"], ["ztun"]))+ , (0x35, (["btur"], ["zbtu"]))+ , (0x01, (["road", "fini"], ["zroa", "zfin"]))+ , (0x40, (["loo1", "loop"], ["zloo"]))+ , (0x44, (["pip2", "pipe"], ["zpip"]))+ , (0x55, (["vcor"], ["zvco"])) -- milyen ut van alatta?+ , (0x73, (["barr", "road"], ["zbar"])) -- jo az utkozes geometria? nem jo az akadaly utkozes es nincs ut utkozes modell+ ]+{-+todo:+,"cfen" - kerites sarok+,"zcfe" - kerites sarok utkozes modell++,"fenc" - kerites oldal+,"zfen" - kerites oldal utkozes modell+]+-}++trackModelsGame2P3S :: IntMap ([String],[String])+trackModelsGame2P3S = IM.fromList+ -- simple+ [ (0xAB, (["boat"], ["zboa"]))+ , (0x3A, (["brid"], ["zbri"]))+ , (0x22, (["elrd"], ["zelr"]))+ , (0x67, (["elsp"], ["zesp"]))+ , (0x9B, (["gass"], ["zgas"]))+ , (0x97, (["palm"], ["zpal"]))+ , (0x26, (["ramp"], ["zram"]))+ , (0xAF, (["rest"], ["zres"]))+ , (0x63, (["selr"], ["zser"]))+ , (0x6A, (["sest"], ["zses"]))+ , (0x61, (["sram"], ["zsra"]))+ , (0xA7, (["wind"], ["zwin"]))+ , (0x98, (["cact"], ["cact"]))+ , (0x99, (["tree"], ["tree"]))+ , (0x9A, (["tenn"], ["zten"]))+ , (0x9F, (["barn"], ["zbrn"]))++ -- complex+ , (0x75, (["lco0", "lco1"], ["zlco"]))+ , (0x79, (["rco0", "rco1"], ["zrco"]))++ -- special element+ -- road on 0x09 Terrain+ , (0xD0, (["rdup"], ["zrdu"]))+ ]+-- egy palyaelem alatt sincs terrain+{-+todo:+,"cld1" - 0x ??? felho+,"cld2" - 0x ??? felho+,"cld3" - 0x ??? felho+,"exp0" - 0x ???+,"exp1" - 0x ???+,"exp2" - 0x ???+,"exp3" - 0x ???+,"flag" - 0x ???++,"sigl" - 0x ??? bal kanyar jelzo tabla (tukrozni kell, fel kell cserelni az eszak <-> del iranyt)+,"sigr" - 0x ??? jobb kanyar jelzo tabla (tukrozni kell, fel kell cserelni az eszak <-> del iranyt)++,"truk" - 0x eszak fele nezo teherauto, innen gurul ki a veresenyzo kocsija+]+-}+
+ src/Stunts/Unpack.hs view
@@ -0,0 +1,88 @@+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}++module Stunts.Unpack where++import Control.Applicative+import Data.Bits+import Data.List+import Data.Vector ((!), (//))+import System.IO+import qualified Data.ByteString as SB+import qualified Data.ByteString.Lazy as LB+import qualified Data.Vector as V++data Dict = Empty | Leaf Int | Dict :|: Dict++loadResource :: FilePath -> IO [Int]+loadResource path = withBinaryFile path ReadMode $ \hdl ->+ force =<< unpack . map fromEnum <$> hGetContents hdl+ where+ force xs = last xs `seq` return xs++unpackResource :: LB.ByteString -> LB.ByteString+unpackResource = LB.pack . map fromIntegral . unpack . map fromIntegral . LB.unpack++unpackResource' :: SB.ByteString -> SB.ByteString+unpackResource' = SB.pack . map fromIntegral . unpack . map fromIntegral . SB.unpack++unpack :: [Int] -> [Int]+unpack (n:xs)+ | testBit n 7 = iterate pass (drop 3 xs) !! (n .&. 0x7f)+ | otherwise = pass (n:xs)+ where+ pass (compType:b1:b2:b3:xs) = take l $ case compType of+ 1 -> unpackRLE (drop 4 xs)+ 2 -> unpackVLE xs+ _ -> error "Unknown compression type!"+ where+ l = b1 + b2 `shiftL` 8 + b3 `shiftL` 16++unpackRLE :: [Int] -> [Int]+unpackRLE (escCount:xs) = decodeBytes $+ if escCount > 0x7f then rest else decodeSeq (escCodes !! 1) rest+ where+ (escCodes,rest) = splitAt (escCount .&. 0x7f) xs+ escLookup = V.replicate 0x100 0 // zip escCodes [1..]++ decodeSeq code = concat . go+ where+ go [] = []+ go (c:cs)+ | c == code = replicate rep run ++ go rest+ | otherwise = [c] : go cs+ where+ (run,_:rep:rest) = break (==code) cs++ decodeBytes [] = []+ decodeBytes (c:cs) = case escLookup ! c of+ 0 -> c : decodeBytes cs+ 1 -> let n:c:cs' = cs in replicate n c ++ decodeBytes cs'+ 3 -> let n1:n2:c:cs' = cs in replicate (n1 + n2 `shiftL` 8) c ++ decodeBytes cs'+ n -> let c:cs' = cs in replicate (n-1) c ++ decodeBytes cs'++unpackVLE :: [Int] -> [Int]+unpackVLE (widthsCount:xs) = unfoldr (readDict dict) stream+ where+ widthsLen = widthsCount .&. 0x7f+ (widths,xs') = splitAt widthsLen xs+ (alphabet,xs'') = splitAt (sum widths) xs'+ stream = [testBit x n | x <- xs'', n <- [7,6..0]]+ dict = buildDict widths alphabet++ buildDict ws as = go ws as 1 (0 :: Int) Empty+ where+ go [] _ _ _ d = d+ go (w:ws) as l n d+ | w == 0 = go ws as (l+1) (n `shiftL` 1) d+ | otherwise = go (w-1:ws) as' l (n+1) (add l d a)+ where+ a:as' = as+ add 0 _ a = Leaf a+ add l' Empty a = add (l'-1) Empty a :|: Empty+ add l' (d1 :|: d2) a+ | testBit n (l'-1) = d1 :|: add (l'-1) d2 a+ | otherwise = add (l'-1) d1 a :|: d2++ readDict (Leaf x) bs = Just (x,bs)+ readDict (d1 :|: d2) (b:bs) = readDict (if b then d2 else d1) bs+ readDict _ _ = Nothing
+ src/Utils.hs view
@@ -0,0 +1,103 @@+module Utils where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Data.IORef++import FRP.Elerea.Param+import Graphics.UI.GLFW as GLFW++import Graphics.LambdaCube as LC++-- Reactive helper functions++integral :: (Real p, Fractional t) => t -> Signal t -> SignalGen p (Signal t)+integral v0 s = transfer v0 (\dt v v0 -> v0+v*realToFrac dt) s++driveNetwork :: (MonadIO m) => (p -> IO (m a)) -> IO (Maybe p) -> m ()+driveNetwork network driver = do+ dt <- liftIO driver+ case dt of+ Just dt -> do+ join . liftIO $ network dt+ driveNetwork network driver+ Nothing -> return ()++-- OpenGL/GLFW boilerplate++initCommon :: String -> IO (Signal (Int, Int))+initCommon title = do+ initialize+ openWindow defaultDisplayOptions+ { displayOptions_numRedBits = 8+ , displayOptions_numGreenBits = 8+ , displayOptions_numBlueBits = 8+ , displayOptions_numDepthBits = 24+ , displayOptions_width = 1280+ , displayOptions_height = 720+-- , displayOptions_displayMode = Fullscreen+ }+ setWindowTitle title++ (windowSize,windowSizeSink) <- external (0,0)+ setWindowSizeCallback $ \w h -> windowSizeSink (fromIntegral w, fromIntegral h)++ return windowSize++-- FPS tracking++data State = State { frames :: IORef Int, t0 :: IORef Double }++fpsState :: IO State+fpsState = State <$> newIORef 0 <*> newIORef 0++updateFPS :: State -> Double -> IO ()+updateFPS state t1 = do+ let t = 1000*t1+ fR = frames state+ tR = t0 state+ modifyIORef fR (+1)+ t0' <- readIORef tR+ writeIORef tR $ t0' + t+ when (t + t0' >= 5000) $ do+ f <- readIORef fR+ let seconds = (t + t0') / 1000+ fps = fromIntegral f / seconds+ putStrLn (show f ++ " frames in " ++ show seconds ++ " seconds = "++ show fps ++ " FPS")+ writeIORef tR 0+ writeIORef fR 0++-- Continuous camera state (rotated with mouse, moved with arrows)+userCamera :: Real p => Vec3 -> Signal (FloatType, FloatType) -> Signal (Bool, Bool, Bool, Bool, Bool)+ -> SignalGen p (Signal (Vec3, Vec3, Vec3, (FloatType, FloatType)))+userCamera p mposs keyss = transfer2 (p,zero,zero,(0,0)) calcCam mposs keyss+ where+ d0 = Vec4 0 0 (-1) 1+ u0 = Vec4 0 1 0 1+ calcCam dt (dmx,dmy) (ka,kw,ks,kd,turbo) (p0,_,_,(mx,my)) = (p',d,u,(mx',my'))+ where+ f0 c n = if c then (&+ n) else id+ p' = foldr1 (.) [f0 ka (v &* (-t)),f0 kw (d &* t),f0 ks (d &* (-t)),f0 kd (v &* t)] p0+ k = if turbo then 100 else 30+ t = k * realToFrac dt+ mx' = dmx + mx+ my' = dmy + my+ rm = fromProjective $ rotationEuler $ Vec3 (mx' / 100) (my' / 100) 0+ d = trim $ rm *. d0 :: Vec3+ u = trim $ rm *. u0 :: Vec3+ v = LC.normalize $ d &^ u++followCamera :: FloatType -> FloatType -> FloatType -> Signal Proj4 -> SignalGen p (Signal (Vec3, Vec3))+followCamera height minDist maxDist target = transfer (Vec3 (-maxDist) height 0, Vec3 1 0 0) follow target+ where+ follow _dt tproj (pos,_dir) = (pos',tpos &- pos')+ where+ Mat4 _ _ _ tpos4 = fromProjective (tproj .*. translation (Vec3 0 height 0))+ tpos = trim tpos4+ tdir = tpos &- pos+ dist = len tdir+ pos'+ | dist < minDist = pos &+ (normalize tdir &* (dist-minDist))+ | dist > maxDist = pos &+ (normalize tdir &* (dist-maxDist))+ | otherwise = pos
+ stunts.cabal view
@@ -0,0 +1,64 @@+Name: stunts+Version: 0.1.0+Cabal-Version: >= 1.2+Synopsis: A revival of the classic game Stunts (LambdaCube tech demo)+Category: Graphics+Description:+ A revival of the classic racing game Stunts to serve as a+ non-toy-sized example for LambdaCube. In order to make it work, you+ need to download the original game as per the instructions given by+ the program.+ .+ The program contains screenshotting functionality that allows you to+ capture frames as separate PNG files to produce movies with a smooth+ frame rate. To enable, install with the @capture@ flag:+ .+ @cabal install --flags=capture@+ .+ It is also possible to compile a version of the program that looks+ for the resource files in the current directory by enabling the+ @portable@ flag.++Author: Csaba Hruska, Gergely Patai+Maintainer: csaba (dot) hruska (at) gmail (dot) com+Copyright: (c) 2011, Csaba Hruska+Homepage: http://www.haskell.org/haskellwiki/LambdaCubeEngine+Bug-Reports: http://code.google.com/p/lambdacube/issues+License: BSD3+License-File: LICENSE+Stability: experimental+Build-Type: Simple+Extra-Source-Files:+ README+ src/GameData.hs+ src/GamePhysics.hs+ src/Stunts/Color.hs+ src/Stunts/Loader.hs+ src/Stunts/Track.hs+ src/Stunts/Unpack.hs+ src/Utils.hs++Data-Files:+ media/newstunts.zip++Flag Capture+ Description: Enable the continuous screen capture functionality.+ Default: False++Flag Portable+ Description: Compile a version that looks for resources in the current directory.+ Default: False++Executable stunts+ HS-Source-Dirs: src+ Main-IS: Main.hs+ Extensions: CPP+ GHC-Options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -O2 -fspec-constr-count=6 -rtsopts+ Build-Depends: base >= 4 && < 5, directory, random, mtl, lambdacube-engine, lambdacube-bullet, bullet, elerea, GLFW-b, bytestring, binary, containers, vector++ if flag(Capture)+ Build-Depends: Codec-Image-DevIL+ CPP-Options: -DCAPTURE++ if flag(Portable)+ CPP-Options: -DPORTABLE