Library.hs

{-# LANGUAGE OverloadedStrings #-}

module Models.Library
    (Library,
     newLibrary,
     lookupModel)
    where

import Quality
import Data.Maybe
import Data.Map as Map
import RSAGL.Modeling hiding (model)
import Control.Concurrent.STM
import Control.Monad
import GHC.Conc
import PrioritySync.PrioritySync
import System.IO
import Control.Concurrent.MVar

import Models.LibraryData

import Models.Terrain
import Models.QuestionMark
import Models.Tree
import Models.Encephalon
import Models.Recreant
import Models.Androsynth
import Models.Ascendant
import Models.Caduceator
import Models.Reptilian
import Models.PhaseWeapons
import Models.MachineParts
import Models.Sky
import Models.CyborgType4
import Models.EnergyThings
import Models.EnergySwords
import Models.Spheres
import Models.Monolith
import Models.Stargate

-- |
-- Get the modeling data for a named library model.
--
toModel :: LibraryModel -> Quality -> Modeling ()
toModel (TerrainTile s) = terrainTile s
toModel (SimpleModel LeafyBlob) = const $ leafy_blob
toModel (SimpleModel TreeBranch) = const $ tree_branch
toModel (SkySphere sky_info) = const $ makeSky sky_info
toModel (SunDisc sun_info) = const $ makeSun sun_info
toModel (SimpleModel QuestionMark) = const $ question_mark
toModel NullModel = const $ return ()
toModel (SimpleModel Encephalon) = encephalon
toModel (SimpleModel Recreant) = recreant
toModel (SimpleModel Androsynth) = androsynth
toModel (SimpleModel Caduceator) = caduceator
toModel (SimpleModel Reptilian) = reptilian
toModel (SimpleModel AscendantGlow) = ascendant_glow
toModel (SimpleModel PhasePistol) = phase_pistol
toModel (SimpleModel Phaser) = phaser
toModel (SimpleModel PhaseRifle) = phase_rifle
toModel (SimpleModel GasSphere) = gasSphere
toModel (SimpleModel MetalSphere) = metalSphere
toModel (SimpleModel ChromaliteSphere) = chromaliteSphere
toModel (SimpleModel MachineArmLower) = machine_arm_lower
toModel (SimpleModel MachineArmUpper) = machine_arm_upper
toModel (SimpleModel CaduceatorArmLower) = caduceator_arm_lower
toModel (SimpleModel CaduceatorArmUpper) = caduceator_arm_upper
toModel (SimpleModel ReptilianLegLower) = reptilian_leg_lower
toModel (SimpleModel ReptilianLegUpper) = reptilian_leg_upper
toModel (SimpleModel ReptilianArmLower) = reptilian_arm_lower
toModel (SimpleModel ReptilianArmUpper) = reptilian_arm_upper
toModel (SimpleModel ThinLimb) = thin_limb
toModel (SimpleModel CyborgType4Dome) = cyborg_type_4_dome
toModel (SimpleModel CyborgType4Base) = cyborg_type_4_base
toModel (SimpleModel CyborgType4HyperspaceDisc) = cyborg_type_4_hyperspace_disc
toModel (SimpleModel CyborgType4HyperspaceRotor) =
        cyborg_type_4_hyperspace_rotor
toModel (SimpleModel CyborgType4HyperspaceStabilizer) =
        cyborg_type_4_hyperspace_stabilizer
toModel (EnergyThing EnergyCylinder c) = energyCylinder c
toModel (EnergyThing EnergySword c) = energySword c 3
toModel (SimpleModel Monolith) = monolith
toModel (SimpleModel Portal) = portal

-- |
-- Models that should be displayed at lower quality.
--
downgraded_models :: [LibraryModel]
downgraded_models =
    Prelude.map toLibraryModel
        [LeafyBlob,TreeBranch,
         GasSphere,MetalSphere,ChromaliteSphere,MachineArmLower,
         MachineArmUpper,CaduceatorArmLower,CaduceatorArmUpper,
         ReptilianLegLower,ReptilianLegUpper,ReptilianArmLower,
         ReptilianArmUpper, ThinLimb]

-- |
-- Sometimes we want to constrain the quality of some models.
--
forceQuality :: LibraryModel -> Quality -> Quality
-- ambient box, LOD doesn't affect appearance
forceQuality (SimpleModel CyborgType4HyperspaceRotor) = const Bad
-- terrain just isn't that interesting
forceQuality (TerrainTile _) = min Poor
forceQuality x | x `elem` downgraded_models = \q -> case q of
    Bad -> Bad
    Poor -> Bad
    Good -> Poor
    Super -> Poor
forceQuality _ = id

-- |
-- Models to build at start time.
--
essential_library_models :: [LibraryModel]
essential_library_models =
    Prelude.map TerrainTile known_terrain_types ++
    Prelude.map SimpleModel [minBound..maxBound] ++
    [EnergyThing x y | x <- [minBound..maxBound],
                       y <- [minBound..maxBound]]

modelPriority :: Quality -> LibraryModel -> Integer
modelPriority Bad model | model `elem` essential_library_models = 0
modelPriority q (SkySphere {}) = 10 * qualityPriority q
modelPriority q _ = qualityPriority q

qualityPriority :: Quality -> Integer
qualityPriority Bad = 1
qualityPriority Poor = 2
qualityPriority Good = 4
qualityPriority Super = 8

-- |
-- A library of named models.  Models are generated on demand, but models
-- known in all_library_models are generated at worst quality when the library
-- is first initialized.
--
data Library = Library {
    library_cache :: TVar (Map.Map (Quality,LibraryModel)
                                   (TVar (Maybe BakedModel))),
    library_wrapper :: Quality -> LibraryModel -> IO () -> IO () }

-- |
-- Create a new library.
-- Only one Library should be needed per process instance.
--
newLibrary :: IO Library
newLibrary =
    do task_pool <- newTaskPool fast_queue_configuration
                                (max 1 $ numCapabilities - 2)
                                ()
       startQueue task_pool
       cache <- newTVarIO Map.empty
       loading_stdout_mvar <- newMVar ()
       let lib = Library cache $ \q m actionIO ->
                     do _ <- dispatch (schedule task_pool $ modelPriority q m)
                                      actionIO
                        return ()
       forM_ essential_library_models $ \x -> lookupModel lib x Bad
       let waitFor x = atomically $
                  do b <- isLoaded lib x
                     when (not b) retry
       forM_ essential_library_models $ \x -> forkIO $
           do waitFor x
              modifyMVar_ loading_stdout_mvar $ const $
                  do hPutStrLn stderr $ "Pregenerated model: " ++ show x
                     hPutStrLn stderr . modelInfo =<< lookupModel lib x Bad
                     return ()
       forM_ essential_library_models $ \x -> waitFor x
       return lib

-- |
-- Get a library model.  If the model is not available at the requested quality
-- level, a poorer model will be provided instead, and a background thread will
-- launch to begin generating the model at the requested level of detail.
--
lookupModel :: Library -> LibraryModel -> Quality -> IO IntermediateModel
lookupModel lib model q_ = (id =<<) $ atomically $
    do let q = forceQuality model q_
       cache <- readTVar $ library_cache lib
       let m_var = Map.lookup (q,model) cache
       case m_var of
           Just var ->
               do m_result <- liftM (fmap toIntermediateModel) $ readTVar var
                  case m_result of
                      Just result -> return $ return result
                      Nothing | model == NullModel ->
                          return $ atomically $ liftM toIntermediateModel $
                              maybe retry return =<< readTVar var
                      Nothing | q == Bad -> return $
                          lookupModel lib NullModel Bad
                      Nothing -> return $
                          lookupModel lib model (pred q)
           Nothing ->
               do target <- newTVar Nothing
                  writeTVar (library_cache lib) $
                      Map.insert (q,model) target cache
                  return $
                      do library_wrapper lib q model $
                             bakeAndStore target model q
                         lookupModel lib model q

isLoaded :: Library -> LibraryModel -> STM Bool
isLoaded lib model =
    do cache <- readTVar $ library_cache lib
       let m_var = Map.lookup (Bad,model) cache
       maybe (return False) (liftM isJust . readTVar) m_var

bakeAndStore :: TVar (Maybe BakedModel) -> LibraryModel -> Quality -> IO ()
bakeAndStore target model q =
    do result <- bakeModel $ buildIntermediateModel (qualityToVertices q)
                                                    (toModel model q)
       atomically $ writeTVar target $ Just result