{-# OPTIONS_GHC -XFlexibleContexts #-} module Language.Lsl.WorldDef(Avatar(..), AvatarControlListener(..), Prim(..), PrimFace(..), TextureInfo(..), Flexibility(..), LightInfo(..), LSLObject(..), ObjectDynamics(..), PositionTarget(..), RotationTarget(..), PrimType(..), FullWorldDef(..), Region(..), Parcel(..), InventoryItemIdentification(..), InventoryItem(..), InventoryInfo(..), InventoryItemData(..), Script(..), ScriptId, Attachment(..), CameraParams(..), Email(..), WebHandling(..), -- imported types LSLValue(..), Event(..), ScriptImage, defaultAvatar, defaultCamera, defaultDynamics, isInvScriptItem, isInvBodyPartItem, isInvGestureItem, isInvClothingItem, isInvTextureItem, isInvSoundItem, isInvAnimationItem, isInvLandmarkItem, isInvNotecardItem, isInvObjectItem, inventoryInfoPermValue, defaultInventoryPermissions, inventoryItemName, inventoryItemNames, scriptInventoryItem, findByInvName, findByInvKey, emptyPrim, primPhantomBit, primPhysicsBit, worldFromFullWorldDef, worldElement, defaultRegions, mkScript ) where import Control.Monad(when,foldM) import Control.Monad.Error(MonadError(..),ErrorT(..)) import Control.Monad.Writer(tell,lift,runWriterT) import qualified Control.Monad.State as SM(get,put,State) import Data.List(find) import qualified Data.Map as M import qualified Data.IntMap as IM import Data.Maybe(isNothing) import Language.Lsl.Internal.DOMProcessing(ElemAcceptor(..),Element(..),findOrDefault,findValueOrDefault,elementList, findOptionalElement,elementsOnly,findValue,findElement,findSimple,simpleElement, findSimpleOrDefault,valueAcceptor,elementListWith,matchChoice) import Language.Lsl.Internal.Evaluation(Event(..)) import Language.Lsl.Internal.Exec(ScriptImage,initLSLScript) import Language.Lsl.Internal.Key(mkKey,nullKey) import Language.Lsl.Internal.Type(LSLValue(..)) import Language.Lsl.Internal.Util(mlookup,readM,Permutation3(..),rotationsToQuaternion) type KeyManagerM = ErrorT String (SM.State (M.Map String String,Integer)) type ScriptId = (String,String) data FullWorldDef = FullWorldDef { fullWorldDefMaxTime :: Int, fullWorldDefSliceSize :: Int, fullWorldDefWebHandling :: WebHandling, fullWorldDefEventHandler :: Maybe String, fullWorldDefObjects :: [LSLObject], fullWorldDefPrims :: [Prim], fullWorldDefAvatars :: [Avatar], fullWorldDefRegions :: [((Int,Int),Region)], fullWorldDefInitialKeyIndex :: Integer } deriving (Show) data WebHandling = WebHandlingByFunction | WebHandlingByDoingNothing | WebHandlingByInternet { webHandlingTimeout :: Float } deriving (Show) data LSLObject = LSLObject { primKeys :: [String], objectDynamics :: !ObjectDynamics } deriving (Show) data ObjectDynamics = ObjectDynamics { objectPosition :: (Float,Float,Float), objectRotation :: (Float,Float,Float,Float), objectVelocity :: (Float,Float,Float), objectForce :: ((Float,Float,Float),Bool), objectBuoyancy :: Float, objectImpulse :: (((Float,Float,Float),Bool),Int), objectTorque :: ((Float,Float,Float),Bool), objectRotationalImpulse :: (((Float,Float,Float),Bool),Int), objectOmega :: (Float,Float,Float), objectPositionTarget :: !(Maybe PositionTarget), objectRotationTarget :: !(Maybe RotationTarget), objectVolumeDetect :: Bool } deriving (Show) defaultDynamics = ObjectDynamics { objectPosition = (0,0,0), objectRotation = (0,0,0,1), objectVelocity = (0,0,0), objectForce = ((0,0,0),False), objectBuoyancy = 0, objectImpulse = (((0,0,0),False),0), objectTorque = ((0,0,0),False), objectRotationalImpulse = (((0,0,0),False),0), objectOmega = (0,0,0), objectPositionTarget = Nothing, objectRotationTarget = Nothing, objectVolumeDetect = False } data PositionTarget = Repel { positionTargetTau :: Float, positionTargetOverWater :: Bool, positionTargetHeight :: Float } | Hover { positionTargetTau :: Float, positionTargetOverWater :: Bool, positionTargetHeight :: Float } | PositionTarget { positionTargetTau :: Float, positionTargetLocation :: (Float,Float,Float), positionTargetSetBy :: ScriptId } deriving (Show) data RotationTarget = RotationTarget { rotationTarget :: (Float,Float,Float,Float), rotationTargetStrength :: Float, rotationTargetTau :: Float } deriving (Show) data Avatar = Avatar { avatarKey :: String, avatarName :: String, avatarActiveGroup :: Maybe String, avatarRegion :: (Int,Int), avatarPosition :: (Float,Float,Float), avatarRotation :: (Float,Float,Float,Float), avatarHeight :: Float, avatarState :: Int, avatarInventory :: [InventoryItem], avatarCameraPosition :: (Float,Float,Float), avatarCameraRotation :: (Float,Float,Float,Float), avatarCameraControlParams :: CameraParams, avatarActiveAnimations :: [(Maybe Int,String)], avatarAttachments :: IM.IntMap String, avatarEventHandler :: !(Maybe (String,[(String,LSLValue Float)])), avatarControls :: !Int, avatarControlListener :: !(Maybe AvatarControlListener) } deriving (Show) data AvatarControlListener = AvatarControlListener { avatarControlListenerMask :: !Int, avatarControlListenerScript :: !(String,String) } deriving (Show) data CameraParams = CameraParams { cameraActive :: Bool, cameraBehindednessAngle :: Float, cameraBehindednessLag :: Float, cameraDistance :: Float, cameraFocus :: Maybe (Float,Float,Float), cameraFocusLag :: Float, cameraFocusLocked :: Bool, cameraFocusOffset :: (Float,Float,Float), cameraFocusThreshold :: Float, cameraPitch :: Float, cameraPosition :: Maybe (Float,Float,Float), cameraPositionLag :: Float, cameraPositionLocked :: Bool, cameraPositionThreshold :: Float } deriving Show defaultCamera = CameraParams { cameraActive = False, cameraBehindednessAngle = 10.0, cameraBehindednessLag = 0, cameraDistance = 3.0, cameraFocus = Nothing, cameraFocusLag = 0, cameraFocusLocked = False, cameraFocusOffset = (0,0,0), cameraFocusThreshold = 1.0, cameraPitch = 0.0, cameraPosition = Nothing, cameraPositionLag = 0.1, cameraPositionLocked = False, cameraPositionThreshold = 1 } defaultAvatar key = Avatar { avatarKey = key, avatarName = "Default Avatar", avatarActiveGroup = Nothing, avatarRegion = (0,0), avatarPosition = (128.0,128.0,0.0), avatarRotation = (0.0, 0.0, 0.0, 1.0), avatarHeight = 2, avatarState = 0, avatarInventory = [], avatarCameraPosition = (128.0,128.0,0.0), avatarCameraRotation = (0,0,0,1), avatarCameraControlParams = defaultCamera, avatarActiveAnimations = [], avatarAttachments = IM.empty, avatarEventHandler = Nothing, avatarControls = 0, avatarControlListener = Nothing } -- these are bit INDEXES not MASKS (0 == least significant bit) primPhantomBit :: Int primPhantomBit = 4 primPhysicsBit :: Int primPhysicsBit = 0 data InventoryItemData = InvScript { invScriptLibId :: String, invScriptState :: Maybe (ScriptImage Float) } | InvBodyPart | InvGesture | InvClothing | InvTexture | InvSound { invSoundDuration :: Float } | InvAnimation { invAnimationDuration :: Maybe Float } | InvLandmark { invLandmarkLocation :: ((Int,Int),(Float,Float,Float)) } | InvNotecard { invNotecardLines :: [String] } | InvObject { invObjectPrims :: [Prim] } deriving (Show) isInvScript (InvScript _ _) = True isInvScript _ = False isInvBodyPart InvBodyPart = True isInvBodyPart _ = False isInvGesture InvGesture = True isInvGesture _ = False isInvClothing InvClothing = True isInvClothing _ = False isInvTexture InvTexture = True isInvTexture _ = False isInvSound (InvSound _) = True isInvSound _ = False isInvAnimation (InvAnimation _) = True isInvAnimation _ = False isInvLandmark (InvLandmark _) = True isInvLandmark _ = False isInvNotecard (InvNotecard _) = True isInvNotecard _ = False isInvObject (InvObject _) = True isInvObject _ = False isInvScriptItem = isInvScript . inventoryItemData isInvBodyPartItem = isInvBodyPart . inventoryItemData isInvGestureItem = isInvGesture . inventoryItemData isInvClothingItem = isInvClothing . inventoryItemData isInvTextureItem = isInvTexture . inventoryItemData isInvSoundItem = isInvSound . inventoryItemData isInvAnimationItem = isInvAnimation . inventoryItemData isInvLandmarkItem = isInvLandmark . inventoryItemData isInvNotecardItem = isInvNotecard . inventoryItemData isInvObjectItem = isInvObject . inventoryItemData newtype InventoryItemIdentification = InventoryItemIdentification { inventoryItemNameKey :: (String,String) } deriving (Show) -- data InventoryItem a = InventoryItem { inventoryItemIdentification :: InventoryItemIdentification, -- inventoryItemInfo :: InventoryInfo, -- inventoryItemData :: a } deriving (Show) data InventoryInfo = InventoryInfo { inventoryInfoCreator :: String, --inventoryInfoOwner :: String, inventoryInfoPerms :: (Int,Int,Int,Int,Int) } deriving (Show) data InventoryItem = InventoryItem { inventoryItemIdentification :: InventoryItemIdentification, inventoryItemInfo :: InventoryInfo, inventoryItemData :: InventoryItemData } deriving (Show) --inventoryItemInfoMap = map ( \ item -> (inventoryItemIdentification item, inventoryItemInfo item)) inventoryItemName = fst . inventoryItemNameKey . inventoryItemIdentification inventoryItemNames = map inventoryItemName scriptInventoryItem s k id = InventoryItem (InventoryItemIdentification (s,k)) (InventoryInfo "" defaultInventoryPermissions) (InvScript id Nothing) inventoryItemIdentifications = map inventoryItemIdentification findByInvName name = find ((== name) . (fst . inventoryItemNameKey . inventoryItemIdentification)) findByInvKey key = find ((== key) . (snd . inventoryItemNameKey . inventoryItemIdentification)) inventoryInfoPermValue 0 (i,_,_,_,_) = return i inventoryInfoPermValue 1 (_,i,_,_,_) = return i inventoryInfoPermValue 2 (_,_,i,_,_) = return i inventoryInfoPermValue 3 (_,_,_,i,_) = return i inventoryInfoPermValue 4 (_,_,_,_,i) = return i inventoryInfoPermValue i _ = throwError ("no such perm mask - " ++ show i) defaultInventoryPermissions :: (Int,Int,Int,Int,Int) defaultInventoryPermissions = (0xffffffff,0xffffffff,0xffffffff,0xffffffff,0xffffffff) data Prim = Prim { primName :: String, primKey :: String, primParent :: Maybe String, primDescription :: String, primInventory :: [InventoryItem], primOwner :: String, primGroup :: Maybe String, primCreator :: String, primPosition :: (Float, Float, Float), primRotation :: (Float, Float, Float, Float), primScale :: (Float, Float, Float), primFaces :: [PrimFace], primFlexibility :: Maybe Flexibility, primMaterial :: Int, primStatus :: Int, primVehicleFlags :: Int, primLight :: Maybe LightInfo, primTempOnRez :: Bool, primTypeInfo :: PrimType, primPermissions :: [Int], primAllowInventoryDrop :: Bool, primSitTarget :: Maybe ((Float,Float,Float),(Float,Float,Float,Float)), primSittingAvatar :: Maybe String, primPendingEmails :: [Email], primPassTouches :: Bool, primPassCollisions :: Bool, primPayInfo :: (Int,Int,Int,Int,Int), primAttachment :: Maybe Attachment, primRemoteScriptAccessPin :: Int } deriving (Show) data PrimType = PrimTypeUnknown | PrimType { primVersion :: Int, -- 1 or 9 primTypeCode :: Int, primHoleshape :: Int, primCut :: (Float,Float,Float), primTwist :: (Float,Float,Float), primHolesize :: (Float,Float,Float), primTopshear :: (Float, Float, Float), primHollow :: Float, primTaper :: (Float,Float,Float), primAdvancedCut :: (Float,Float,Float), primRadiusOffset :: Float, primRevolutions :: Float, primSkew :: Float, primSculptTexture :: Maybe String, primSculptType :: Int } deriving (Show) basicBox = PrimType 9 0 0 (0,1,0) (0,0,0) (0,0,0) (0,0,0) 0 (0,0,0) (0,1,0) 0 0 0 Nothing 0 data Attachment = Attachment { attachmentKey :: String, attachmentPoint :: Int } deriving (Show) data LightInfo = LightInfo { lightColor :: (Float,Float,Float), lightIntensity :: Float, lightRadius :: Float, lightFalloff :: Float } deriving (Show) data Flexibility = Flexibility { flexSoftness :: Int, flexGravity :: Float, flexFriction :: Float, flexWind :: Float, flexTension :: Float, flexForce :: (Float,Float,Float) } deriving (Show) data PrimFace = PrimFace { faceAlpha :: Float, faceColor :: (Float,Float,Float), faceShininess :: Int, faceBumpiness :: Int, faceFullbright :: Bool, faceTextureMode :: Int, faceTextureInfo :: TextureInfo } deriving (Show) defaultFace = PrimFace 1.0 (1.0,1.0,1.0) 0 0 False 0 defaultTextureInfo data TextureInfo = TextureInfo { textureKey :: String, textureRepeats :: (Float,Float,Float), textureOffsets :: (Float,Float,Float), textureRotation :: Float } deriving (Show) defaultTextureInfo = TextureInfo "" (1.0,1.0,0.0) (0.0,0.0,0.0) 0.0 data Email = Email { emailSubject :: String, emailAddress :: String, -- sender address emailMessage :: String, emailTime :: Int } deriving (Show) emptyPrim name key = Prim { primName = name, primKey = key, primParent = Nothing, primDescription = "", primInventory = [], primOwner = "", primGroup = Nothing, primCreator = "", primPosition = (0.0,0.0,0.0), primRotation = (0.0,0.0,0.0,1.0), primScale = (1.0,1.0,1.0), primFaces = replicate 6 defaultFace, primFlexibility = Nothing, primMaterial = 0, primStatus = 0x0e, primVehicleFlags = 0, primLight = Nothing, primTempOnRez = False, primTypeInfo = basicBox, primPermissions = [0], primAllowInventoryDrop = False, primSitTarget = Nothing, primSittingAvatar = Nothing, primPendingEmails = [], primPassTouches = False, primPassCollisions = False, primPayInfo = ( -2, -2, -2, -2, -2), primAttachment = Nothing, primRemoteScriptAccessPin = 0 } data Region = Region { regionName :: String, regionFlags :: Int, regionParcels :: [Parcel] } deriving (Show) data Parcel = Parcel { parcelName :: String, parcelDescription :: String, parcelBoundaries :: (Int,Int,Int,Int), -- bottom, top, left, right aka south,north,west,east parcelOwner :: String, parcelFlags :: Int, parcelBanList :: [(String,Maybe Int)], parcelPassList :: [(String,Maybe Int)] } deriving (Show) defaultRegions :: String -> [((Int,Int),Region)] defaultRegions owner = [ ((0,0), Region { regionName = "Region_0_0", regionFlags = 0, regionParcels = [Parcel "parcel_0" "default parcel" (0,256,0,256) owner 0xffffffff [] []] }) ] data Script = Script { scriptImage :: !(ScriptImage Float), scriptActive :: Bool, scriptPermissions :: M.Map String Int, scriptLastPerm :: Maybe String, scriptStartTick :: Int, scriptLastResetTick :: Int, scriptEventQueue :: [Event Float], scriptStartParameter :: Int, scriptCollisionFilter :: !(String,String,Bool), scriptTargetIndex :: !Int, scriptPositionTargets :: !(IM.IntMap ((Float,Float,Float), Float)), scriptRotationTargets :: !(IM.IntMap ((Float,Float,Float,Float), Float)) } deriving (Show) mkScript img = Script { scriptImage = img, scriptActive = True, scriptPermissions = M.empty, scriptLastPerm = Nothing, scriptStartTick = 0, scriptLastResetTick = 0, scriptEventQueue = [Event "state_entry" [] M.empty], scriptStartParameter = 0, scriptCollisionFilter = ("",nullKey,True), scriptTargetIndex = 0, scriptPositionTargets = IM.empty, scriptRotationTargets = IM.empty } worldFromFullWorldDef worldBuilder fwd lib scripts = do let primMap = mkPrimMap (fullWorldDefPrims fwd) primMap' <- checkObjects primMap (fullWorldDefObjects fwd) -- prove all the prims in all the objects exists let activeScripts = concat (map (\ prim -> map (\ item -> ((primKey prim, fst $ inventoryItemNameKey $ inventoryItemIdentification item), invScriptLibId $ inventoryItemData item)) (filter isInvScriptItem $ primInventory prim)) (M.elems primMap')) (activatedScripts,log) <- runWriterT (activateScripts activeScripts scripts primMap') return $ worldBuilder (fullWorldDefSliceSize fwd) (fullWorldDefMaxTime fwd) [] lib scripts (M.fromList $ mkAvatarLookup (fullWorldDefAvatars fwd)) (mkObjectMap (fullWorldDefObjects fwd)) primMap' (M.fromList activatedScripts) (M.fromList (fullWorldDefRegions fwd)) (fullWorldDefInitialKeyIndex fwd) (fullWorldDefWebHandling fwd) (fullWorldDefEventHandler fwd) log fctx :: MonadError String m => String -> Either String a -> m a fctx s (Left s') = throwError s fctx _ (Right v) = return v maybe2Either Nothing = Left "failed" maybe2Either (Just v) = Right v mkPrimMap prims = M.fromList [(primKey p, p) | p <- prims] --let tuples = map (\ p -> (primKey p, p)) prims in M.fromList tuples mkObjectMap objects = M.fromList [ (p, o) | o@(LSLObject { primKeys = (p:_) }) <- objects ] mkAvatarLookup avatars = [ (avatarKey a,a) | a <- avatars] checkObject primMap o = foldM checkPrim primMap (primKeys o) where root = head (primKeys o) checkPrim m k = case M.lookup k m of Nothing -> fail ("prim " ++ k ++ " not found in definition") Just prim -> return (if (k == root) then m else M.insert k (prim { primParent = Just root }) m) checkObjects primMap os = foldM checkObject primMap os activateScripts scriptIdInfo compiledScripts primMap = mapM (activateScript compiledScripts primMap) scriptIdInfo >>= (\ ms -> return [ s | Just s <- ms ]) activateScript scripts primMap (k@(primKey,invName),(scriptID)) = do let script = case lookup scriptID scripts of Nothing -> fail "script not found" Just v -> v prim <- (lift . fctx ("looking up prim " ++ primKey ++ " failed")) (mlookup primKey primMap) when (isNothing (findByInvName invName (primInventory prim))) $ fail (invName ++ " doesn't exist in prim " ++ primKey) case script of Left ((_,s):_) -> tell [("script \"" ++ invName ++ "\" in prim " ++ primKey ++ " failed to activate because of error: " ++ s)] >> return Nothing Right code -> return $ Just (k,mkScript $ initLSLScript code) newKey xref = do (m,i) <- lift SM.get let k = mkKey i let m' = case xref of Nothing -> m Just v -> M.insert v k m lift $ SM.put (m',i+1) return k findRealKey k = lift SM.get >>= mlookup k . fst --worldElement :: ElemAcceptor KeyManagerM FullWorldDef worldElement = let f (Elem _ _ contents) = do (maxTime, c1) <- findValue "maxTime" (elementsOnly contents) (handler, c2) <- findOptionalElement (simpleElement "simEventHandler") c1 (sliceSizeStr, c3) <- findSimple "sliceSize" c2 (avatars,c4) <- findElement avatarsElement c3 (prims,c5) <- findElement primsElement c4 (objects,[]) <- findElement objectsElement c5 sliceSize <- readM sliceSizeStr (m,keyIndex) <- lift SM.get let webHandling = if isNothing handler then WebHandlingByDoingNothing else WebHandlingByFunction return (FullWorldDef maxTime sliceSize webHandling handler objects prims avatars (defaultRegions "") keyIndex) in ElemAcceptor "world-def" f activeScriptsElement :: ElemAcceptor KeyManagerM [((String,String),String)] activeScriptsElement = elementList "scripts" activeScriptElement activeScriptElement :: ElemAcceptor KeyManagerM ((String,String),String) activeScriptElement = ElemAcceptor "script" $ \ (Elem _ _ contents) -> do (primKey,c1) <- findSimple "primKey" (elementsOnly contents) realPrimKey <- findRealKey primKey (scriptName, c2) <- findSimple "scriptName" c1 (scriptId, []) <- findSimple "scriptId" c2 return ((realPrimKey,scriptName), scriptId) objectsElement :: ElemAcceptor KeyManagerM [LSLObject] objectsElement = elementList "objects" objectElement objectElement :: ElemAcceptor KeyManagerM LSLObject objectElement = ElemAcceptor "object" $ \ (Elem _ _ contents) -> do (position,c) <- findOrDefault (0,0,0) (vecAcceptor "position") (elementsOnly contents) (primKeys,[]) <- findElement (elementList "primKeys" (simpleElement "string")) c --(m,i) <- lift SM.get realPrimKeys <- mapM findRealKey primKeys return $ LSLObject realPrimKeys (defaultDynamics { objectPosition = position }) primsElement :: ElemAcceptor KeyManagerM [Prim] primsElement = elementList "prims" primElement primElement :: ElemAcceptor KeyManagerM Prim primElement = ElemAcceptor "prim" $ \ (Elem _ _ contents) -> do (name,c1) <- findSimple "name" (elementsOnly contents) (key,c2) <- findSimple "key" c1 realKey <- newKey (Just key) (description, c3) <- findSimpleOrDefault "" "description" c2 (scripts,c4) <- findElement (elementList "scripts" (scriptAcceptor "script")) c3 (owner,c5) <- findSimpleOrDefault "" "owner" c4 realOwner <- findRealKey owner (position,c6) <- findOrDefault (128.0,128.0,0.0) (vecAcceptor "position") c5 (eulerRotation,c7) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "rotation") c6 (scale,c8) <- findOrDefault (1.0,1.0,1.0) (vecAcceptor "scale") c7 (faces,c9) <- findOrDefault (replicate 6 defaultFace) (elementList "faces" (faceAcceptor "face")) c8 (flexibility,c10) <- findOptionalElement (flexibilityAcceptor "flexibility") c9 (material,c11) <- findValueOrDefault 0 "material" c10 (status,c12) <- findValueOrDefault 0x0e "status" c11 (light,c13) <- findOptionalElement (lightAcceptor "light") c12 (tempOnRez, c14) <- findValueOrDefault False "tempOnRez" c13 (typeInfo, c15) <- findOrDefault basicBox (primTypeAcceptor "typeInfo") c14 (permissions, c16) <- findOrDefault [0] (elementList "permissions" (valueAcceptor "int")) c15 (dropAllowed,c17) <- findValueOrDefault False "dropAllowed" c16 (inventory,[]) <- findOrDefault [] (elementListWith "inventory" acceptInventoryItem) c17 return Prim { primName = name, primKey = realKey, primParent = Nothing, primDescription = description, primInventory = scripts ++ inventory, primOwner = realOwner, primGroup = Nothing, primCreator = realOwner, primPosition = position, primRotation = rotationsToQuaternion P123 eulerRotation, primScale = scale, primFaces = faces, primFlexibility = flexibility, primMaterial = material, primStatus = status, primVehicleFlags = 0, primLight = light, primTempOnRez = tempOnRez, primTypeInfo = typeInfo, primPermissions = permissions, primAllowInventoryDrop = dropAllowed, primSitTarget = Nothing , primSittingAvatar = Nothing, primPendingEmails = [], primPassTouches = False, primPassCollisions = False, primPayInfo = (-2, -2, -2, -2, -2), primAttachment = Nothing, primRemoteScriptAccessPin = 0 } acceptInventoryItem e = matchChoice (map (uncurry mkInventoryItemAcceptor) [("notecardItem",acceptNotecardData), ("textureItem", acceptTextureData), ("bodyPartItem", acceptBodyPartData), ("clothingItem", acceptClothingData), ("gestureItem", acceptGestureData), ("soundItem", acceptSoundData), ("animationItem", acceptAnimationData), ("inventoryObjectItem", acceptInventoryObjectData), ("landmarkItem", acceptLandmarkData) ]) e acceptNotecardData contents = do (lines,c1) <- findOrDefault [] (elementList "lines" (simpleElement "string")) contents return (InvNotecard lines,c1) acceptTextureData contents = return (InvTexture,contents) acceptBodyPartData contents = return (InvBodyPart,contents) acceptClothingData contents = return (InvClothing,contents) acceptGestureData contents = return (InvGesture,contents) acceptSoundData contents = do (duration,c1) <- findValue "duration" contents return (InvSound duration,c1) acceptAnimationData contents = do (duration,c1) <- findValue "duration" contents return (InvAnimation (if duration == 0 then Nothing else Just duration),c1) acceptInventoryObjectData contents = do (prims,c1) <- findElement primsElement contents return (InvObject prims,c1) acceptLandmarkData contents = do (region,c1) <- findElement (regionAcceptor "region") contents (position, c2) <- findElement (vecAcceptor "position") c1 return (InvLandmark (region,position), c2) mkInventoryItemAcceptor s f = ElemAcceptor s $ \ (Elem _ _ contents) -> do let c0 = elementsOnly contents (name,c1) <- findSimple "name" c0 key <- newKey Nothing (creator,c2) <- findSimple "creator" c1 realCreator <- findRealKey creator (itemData,[]) <- f c2 return $ InventoryItem (InventoryItemIdentification (name, key)) (InventoryInfo creator defaultInventoryPermissions) itemData scriptAcceptor s = ElemAcceptor s $ \ (Elem _ _ contents) -> do let c0 = elementsOnly contents (scriptName, c1) <- findSimple "scriptName" c0 (scriptId, []) <- findSimple "scriptId" c1 k <- newKey Nothing return $ scriptInventoryItem scriptName k scriptId faceAcceptor s = ElemAcceptor s $ \ (Elem _ _ contents) -> do let c0 = elementsOnly contents (alpha,c1) <- findValueOrDefault 0.0 "alpha" c0 (color,c2) <- findOrDefault (1.0,1.0,1.0) (vecAcceptor "color") c1 (shininess, c3) <- findValueOrDefault 0 "shininess" c2 (bumpiness, c4) <- findValueOrDefault 0 "bumpiness" c3 (fullbright, c5) <- findValueOrDefault False "fullbright" c4 (textureMode, c6) <- findValueOrDefault 0 "textureMode" c5 (textureInfo, []) <- findOrDefault defaultTextureInfo (textureInfoAcceptor "textureInfo") c6 return PrimFace { faceAlpha = alpha, faceColor = color, faceShininess = shininess, faceBumpiness = bumpiness, faceFullbright = fullbright, faceTextureMode = textureMode, faceTextureInfo = textureInfo } textureInfoAcceptor s = ElemAcceptor s $ \ (Elem _ _ contents) -> do let c0 = elementsOnly contents (name,c1) <- findSimpleOrDefault "" "name" c0 (repeats,c2) <- findOrDefault (1.0,1.0,1.0) (vecAcceptor "repeats") c1 (offsets,c3) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "offsets") c2 (rotation,[]) <- findValueOrDefault 0.0 "rotation" c3 return TextureInfo { textureKey = name, textureRepeats = repeats, textureOffsets = offsets, textureRotation = rotation } flexibilityAcceptor s = ElemAcceptor s $ \ (Elem _ _ contents) -> do let c0 = elementsOnly contents (softness,c1) <- findValueOrDefault 0 "softness" c0 (gravity,c2) <- findValueOrDefault 1.0 "gravity" c1 (friction,c3) <- findValueOrDefault 0.0 "friction" c2 (wind,c4) <- findValueOrDefault 0.0 "wind" c3 (tension,c5) <- findValueOrDefault 1.0 "tension" c4 (force, []) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "force") c5 return Flexibility { flexSoftness = softness, flexGravity = gravity, flexFriction = friction, flexWind = wind, flexTension = tension, flexForce = force } lightAcceptor s = ElemAcceptor s $ \ (Elem _ _ contents) -> do let c0 = elementsOnly contents (color,c1) <- findOrDefault (1.0,1.0,1.0) (vecAcceptor "color") c0 (intensity,c2) <- findValueOrDefault 1.0 "intensity" c1 (radius,c3) <- findValueOrDefault 10.0 "radius" c2 (falloff,[]) <- findValueOrDefault 1.0 "falloff" c3 return LightInfo { lightColor = color, lightIntensity = intensity, lightRadius = radius, lightFalloff = falloff } primTypeAcceptor s = ElemAcceptor s $ \ (Elem _ _ contents) -> do let c0 = elementsOnly contents (version, c1) <- findValueOrDefault 9 "version" c0 (typeCode, c2) <- findValueOrDefault 0 "typeCode" c1 (holeshape, c3) <- findValueOrDefault 0 "holeshape" c2 (cut, c4) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "cut") c3 (twist, c5) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "twist") c4 (holesize, c6) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "holesize") c5 (topshear, c7) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "topshear") c6 (hollow, c8) <- findValueOrDefault 0.0 "hollow" c7 (taper, c9) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "taper") c8 (advancedCut, c10) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "advancedCut") c9 (radiusOffset, c11) <- findValueOrDefault 0.0 "radiusOffset" c10 (revolutions, c12) <- findValueOrDefault 0.0 "revolutions" c11 (skew, c13) <- findValueOrDefault 0.0 "skew" c12 (sculptTexture, c14) <- findOptionalElement (simpleElement "sculptTexture") c13 (sculptType, []) <- findValueOrDefault 0 "sculptType" c14 return PrimType { primVersion = version, -- 1 or 9 primTypeCode = typeCode, primHoleshape = holeshape, primCut = cut, primTwist = twist, primHolesize = holesize, primTopshear = topshear, primHollow = hollow, primTaper = taper, primAdvancedCut = advancedCut, primRadiusOffset = radiusOffset, primRevolutions = revolutions, primSkew = skew, primSculptTexture = sculptTexture, primSculptType = sculptType } avatarsElement :: ElemAcceptor KeyManagerM [Avatar] avatarsElement = elementList "avatars" avatarElement avatarElement :: ElemAcceptor KeyManagerM Avatar avatarElement = ElemAcceptor "avatar" $ \ (Elem _ _ contents) -> do (name,c2) <- findSimple "name" (elementsOnly contents) realKey <- newKey (Just name) (x,c3) <- findValue "xPos" c2 (y,c4) <- findValue "yPos" c3 (z,c5) <- findValue "zPos" c4 (handlerName,_) <- findOptionalElement (simpleElement "avatarEventHandler") c5 let initialHandler = fmap (flip (,) []) handlerName return $ (defaultAvatar realKey) { avatarName = name, avatarPosition = (x,y,z), avatarCameraPosition = (x,y,z), avatarEventHandler = initialHandler } vecAcceptor s = ElemAcceptor s $ \ (Elem _ _ contents) -> do (x,c1) <- findValue "x" (elementsOnly contents) (y,c2) <- findValue "y" c1 (z,[]) <- findValue "z" c2 return (x,y,z) rotAcceptor s = ElemAcceptor s $ \ (Elem _ _ contents) -> do (x,c1) <- findValue "x" (elementsOnly contents) (y,c2) <- findValue "y" c1 (z,c3) <- findValue "z" c2 (s,[]) <- findValue "s" c3 return (x,y,z,s) regionAcceptor s = ElemAcceptor s $ \ (Elem _ _ contents) -> do (x,c1) <- findValue "x" (elementsOnly contents) (y,[]) <- findValue "y" (c1) return (x,y)