{-# 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
             )