stunts-0.1.0: 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.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
)