diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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= - 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) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/media/newstunts.zip b/media/newstunts.zip new file mode 100644 Binary files /dev/null and b/media/newstunts.zip differ diff --git a/src/GameData.hs b/src/GameData.hs new file mode 100644 --- /dev/null +++ b/src/GameData.hs @@ -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 + ) diff --git a/src/GamePhysics.hs b/src/GamePhysics.hs new file mode 100644 --- /dev/null +++ b/src/GamePhysics.hs @@ -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) diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 " 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 diff --git a/src/Stunts/Color.hs b/src/Stunts/Color.hs new file mode 100644 --- /dev/null +++ b/src/Stunts/Color.hs @@ -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 + ] diff --git a/src/Stunts/Loader.hs b/src/Stunts/Loader.hs new file mode 100644 --- /dev/null +++ b/src/Stunts/Loader.hs @@ -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 diff --git a/src/Stunts/Track.hs b/src/Stunts/Track.hs new file mode 100644 --- /dev/null +++ b/src/Stunts/Track.hs @@ -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 +] +-} + diff --git a/src/Stunts/Unpack.hs b/src/Stunts/Unpack.hs new file mode 100644 --- /dev/null +++ b/src/Stunts/Unpack.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -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 diff --git a/stunts.cabal b/stunts.cabal new file mode 100644 --- /dev/null +++ b/stunts.cabal @@ -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