stunts-0.1.2: src/GameData.hs
{-# 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.Ord
import Graphics.LambdaCube as LC
import Stunts.Color
import Stunts.Loader
import Stunts.Track
import Stunts.Unpack
import System.Random
import qualified Data.Vector as V
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]
toVMesh :: Model -> VMesh
toVMesh mdOrig = VMesh sml (Just vvb)
where
md = separateFaces mdOrig
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
vsm pty = VSubMesh "StuntsMaterial" 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, VVD_DIFFUSE d, VVD_SPECULAR s]
else error $ "not matching sizes: " ++ show (V.length n) ++ " " ++ show (V.length v)
sml = map groupToSubMesh $ groupSetBy (comparing (prMaterials &&& prType)) $ mdPrimitives md
genNormal (a:b:c:_) = normalize $ (vc &- va) &^ (vb &- va)
where
va = v V.! a
vb = v V.! b
vc = v V.! c
genNormal _ = zero
genMat pr = (Vec4 r g b 1, Vec3 d z shiny)
where
i = head (prMaterials pr)
Material pattern rgb _ shiny = materialMap IM.! i
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
z = if i `elem` [16,101,102,103,104,105] then 1.00001
else if prZBias pr then 1 else 1.000005
(nf,df,sf) = V.unzip3 $ V.fromList [(genNormal (prIndices pr), d, s) | pr <- mdPrimitives md, let (d,s) = genMat pr]
i = V.fromList [ix | (ix,pr) <- zip [0..] (mdPrimitives md), _ <- prIndices pr]
n = V.backpermute nf i
d = V.backpermute df i
s = V.backpermute sf i
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..] }
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
let loadRes n = readResources <$> unpackResource <$> LC.readFile n
loadVMesh n = M.map (toVMesh . runGet getModel) <$> loadRes n
loadCarVMesh n = M.mapWithKey (\k -> toVMesh . 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
isNewFace _ = False
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]
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)
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 (wheelBase 16))]) | (p,w,r) <- carWheels],
mkVMesh' (terrain ++ clouds ++ fence),
mkVMesh' track,
startPos,
carSim
)