{-# OPTIONS_GHC -XFlexibleContexts -fwarn-unused-binds #-} module Language.Lsl.Sim(SimStatus(..), SimStateInfo(..), SimCommand(..), SimInputEventDefinition(..), SimParam(..), SimParamType(..), -- imported types re=exported LogMessage(..), LogLevel(..), Breakpoint, BreakpointManager, EvalResult, ScriptInfo(..), AvatarOutputEvent(..), AvatarInputEvent(..), SimEvent(..), SimEventArg(..), WorldM, World, -- eventDescriptors, simStep, unimplementedFuncs --module Language.Lsl.Internal.WorldState ) where import Control.Monad(MonadPlus(..),(>=>),filterM,foldM,forM_,liftM,liftM2,unless,when) import Control.Monad.State(StateT(..),lift) import Control.Monad.Identity(Identity(..)) import Control.Monad.Error(MonadError(..),ErrorT(..)) import Data.List(elemIndex,find,foldl',isSuffixOf,nub,sortBy) import Data.Bits((.&.),(.|.),bit,clearBit,complement,xor,setBit,shiftL,testBit) import Data.Int() import Data.Map(Map) import Data.Maybe(fromMaybe,isJust,isNothing) import qualified Data.Map as M import qualified Data.Set as S import qualified Data.IntMap as IM import Language.Lsl.Internal.Animation(builtInAnimations) import Language.Lsl.Internal.AvEvents(AvatarOutputEvent(..),AvatarInputEvent(..)) import Language.Lsl.Internal.Breakpoint(Breakpoint,BreakpointManager,emptyBreakpointManager,setStepOverBreakpoint,setStepOutBreakpoint,replaceBreakpoints, setStepBreakpoint,breakpointFile,breakpointLine,checkBreakpoint) import Language.Lsl.Internal.CodeHelper(renderCall) import Language.Lsl.Internal.Constants import Language.Lsl.Internal.Evaluation(ScriptInfo(..),Event(..),EvalResult(..)) import Language.Lsl.Internal.EventSigs(EventAdditionalData(..),EventDelivery(..),lslEventDescriptors) import Language.Lsl.Internal.Exec(ExecutionState(..),ExecutionInfo(ExecutionInfo),ScriptImage(..),executeLsl,frameInfo,hardReset,hasActiveHandler,initLSLScript) import Language.Lsl.Internal.ExpressionHandler(evaluateExpression) import Language.Lsl.Internal.FuncSigs(funcSigs) import Language.Lsl.Internal.InternalLLFuncs(internalLLFuncs) import Language.Lsl.Internal.Key(nullKey) import Language.Lsl.Internal.Log(LogLevel(..),LogMessage(..)) import Language.Lsl.Internal.Physics(calcAccel,checkIntersections,dampForce,dampTorque,dampZForce,gravC,kin,primMassApprox,rotDyn,totalTorque) import Language.Lsl.Syntax(Ctx(..),FuncDec(..),predefFuncs) import Language.Lsl.Internal.Type(LSLValue(..),LSLType(..),defaultValue,isIVal,isLVal,isSVal, lslShowVal,lslTypeString,lslValString,rVal2Rot,rot2RVal,typeOfLSLValue,vVal2Vec,vec2VVal) import Language.Lsl.UnitTestEnv(simFunc,hasFunc) import Language.Lsl.Internal.Util(add3d,angleBetween,diff3d,dist3d2,fac,findM,fromInt,generatePermutation,ilookup,lookupByIndex, mag3d,mlookup,neg3d,norm3d,quaternionMultiply,quaternionToMatrix,rot3d,rotationBetween,scale3d,tuplify) import Language.Lsl.WorldDef(Attachment(..),Avatar(..),AvatarControlListener(..),Email(..),Flexibility(..),InventoryInfo(..), InventoryItem(..),InventoryItemData(..),InventoryItemIdentification(..),LightInfo(..),LSLObject(..), ObjectDynamics(..),Parcel(..),Prim(..),PrimFace(..),PrimType(..),PositionTarget(..),Region(..),RotationTarget(..), Script(..),TextureInfo(..),WebHandling(..), defaultCamera,defaultDynamics,emptyPrim,findByInvKey,findByInvName, inventoryInfoPermValue,inventoryItemName,mkScript, isInvAnimationItem,isInvBodyPartItem,isInvClothingItem,isInvGestureItem,isInvNotecardItem, isInvObjectItem,isInvScriptItem,isInvSoundItem,isInvTextureItem, primPhantomBit,primPhysicsBit,scriptInventoryItem,worldFromFullWorldDef) import Language.Lsl.Internal.WorldState import System.Random(mkStdGen) import System.Time(ClockTime(..),CalendarTime(..),TimeDiff(..),addToClockTime,toUTCTime) import Text.Printf(PrintfType(..),printf) -- execute a predefined ('ll') function doPredef :: Monad m => String -> ScriptInfo Float -> [LSLValue Float] -> WorldM m (EvalResult,LSLValue Float) doPredef name info@(ScriptInfo oid pid sid pkey event) args = do predefs <- getPredefFuncs -- find the correct function to execute case tryPredefs name predefs of Just (t,f) -> runErrFunc info name (defaultValue t) args f Nothing -> do (_,rettype,argtypes) <- findM (\ (x,y,z) -> x == name) funcSigs logAMessage LogDebug (pkey ++ ":" ++ sid) ("unimplemented predefined function called: " ++ renderCall name args) continueWith $ defaultValue rettype getParcelByPosition regionIndex (x,y,_) = do region <- getRegion regionIndex findParcel 0 (regionParcels region) where findParcel _ [] = throwError "parcel not found" -- mzero findParcel i (p:ps) = let (south,north,west,east) = parcelBoundaries p (xc,yc) = (floor x, floor y) in if xc < east && xc >= west && yc < north && yc >= south then return (i,p) else findParcel (i + 1) ps getPrimParcel pk = do regionIndex <- getPrimRegion pk pos <- getRootPrim pk >>= getObject >>= return . objectPosition . objectDynamics (index,parcel) <- getParcelByPosition regionIndex pos return (regionIndex,index,parcel) putParcel regionIndex index parcel = do region <- getRegion regionIndex let (before,after) = splitAt index (regionParcels region) let parcels' = if null after then parcel : before else before ++ (parcel : tail after) lift $ setRegion regionIndex $ region { regionParcels = parcels' } tryPredefs name predefs = case M.lookup name predefs of Just (PredefFunc _ t predef) -> Just (t,predef) Nothing -> Nothing defaultPredef name predef = case lookup name $ map (\ (FuncDec n t ps) -> (ctxItem n,t)) predefFuncs of Nothing -> error ("undefined predef " ++ name) Just t -> PredefFunc name t predef runErrFunc info fname defval args f = do v <- evalErrorT (f info args) case v of Left s -> logFromScript info (fname ++ ": " ++ s) >> return (EvalIncomplete,defval) Right result -> return result runFace k i action = action <||> throwError ("face " ++ (show i) ++ " or prim " ++ k ++ " not found") (<||>) a b = a `catchError` (\ _ -> b) infixl 0 <||> primErr k = (\ s -> throwError ("problem - can't find prim " ++ k)) --- Web related functions ---------------------------------------------------- llHTTPRequest info@(ScriptInfo _ _ sn pk _) [SVal url, LVal params, SVal body] = do t <- lift getTick -- verify the parameters when (length params `mod` 2 /= 0) (throwError "invalid parameter list") when (length params > 8) (throwError "invalid parameter list") let params' = tuplify params when (not $ all (\ (x,_) -> x `elem` [llcHTTPMethod,llcHTTPMimetype,llcHTTPBodyMaxlength,llcHTTPVerifyCert]) params') (throwError "invalid parameter list") method <- maybe (return "GET") (\ v -> if not $ v `elem` (map SVal ["GET","POST","PUT","DELETE"]) then throwError ("invalid HTTP method " ++ lslValString v) else let SVal s = v in return s) (lookup llcHTTPMethod params') mimetype <- maybe (return "text/plain;charset=utf-8") (\ v -> if LLString /= typeOfLSLValue v then throwError "invalid mimtype" else let SVal s = v in return s) (lookup llcHTTPMimetype params') maxlength <- maybe (return 2048) (\ v -> if LLInteger /= typeOfLSLValue v then throwError "invalid body length" else return (let IVal i = v in i)) (lookup llcHTTPBodyMaxlength params') verify <- maybe (return 1) (\ v -> if LLInteger /= typeOfLSLValue v then throwError "invalid verify cert value" else return (let IVal i = v in i)) (lookup llcHTTPVerifyCert params') -- parameters ok key <- lift newKey lift $ putWorldEvent 0 (HTTPRequestEvent (pk,sn) key url method mimetype maxlength verify body) continueWith $ KVal key --- Sensor related functions ------------------------------------------------- llSensor info@(ScriptInfo _ _ sn pk _) [SVal name, KVal key, IVal etype, FVal range, FVal arc] = lift $ putWorldEvent 0 (SensorEvent (pk,sn) name key etype range arc Nothing) >> continueWith VoidVal llSensorRepeat info@(ScriptInfo _ _ sn pk _) [SVal name, KVal key, IVal etype, FVal range, FVal arc, FVal interval] = let interval' = if interval < 0 then 0 else interval in lift $ putWorldEvent interval (SensorEvent (pk,sn) name key etype range arc (Just interval')) >> continueWith VoidVal llSensorRemove info@(ScriptInfo _ _ sn pk _) [] = do q <- lift getWQueue lift $ setWQueue [ qentry | qentry@(_,event) <- q, not (isSensorEvent event) || sensorAddress event /= (pk,sn)] continueWith VoidVal ------------------------------------------------------------------------------ llRequestAgentData info@(ScriptInfo _ _ sn pk _) [KVal ak, IVal d] = do key <- lift newKey av <- (lift getWorldAvatars >>= return . M.lookup ak) -- <||> (throwError ("no such avatar" ++ ak)) dataVal <- case av of Nothing -> do lift $ logFromScript info ("llRequestAgentData: no such avatar - " ++ ak) return "0" Just av -> case d of d | d == cDataBorn -> return "1981-01-01" | d == cDataOnline -> return "1" | d == cDataRating -> return "0,0,0,0,0" | d == cDataName -> return $ avatarName av | d == cDataPayinfo -> return "3" | otherwise -> throwError ("invalid data requested: " ++ show d) lift $ pushDataserverEvent pk sn key dataVal continueWith (KVal key) llRequestSimulatorData info@(ScriptInfo _ _ sn pk _) [SVal simName, IVal d] = do key <- lift newKey regions <- lift getWorldRegions let findRegion = findM ((==simName) . regionName . snd) (M.toList regions) let simErr = throwError ("unknown simulator " ++ simName) val <- case d of d | d == cDataSimStatus -> (findRegion >> return "up") <||> return "unknown" | d == cDataSimRating -> (findRegion >> return "PG") <||> simErr | d == cDataSimPos -> (do ((x,y),_) <- findRegion return $ lslValString $ vec2VVal (256 * fromIntegral x, 256 * fromIntegral y, 0)) <||> simErr | otherwise -> throwError ("invalid data requested: " ++ show d) lift $ pushDataserverEvent pk sn key val continueWith (KVal key) --- INVENTORY related functions ---------------------------------------------- sortByInvName l = sortBy (\ i i' -> compare (invName i) (invName i')) l invName = inventoryItemName getPrimInventoryInfo info@(ScriptInfo _ _ _ pk _) invType = case invType of i | i == llcInventoryAll -> getPrimInventory pk >>= return . sortByInvName | i == llcInventoryAnimation -> getPrimAnimations pk >>= return . sortByInvName | i == llcInventoryBodyPart -> getPrimBodyParts pk >>= return . sortByInvName | i == llcInventoryClothing -> getPrimClothing pk >>= return . sortByInvName | i == llcInventoryGesture -> getPrimGestures pk >>= return . sortByInvName | i == llcInventoryNotecard -> getPrimNotecards pk >>= return . sortByInvName | i == llcInventoryObject -> getPrimObjects pk >>= return . sortByInvName | i == llcInventoryScript -> getPrimScripts pk >>= return . sortByInvName | i == llcInventorySound -> getPrimSounds pk >>= return . sortByInvName | i == llcInventoryTexture -> getPrimTextures pk >>= return . sortByInvName | otherwise -> do lift $ logFromScript info ("invalid inventory type: " ++ lslValString invType) return [] llGetInventoryNumber info@(ScriptInfo _ _ _ pk _) [invType@(IVal _)] = do getPrimInventoryInfo info invType >>= continueWith . IVal . length llGetInventoryCreator info@(ScriptInfo _ _ _ pk _) [SVal name] = do all <- getPrimInventory pk result <- case findByInvName name all of Nothing -> (lift $ putChat (Just 20.0) pk 0 ("no item named '" ++ name ++ "'")) >> return nullKey Just item -> return $ inventoryInfoCreator $ inventoryItemInfo item continueWith $ KVal result llGetInventoryPermMask info@(ScriptInfo _ _ _ pk _) [SVal name, IVal mask] = do all <- getPrimInventory pk mask <- case findByInvName name all of Nothing -> (lift $ putChat (Just 20.0) pk 0 ("No item named '" ++ name ++ "'")) >> throwError ("No item named '" ++ name ++ "'") Just item -> inventoryInfoPermValue mask (inventoryInfoPerms $ inventoryItemInfo item) continueWith (IVal mask) llGetInventoryKey info@(ScriptInfo _ _ _ pk _) [SVal name] = do all <- getPrimInventory pk result <- case findByInvName name all of Nothing -> return nullKey Just (InventoryItem id invInfo _) -> let Right perms = inventoryInfoPermValue cMaskOwner (inventoryInfoPerms invInfo) in if perms .&. cFullPerm == cFullPerm then return $ snd (inventoryItemNameKey id) else return nullKey continueWith $ KVal result llGetInventoryName info@(ScriptInfo _ _ _ pk _) [invType@(IVal _), IVal index] = getPrimInventoryInfo info invType >>= return . map (\ item -> invName item) >>= continueWith . SVal . fromMaybe "" . lookupByIndex index llGetInventoryType info@(ScriptInfo _ _ _ pk _) [SVal name] = do getPrimInventory pk >>= continueWith . classify . findByInvName name where classifications = [(isInvAnimationItem,llcInventoryAnimation),(isInvBodyPartItem,llcInventoryBodyPart), (isInvClothingItem,llcInventoryClothing),(isInvGestureItem,llcInventoryGesture), (isInvNotecardItem,llcInventoryNotecard),(isInvObjectItem,llcInventoryObject), (isInvSoundItem,llcInventorySound),(isInvTextureItem,llcInventoryTexture), (isInvScriptItem,llcInventoryScript)] classify Nothing = IVal (-1) classify (Just item) = foldl' (\ (IVal cur) (f,i) -> if (cur >= 0) || not (f item) then IVal cur else i) (IVal (-1)) classifications llRemoveInventory info@(ScriptInfo _ _ _ pk _) [SVal name] = do inv <- getPrimInventory pk maybe (lift $ putChat (Just 20) pk cDebugChannel ("Missing inventory item '" ++ name ++ "'")) (\ _ -> let inv' = [ item | item <- inv, name /= (inventoryItemName item)] in lift $ setPrimInventory pk inv') (findByInvName name inv) continueWith VoidVal copyInventoryItem newOwner newGroup item = case item of item | isInvObjectItem item -> do let copyLink prim = do k <- lift newKey inventory <- mapM (copyInventoryItem newOwner newGroup) (primInventory prim) return (prim { primKey = k, primInventory = inventory, primOwner = newOwner, primGroup = newGroup }) InvObject links <- return $ inventoryItemData item links' <- mapM copyLink links when (null links') $ throwError "empty linkset!" let info = inventoryItemInfo item return (InventoryItem (InventoryItemIdentification (inventoryItemName item,primKey $ head links')) info (InvObject links')) | otherwise -> do k <- lift newKey let info = inventoryItemInfo item let dat = inventoryItemData item return (InventoryItem (InventoryItemIdentification (inventoryItemName item, k)) info dat) changeName (InventoryItem (InventoryItemIdentification (name,key)) info dat) newName = (InventoryItem (InventoryItemIdentification (newName,key)) info dat) llGiveInventory info@(ScriptInfo _ _ _ pk _) [KVal k, SVal inv] = do inventory <- getPrimInventory pk <||> throwError "cant find prim!" item <- maybe (throwError ("inventory item " ++ inv ++ "not found")) (return . id) (findByInvName inv inventory) prims <- lift getPrims case M.lookup k prims of Just p -> do owner <- getPrimOwner pk group <- getPrimGroup pk let (_,ownerP,groupP,everybodyP,_) = let [p1,p2,p3,p4,p5] = take 5 (primPermissions p) ++ repeat 0 in (p1,p2,p3,p4,p5) let hasModifyPerm = (cPermModify .&. everybodyP /= 0) || (cPermModify .&. groupP /= 0 && not (isNothing group) && group == primGroup p) || (cPermModify .&. ownerP /= 0 && owner == primOwner p) if hasModifyPerm || primAllowInventoryDrop p then do let newOwner = primOwner p let newGroup = primGroup p item' <- copyInventoryItem newOwner newGroup item let inventory' = primInventory p let findAName i base = let name = base ++ " " ++ show i in if isNothing (findByInvName name inventory') then name else findAName (i + 1) base let inventory'' = case findByInvName inv inventory' of Nothing -> item' : inventory' Just _ -> let newName = findAName 1 inv in (changeName item' newName) : inventory' lift $ setPrimInventory k inventory'' -- TODO: are scripts handled right? lift $ pushDeferredScriptEventToPrim (Event "changed" [if hasModifyPerm then llcChangedInventory else llcChangedAllowedDrop] M.empty) k 0 else throwError ("can't modify/drop inventory on target") Nothing -> do avatars <- lift getWorldAvatars case M.lookup k avatars of Nothing -> throwError ("no object or avatar found with key " ++ k) Just av -> lift (putWorldEvent 0 (GiveAvatarInventoryEvent k item)) >> (lift $ logFromScript info $ "llGiveInventory: avatar " ++ k ++ " given option of accepting inventory") continueWith VoidVal llSetRemoteScriptAccessPin info@(ScriptInfo _ _ _ pk _) [IVal pin] = lift $ setPrimRemoteScriptAccessPin pk pin >> continueWith VoidVal llRemoteLoadScript info@(ScriptInfo _ _ _ pk _) [KVal _,SVal _, IVal _, IVal _] = lift $ putChat (Just 20.0) pk cDebugChannel "Deprecated. Please use llRemoteLoadScriptPin instead." >> continueWith VoidVal llRezObject info params = rezObject False info params llRezAtRoot info params = rezObject True info params rezObject atRoot info@(ScriptInfo _ _ _ pk _) [SVal inventory, VVal px py pz, VVal vx vy vz, RVal rx ry rz rs, IVal param] = do objects <- getPrimObjects pk maybe (do lift $ putChat (Just 20) pk 0 ("Couldn't find object '" ++ inventory ++ "'") throwError ("no such inventory item - " ++ inventory)) (\ item -> do let copy = isCopyable item let InvObject linkSet = inventoryItemData item lift $ putWorldEvent 0 (RezObjectEvent linkSet (px,py,pz) (vz,vy,vz) (rz,ry,rz,rs) param pk copy atRoot) when (not copy) $ do -- delete! wholeInventory <- getPrimInventory pk lift $ setPrimInventory pk [ item | item <- wholeInventory, inventory /= inventoryItemName item] ) (findByInvName inventory objects) continueWith VoidVal isCopyable item = let (_,perm,_,_,_) = inventoryInfoPerms $ inventoryItemInfo item in if cPermCopy .&. perm == 0 then False else (if isInvObjectItem item then let InvObject links = inventoryItemData item primCopyable prim = all isCopyable (primInventory prim) in all primCopyable links else True) llResetScript info@(ScriptInfo _ _ sn pk _) [] = do lift $ putWorldEvent 0 (ResetScriptEvent pk sn) return (EvalComplete Nothing,VoidVal) llResetOtherScript info@(ScriptInfo _ _ sn pk _) [SVal sn'] = do when (sn == sn') $ throwError ("trying to reset the current script - must use llResetScript for this") lift getWorldScripts >>= mlookup (pk,sn) >>= return . scriptActive >>= flip when (throwError "can't reset a stopped script") . not resetScript pk sn' continueWith VoidVal resetScript pk sn = do lift $ logAMessage LogDebug "sim" "resetting a script" scripts <- lift getWorldScripts script <- mlookup (pk,sn) scripts t <- lift getTick let img = scriptImage script let doReset execState = let script' = script { scriptImage = (hardReset img) {executionState = execState}, scriptActive = True, scriptPermissions = M.empty, scriptLastPerm = Nothing, scriptLastResetTick = t, scriptEventQueue = [Event "state_entry" [] M.empty] } in lift $ setWorldScripts (M.insert (pk,sn) script' scripts) in case executionState img of Executing -> doReset Waiting Waiting -> doReset Waiting SleepingTil i -> doReset (WaitingTil i) WaitingTil i -> doReset (WaitingTil i) _ -> throwError ("can't reset script that is crashed or suspended") llGetScriptState info@(ScriptInfo _ _ _ pk _) [SVal sn] = do script <- (lift getWorldScripts >>= mlookup (pk,sn)) <||> throwError "no such script/invalid script" (continueWith . IVal) $ if not $ scriptActive script then 0 else case executionState (scriptImage script) of Halted -> 0 Erroneous _ -> 0 Crashed _ -> 0 _ -> 1 llSetScriptState info@(ScriptInfo _ _ sn pk _) [SVal sn', IVal state] = do when (sn == sn') $ throwError ("can't change your own state") scripts <- lift getWorldScripts script <- mlookup (pk,sn') scripts <||> throwError "no such script (could be invalid script)" if state == 0 then if (scriptActive script) then lift $ setWorldScripts (M.insert (pk,sn') (script { scriptActive = False }) scripts) else return () else case executionState (scriptImage script) of Crashed _ -> throwError "can't change state of crashed script" Erroneous _ -> throwError "can't change state of erroneous script" _ -> if scriptActive script then throwError "script is already running" else resetScript pk sn' continueWith VoidVal ------------------------------------------------------------------------------ llSetPayPrice info@(ScriptInfo _ _ sn pk _) [IVal price, LVal l] = let toI (IVal i) = if (i < (-2)) then (-1) else i toI _ = (-1) [i1,i2,i3,i4] = take 4 $ (map toI l) ++ replicate 4 (-1) in do hasMoney <- scriptHasActiveHandler pk sn "money" when (not hasMoney) $ throwError ("no money handler, pay price info ignored") lift $ setPrimPayInfo pk (price,i1,i2,i3,i4) continueWith VoidVal llGetStartParameter info@(ScriptInfo _ _ sn pk _) [] = (lift getWorldScripts >>= mlookup (pk,sn) >>= continueWith . IVal . scriptStartParameter) ------------------------------------------------------------------------------ llCloud info [v@(VVal x y z)] = do lift $ logFromScript info "llCloud: returning default density" continueWith $ FVal 0 llWind info [v@(VVal x y z)] = lift $ logFromScript info "llWind: returning default density" >> continueWith (VVal 0 0 0) llWater info [v@(VVal x y z)] = do lift $ logFromScript info "llWater: returning default water elevation" continueWith $ FVal 0 llSitTarget (ScriptInfo _ _ _ pk _) [v@(VVal _ _ _),r@(RVal _ _ _ _)] = lift $ setPrimSitTarget pk (Just (vVal2Vec v, rVal2Rot r)) >> continueWith VoidVal llAvatarOnSitTarget info@(ScriptInfo _ _ _ pk _) [] = do sitTarget <- getPrimSitTarget pk when (sitTarget == Nothing) (throwError ("no sit target")) k <- getPrimSittingAvatar pk >>= return . fromMaybe nullKey continueWith (KVal k) llUnSit info@(ScriptInfo _ _ _ pk _) [KVal k] = do val <- getPrimSittingAvatar pk maybe (throwError "no avatar sitting on prim (land unsit not implemented") (\ ak -> if ak == k then lift $ setPrimSittingAvatar pk Nothing else throwError "unsit of avatar not sitting on prim attempted (land unsit not implemented)") val continueWith VoidVal llMessageLinked info@(ScriptInfo oid pid sid pkey _) [IVal link,IVal val,SVal msg,KVal key] = do LSLObject { primKeys = links } <- (getObject oid) <||> throwError ("object not found!") when (null links) $ throwError ("object is has no links!") let sender = if length links > 1 then pid + 1 else pid let targetLinkIndices = targetLinks (length links) link pid let targetLinks = map (links !!) targetLinkIndices let event = (Event "link_message" [IVal sender, IVal val, SVal msg, KVal key] M.empty) lift $ mapM_ (\ pk -> pushDeferredScriptEventToPrim event pk 0) targetLinks continueWith VoidVal targetLinks n link pid = case link of l | l == linkSet -> [0 .. (n - 1)] | l == linkAllOthers -> [0..(pid - 1)] ++ [(pid + 1).. (n - 1)] | l == linkAllChildren -> [1..(n - 1)] | l == linkThis -> [pid] | otherwise -> [link - 1] -- the key to 'sleep' is that instead of returning 'EvalIncomplete' as its EvalResult, it returns -- 'YieldTil ', which puts the script into a sleep state. -- other functions which have a built in delay should use this mechanism as well. llSleep info@(ScriptInfo oid pid sid pkey event) [FVal f] = do tick <- lift $ getTick return $ (YieldTil (tick + durationToTicks f),VoidVal) llInstantMessage info@(ScriptInfo _ _ _ pk _) [KVal ak, SVal message] = do tick <- lift getTick name <- getPrimName pk av <- (lift getWorldAvatars >>= mlookup ak) <||> throwError ("no such user: " ++ ak) let avname = avatarName av lift $ logAMessage LogInfo "sim" ("IM to " ++ avname ++ " from " ++ name ++ ": " ++ message) return (YieldTil (tick + durationToTicks 2),VoidVal) llSay info params= lift $ chat (Just 20.0) info params llWhisper info params = lift $ chat (Just 10.0) info params llShout info params = lift $ chat (Just 100.0) info params llRegionSay info params@[IVal chan, SVal message] = if (chan == 0) then do lift $ logAMessage LogWarn (scriptInfoPrimKey info ++ ": " ++ scriptInfoScriptName info) "attempt to llRegionSay on channel 0" return (EvalIncomplete,VoidVal) else lift $ chat Nothing info params chat range info@(ScriptInfo oid pid sid pkey event) [IVal chan, SVal message] = do logFromScript info $ concat ["chan = ", show chan, ", message = ", message] putChat range pkey chan message return (EvalIncomplete,VoidVal) putChat range k chan message = do prims <- getPrims case M.lookup k prims of Just prim -> runErrPrim k () $ do region <- (getPrimRegion k) pos <- getRootPrim k >>= getObject >>= return . objectPosition . objectDynamics lift $ putWorldEvent 0 $ Chat chan (primName prim) k message (region, pos) (range) Nothing -> do avatars <- getWorldAvatars case M.lookup k avatars of Just avatar -> putWorldEvent 0 $ Chat chan (avatarName avatar) k message (avatarRegion avatar, avatarPosition avatar) (range) Nothing -> logAMessage LogWarn "sim" ("Trying to chat from unknown object/avatar with key " ++ k) llListen (ScriptInfo oid pid sid pkey event) [IVal chan, SVal sender, KVal key, SVal msg] = (lift $ registerListener $ Listener pkey sid chan sender key msg) >>= continueWith . IVal llListenRemove (ScriptInfo _ _ sid pk _) [IVal id] = (unregisterListener pk sid id) >> continueWith VoidVal llListenControl (ScriptInfo _ _ sid pk _) [IVal id, IVal active] = (updateListener pk sid id $ active /= 0) >> continueWith VoidVal llFrand _ [FVal maxval] = lift $ do r <- wrand continueWith $ FVal (maxval * r) llTeleportAgentHome info@(ScriptInfo _ _ _ pk _) [KVal ak] = do owner <- getPrimOwner pk regionIndex <- getPrimRegion pk (_,_,parcel) <- getPrimParcel pk if parcelOwner parcel == owner then lift $ logFromScript info ("llTeleportAgentHome: user " ++ ak ++ " teleported home (in theory)") else lift $ logFromScript info ("llTeleportAgentHome: not permitted to teleport agents from this parcel") continueWith VoidVal llEjectFromLand info@(ScriptInfo oid _ _ pk _) [KVal user] = do owner <- getPrimOwner pk regionIndex <- getPrimRegion pk (_,parcel) <- getObjectPosition oid >>= getParcelByPosition regionIndex if parcelOwner parcel == owner then lift $ logFromScript info ("llEjectFromLand: user " ++ user ++ " ejected (in theory)") else lift $ logFromScript info ("llEjectFromLand: not permitted to eject from this parcel") continueWith VoidVal llBreakLink info@(ScriptInfo oid _ sid pk _) [IVal link] = do perm <- getPermissions pk sid if perm .&. cPermissionChangeLinks /= 0 then do objects <- lift getObjects LSLObject { primKeys = links, objectDynamics = dynamics } <- mlookup oid objects attachment <- getPrimAttachment oid case attachment of Nothing -> if link < 1 || link > length links then lift $ logFromScript info ("llBreakLink: invalid link id") else do let (dyn1,dyn2) = if link == 1 then (defaultDynamics,dynamics) else (dynamics,defaultDynamics) let (xs,y:ys) = splitAt (link - 1) links let (linkSet1,linkSet2) = (xs ++ ys, [y]) let objects' = if null linkSet1 then objects else M.insert (head linkSet1) (LSLObject linkSet1 dyn1) objects lift $ setObjects (M.insert (head linkSet2) (LSLObject linkSet2 dyn2) objects') when (not (null linkSet1)) $ do lift $ pushChangedEventToObject (head linkSet1) cChangedLink lift $ setPrimParent (head linkSet1) Nothing lift $ pushChangedEventToObject (head linkSet2) cChangedLink lift $ setPrimParent (head linkSet2) Nothing _ -> lift $ logFromScript info ("llBreakLink: can't change links of attached object") else lift $ logFromScript info ("llBreakLink: no permission") continueWith VoidVal llBreakAllLinks info@(ScriptInfo oid _ sid pk _) [] = do perm <- getPermissions pk sid if perm .&. cPermissionChangeLinks /= 0 then do objects <- lift getObjects LSLObject links dynamics <- mlookup oid objects attachment <- getPrimAttachment oid case attachment of Nothing -> if length links > 1 then do -- order of parameters to union is vital: union is left biased, so we want the -- new objects (in the left argument) to replace the old (in the right) where -- both exist (the root key of the old object is found in both) let objects' = M.union (M.fromList $ map (\ k -> (k, LSLObject [k] (if k == oid then dynamics else defaultDynamics))) links) objects lift $ setObjects objects' lift $ mapM_ (\ link -> pushChangedEventToObject link cChangedLink >> setPrimParent link Nothing) links else return () _ -> lift $ logFromScript info ("llBreakAllLinks: can't change links of attached object") else lift $ logFromScript info ("llBreakAllLinks: no permission") continueWith VoidVal -- TODO: verify link order llCreateLink info@(ScriptInfo oid _ sid pk _) [KVal target, IVal iparent] = do perm <- getPermissions pk sid if perm .&. cPermissionChangeLinks /= 0 then do objects <- lift getObjects LSLObject (link:links) dynamics <- mlookup oid objects case M.lookup target objects of Nothing -> lift $ logFromScript info "llCreateLink: target not found" Just (LSLObject (link':links') dynamics') -> do attachment0 <- getPrimAttachment oid attachment1 <- getPrimAttachment target case (attachment0,attachment1) of (Nothing,Nothing) -> do mask <- getObjectPermMask target cMaskOwner ownerTarget <- getPrimOwner target owner <- getPrimOwner oid if mask .&. cPermModify /= 0 && owner == ownerTarget then do let (newLinkset,deleteKey,newDynamics) = if parent then ((link:link':links') ++ links, link',dynamics) else ((link':link:links) ++ links', link,dynamics') lift $ setObjects (M.insert (head newLinkset) (LSLObject newLinkset newDynamics) $ M.delete deleteKey objects) lift $ pushChangedEventToObject (head newLinkset) cChangedLink else lift $ logFromScript info "llCreateLink: no modify permission on target" _ -> lift $ logFromScript info ("llCreateLink: can't change links of attached object") else lift $ logFromScript info ("llCreateLink: no permission to change links") continueWith VoidVal where parent = iparent /= 0 llDie info@(ScriptInfo oid _ _ pk _) [] = do attachment <- getPrimAttachment oid case attachment of Nothing -> do objects <- lift getObjects LSLObject { primKeys = (links) } <- mlookup oid objects allScripts <- mapM getPrimScripts links let primsWithScriptNames = zip links (map (map (invName)) allScripts) let skeys = concat $ map ( \ (k,list) -> map ((,)k) list) primsWithScriptNames lift $ mapM_ delScript skeys lift $ mapM_ (\ link -> (getPrims >>= return . M.delete link >>= setPrims)) links lift $ setObjects (M.delete oid objects) lift $ logFromScript info ("object, and therefore this script, is dying") return (EvalComplete Nothing,VoidVal) where delScript (k,s) = getWorldScripts >>= return . M.delete (k,s) >>= setWorldScripts _ -> do lift $ logFromScript info ("attachment cannot die") return (EvalIncomplete,VoidVal) llAttachToAvatar info@(ScriptInfo oid _ sid pk _) [IVal attachPoint] = if attachPoint `elem` validAttachmentPoints then do script <- (lift getWorldScripts >>= mlookup (pk,sid)) attachment <- getPrimAttachment oid case attachment of Just _ -> lift $ logFromScript info "llAttachToAvatar: already attached" Nothing -> case scriptLastPerm script of Nothing -> throwError "no permission to attach" Just k -> do perm <- mlookup k (scriptPermissions script) when (perm .&. cPermissionAttach == 0) $ throwError "no permission to attach" owner <- getPrimOwner pk if (k /= owner) then lift $ putChat (Just 20.0) pk 0 ("Script trying to attach to someone other than owner!") else do avatars <- lift getWorldAvatars let av = M.lookup k avatars case av of Nothing -> throwError "avatar not present in sim" Just av -> let attachments = avatarAttachments av in case IM.lookup attachPoint attachments of Nothing -> let av' = av { avatarAttachments = IM.insert attachPoint oid attachments } in do lift $ setWorldAvatars (M.insert k av' avatars) lift $ setPrimAttachment oid (Just $ Attachment k attachPoint) lift $ pushAttachEvent pk k Just _ -> throwError "attachment point already occupied" continueWith VoidVal else throwError ("invalid attachment point: " ++ show attachPoint) llDetachFromAvatar info@(ScriptInfo oid _ sid pk _) [] = do when (oid /= pk) $ throwError "can't detach from within child prim" script <- (lift getWorldScripts >>= mlookup (pk,sid)) <||> throwError "can't find current script!" attachment <- getPrimAttachment oid when (isNothing attachment) $ throwError "not attached!" Just (Attachment k attachPoint) <- return attachment perm <- (mlookup k $ scriptPermissions script) <||> throwError "no permission to detach" when (perm .&. cPermissionAttach == 0) $ throwError "no permission to attach" avatars <- lift getWorldAvatars avatar <- mlookup k avatars <||> throwError "can't find avatar!" let attachments = avatarAttachments avatar lift $ setWorldAvatars (M.insert k (avatar { avatarAttachments = IM.delete attachPoint attachments }) avatars) lift $ setPrimAttachment oid Nothing lift $ pushAttachEvent oid nullKey lift $ putWorldEvent 1 (DetachCompleteEvent oid k) continueWith VoidVal llGetAttached info@(ScriptInfo oid _ _ _ _) [] = getPrimAttachment oid >>= return . maybe 0 attachmentPoint >>= continueWith . IVal llGiveMoney info@(ScriptInfo _ _ sn pk _) [KVal ak, IVal amount] = do script <- (lift getWorldScripts >>= mlookup (pk,sn)) <||> (throwError "can't find script!") permKey <- maybe (throwError "no permission") (return . id) (scriptLastPerm script) perm <- mlookup permKey (scriptPermissions script) when (perm .&. cPermissionAttach == 0) $ throwError "no permission" lift $ logFromScript info ("llGiveMoney: pretending to give " ++ show amount ++ " to avatar with key " ++ ak) continueWith (IVal 0) llGetPermissionsKey (ScriptInfo _ _ sid pk _) [] = lift getWorldScripts >>= mlookup (pk,sid) >>= continueWith . KVal . fromMaybe nullKey . scriptLastPerm llGetPermissions (ScriptInfo _ _ sid pk _) [] = getPermissions pk sid >>= continueWith . IVal getPermissions pk s = do script <- (lift getWorldScripts >>= mlookup (pk,s)) case scriptLastPerm script of Nothing -> return 0 Just k -> mlookup k (scriptPermissions script) getPermittedAvKey info@(ScriptInfo _ _ s pk _) fname perm = do script <- (lift getWorldScripts >>= mlookup (pk,s)) case scriptLastPerm script of Nothing -> lift $ logFromScript info (fname ++ ": not permitted") >> return Nothing Just k -> case M.lookup k (scriptPermissions script) of Nothing -> lift $ logFromScript info (fname ++ ": internal error getting permissions") >> return Nothing Just i | i .&. perm /= 0 -> return (Just k) | otherwise -> return Nothing llRequestPermissions (ScriptInfo _ _ sid pk _) [KVal k, IVal mask] = do avatars <- lift $ getWorldAvatars case M.lookup k avatars of Nothing -> lift $ logAMessage LogInfo (pk ++ ":" ++ sid) ("Invalid permissions request: no such avatar: " ++ k) _ -> lift $ putWorldEvent 0 (PermissionRequestEvent pk sid k mask) continueWith VoidVal llClearCameraParams info@(ScriptInfo _ _ sid pk _) [] = do avKey <- getPermittedAvKey info "llClearCameraParams" cPermissionControlCamera case avKey of Nothing -> return () Just k -> do avatars <- lift getWorldAvatars av <- mlookup k avatars lift $ setWorldAvatars (M.insert k (av { avatarCameraControlParams = defaultCamera }) avatars) continueWith VoidVal llGetCameraPos info@(ScriptInfo _ _ sid pk _) [] = do avKey <- getPermittedAvKey info "llGetCameraPos" cPermissionTrackCamera maybe (return (0,0,0)) (\ k -> lift getWorldAvatars >>= mlookup k >>= return . avatarCameraPosition) avKey >>= continueWith . vec2VVal llGetCameraRot info@(ScriptInfo _ _ sid pk _) [] = do avKey <- getPermittedAvKey info "llGetCameraRot" cPermissionTrackCamera maybe (return (0,0,0,1)) (\ k -> lift getWorldAvatars >>= mlookup k >>= return . avatarCameraRotation) avKey >>= continueWith . rot2RVal llTakeCamera info _ = lift $ logFromScript info "llTakeCamera: deprecated!" >> continueWith VoidVal llReleaseCamera info _ = lift $ logFromScript info "llRelaaseCamera: deprecated!" >> continueWith VoidVal llPointAt info _ = lift $ logFromScript info "llPointAt: deprecated!" >> continueWith VoidVal llStopPointAt info _ = lift $ logFromScript info "llStopPointAt: deprecated!" >> continueWith VoidVal llSetPrimURL info _ = lift $ logFromScript info "llSetPrimURL: unimplemented!" >> continueWith VoidVal llRefreshPrimURL info _ = lift $ logFromScript info "llRefreshPrimURL: unimplemted!" >> continueWith VoidVal llGetRot info@(ScriptInfo oid _ _ pk _) [] = getGlobalRot pk >>= continueWith . rot2RVal llGetLocalRot info@(ScriptInfo oid _ _ pk _) [] = (if oid == pk then getObjectRotation oid else getPrimRotation pk) >>= continueWith . rot2RVal llGetRootRotation info@(ScriptInfo oid _ _ pk _) [] = getObjectRotation oid >>= continueWith . rot2RVal --TODO: handle attachments... --TODO: confirm order of rotations in both of these llSetRot info@(ScriptInfo oid _ _ pk _) [r@(RVal _ _ _ _)] = (if oid == pk then setRootRotation oid rot else setChildRotation oid pk rot) >> continueWith VoidVal where rot = rVal2Rot r -- TODO: fix this!! setChildRotation rk pk rot = do rootRot <- getPrimRotation rk lift $ setPrimRotation pk (rot `quaternionMultiply` rootRot `quaternionMultiply` rootRot) setRootRotation rk rot = do obj <- getObject rk lift $ setObject rk (obj { objectDynamics = (objectDynamics obj) { objectRotation = rot }}) llSetLocalRot info@(ScriptInfo oid _ _ pk _) [r@(RVal _ _ _ _)] = (if oid == pk then setRootRotation oid rot else lift $ setPrimRotation pk rot) >> continueWith VoidVal where rot = rVal2Rot r llSetPos info@(ScriptInfo oid pid sid pk event) [val] = (if oid == pk then setRootPos oid v else setChildPos pk v) >> continueWith VoidVal where v = vVal2Vec val setChildPos pk val = lift $ setPrimPosition pk val -- updates the world coordinates of object -- does NOT consider region boundaries (TODO: fix!) setRootPos oid v = do v0 <- getObjectPosition oid let vec = diff3d v v0 let dist = mag3d vec let vec' = if dist <= 10.0 then vec else scale3d 10.0 $ norm3d vec --objects <- lift getObjects obj <- getObject oid lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectPosition = v0 `add3d` vec' } }) llGetOwner info [] = let k = scriptInfoPrimKey info in getPrimOwner k >>= continueWith . KVal llGetCreator info [] = let k = scriptInfoPrimKey info in getPrimCreator k >>= continueWith . KVal llSameGroup info@(ScriptInfo _ _ _ pk _) [KVal k] = do group <- avGroup <||> getPrimGroup k <||> throwError ("no such object or avatar: " ++ k) myGroup <- getPrimGroup pk <||> throwError ("can't find " ++ pk) continueWith (IVal (if group == myGroup then 1 else 0)) where avGroup = lift getWorldAvatars >>= mlookup k >>= return . avatarActiveGroup llGetLinkKey (ScriptInfo oid _ _ _ _) [IVal link] = do do LSLObject { primKeys = pkeys } <- getObject oid pk <- lookupByIndex (link - 1) pkeys continueWith (KVal pk) -- TODO: should check for av/prim in same region -- TODO: no concept of online/offline for av llKey2Name info [KVal k] = lift $ do avs <- getWorldAvatars case M.lookup k avs of Just av -> continueWith $ SVal (avatarName av) _ -> do prims <- getPrims case M.lookup k prims of Just prim -> continueWith $ SVal (primName prim) Nothing -> continueWith (SVal "") llOwnerSay info [SVal s] = do lift $ logAMessage LogInfo (infoToLogSource info) ("Owner Say: " ++ s) owner <- getPrimOwner (scriptInfoObjectKey info) lift $ putWorldEvent 0 (AvatarInputEvent owner (AvatarOwnerSay (scriptInfoPrimKey info) s)) continueWith VoidVal llGetGeometricCenter info@(ScriptInfo oid _ _ _ _) [] = do LSLObject { primKeys = links } <- getObject oid when (null links) $ throwError "error: empty linkset!" rootPos <- getObjectPosition oid foldM (\ v k -> getGlobalPos k >>= return . add3d v) (0,0,0) links >>= continueWith . vec2VVal . scale3d (1 / fromIntegral (length links)) llGetMass info@(ScriptInfo oid _ _ _ _) [] = objectMass oid >>= continueWith . FVal objectMass oid = do LSLObject { primKeys = links } <- getObject oid foldM (\ v k -> getPrim k >>= ( \ prim -> return $ v + primMassApprox prim)) 0.0 links llGetObjectMass info [KVal k] = do avatars <- lift getWorldAvatars val <- case M.lookup k avatars of Just _ -> return 80.0 Nothing -> objectMass k continueWith (FVal val) llGetVel info@(ScriptInfo oid _ _ _ _) [] = getObject oid >>= continueWith . vec2VVal . objectVelocity . objectDynamics llGetForce info@(ScriptInfo oid _ _ _ _) [] = getObject oid >>= return . objectForce . objectDynamics >>= continueWith . vec2VVal . fst llSetForce info@(ScriptInfo oid _ _ _ _) [v@(VVal x y z), IVal local] = do obj <- getObject oid lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectForce = ((x,y,z), local /= 0) }}) continueWith VoidVal llSetBuoyancy info@(ScriptInfo { scriptInfoObjectKey = oid }) [FVal buoy] = do obj <- getObject oid lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectBuoyancy = buoy }}) continueWith VoidVal llApplyImpulse info@(ScriptInfo oid _ _ _ _) [v@(VVal x y z), IVal local] = do t <- lift getTick obj <- getObject oid lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectImpulse = (((x,y,z), local /= 0), t + durationToTicks 1) } }) continueWith VoidVal llGetAccel info@(ScriptInfo oid _ _ _ _) [] = do prim <- getPrim oid obj <- getObject oid let dyn = objectDynamics obj let force = fst (objectForce dyn) `rot3d` rotation where rotation = if snd $ objectForce dyn then objectRotation dyn else (0,0,0,1) let impulse = ((fst . fst . objectImpulse) dyn `rot3d` rotation, (snd . objectImpulse) dyn) where rotation = if (snd . fst . objectImpulse) dyn then objectRotation dyn else (0,0,0,1) t <- lift getTick mass <- objectMass oid pos <- getObjectPosition oid continueWith $ vec2VVal $ calcAccel t 0 mass pos force impulse llSetTorque info@(ScriptInfo { scriptInfoObjectKey = oid }) [VVal x y z, IVal local] = do obj <- getObject oid lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectTorque = ((x,y,z),local /= 0) } }) continueWith VoidVal llSetForceAndTorque info@(ScriptInfo { scriptInfoObjectKey = oid}) [VVal fx fy fz, VVal tx ty tz, IVal local] = do obj <- getObject oid let loc = local /= 0 lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectForce = ((fx,fy,fz),loc), objectTorque = ((tx,ty,tz),loc) } }) continueWith VoidVal llGetTorque info@(ScriptInfo { scriptInfoObjectKey = oid }) [] = getObject oid >>= continueWith . vec2VVal . fst . objectTorque . objectDynamics llGetOmega info@(ScriptInfo { scriptInfoObjectKey = oid }) [] = getObject oid >>= continueWith . vec2VVal . objectOmega . objectDynamics llApplyRotationalImpulse info@(ScriptInfo { scriptInfoObjectKey = oid }) [VVal x y z, IVal local] = do obj <- getObject oid t <- lift getTick lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectRotationalImpulse = (((x,y,z),local /= 0), t + durationToTicks 1) } }) continueWith VoidVal llGetPos info@(ScriptInfo _ _ _ pk _) [] = getGlobalPos pk >>= continueWith . vec2VVal llGetRootPosition info@(ScriptInfo oid _ _ _ _) [] = getObjectPosition oid >>= continueWith . vec2VVal getGlobalPos pk = do oid <- getRootPrim pk root <- getObjectPosition oid rel <- getPrimPosition pk rot <- getObjectRotation oid return (root `add3d` (rot3d rel rot)) getGlobalRot pk = do oid <- getRootPrim pk rot0 <- getObjectRotation oid rot <- getPrimRotation pk return (rot `quaternionMultiply` rot0) llRotLookAt info@(ScriptInfo oid _ _ _ _) [RVal x y z s, FVal strength, FVal tau] = rotLookAt oid (x,y,z,s) strength tau >> continueWith VoidVal llLookAt info@(ScriptInfo oid _ _ _ _) [VVal x y z, FVal strength, FVal tau] = do pos <- getObjectPosition oid rot <- getGlobalRot oid let v = diff3d (x,y,z) pos let rot1 = rot `quaternionMultiply` (rotationBetween (rot3d (0,0,1) rot) v) rotLookAt oid rot1 strength tau continueWith VoidVal rotLookAt oid (x,y,z,s) strength tau = do obj <- getObject oid lift $ setObject oid $ obj { objectDynamics = (objectDynamics obj) { objectRotationTarget = Just (RotationTarget { rotationTarget = (x,y,z,s), rotationTargetStrength = strength, rotationTargetTau = tau } ) }} llStopLookAt info@(ScriptInfo oid _ _ _ _) [] = do obj <- getObject oid lift $ setObject oid $ obj { objectDynamics = (objectDynamics obj) { objectRotationTarget = Nothing }} continueWith VoidVal llGetLocalPos info@(ScriptInfo oid _ _ pk _) [] = getLocalPos pk >>= continueWith . vec2VVal getLocalPos k = getPrimPosition k llMoveToTarget info@(ScriptInfo { scriptInfoObjectKey = oid, scriptInfoScriptName = sn, scriptInfoPrimKey = pk }) [VVal x y z, FVal tau] = do obj <- getObject oid let action = setTarg obj case objectPositionTarget (objectDynamics obj) of Nothing -> action Just (PositionTarget { positionTargetSetBy = scriptId }) | scriptId == (pk,sn) -> action | otherwise -> lift $ logAMessage LogInfo "llMoveToTarget" ("target already set by another script: " ++ show scriptId) Just _ -> action continueWith VoidVal where setTarg obj = lift $ setObject oid obj' where targ = PositionTarget { positionTargetTau = tau, positionTargetLocation = (x,y,z), positionTargetSetBy = (pk,sn) } obj' = obj { objectDynamics = (objectDynamics obj) { objectPositionTarget = Just targ } } llStopMoveToTarget info@(ScriptInfo { scriptInfoObjectKey = oid, scriptInfoScriptName = sn, scriptInfoPrimKey = pk }) [] = do obj <- getObject oid case objectPositionTarget $ objectDynamics obj of Just (PositionTarget {}) -> lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectPositionTarget = Nothing }}) _ -> return () continueWith VoidVal llGroundRepel info@(ScriptInfo { scriptInfoObjectKey = oid }) [FVal height, IVal water, FVal tau] = do obj <- getObject oid lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectPositionTarget = Just $ Repel { positionTargetTau = tau, positionTargetOverWater = water /= 0, positionTargetHeight = height } } }) continueWith VoidVal llSetHoverHeight info@(ScriptInfo { scriptInfoObjectKey = oid }) [FVal height, IVal water, FVal tau] = do obj <- getObject oid lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectPositionTarget = Just $ Hover { positionTargetTau = tau, positionTargetOverWater = water /= 0, positionTargetHeight = height } } }) continueWith VoidVal llStopHover info@(ScriptInfo { scriptInfoObjectKey = oid }) [] = do obj <- getObject oid case objectPositionTarget $ objectDynamics obj of Just (Hover {}) -> lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectPositionTarget = Nothing }}) _ -> lift $ logAMessage LogWarn "llStopHover" "not hovering" continueWith VoidVal llGetAlpha (ScriptInfo _ _ _ pkey _) [IVal side] = computeAlpha >>= continueWith where computeAlpha = if (side /= -1) then runFace pkey side $ (getPrimFaceAlpha pkey side >>= return . FVal) else runFace pkey side $ do faces <- getPrimFaces pkey let n = length faces let alpha = if n > 0 then sum (map faceAlpha faces) / (fromInt $ length faces) else 1.0 return $ FVal alpha llSetAlpha (ScriptInfo _ _ _ pkey _) [FVal alpha, IVal face] = lift $ setAlpha alpha face pkey setAlpha alpha face pkey = if face == -1 then runErrFace pkey face (EvalIncomplete,VoidVal) $ do faces <- getPrimFaces pkey let faces' = map (\ face -> face { faceAlpha = alpha }) faces lift $ setPrimFaces pkey faces' continueWith VoidVal else setPrimFaceAlpha pkey face alpha >> continueWith VoidVal llSetLinkAlpha (ScriptInfo oid pid _ _ _) [IVal link, FVal alpha, IVal face] = do pks <- lift $ getTargetPrimKeys oid link pid lift $ mapM_ (setAlpha alpha face) pks continueWith VoidVal getTargetPrimKeys oid link pid = do LSLObject { primKeys = prims } <- runAndLogIfErr ("can't find object " ++ oid) (LSLObject [] defaultDynamics) $ getObject oid let targetList = targetLinks (length prims) link pid mapM (flip lookupByIndex prims) targetList llGetColor (ScriptInfo _ _ _ pkey _) [IVal side] = computeColor >>= continueWith where computeColor = if (side /= -1) then runFace pkey side $ (getPrimFaceColor pkey side >>= return . vec2VVal) else runFace pkey side $ do faces <- getPrimFaces pkey let n = length faces let color = if n > 0 then scale3d (1.0/ (fromInt $ length faces) ) (foldr add3d (0.0,0.0,0.0) (map faceColor faces)) else (1.0,1.0,1.0) return $ vec2VVal color llSetColor (ScriptInfo _ _ _ pkey _) [color, IVal face] = setColor color face pkey setColor color face pkey = if face == -1 then runFace pkey face $ do faces <- getPrimFaces pkey let colorVal = vVal2Vec color let faces' = map (\ face -> face { faceColor = colorVal }) faces lift $ setPrimFaces pkey faces' continueWith VoidVal else lift $ setPrimFaceColor pkey face (vVal2Vec color) >> continueWith VoidVal llSetLinkColor (ScriptInfo oid pid _ _ _) [IVal link, color, IVal face] = do pks <- lift $ getTargetPrimKeys oid link pid mapM (setColor color face) pks continueWith VoidVal llGetTextureOffset (ScriptInfo _ _ _ pkey _) [IVal face] = let face' = if face == -1 then 0 else face in runFace pkey face (getPrimFaceTextureInfo pkey face' >>= return . textureOffsets) >>= continueWith . vec2VVal llGetTextureScale (ScriptInfo _ _ _ pkey _) [IVal face] = let face' = if face == -1 then 0 else face in runFace pkey face (getPrimFaceTextureInfo pkey face' >>= return . textureRepeats) >>= continueWith . vec2VVal llGetTextureRot (ScriptInfo _ _ _ pkey _) [IVal face] = let face' = if face == -1 then 0 else face in runFace pkey face (getPrimFaceTextureInfo pkey face' >>= return . textureRotation) >>= continueWith . FVal llSetTexture info@(ScriptInfo _ _ _ pk _) [SVal texture,IVal face] = do tk <- findTexture pk texture setTexture tk face pk continueWith VoidVal -- TODO: worry about texture permissions llGetTexture (ScriptInfo _ _ _ pkey _) [IVal face] = let face' = if face == -1 then 0 else face in runFace pkey face (do info <- getPrimFaceTextureInfo pkey face' invTextures <- getPrimTextures pkey let tKey = textureKey info case findByInvKey tKey invTextures of Nothing -> return tKey Just item -> return $ invName item) >>= continueWith . SVal llSetLinkTexture info@(ScriptInfo oid pid _ pk _) [IVal link, SVal texture,IVal face] = do pks <- lift $ getTargetPrimKeys oid link pid tk <- findTexture pk texture mapM_ (setTexture tk face) pks continueWith VoidVal findTexture pk id = do textures <- getPrimTextures pk case findByInvName id textures of Just item -> return $ snd $ inventoryItemNameKey $ inventoryItemIdentification item Nothing -> do result <- return $ findTextureAsset id case result of Nothing -> throwError ("cannot find texture " ++ id) Just item -> return $ snd $ inventoryItemNameKey $ inventoryItemIdentification item setTexture tk face pkey = do if face == -1 then do faces <- getPrimFaces pkey let faces' = map (\ face -> let info = faceTextureInfo face in face { faceTextureInfo = info { textureKey = tk } }) faces lift $ setPrimFaces pkey faces' else do faces <- getPrimFaces pkey f <- lookupByIndex face faces let tInfo = faceTextureInfo f updatePrimFace pkey face (\ f -> f { faceTextureInfo = tInfo { textureKey = tk } }) updateTextureInfo update pk faceIndex = runFace pk faceIndex ( if faceIndex == -1 then do faces <- getPrimFaces pk let faces' = map (\ face -> let info = faceTextureInfo face in face { faceTextureInfo = update info }) faces lift $ setPrimFaces pk faces' else do f <- getPrimFaces pk >>= lookupByIndex faceIndex let tInfo = update $ faceTextureInfo f updatePrimFace pk faceIndex (\ f -> f { faceTextureInfo = tInfo }) ) >> continueWith VoidVal llScaleTexture info@(ScriptInfo _ _ _ pk _) [FVal h,FVal v,IVal faceIndex] = updateTextureInfo update pk faceIndex where update info = info { textureRepeats = (h,v,0) } llOffsetTexture (ScriptInfo _ _ _ pk _) [FVal h, FVal v, IVal faceIndex] = updateTextureInfo update pk faceIndex where update info = info { textureOffsets = (h,v,0) } llRotateTexture (ScriptInfo _ _ _ pk _) [FVal rot, IVal faceIndex] = updateTextureInfo update pk faceIndex where update info = info { textureRotation = rot } getPos pkey = runErrPrim pkey (VVal 0.0 0.0 0.0) (getRootPrim pkey >>= getObjectPosition >>= return . vec2VVal) getRegionIndex pkey = return (0,0) groupList _ [] = [] groupList n l | n > 0 = take n l : groupList n (drop n l) | otherwise = groupList 1 l genNum :: [Int] -> Integer -> Integer genNum rands maxval = let rands' :: [Integer] rands' = map ((0x80000000-).toInteger) rands topval :: Rational topval = fromInteger $ foldl' (.|.) 0 $ zipWith (shiftL) (replicate (length rands') 0xffffffff) [0,32..] randval :: Rational randval = fromInteger $ foldl' (.|.) 0 $ zipWith (shiftL) rands' [0,32] in floor ((randval / topval) * (fromInteger maxval)) llListRandomize _ [LVal list, IVal stride] = let l1 = groupList stride list n = fac (toInteger $ length l1) randsNeeded = ceiling $ (logBase 2 (fromInteger n)) / 32 wrands = replicate randsNeeded wrand in lift $ do rands <- sequence wrands let permutation = genNum rands n let list' = generatePermutation list permutation continueWith $ LVal list' llGetNumberOfPrims (ScriptInfo oid _ _ pkey _) [] = do (LSLObject { primKeys = prims }) <- getObject oid continueWith $ IVal (length prims) llGetObjectPrimCount info@(ScriptInfo oid _ _ pkey _) [KVal k] = do region <- getPrimRegion oid p <- getPrim k region' <- getPrimRegion k if region /= region' then continueWith (IVal 0) else getRootPrim k >>= primCount >>= continueWith . IVal where primCount oid = do (LSLObject { primKeys = l}) <- getObject oid return $ length l llGetNumberOfSides (ScriptInfo _ _ _ pkey _) [] = getPrimFaces pkey >>= continueWith . IVal . length llGetObjectDesc (ScriptInfo _ _ _ pkey _) [] = getPrimDescription pkey >>= continueWith . SVal llGetObjectName (ScriptInfo _ _ _ pkey _) [] = getPrimName pkey >>= continueWith . SVal llSetObjectName (ScriptInfo _ _ _ pkey _) [SVal name] = lift $ setPrimName pkey (take 255 name) >> continueWith VoidVal llSetObjectDesc (ScriptInfo _ _ _ pkey _) [SVal desc] = lift $ setPrimDescription pkey (take 127 desc) >> continueWith VoidVal llGetObjectPermMask (ScriptInfo oid _ _ _ _) [IVal maskId] = getObjectPermMask oid maskId >>= continueWith . IVal getObjectPermMask oid maskId = do masks <- getPrimPermissions oid let base = if null masks then 0x0008e000 else masks !! 0 let n = length masks return (if maskId `elem` [0..(n-1)] then masks !! maskId else if maskId == 3 then 0 else base) llGetScale (ScriptInfo _ _ _ pkey _) [] = getPrimScale pkey >>= continueWith . vec2VVal llSetScale (ScriptInfo _ _ _ pk _) [scale] = if tooSmall then continueWith VoidVal else lift $ setPrimScale pk clippedVec >> continueWith VoidVal where (x,y,z) = vVal2Vec scale tooSmall = (x < 0.01 || y < 0.01 || z < 0.01) clippedVec = (min x 10.0, min y 10.0, min z 10.0) llGetBoundingBox info [KVal k] = do lift $ logAMessage LogInfo "sim" "note: llGetBoundingBox does not return accurate results (yet)" avatars <- lift getWorldAvatars case M.lookup k avatars of Just avatar -> let pos = avatarPosition avatar in continueWith (LVal $ map (vec2VVal . (add3d pos)) [(-1.0,-1.0,-1.0),(1.0,1.0,1.0)]) Nothing -> getRootPrim k >>= getPrimBox >>= continueWith . LVal . map vec2VVal . tup2l where tup2l (x,y) = [x,y] getPrimBox pk = do pos <- getGlobalPos pk scale <- getPrimScale pk let (xs,ys,zs) = scale3d 0.5 scale return (add3d pos (-xs, -ys, -zs),add3d pos (xs,ys,zs)) -- this is extremely approximate.... objRadius oid = do LSLObject { primKeys = keys } <- getObject oid foldM f 0 keys where f r k = do (x,y,z) <- getPrimPosition k (sx,sy,sz) <- getPrimScale k let (rx,ry,rz) = (sx / 2 + abs x, sy / 2 + abs y, sz / 2 + abs z) return $ maximum [r,rx,ry,rz] llSetTimerEvent (ScriptInfo _ _ sn pk _) [FVal interval] = -- TODO: this may not accurately reflect buggy behavior in SL do lift $ removePendingTimerEvent pk sn when (interval > 0) $ lift $ putWorldEvent interval (TimerEvent interval (pk,sn)) continueWith VoidVal where removePendingTimerEvent pk sn = do wq <- getWQueue let wq' = flip filter wq $ \ e -> case e of (_,TimerEvent _ (pk',sn')) -> pk /= pk' || sn /= sn' _ -> True setWQueue wq' llSetVehicleFlags info@(ScriptInfo _ _ _ pk _) [IVal flagsToSet] = do flags <- getPrimVehicleFlags pk `catchError` primErr pk lift $ setPrimVehicleFlags pk (flags .|. flagsToSet) continueWith VoidVal llRemoveVehicleFlags info@(ScriptInfo _ _ _ pk _) [IVal flagsToClear] = do flags <- getPrimVehicleFlags pk `catchError` primErr pk lift $ setPrimVehicleFlags pk (flags .&. complement flagsToClear) continueWith VoidVal ---------------------------------------------------------------------- -- get/set prim parameters llGetPrimitiveParams (ScriptInfo _ _ _ pk _) [LVal l] = getPrimParameters pk l >>= continueWith . LVal llSetPrimitiveParams (ScriptInfo _ _ _ pk _) [LVal l] = setPrimParameters pk l >> continueWith VoidVal llSetLinkPrimitiveParams (ScriptInfo oid pid _ _ _) [IVal link,LVal l] = do do LSLObject { primKeys = pks } <- getObject oid let targetList = targetLinks (length pks) link pid pkList <- mapM (flip lookupByIndex pks) targetList mapM_ (flip setPrimParameters l) pkList continueWith VoidVal getPrimParameters pk params = case params of [] -> return [] (x:xs) | x `elem` [llcPrimBumpShiny,llcPrimFullbright,llcPrimColor,llcPrimTexture,llcPrimTexgen] && null xs -> return [] | x == llcPrimBumpShiny -> queryAndDoRest (queryPrimBumpShiny $ head xs) (tail xs) | x == llcPrimColor -> queryAndDoRest (queryPrimColor $ head xs) (tail xs) | x == llcPrimTexture -> queryAndDoRest (queryPrimTexture $ head xs) (tail xs) | x == llcPrimTexgen -> queryAndDoRest (queryPrimTexgen $ head xs) (tail xs) | x == llcPrimFullbright -> queryAndDoRest (queryPrimFullbright $ head xs) (tail xs) | x == llcPrimMaterial -> queryAndDoRest queryPrimMaterial xs | x == llcPrimPhantom -> queryAndDoRest (queryPrimStatus primPhantomBit) xs | x == llcPrimPhysics -> queryAndDoRest (queryPrimStatus primPhysicsBit) xs | x == llcPrimFlexible -> queryAndDoRest queryPrimFlexible xs | x == llcPrimPointLight -> queryAndDoRest queryPrimLight xs | x == llcPrimPosition -> queryAndDoRest queryPrimPosition xs | x == llcPrimRotation -> queryAndDoRest queryPrimRotation xs | x == llcPrimSize -> queryAndDoRest queryPrimScale xs | x == llcPrimTempOnRez -> queryAndDoRest queryPrimTempOnRez xs | x == llcPrimType -> queryAndDoRest queryPrimType xs | x == IVal 1 -> queryAndDoRest queryPrimTypeOldSkool xs | otherwise -> getPrimParameters pk xs where queryAndDoRest q rest = liftM2 (++) (q pk) (getPrimParameters pk rest) queryPrimTempOnRez k = getPrimTempOnRez k >>= return . return . IVal . (\ b -> if b then 1 else 0) queryPrimRotation k = getGlobalRot k >>= return . return . rot2RVal queryPrimPosition k = getGlobalPos k >>= return . return . vec2VVal queryPrimScale k = getPrimScale k >>= return . return . vec2VVal queryPrimFlexible k = getPrimFlexibility k >>= (\ flex -> case flex of Nothing -> return [IVal 0, IVal 0, FVal 0, FVal 0, FVal 0, FVal 0, VVal 0.0 0.0 0.0] Just flex' -> return $ map ($ flex') [const (IVal 1),IVal . flexSoftness, FVal . flexGravity, FVal . flexFriction, FVal . flexWind, FVal . flexTension, vec2VVal . flexForce]) queryPrimLight k = getPrimLight k >>= (\ light -> case light of Nothing -> return [IVal 0, VVal 0 0 0, FVal 0, FVal 0, FVal 0] Just light' -> return $ map ($ light') [const (IVal 1), vec2VVal . lightColor, FVal . lightIntensity, FVal . lightRadius, FVal . lightFalloff]) queryPrimMaterial k = getPrimMaterial k >>= return . return . IVal queryPrimStatus bit k = getPrimStatus k >>= return . return . IVal . (\ i -> if testBit i bit then 1 else 0) queryPrimBumpShiny side = queryFaceVals bumpShiny side where bumpShiny face = [IVal $ faceShininess face, IVal $ faceBumpiness face] queryPrimColor side = queryFaceVals colorAlpha side where colorAlpha face = [vec2VVal $ faceColor face, FVal $ faceAlpha face] queryPrimTexture side = queryFaceVals textureInfo side where textureInfo face = let tinfo = faceTextureInfo face in map ($ tinfo) [SVal .textureKey,vec2VVal . textureRepeats,vec2VVal . textureOffsets,FVal . textureRotation] queryPrimTexgen side = queryFaceVals (return . IVal . faceTextureMode) side queryPrimFullbright side = queryFaceVals (\ face -> if faceFullbright face then [IVal 1] else [IVal 0]) side queryFaceVals f (IVal side) k = if side == -1 then getPrimFaces k >>= return . concat . (map f) else getPrimFaces k >>= fromErrorT [] . (\ faces -> (lookupByIndex side faces >>= return . f)) -- TODO: get these out of here Just (Constant _ llcObjectUnknownDetail) = findConstant "OBJECT_UNKNOWN_DETAIL" Just (Constant _ llcObjectName) = findConstant "OBJECT_NAME" Just (Constant _ llcObjectDesc) = findConstant "OBJECT_DESC" Just (Constant _ llcObjectPos) = findConstant "OBJECT_POS" Just (Constant _ llcObjectRot) = findConstant "OBJECT_ROT" Just (Constant _ llcObjectVelocity) = findConstant "OBJECT_VELOCITY" Just (Constant _ llcObjectOwner) = findConstant "OBJECT_OWNER" Just (Constant _ llcObjectGroup) = findConstant "OBJECT_GROUP" Just (Constant _ llcObjectCreator) = findConstant "OBJECT_CREATOR" queryPrimType k = do (PrimType version typecode holeshape cut twist holesize topshear hollow taper advancedcut roffset revs skew sculpt sculptType) <- getPrimTypeInfo k case typecode of i | (IVal i) `elem` [llcPrimTypeBox,llcPrimTypeCylinder,llcPrimTypePrism] -> return [IVal i,IVal holeshape, vec2VVal cut, FVal hollow, vec2VVal twist, vec2VVal taper, vec2VVal topshear] | (IVal i) == llcPrimTypeSphere -> return [IVal i,IVal holeshape, vec2VVal cut, FVal hollow, vec2VVal twist, vec2VVal advancedcut] | (IVal i) `elem` [llcPrimTypeRing,llcPrimTypeTorus,llcPrimTypeTube] -> return [IVal i,IVal holeshape, vec2VVal cut, FVal hollow, vec2VVal twist, vec2VVal holesize, vec2VVal topshear, vec2VVal advancedcut, vec2VVal taper, FVal revs, FVal roffset, FVal skew] | (IVal i) == llcPrimTypeSculpt -> return [IVal i,SVal $ fromMaybe "" sculpt, IVal sculptType] | otherwise -> return [] queryPrimTypeOldSkool k = do (PrimType version typecode holeshape cut twist holesize topshear hollow taper advancedcut roffset revs skew sculpt sculptType) <- getPrimTypeInfo k case typecode of i | (IVal i) `elem` [llcPrimTypeBox,llcPrimTypeCylinder,llcPrimTypePrism] -> return [IVal i, vec2VVal cut, FVal hollow, FVal $ yOf twist, vec2VVal taper, vec2VVal topshear] | (IVal i) == llcPrimTypeSphere -> return [IVal i,vec2VVal cut, FVal hollow,vec2VVal advancedcut] | (IVal i) == llcPrimTypeTorus -> return [IVal i, vec2VVal cut, FVal hollow, FVal $ yOf twist, FVal $ yOf taper, vec2VVal topshear, vec2VVal advancedcut] | (IVal i) == llcPrimTypeTube -> return [IVal i, vec2VVal cut, FVal hollow, FVal $ yOf twist, FVal $ xOf topshear] | otherwise -> return [] where xOf (x,y,z) = x yOf (x,y,z) = y setPrimParameters pk params = updatePrimParameters pk params >> return () updatePrimParameters pk [] = return [] updatePrimParameters pk (code:rest) = do result <- case code of i | i == llcPrimTempOnRez -> updatePrimTempOnRez pk rest | i == llcPrimMaterial -> updatePrimMaterial pk rest | i == llcPrimPhantom -> updatePrimPhantom pk rest | i == llcPrimPhysics -> updatePrimPhysics pk rest | i == llcPrimPosition -> updatePrimPosition pk rest | i == llcPrimRotation -> updatePrimRotation pk rest | i == llcPrimSize -> updatePrimScale pk rest | i == llcPrimFlexible -> updatePrimFlexible pk rest | i == llcPrimPointLight -> updatePrimLight pk rest | i == llcPrimBumpShiny -> updatePrimBumpShiny pk rest | i == llcPrimColor -> updatePrimColor pk rest | i == llcPrimTexture -> updatePrimTexture pk rest | i == llcPrimTexgen -> updatePrimTexgen pk rest | i == llcPrimFullbright -> updatePrimFullbright pk rest | i == llcPrimType -> updatePrimType pk rest | i == IVal 1 -> updatePrimTypeOldSkool pk rest | otherwise -> fail "incorrect parameter" updatePrimParameters pk result updatePrimType pk vals = getPrim pk >>= flip updatePrimType' vals >>= (\ (prim,rest) -> (lift $ setPrim pk prim) >> return rest) updatePrimType' prim (primCode@(IVal i):rest) | primCode == llcPrimTypeSphere = updatePrimTypeSphere prim rest | primCode `elem` [llcPrimTypeBox,llcPrimTypeCylinder,llcPrimTypePrism] = updatePrimTypeBoxCylPrism i prim rest | primCode `elem` [llcPrimTypeTorus,llcPrimTypeTube,llcPrimTypeRing] = updatePrimTypeRingTorusTube i prim rest | primCode == llcPrimTypeSculpt = updatePrimTypeSculpt prim rest | otherwise = fail "incorrect parameters for PRIM_TYPE" updatePrimType' _ _ = fail "insufficient or incorrect parameters for PRIM_TYPE" updatePrimTypeOldSkool pk vals = getPrim pk >>= flip updatePrimTypeOldSkool' vals >>= (\ (prim,rest) -> (lift $ setPrim pk prim) >> return rest) updatePrimTypeOldSkool' prim (primCode@(IVal i):rest) | primCode == llcPrimTypeSphere = updatePrimTypeSphereOld prim rest | primCode `elem` [llcPrimTypeBox,llcPrimTypeCylinder,llcPrimTypePrism] = updatePrimTypeBoxCylPrismOld i prim rest | primCode == llcPrimTypeTorus = updatePrimTypeTorusOld prim rest | primCode == llcPrimTypeTube = updatePrimTypeTubeOld prim rest | otherwise = fail "incorrect parameters for deprecated prim type" updatePrimTypeOldSkool' _ _ = fail "insufficient or incorrect parameters for deprecated prim type" --updatePrimTempOnRez prim (IVal tempOnRez:rest) = return (prim { primTempOnRez = if tempOnRez /= 0 then True else False }, rest) updatePrimTempOnRez pk (IVal tempOnRez:rest) = lift (setPrimTempOnRez pk (tempOnRez /= 0)) >> return rest updatePrimTempOnRez _ _ = fail "insufficient or incorrect parameters for PRIM_TEMP_ON_REZ" --updatePrimMaterial prim (IVal material:rest) = return (prim { primMaterial = material }, rest) updatePrimMaterial pk (IVal material:rest) = lift (setPrimMaterial pk material) >> return rest updatePrimMaterial _ _ = fail "insufficient or incorrect parameters for PRIM_MATERIAL" updatePrimPhantom pk params = updatePrimStatus "insufficient or incorrect parameters for PRIM_PHANTOM" primPhantomBit pk params updatePrimPhysics pk params = updatePrimStatus "insufficient or incorrect parameters for PRIM_PHYSICS" primPhysicsBit pk params -- updatePrimStatus _ bit prim (IVal i:rest) = return (prim { primStatus = if i == 0 then clearBit (primStatus prim) bit -- else setBit (primStatus prim) bit }, rest) updatePrimStatus _ bit pk (IVal i:rest) = (getPrimStatus pk) >>= lift . (setPrimStatus pk) . (if i == 0 then flip clearBit bit else flip setBit bit) >> return rest updatePrimStatus fMsg _ _ _ = fail fMsg updatePrimPosition pk (pos@(VVal _ _ _):rest) = do getPrimParent pk >>= \ mok -> case mok of Nothing -> setRootPos pk v Just ok -> setChildPos pk v return rest where v = vVal2Vec pos updatePrimPosition _ _ = fail "insufficient or incorrect parameters for PRIM_POSITION" updatePrimRotation pk (rot@(RVal _ _ _ _):rest) = do getPrimParent pk >>= \ mok -> case mok of Nothing -> setRootRotation pk r Just rk -> setChildRotation rk pk r return rest where r = rVal2Rot rot updatePrimRotation _ _ = fail "insufficient or incorrect parameters for PRIM_ROTATION" updatePrimScale pk (scale@(VVal _ _ _):rest) = (lift $ setPrimScale pk (vVal2Vec scale)) >> return rest updatePrimScale _ _ = fail "insufficient or incorrect parameters for PRIM_SIZE" updatePrimFlexible pk (IVal flex:IVal soft:FVal gravity:FVal friction:FVal wind:FVal tension:VVal fx fy fz:rest) = lift (setPrimFlexibility pk (if flex == 0 then Nothing else Just (Flexibility soft gravity friction wind tension (fx,fy,fz)))) >> return rest updatePrimFlexible _ _ = fail "insufficient or incorrect parameters for PRIM_FLEXIBLE" updatePrimLight pk (IVal light:VVal r g b:FVal intensity:FVal radius:FVal falloff:rest) = lift (setPrimLight pk (if light == 0 then Nothing else Just (LightInfo (r,g,b) intensity radius falloff))) >> return rest updatePrimLight _ _ = fail "insufficient or incorrect parameters for PRIM_POINT_LIGHT" updatePrimBumpShiny pk params = let extract (IVal face:IVal bump:IVal shiny:rest) = return (face, [IVal bump, IVal shiny], rest) extract _ = fail ("insufficient or incorrect parameters for PRIM_BUMP_SHINY") update [IVal bump, IVal shiny] face = face { faceBumpiness = bump, faceShininess = shiny } in updatePrimFaceParams pk params extract update updatePrimColor pk params = let extract (IVal face:VVal r g b:FVal alpha:rest) = return (face,[VVal r g b, FVal alpha], rest) extract _ = fail ("insufficient or incorrect parameters for PRIM_COLOR") update [color, FVal alpha] face = face { faceColor = vVal2Vec color, faceAlpha = alpha } in updatePrimFaceParams pk params extract update updatePrimTexture pk params = let extract (IVal face:name@(SVal _):repeats@(VVal _ _ _):offsets@(VVal _ _ _):rotation@(FVal _):rest) = return (face,[name,repeats,offsets,rotation],rest) extract _ = fail ("insufficient or incorrect parameters for PRIM_TEXTURE") update [SVal name,repeats,offsets,FVal rotation] face = face { faceTextureInfo = TextureInfo name (vVal2Vec repeats) (vVal2Vec offsets) rotation } in updatePrimFaceParams pk params extract update updatePrimTexgen pk params = let extract (IVal face:IVal mode:rest) = return (face,[IVal mode],rest) extract _ = fail "insufficient or incorrect parameters for PRIM_TEXGEN" update [IVal mode] face = face { faceTextureMode = mode } in updatePrimFaceParams pk params extract update updatePrimFullbright pk params = let extract (IVal face:IVal fullbright:rest) = return (face,[IVal fullbright],rest) extract _ = fail "insufficient or incorrect parameters for PRIM_FULLBRIGHT" update [IVal fullbright] face = face { faceFullbright = if fullbright == 0 then False else True } in updatePrimFaceParams pk params extract update updatePrimFaceParams pk params extract update = do (face, faceParams, rest) <- extract params -- this can fail prim <- getPrim pk let prim' = if face == -1 then prim { primFaces = map (update faceParams) $ primFaces prim } else let (xs,ys) = splitAt face (primFaces prim) in if null ys then prim else prim { primFaces = xs ++ [(update faceParams $ head ys)] ++ (tail ys) } lift $ setPrim pk prim' return rest updatePrimTypeBoxCylPrism ptype prim (IVal holeshape:VVal cx cy cz:FVal hollow:VVal twx twy twz:VVal tx ty tz:VVal sx sy sz:rest) = return (prim { primTypeInfo = (primTypeInfo prim) { primTypeCode = ptype, primHoleshape = holeshape, primCut = (cx,cy,cz), primHollow = hollow, primTwist = (twx,twy,twz), primTaper = (tx,ty,tz), primTopshear = (sx,sy,sz) }}, rest) updatePrimTypeBoxCylPrism _ _ _ = fail "insufficient or incorret parameters for PRIM_TYPE (PRIM_TYPE_PRISM, PRIM_TYPE_CYLINDER, or PRIM_TYPE_BOX)" updatePrimTypeSphere prim (IVal holeshape:VVal cx cy cz:FVal hollow:VVal tx ty tz:VVal ax ay az:rest) = return (prim { primTypeInfo = (primTypeInfo prim) { primTypeCode = cPrimTypeSphere, primHoleshape = holeshape, primCut = (cx,cy,cz), primHollow = hollow, primTwist = (tx,ty,tz), primAdvancedCut = (ax,ay,az) } }, rest) updatePrimTypeSphere _ _ = fail "insufficient or incorrect parameters for PRIM_TYPE (PRIM_TYPE_SPHERE)" updatePrimTypeRingTorusTube ptype prim (IVal holeshape:VVal cx cy cz:FVal hollow:VVal twx twy twz:VVal hx hy hz:VVal sx sy sz: VVal ax ay az:VVal tx ty tz:FVal revs:FVal roffset:FVal skew:rest) = return (prim { primTypeInfo = (primTypeInfo prim) { primTypeCode = ptype, primHoleshape = holeshape, primCut = (cx,cy,cz), primHollow = hollow, primTwist = (twx,twy,twz), primHolesize = (hx,hy,hz), primTopshear = (sx,sy,sz), primAdvancedCut = (ax,ay,az), primTaper = (tx,ty,tz), primRevolutions = revs, primRadiusOffset = roffset, primSkew = skew } }, rest) updatePrimTypeRingTorusTube _ _ _ = fail "insufficient or incorrect parameters for PRIM_TYPE (PRIM_TYPE_RING, PRIM_TYPE_TORUS, or PRIM_TYPE_TUBE)" updatePrimTypeSculpt prim (SVal name:IVal sculptType:rest) = return (prim { primTypeInfo = (primTypeInfo prim) { primTypeCode = cPrimTypeSculpt, primSculptTexture = Just name, primSculptType = sculptType } }, rest) updatePrimTypeSculpt _ _ = fail "insufficient or incorrect parameters for PRIM_TYPE (PRIM_TYPE_SCULPT)" updatePrimTypeBoxCylPrismOld ptype prim (VVal cx cy cz:FVal hollow:FVal twisty:VVal tx ty tz:VVal sx sy sz:rest) = let info = primTypeInfo prim in return (prim { primTypeInfo = info { primTypeCode = ptype, primCut = (cx,cy,cz), primHollow = hollow, primTwist = let (x,_,z) = primTwist info in (x,twisty,z), primTaper = (tx,ty,tz), primTopshear = (sx,sy,sz) } }, rest) updatePrimTypeBoxCylPrismOld _ _ _ = fail "insufficient or inccorrect parameters for deprecated prim type (PRIM_TYPE_BOX, PRIM_TYPE_CYLINDER, or PRIM_TYPE_PRISM)" updatePrimTypeSphereOld prim (VVal cx cy cz:FVal hollow:VVal ax ay az:rest) = return (prim { primTypeInfo = (primTypeInfo prim) { primTypeCode = cPrimTypeSphere, primCut = (cx,cy,cz), primHollow = hollow, primAdvancedCut = (ax,ay,az) }}, rest) updatePrimTypeSphereOld _ _ = fail "insufficient or incorrect parameters for deprecated prim type (PRIM_TYPE_SPHERE)" updatePrimTypeTorusOld prim (VVal cx cy cz:FVal hollow:FVal twisty:FVal tapery:VVal sx sy sz:VVal ax ay az:rest) = let info = primTypeInfo prim in return (prim { primTypeInfo = info { primTypeCode = cPrimTypeTorus, primCut = (cx,cy,cz), primHollow = hollow, primTwist = let (x,_,z) = primTwist info in (x,twisty,z), primTaper = let (x,_,z) = primTaper info in (x,tapery,z), primTopshear = (sx,sy,sz), primAdvancedCut = (ax,ay,az) } }, rest) updatePrimTypeTorusOld _ _ = fail "insufficient or incorrect parameters for deprecated prim type (PRIM_TYPE_TORUS)" updatePrimTypeTubeOld prim (VVal cx cy cz:FVal hollow:FVal twisty:FVal shearx:rest) = let info = primTypeInfo prim in return (prim { primTypeInfo = info { primTypeCode = cPrimTypeTube, primCut = (cx,cy,cz), primHollow = hollow, primTwist = let (x,_,z) = primTwist info in (x,twisty,z), primTopshear = let (_,y,z) = primTopshear info in (shearx,y,z) } }, rest) updatePrimTypeTubeOld _ _ = fail "insufficient or incorrect parameters for deprecated prim type (PRIM_TYPE_TUBE)" llGetObjectDetails _ [KVal k, LVal params] = -- TODO: this doesn't take into account multiple regions do (getAvatarDetails k params <||> getPrimDetails k params) >>= continueWith . LVal where getAvatarDetails k params = do avs <- lift getWorldAvatars av <- mlookup k avs return $ map (avq av) params where avq av i | i == llcObjectName = SVal $ avatarName av | i == llcObjectDesc = SVal "" | i == llcObjectPos = vec2VVal $ avatarPosition av | i == llcObjectRot = rot2RVal $ avatarRotation av | i == llcObjectVelocity = VVal 0.0 0.0 0.0 -- TODO: avatar velocities | i == llcObjectOwner = KVal k | i == llcObjectGroup = KVal nullKey | i == llcObjectCreator = KVal nullKey | otherwise = llcObjectUnknownDetail getPrimDetails k params = do prim <- getPrim k pos <- getObjectPosition k rot <- getObjectRotation k vel <- getObject k >>= return . objectVelocity . objectDynamics return $ map (primq prim pos rot vel) params where primq prim pos rot vel i | i == llcObjectName = SVal $ primName prim | i == llcObjectDesc = SVal $ primDescription prim | i == llcObjectPos = vec2VVal $ pos | i == llcObjectRot = rot2RVal $ rot | i == llcObjectVelocity = vec2VVal $ vel | i == llcObjectOwner = KVal $ primOwner prim | i == llcObjectGroup = KVal nullKey -- TODO: prim groups | i == llcObjectCreator = KVal $ primOwner prim -- TODO: prim creators | otherwise = llcObjectUnknownDetail -------------------------------------------------------------------------------------------------------------- llAllowInventoryDrop info@(ScriptInfo _ _ _ k _) [IVal add] = (getPrim k >>= return . (\ p -> p { primAllowInventoryDrop = add /= 0 }) >>= lift . setPrim k >> lift (logFromScript info ("drop is now " ++ (if add == 0 then "not " else "") ++ "allowed"))) >> continueWith VoidVal llAdjustSoundVolume info [FVal f] = lift $ do do if (f < 0.0 || f > 1.0) then logFromScript info ("llAdjustSoundVolume: volume " ++ show f ++ " out of range.") else logFromScript info ("llAdjustSoundVolume: volume adjusted to " ++ show f) continueWith VoidVal ----------------------------------------------------------------------------------------------------------------- -- Parcel related functions llSetParcelMusicURL info@(ScriptInfo _ _ _ pk _) [SVal url] = -- parcel music URL is a write-only value, so we won't worry about setting anything.... do -- make sure object owner == parcel owner (_,_,parcel) <- getPrimParcel pk owner <- getPrimOwner pk when (parcelOwner parcel /= owner) $ throwError ("prim doesn't have permission to modify parcel") lift $ logFromScript info ("setting music url for parcel " ++ parcelName parcel ++ " to " ++ url) continueWith VoidVal llGetParcelFlags info@(ScriptInfo _ _ _ pk _) [VVal x y z] = do regionIndex <- getPrimRegion pk (_,parcel) <- getParcelByPosition regionIndex (x,y,z) continueWith $ IVal $ parcelFlags parcel llGetParcelDetails info@(ScriptInfo _ _ _ pk _) [VVal x y z, LVal details] = do regionIndex <- getPrimRegion pk (_,parcel) <- getParcelByPosition regionIndex (x,y,z) detailList <- mapM (getDetail parcel) details continueWith $ LVal [ d | Just d <- detailList] where getDetail parcel (IVal detail) | detail == cParcelDetailsName = return $ Just $ SVal $ parcelName parcel | detail == cParcelDetailsDesc = return $ Just $ SVal $ parcelDescription parcel | detail == cParcelDetailsOwner = return $ Just $ KVal $ parcelOwner parcel | detail == cParcelDetailsGroup = return $ Just $ KVal nullKey | detail == cParcelDetailsArea = return $ Just $ FVal $ fromIntegral $ let (bot,top,left,right) = parcelBoundaries parcel in (top - bot) * (right - left) | otherwise = lift $ logFromScript info ("llGetParcelDetails: invalid detail flag: " ++ show detail) >> return Nothing getDetail _ v = lift $ logFromScript info ("llGetParcelDetails: invalid detail: " ++ lslValString v) >> return Nothing whenParcelPermitted info pk action= do (regionIndex,parcelIndex,parcel) <- getPrimParcel pk prim <- getPrim pk if parcelOwner parcel /= primOwner prim then lift $ logFromScript info "prim not permitted to change parcel" else action regionIndex parcelIndex parcel >>= putParcel regionIndex parcelIndex addToLandACLList aclType aclFromParcel aclIntoParcel info@(ScriptInfo _ _ _ pk _) [KVal ak,FVal duration] = do do whenParcelPermitted info pk $ \ regionIndex parcelIndex parcel -> do lift $ runAndLogIfErr ("attempt to change " ++ aclType ++ " unknown avatar " ++ ak) parcel $ do avs <- lift getWorldAvatars _ <- mlookup ak avs when (duration < 0.0) $ lift $ logFromScript info (aclType ++ " change attempted with invalid duration: " ++ show duration) t <- lift getTick let acl = (ak, if duration == 0 then Nothing else Just $ t + durationToTicks duration) let acllist = acl : ([ b | b@(k,Just expire) <- aclFromParcel parcel,expire < t, k /= ak] ++ [ b | b@(k,Nothing) <- aclFromParcel parcel, k /= ak]) let parcel' = aclIntoParcel parcel acllist lift $ logFromScript info ("added " ++ ak ++ " to " ++ aclType ++ " list for parcel in " ++ (show regionIndex)) return parcel' continueWith VoidVal removeFromLandACLList aclFromParcel aclIntoParcel info@(ScriptInfo _ _ _ pk _) ak = do whenParcelPermitted info pk $ \ regionIndex parcelIndex parcel -> do avs <- lift getWorldAvatars mlookup ak avs `catchError` (\ _ -> throwError ("unkown avatar " ++ ak)) let acl = aclFromParcel parcel return $ aclIntoParcel parcel [ ac | ac@(k,_) <- acl, k /= ak ] llResetLandBanList info@(ScriptInfo _ _ _ pk _) [] = do whenParcelPermitted info pk (\ regionIndex parcelIndex parcel -> return $ parcel { parcelBanList = [] }) continueWith VoidVal llResetLandPassList info@(ScriptInfo _ _ _ pk _) [] = do whenParcelPermitted info pk (\ regionIndex parcelIndex parcel -> return $ parcel { parcelPassList = [] }) continueWith VoidVal llRemoveFromLandPassList info [KVal ak] = let aclFromParcel = parcelPassList aclIntoParcel = (\ parcel list -> parcel { parcelPassList = list}) in do removeFromLandACLList aclFromParcel aclIntoParcel info ak lift $ logFromScript info ("llRemovFromLandPassList: removed " ++ ak) continueWith VoidVal llRemoveFromLandBanList info [KVal ak] = let aclFromParcel = parcelBanList aclIntoParcel = (\ parcel list -> parcel { parcelBanList = list}) in do removeFromLandACLList aclFromParcel aclIntoParcel info ak lift $ logFromScript info ("llRemovFromLandBanList: removed " ++ ak) continueWith VoidVal llAddToLandPassList info args = let aclFromParcel = parcelPassList aclIntoParcel = (\ parcel list -> parcel { parcelPassList = list }) in addToLandACLList "pass" aclFromParcel aclIntoParcel info args llAddToLandBanList info args = let aclFromParcel = parcelBanList aclIntoParcel = (\ parcel list -> parcel { parcelBanList = list }) in addToLandACLList "ban" aclFromParcel aclIntoParcel info args llGetLandOwnerAt info@(ScriptInfo _ _ _ pk _) [VVal x y z] = do regionIndex <- getPrimRegion pk getParcelByPosition regionIndex (x,y,z) >>= continueWith . KVal . parcelOwner . snd llOverMyLand info@(ScriptInfo _ _ _ pk _) [KVal ak] = do regionIndex <- getPrimRegion pk owner <- getPrimOwner pk avatars <- lift getWorldAvatars i <- case M.lookup ak avatars of Nothing -> lift $ logFromScript info "llOverMyLand: no such avatar" >> return 0 Just av | avatarRegion av /= regionIndex -> lift $ logFromScript info "llOverMyLand: avatar not in sim" >> return 0 | otherwise -> do parcel <- getParcelByPosition regionIndex (avatarPosition av) return $ if owner == (parcelOwner . snd) parcel then 1 else 0 continueWith (IVal i) ------------------------------------------------------------------------------- -- EMAIL llGetNextEmail info@(ScriptInfo _ _ sn pk _) [SVal addr, SVal subj] = do emails <- getPrimPendingEmails pk case find match emails of Nothing -> return () Just email -> do lift $ pushDeferredScriptEvent (Event "email" [SVal $ show $ emailTime email, SVal $ emailAddress email, SVal $ emailSubject email, SVal $ emailMessage email, IVal (length emails - 1)] M.empty) pk sn 0 lift $ setPrimPendingEmails pk (filter (not . match) emails) continueWith VoidVal where match email = (addr == "" || addr == emailAddress email) && (subj == "" || subj == emailSubject email) llEmail info@(ScriptInfo _ _ _ pk _) [SVal address, SVal subject, SVal message] = do let suffix = "@lsl.secondlife.com" let logit = lift $ logFromScript info ("llEmail: sending email to " ++ address) if suffix `isSuffixOf` address then let potentialKey = take (length address - length suffix) address in do pending <- (getPrimPendingEmails potentialKey) <||> throwError ("LSL destination addresses unknown prim") time <- lift $ getUnixTime lift $ setPrimPendingEmails pk (pending ++ [Email subject address message time]) logit else logit continueWith VoidVal -- should do a yield til... (20 second delay!) ------------------------------------------------------------------------------- soundExists pk sound = do sounds <- getPrimSounds pk case findByInvName sound sounds of Nothing -> do result <- lift $ findAsset sound case result of Nothing -> return False Just v -> return $ if isSoundAsset v then True else False Just _ -> return True llTriggerSound info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal volume] = do found <- soundExists pk sound let message = if found then "llTriggerSound: triggering sound " ++ sound else "llTriggerSound: sound not found - " ++ sound lift $ logFromScript info message continueWith VoidVal llTriggerSoundLimited info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal volume, VVal t n e, VVal b s w] = do when (t <= b || n <= s || e <= w) $ lift $ logFromScript info ("llTriggerSoundLimited: bounding box has zero or negative volume") found <- soundExists pk sound let message = if found then "llTriggerSoundLimited: triggering sound " ++ sound else "llTriggerSoundLimited: sound no found - " ++ sound lift $ logFromScript info message continueWith VoidVal llSound info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol, IVal q, IVal loop] = do found <- soundExists pk sound let message = if found then "llSound (deprecated): playing sound " ++ sound else "llSound (deprecated): sound not found - " ++ sound lift $ logFromScript info message continueWith VoidVal llPlaySound info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol] = do found <- soundExists pk sound let message = if found then "llPlaySound: playing sound " ++ sound else "llPlaySound: sound not found - " ++ sound lift $ logFromScript info message continueWith VoidVal llCollisionSound info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol] = do found <- soundExists pk sound let message = if found then "llCollisionSound: setting collision sound to " ++ sound else "llCollisionSound: sound not found - " ++ sound lift $ logFromScript info message continueWith VoidVal llPreloadSound info@(ScriptInfo _ _ _ pk _) [SVal sound] = do found <- soundExists pk sound let message = if found then "llPreloadSound: loading sound " ++ sound else "llPreloadSound: sound not found - " ++ sound lift $ logFromScript info message continueWith VoidVal llSoundPreload info@(ScriptInfo _ _ _ pk _) [SVal sound] = do found <- soundExists pk sound let message = if found then "llSoundPreload: loading sound " ++ sound else "llSoundPreload: sound not found - " ++ sound lift $ logFromScript info message continueWith VoidVal llPlaySoundSlave info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol] = do found <- soundExists pk sound let message = if found then "llPlaySoundSlave: playing sound " ++ sound else "llPlaySoundSlave: sound not found - " ++ sound lift $ logFromScript info message continueWith VoidVal llLoopSoundSlave info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol] = do found <- soundExists pk sound let message = if found then "llLoopSoundSlave: playing sound " ++ sound else "llLoopSoundSlave: sound not found - " ++ sound lift $ logFromScript info message continueWith VoidVal llLoopSound info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol] = do found <- soundExists pk sound let message = if found then "llLoopSound: playing sound " ++ sound else "llLoopSound: sound not found - " ++ sound lift $ logFromScript info message continueWith VoidVal llLoopSoundMaster info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol] = do found <- soundExists pk sound let message = if found then "llLoopSoundMaster: playing sound " ++ sound else "llLoopSoundMaster: sound not found - " ++ sound lift $ logFromScript info message continueWith VoidVal llStopSound info [] = lift $ logFromScript info "llStopSound: stopping sound" >> continueWith VoidVal llSetSoundRadius info [FVal radius] = lift $ logFromScript info "llSetSoundRadius: called. In real sim, this function has no effect." >> continueWith VoidVal llSetSoundQueueing info [IVal bool] = lift $ logFromScript info ("llSetSoundQueuiing: set to " ++ (if bool /= 0 then "TRUE" else "FALSE")) >> continueWith VoidVal ------------------------------------------------------------------------------ llCollisionSprite info@(ScriptInfo _ _ _ pk _) [SVal impactSprite] = do tk <- findTexture pk impactSprite lift $ logFromScript info ("llCollisionSprite: set sprite to " ++ tk) continueWith VoidVal -- llGetKey (ScriptInfo _ _ _ pk _) [] = continueWith $ KVal pk llGetOwnerKey info@(ScriptInfo _ _ _ pk _) [KVal k] = (do regionIndex <- getPrimRegion pk mRegionIndex <- fromErrorT Nothing (getPrimRegion k >>= return . Just) key <- case mRegionIndex of Nothing -> (lift $ logFromScript info "llGetOwnerKey: object key not found") >> return k Just regionIndex' | regionIndex /= regionIndex' -> (lift $ logFromScript info "llGetOwnerKey: object in different simulator") >> return k | otherwise -> getPrimOwner k continueWith (KVal key)) <||> (do avatars <- lift $ getWorldAvatars case M.lookup k avatars of Nothing -> throwError "no such key" Just _ -> continueWith (KVal k)) llGetLinkNumber (ScriptInfo oid pid _ pk _) [] = if pid /= 0 then continueWith (IVal $ pid + 1) else do LSLObject { primKeys = links } <- getObject oid continueWith $ IVal (if length links == 1 then 0 else 1) llGetUnixTime (ScriptInfo _ _ _ _ _) [] = lift (getUnixTime >>= continueWith . IVal) llGetTimestamp (ScriptInfo _ _ _ _ _) [] = lift $ do cal <- getTimeOfDay >>= return . toUTCTime continueWith $ SVal $ printf "%04d-%02d-%02dT%02d:%02d:%02.6f" (ctYear cal) (1 + (fromEnum $ ctMonth cal)) (ctDay cal) (ctHour cal) (ctMin cal) (((fromIntegral $ ctSec cal) / (10.0^12 * (fromIntegral $ ctPicosec cal))) :: Float) llGetDate (ScriptInfo _ _ _ _ _) [] = lift (getUTCDate >>= continueWith . SVal) llGetGMTclock (ScriptInfo _ _ _ _ _) [] = lift $ do cal <- getTimeOfDay >>= return . toUTCTime continueWith $ IVal $ (24 * ctHour cal) + (60 * ctMin cal) + (ctSec cal) llGetWallclock (ScriptInfo _ _ _ _ _) [] = lift $ do cal <- getLocalTimeOfDay (-8) >>= return . toUTCTime continueWith $ IVal $ (24 * ctHour cal) + (60 * ctMin cal) + (ctSec cal) llGetTimeOfDay (ScriptInfo _ _ _ _ _) [] = lift $ do t <- getTick continueWith $ FVal $ (ticksToDuration (t `mod` durationToTicks 4.0)) getUnixTime :: (Monad (StateT (World a) a), Monad a) => StateT (World a) a Int getUnixTime = (liftM2 (+) getWorldZeroTime (getTick >>= return . floor . ticksToDuration)) >>= return . fromIntegral getTimeOfDay :: (Monad (StateT (World a) a), Monad a) => StateT (World a) a ClockTime getTimeOfDay = getUnixTime >>= return . (flip TOD 0) . fromIntegral getLocalTimeOfDay offset = getTimeOfDay >>= return . (addToClockTime (TimeDiff 0 0 0 offset 0 0 0)) getUTCDate :: (Monad (StateT (World a) a), Monad a, PrintfType (Int -> Int -> Int -> b)) => StateT (World a) a b getUTCDate = do cal <- getTimeOfDay >>= return . toUTCTime return $ printf "%04d-%02d-%02d" (ctYear cal) (1 + fromEnum (ctMonth cal)) (ctDay cal) llGetRegionFPS _ _ = continueWith $ FVal 45.0 llGetRegionTimeDilation _ _ = continueWith $ FVal 1.0 llGetTime (ScriptInfo _ _ sid pk _) [] = do t <- lift getTick script <- lift getWorldScripts >>= mlookup (pk,sid) continueWith $ FVal $ ticksToDuration (t - scriptLastResetTick script) getAndResetTick pk sid = do scripts <- lift getWorldScripts script <- mlookup (pk,sid) scripts let t = scriptLastResetTick script t' <- lift getTick lift $ setWorldScripts (M.insert (pk,sid) (script { scriptLastResetTick = t' } ) scripts) return $ t' - t llGetAndResetTime (ScriptInfo _ _ sid pk _) [] = getAndResetTick pk sid >>= continueWith . FVal . ticksToDuration llResetTime (ScriptInfo _ _ sid pk _) [] = getAndResetTick pk sid >> continueWith VoidVal llSetText info [SVal text, VVal r g b, FVal alpha] = lift $ setText "llSetText" 254 info text llSetSitText info [SVal text] = lift $ setText "llSetSitText" 9 info text llSetTouchText info [SVal text] = lift $ setText "llSetTouchText" 9 info text setText func lim info text = do logFromScript info (func ++ ": setting text to " ++ text) when (length text > lim) $ logFromScript info (func ++ ": text exceeds " ++ show lim ++ " character limit") continueWith VoidVal llGetScriptName (ScriptInfo _ _ sid _ _) [] = continueWith (SVal sid) llGetNumberOfNotecardLines (ScriptInfo _ _ sn pk _) [SVal name] = do notecards <- getPrimNotecards pk key <- case find ((name==) . inventoryItemName) notecards of Nothing -> (lift $ putChat (Just 20.0) pk 0 ("Couldn't find notecard " ++ name)) >> return nullKey Just notecard -> do key <- lift newKey lift $ pushDataserverEvent pk sn key (show $ length $ invNotecardLines $ inventoryItemData notecard) return key continueWith (KVal key) llGetNotecardLine (ScriptInfo _ _ sn pk _) [SVal name, IVal lineNumber] = do notecards <- getPrimNotecards pk key <- case find ((name==) . inventoryItemName) notecards of Nothing -> (lift $ putChat (Just 20.0) pk cDebugChannel ("Couldn't find notecard " ++ name)) >> return nullKey Just notecard -> do key <- lift newKey let line = case lookupByIndex lineNumber $ invNotecardLines $ inventoryItemData notecard of Nothing -> cEOF Just v -> take 255 v lift $ pushDataserverEvent pk sn key line return key continueWith (KVal key) llRequestInventoryData info@(ScriptInfo _ _ sn pk _) [SVal name] = do do t <- lift getTick landmarks <- getPrimLandmarks pk landmark <- maybe (throwError ("no landmark named " ++ name)) (\ l -> return l) (findByInvName name landmarks) let (_,v) = invLandmarkLocation $ inventoryItemData landmark key <- lift newKey lift $ pushDataserverEvent pk sn key (lslValString (vec2VVal v)) return (YieldTil $ t + durationToTicks 1,KVal key) llGetLinkName (ScriptInfo oid _ _ _ _) [IVal linkNumber] = do LSLObject { primKeys = links } <- getObject oid name <- if length links == 0 then if linkNumber == 0 then getPrimName oid else return nullKey else case lookupByIndex (linkNumber - 1) links of Nothing -> return nullKey Just k -> getPrimName k continueWith (SVal name) llGetStatus (ScriptInfo _ _ _ pk _) [IVal check] = do status <- getPrimStatus pk continueWith $ IVal $ case mssb check of Nothing -> 0 Just b -> if bit b .&. status /= 0 then 1 else 0 where mssb i = foldl' (\ x y -> x `mplus` (if testBit i y then Just y else Nothing)) Nothing [31,30..0] llSetStatus info@(ScriptInfo _ _ _ pk _) [IVal mask, IVal val] = do status <- getPrimStatus pk let status' = if val == 0 then status .&. (complement mask) else status .|. mask lift $ setPrimStatus pk status' continueWith VoidVal llPassTouches info@(ScriptInfo _ _ _ pk _) [IVal val] = lift $ setPrimPassTouches pk (if val /= 0 then True else False) >> continueWith VoidVal llPassCollisions info@(ScriptInfo _ _ _ pk _) [IVal val] = lift $ setPrimPassCollisions pk (if val /= 0 then True else False) >> continueWith VoidVal llGetRegionCorner (ScriptInfo _ _ _ pk _) [] = do (x,y) <- getPrimRegion pk continueWith $ vec2VVal (256 * fromIntegral x, 256 * fromIntegral y, 0) llGetRegionFlags info@(ScriptInfo _ _ _ pk _) [] = getPrimRegion pk >>= getRegion >>= return . regionFlags >>= continueWith . IVal llGetSimulatorHostname (ScriptInfo _ _ _ pk _) [] = do (i,j) <- getPrimRegion pk (continueWith . SVal) (show i ++ "x" ++ show j ++ ".example.com") llGetRegionName (ScriptInfo _ _ _ pk _) [] = do regionIndex <- getPrimRegion pk regions <- lift getWorldRegions region <- mlookup regionIndex regions continueWith $ SVal $ regionName region llGetAgentSize info@(ScriptInfo _ _ _ pk _) [KVal ak] = do region <- getPrimRegion pk avatars <- lift getWorldAvatars size <- case M.lookup ak avatars of Nothing -> lift $ logFromScript info ("llGetAgentSize: no such agent - " ++ ak) >> return (0,0,0) Just av -> if avatarRegion av == region then return $ (0.45,0.6,avatarHeight av) else lift $ logFromScript info ("llGetAgentSize: agent not in sim") >> return (0,0,0) continueWith (vec2VVal size) llGetAgentInfo info@(ScriptInfo _ _ _ pk _) [KVal ak] = do region <- getPrimRegion pk avatars <- lift getWorldAvatars i <- case M.lookup ak avatars of Nothing -> lift $ logFromScript info ("llGetAgentInfo: no such agent - " ++ ak) >> return 0 Just av -> if avatarRegion av == region then return $ avatarState av else lift $ logFromScript info ("llGetAgentInfo: agent not in sim") >> return 0 continueWith (IVal i) -- llDetected* functions ------------------------------------------------------ -- TODO: only setup for 1 detected thing at a time... -- This is a problem especially for sensor testing llDetectedKey (ScriptInfo _ _ _ pk mevent) [IVal i] = continueWith $ maybe (KVal nullKey) id $ do event <- mevent M.lookup ("key_" ++ show i) (eventInfo event) llDetectedLinkNumber (ScriptInfo _ _ _ pk mevent) [IVal i] = continueWith $ maybe (IVal 0) id (mevent >>= M.lookup ("integer_" ++ (show i)) . eventInfo) llDetectedGrab (ScriptInfo _ _ _ _ mevent) [IVal i] = continueWith $ maybe (VVal 0 0 0) id (mevent >>= M.lookup ("vector_" ++ show i) . eventInfo) llDetectedPos (ScriptInfo _ _ _ _ mevent) [IVal i] = do avatars <- lift getWorldAvatars Just event <- return mevent KVal key <- mlookup ("key_" ++ show i) (eventInfo event) v <- case M.lookup key avatars of Just av -> return $ avatarPosition av Nothing -> getRootPrim key >>= getObjectPosition continueWith (vec2VVal v) llDetectedRot (ScriptInfo _ _ _ _ mevent) [IVal i] = do avatars <- lift getWorldAvatars Just event <- return mevent KVal key <- mlookup ("key_" ++ show i) (eventInfo event) r <- case M.lookup key avatars of Just av -> return $ avatarRotation av Nothing -> getRootPrim key >>= getObjectRotation continueWith (rot2RVal r) llDetectedName (ScriptInfo _ _ _ _ mevent) [IVal i] = do avatars <- lift getWorldAvatars Just event <- return mevent KVal key <- mlookup ("key_" ++ show i) (eventInfo event) name <- case M.lookup key avatars of Just av -> return $ avatarName av Nothing -> getPrimName key continueWith (SVal name) llDetectedOwner (ScriptInfo _ _ _ _ mevent) [IVal i] = do avatars <- lift getWorldAvatars Just event <- return mevent KVal key <- mlookup ("key_" ++ show i) (eventInfo event) k <- case M.lookup key avatars of Just av -> return key Nothing -> getPrimOwner key continueWith (KVal k) llDetectedGroup info@(ScriptInfo _ _ _ _ mevent) [IVal i] = do Just event <- return mevent KVal key <- mlookup ("key_" ++ show i) (eventInfo event) <||> throwError ("index " ++ show i ++ " out of range") avatars <- lift getWorldAvatars prims <- lift getPrims k <- (mlookup key avatars >>= return . fromMaybe nullKey . avatarActiveGroup) <||> (mlookup key prims >>= return . fromMaybe nullKey . primGroup) <||> throwError ("error: key not an avatar or an object!") continueWith (KVal k) llDetectedVel _ [IVal i] = continueWith $ VVal 0 0 0 -- TODO: physics!!! llDetectedType (ScriptInfo _ _ _ _ mevent) [IVal i] = do Just event <- return mevent KVal key <- mlookup ("key_" ++ show i) (eventInfo event) avatars <- lift getWorldAvatars t <- case M.lookup key avatars of Just _ -> return cAgent Nothing -> determineActivePassiveScripted key continueWith (IVal t) determineActivePassiveScripted key = do status <- getPrimStatus key case status of st | st .&. cStatusPhysics /= 0 -> return cActive | otherwise -> do scripts <- getPrimScripts key return (if length scripts > 0 then cScripted else cPassive) ------------------------------------------------------------------------------- -- animation functions llGetAnimationList info@(ScriptInfo _ _ _ pk _) [KVal ak] = do rp <- getPrimRegion pk avatars <- lift getWorldAvatars list <- case M.lookup ak avatars of Nothing -> lift $ logFromScript info ("llGetAnimationList: no such avatar: " ++ ak) >> return [] Just av | avatarRegion av /= rp -> lift $ logFromScript info ("llGetAnimationList: avatar not in sim") >> return [] | otherwise -> do now <- lift getTick return [ KVal anim | (t,anim) <- avatarActiveAnimations av, maybe True ( lift $ logFromScript info ("llGetAnimation: no such avatar: " ++ ak) >> return "" Just av | avatarRegion av /= rp -> lift $ logFromScript info ("llGetAnimationList: avatar no in sim") >> return "" | otherwise -> return "Standing" -- TODO: real animation state continueWith (SVal nm) llStartAnimation info@(ScriptInfo _ _ sid pk _) [SVal anim] = do avKey <- getPermittedAvKey info "llStartAnimation" cPermissionTriggerAnimation case avKey of Nothing -> return () Just ak -> do avatars <- lift getWorldAvatars av <- mlookup ak avatars let anims = avatarActiveAnimations av now <- lift getTick result <- findAnimation pk anim case result of Just (key,mduration) -> do let anims' = updateAnims anims now mduration key lift $ setWorldAvatars (M.insert ak (av { avatarActiveAnimations = anims' }) avatars) Nothing -> lift $ logFromScript info ("llStartAnimation: animation not found - " ++ anim) where updateAnims anims now mduration key = (expire,key):[(t,k) | (t,k) <- anims, (maybe True ( invName item == anim) primAnims of Just item -> do return $ Just (snd $ inventoryItemNameKey $ inventoryItemIdentification item, invAnimationDuration $ inventoryItemData item) Nothing -> case find (\ (name,_,_) -> name == anim) builtInAnimations of Just (_,key,mduration) -> return $ Just (key,mduration) Nothing -> return Nothing llStopAnimation info@(ScriptInfo _ _ sid pk _) [SVal anim] = do avKey <- getPermittedAvKey info "llStartAnimation" cPermissionTriggerAnimation case avKey of Nothing -> return () Just ak -> do avatars <- lift getWorldAvatars av <- mlookup ak avatars let anims = avatarActiveAnimations av result <- findAnimation pk anim case result of Just (key,_) -> do case find (\ (_,k) -> k == key) anims of Nothing -> lift $ logFromScript info "llStopAnimation: animation not active" Just _ -> do let anims' = [(expire,k) | (expire,k) <- anims, k /= key] lift $ setWorldAvatars $ M.insert ak (av { avatarActiveAnimations = anims' }) avatars Nothing -> lift $ logFromScript info ("llStopAnimation: animation not found - " ++ anim) continueWith VoidVal llSetClickAction info [IVal action] = lift $ (if action `elem` cClickActions then logFromScript info "llSetClickAction: setting click action" else logFromScript info "llSetClickAction: invalid click action") >> continueWith VoidVal ------------------------------------------------------------------------------- -- XML RPC related functions llCloseRemoteDataChannel info@(ScriptInfo _ _ sn pk _) [KVal key] = do -- according to LSL wiki this function has no effect, -- so we'll just log a message indicating whether or not the passed in key is valid (lookupScriptFromChan key) <||> throwError "key not an open channel" return () continueWith VoidVal llOpenRemoteDataChannel info@(ScriptInfo _ _ sn pk _) [] = do key <- lookupDataChannel (pk,sn) <||> lift newKey insertScriptChannelPair (pk,sn) key lift $ logFromScript info ("pushing remote data channel to script") lift $ pushDeferredScriptEvent (Event "remote_data" [llcRemoteDataChannel, KVal key, KVal nullKey, SVal "", IVal 0, SVal ""] M.empty) pk sn 0 continueWith VoidVal llSendRemoteData info [KVal channel, SVal dest, IVal idata, SVal sdata] = do -- according to LSL Wiki, this function doesn't do anything... but we'll check -- for a valid channel and log a message. lookupScriptFromChan channel <||> throwError "key not an open channel" lift newKey >>= continueWith . KVal llRemoteDataReply info@(ScriptInfo _ _ _ _ mevent) [KVal channel, KVal messageId, SVal sdata, IVal idata] = do Just event <- return mevent when (eventName event /= "remote_data") $ throwError "no effect unless called within remote_data handler" let m = eventInfo event (KVal k) <- mlookup "requestKey" m <||> throwError ("problem: invalid or mistyped request key in event") lift $ putWorldEvent 0 (XMLReplyEvent k channel messageId sdata idata) lift $ logFromScript info ("llRemoteDataReply: (" ++ show channel ++ "," ++ show messageId ++ "," ++ show sdata ++ "," ++ show idata ++ ")") continueWith VoidVal llRemoteDataSetRegion info [] = lift $ logFromScript info "llRemoteDataSetRegion: this function has no effect" >> continueWith VoidVal ------------------------------------------------------------------------------- llDialog info@(ScriptInfo _ _ _ pk _) [KVal ak, SVal message, LVal buttons, IVal channel] = do when (length message > 512) $ doErr "message too long, must be less than 512 characters" when (null message) $ doErr "must supply a message" when (not $ all (==LLString) $ map typeOfLSLValue buttons) $ doErr "button list must contain only strings" let buttons' = take 12 $ map ( \ (SVal s) -> s) buttons when (any ((24 <) . length) buttons') $ doErr "Button Labels cannot have more that 24 characters" when (any null buttons') $ doErr "all buttons must have label strings" (lift getWorldAvatars >>= mlookup ak) <||> throwError ("no such agent/avatar - " ++ ak) lift $ putWorldEvent 0 (DialogEvent ak message buttons' channel pk) -- deprecated! lift $ putWorldEvent 0 (AvatarInputEvent ak (AvatarDialog message buttons' channel pk)) continueWith VoidVal where doErr msg = (lift $ putChat (Just 20) pk cDebugChannel ("llDialog: " ++ msg)) >> throwError msg ------------------------------------------------------------------------------- -- old (deprecated) functions for visual effects llMakeExplosion info _ = lift $ logFromScript info "llMakeExplosion: deprecated" >> continueWith VoidVal llMakeSmoke info _ = lift $ logFromScript info "llMakeSmoke: deprecated" >> continueWith VoidVal llMakeFire info _ = lift $ logFromScript info "llMakeFire: deprecated" >> continueWith VoidVal llMakeFountain info _ = lift $ logFromScript info "llMakeFountain: deprecated" >> continueWith VoidVal -------------------------------------------------------------------------------- llTakeControls info@(ScriptInfo {scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [IVal controls, IVal accept, IVal pass] = do allScripts <- lift getWorldScripts script <- mlookup (pk,sn) allScripts case scriptLastPerm script of Nothing -> lift $ logFromScript info "no persmission to take controls from any agent" Just ak -> do av <- getWorldAvatar ak maybe (throwError $ "no permission to take controls from " ++ avatarName av) (\ perms -> if perms .&. cPermissionTakeControls /= 0 then when (accept /= 0) $ lift $ setWorldAvatar ak (av { avatarControlListener = Just acl }) else (throwError $ "no permission to take controls from " ++ avatarName av)) (M.lookup ak $ scriptPermissions script) where acl = AvatarControlListener { avatarControlListenerMask = controls, avatarControlListenerScript = (pk,sn) } continueWith VoidVal -------------------------------------------------------------------------------- llVolumeDetect info@(ScriptInfo { scriptInfoObjectKey = oid }) [IVal i] = do obj <- getObject oid lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectVolumeDetect = i /= 0 }}) continueWith VoidVal llCollisionFilter info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn }) [SVal name, KVal k, IVal i] = do allScripts <- lift getWorldScripts script <- mlookup (pk,sn) allScripts lift $ setWorldScripts (M.insert (pk,sn) (script { scriptCollisionFilter = (name,k, i /= 0) }) allScripts) continueWith VoidVal llTarget info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [VVal x y z, FVal range] = do allScripts <- lift getWorldScripts script <- mlookup (pk,sn) allScripts let index = scriptTargetIndex script let script' = script {scriptTargetIndex = index + 1, scriptPositionTargets = IM.insert index ((x,y,z),range) (scriptPositionTargets script) } lift $ setWorldScripts (M.insert (pk,sn) script' allScripts) continueWith $ IVal index llTargetRemove info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [IVal tnumber] = do allScripts <- lift getWorldScripts script <- mlookup (pk,sn) allScripts let script' = script { scriptPositionTargets = IM.delete tnumber (scriptPositionTargets script) } lift $ setWorldScripts (M.insert (pk,sn) script' allScripts) continueWith VoidVal llRotTarget info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [RVal x y z s, FVal err] = do allScripts <- lift getWorldScripts script <- mlookup (pk,sn) allScripts let index = scriptTargetIndex script let script' = script { scriptTargetIndex = index + 1, scriptRotationTargets = IM.insert index ((x,y,z,s),err) (scriptRotationTargets script) } lift $ setWorldScripts (M.insert (pk,sn) script' allScripts) continueWith VoidVal llRotTargetRemove info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [IVal tnumber] = do allScripts <- lift getWorldScripts script <- mlookup (pk,sn) allScripts let script' = script { scriptRotationTargets = IM.delete tnumber (scriptRotationTargets script) } lift $ setWorldScripts (M.insert (pk,sn) script' allScripts) continueWith VoidVal -------------------------------------------------------------------------------- llGround info [VVal _ _ _] = continueWith (FVal 0) -- the world is flat! llGroundContour info [VVal _ _ _] = continueWith (VVal 1 0 0) -- could be any vector llGroundNormal info [VVal _ _ _] = continueWith (VVal 0 0 1) -- straight up! llGroundSlope info [VVal _ _ _] = continueWith (VVal 0 1 0) -------------------------------------------------------------------------------- llGetSunDirection info [] = lift $ do az <- getTick >>= return . (*(pi/7200)) . ticksToDuration let el = 80 * pi continueWith $ vec2VVal (sin az * cos el, sin el, cos az * cos el) -------------------------------------------------------------------------------- llLoadURL info [KVal ak, SVal msg, SVal url] = do getWorldAvatar ak lift $ putWorldEvent 0 (AvatarInputEvent ak (AvatarLoadURL msg url)) continueWith VoidVal llMapDestination info [SVal simName, (VVal x y z), (VVal _ _ _)] = do case mevent of Nothing -> do attachment <- getPrimAttachment oid case attachment of Nothing -> lift $ logFromScript info ("prim neither attached nor touched, so call to llMapDestination is not valid") Just (Attachment { attachmentKey = ak }) -> putIt ak Just (Event "touch" _ m) -> case M.lookup "key_0" m of Just (SVal ak) -> putIt ak _ -> throwError "invalid touch event!" continueWith VoidVal where oid = scriptInfoObjectKey info mevent = scriptInfoCurrentEvent info putIt ak = lift $ putWorldEvent 0 (AvatarInputEvent ak (AvatarMapDestination simName (x,y,z))) -------------------------------------------------------------------------------- continueWith val = return (EvalIncomplete,val) defaultPredefs :: Monad m => M.Map String (PredefFunc m) defaultPredefs = M.fromList $ map (\(x,y) -> (x, defaultPredef x y)) [ ("llAddToLandBanList",llAddToLandBanList), ("llAddToLandPassList",llAddToLandPassList), ("llAdjustSoundVolume",llAdjustSoundVolume), ("llAllowInventoryDrop",llAllowInventoryDrop), ("llApplyImpulse",llApplyImpulse), ("llApplyRotationalImpulse", llApplyRotationalImpulse), ("llAttachToAvatar",llAttachToAvatar), ("llAvatarOnSitTarget",llAvatarOnSitTarget), ("llBreakAllLinks",llBreakAllLinks), ("llBreakLink",llBreakLink), ("llClearCameraParams",llClearCameraParams), ("llCloseRemoteDataChannel",llCloseRemoteDataChannel), ("llCloud",llCloud), ("llCollisionFilter", llCollisionFilter), ("llCollisionSound",llCollisionSound), ("llCollisionSprite",llCollisionSprite), ("llCreateLink",llCreateLink), ("llDetachFromAvatar", llDetachFromAvatar), ("llDetectedGrab",llDetectedGrab), ("llDetectedGroup",llDetectedGroup), ("llDetectedKey", llDetectedKey), ("llDetectedLinkNumber", llDetectedLinkNumber), ("llDetectedName", llDetectedName), ("llDetectedOwner", llDetectedOwner), ("llDetectedPos", llDetectedPos), ("llDetectedRot", llDetectedRot), ("llDetectedType", llDetectedType), ("llDetectedVel", llDetectedVel), ("llDialog", llDialog), ("llDie",llDie), ("llEjectFromLand",llEjectFromLand), ("llEmail",llEmail), ("llFrand",llFrand), ("llGetAccel",llGetAccel), ("llGetAgentInfo",llGetAgentInfo), ("llGetAgentSize",llGetAgentSize), ("llGetAlpha",llGetAlpha), ("llGetAndResetTime", llGetAndResetTime), ("llGetAnimation", llGetAnimation), ("llGetAnimationList",llGetAnimationList), ("llGetAttached",llGetAttached), ("llGetBoundingBox",llGetBoundingBox), ("llGetCameraPos",llGetCameraPos), ("llGetCameraRot",llGetCameraRot), ("llGetColor",llGetColor), ("llGetCreator",llGetCreator), ("llGetDate",llGetDate), ("llGetForce", llGetForce), ("llGetGeometricCenter",llGetGeometricCenter), ("llGetGMTclock",llGetGMTclock), ("llGetInventoryCreator",llGetInventoryCreator), ("llGetInventoryKey",llGetInventoryKey), ("llGetInventoryName",llGetInventoryName), ("llGetInventoryNumber",llGetInventoryNumber), ("llGetInventoryPermMask", llGetInventoryPermMask), ("llGetInventoryType",llGetInventoryType), ("llGetKey",llGetKey), ("llGetLocalPos",llGetLocalPos), ("llGetNextEmail",llGetNextEmail), ("llGetNumberOfPrims",llGetNumberOfPrims), ("llGetNumberOfSides",llGetNumberOfSides), ("llGetLinkKey",llGetLinkKey), ("llGetLinkName",llGetLinkName), ("llGetLinkNumber", llGetLinkNumber), ("llGetLocalRot", llGetLocalRot), ("llGetLandOwnerAt", llGetLandOwnerAt), ("llGetMass",llGetMass), ("llGetNotecardLine", llGetNotecardLine), ("llGetNumberOfNotecardLines",llGetNumberOfNotecardLines), ("llGetObjectDesc", llGetObjectDesc), ("llGetObjectDetails", llGetObjectDetails), ("llGetObjectMass", llGetObjectMass), ("llGetObjectName", llGetObjectName), ("llGetObjectPermMask", llGetObjectPermMask), ("llGetObjectPrimCount",llGetObjectPrimCount), ("llGetOmega",llGetOmega), ("llGetOwner", llGetOwner), ("llGetOwnerKey",llGetOwnerKey), ("llGetParcelFlags", llGetParcelFlags), ("llGetParcelDetails", llGetParcelDetails), ("llGetPermissions",llGetPermissions), ("llGetPermissionsKey",llGetPermissionsKey), ("llGetPos", llGetPos), ("llGetPrimitiveParams", llGetPrimitiveParams), ("llGetRegionCorner", llGetRegionCorner), ("llGetRegionFlags", llGetRegionFlags), ("llGetRegionFPS", llGetRegionFPS), ("llGetRegionName", llGetRegionName), ("llGetRegionTimeDilation", llGetRegionTimeDilation), ("llGetRot",llGetRot), ("llGetRootPosition",llGetRootPosition), ("llGetRootRotation",llGetRootRotation), ("llGetScale", llGetScale), ("llGetScriptName", llGetScriptName), ("llGetScriptState", llGetScriptState), ("llGetSimulatorHostname", llGetSimulatorHostname), ("llGetStartParameter",llGetStartParameter), ("llGetStatus",llGetStatus), ("llGetSunDirection",llGetSunDirection), ("llGetTexture", llGetTexture), ("llGetTextureOffset", llGetTextureOffset), ("llGetTextureRot", llGetTextureRot), ("llGetTextureScale", llGetTextureScale), ("llGetTime",llGetTime), ("llGetTimeOfDay",llGetTimeOfDay), ("llGetTimestamp",llGetTimestamp), ("llGetTorque",llGetTorque), ("llGetUnixTime",llGetUnixTime), ("llGetWallclock",llGetWallclock), ("llGetVel",llGetVel), ("llGiveInventory", llGiveInventory), ("llGiveMoney",llGiveMoney), ("llGround", llGround), ("llGroundContour", llGroundContour), ("llGroundNormal", llGroundNormal), ("llGroundRepel",llGroundRepel), ("llGroundSlope",llGroundSlope), ("llHTTPRequest",llHTTPRequest), ("llInstantMessage",llInstantMessage), ("llKey2Name", llKey2Name), ("llListRandomize",llListRandomize), ("llListen", llListen), ("llListenControl",llListenControl), ("llListenRemove",llListenRemove), ("llLoadURL",llLoadURL), ("llLookAt", llLookAt), ("llLoopSound",llLoopSound), ("llLoopSoundSlave",llLoopSoundSlave), ("llLoopSoundMaster", llLoopSoundMaster), ("llMakeExplosion",llMakeExplosion), ("llMakeFire",llMakeFire), ("llMakeFountain",llMakeFountain), ("llMakeSmoke",llMakeSmoke), ("llMapDestination", llMapDestination), ("llMessageLinked", llMessageLinked), ("llMoveToTarget", llMoveToTarget), ("llOffsetTexture", llOffsetTexture), ("llOpenRemoteDataChannel", llOpenRemoteDataChannel), ("llOverMyLand", llOverMyLand), ("llOwnerSay", llOwnerSay), ("llPassCollisions", llPassCollisions), ("llPassTouches", llPassTouches), ("llPlaySound", llPlaySound), ("llPlaySoundSlave", llPlaySoundSlave), ("llPointAt",llPointAt), ("llPreloadSound", llPreloadSound), ("llRefreshPrimURL", llRefreshPrimURL), ("llRegionSay", llRegionSay), ("llReleaseCamera", llReleaseCamera), ("llRemoteDataReply", llRemoteDataReply), ("llRemoteDataSetRegion", llRemoteDataSetRegion), ("llRemoteLoadScript", llRemoteLoadScript), ("llRemoveFromLandPassList",llRemoveFromLandPassList), ("llRemoveFromLandBanList",llRemoveFromLandBanList), ("llRemoveInventory",llRemoveInventory), ("llRemoveVehicleFlags",llRemoveVehicleFlags), ("llRequestAgentData", llRequestAgentData), ("llRequestInventoryData",llRequestInventoryData), ("llRequestPermissions",llRequestPermissions), ("llRequestSimulatorData",llRequestSimulatorData), ("llResetLandPassList",llResetLandPassList), ("llResetLandBanList",llResetLandBanList), ("llResetOtherScript",llResetOtherScript), ("llResetScript",llResetScript), ("llResetTime",llResetTime), ("llRezAtRoot",llRezAtRoot), ("llRezObject",llRezObject), ("llRotLookAt",llRotLookAt), ("llRotTarget",llRotTarget), ("llRotTargetRemove",llRotTargetRemove), ("llRotateTexture", llRotateTexture), ("llSameGroup", llSameGroup), ("llSay",llSay), ("llScaleTexture", llScaleTexture), ("llSensor",llSensor), ("llSensorRemove",llSensorRemove), ("llSensorRepeat",llSensorRepeat), ("llSendRemoteData",llSendRemoteData), ("llSetAlpha", llSetAlpha), ("llSetBuoyancy", llSetBuoyancy), ("llSetClickAction", llSetClickAction), ("llSetColor", llSetColor), ("llSetForce", llSetForce), ("llSetForceAndTorque", llSetForceAndTorque), ("llSetHoverHeight", llSetHoverHeight), ("llSetLinkAlpha",llSetLinkAlpha), ("llSetLinkColor",llSetLinkColor), ("llSetLinkPrimitiveParams",llSetLinkPrimitiveParams), ("llSetLinkTexture",llSetLinkTexture), ("llSetLocalRot",llSetLocalRot), ("llSetObjectName",llSetObjectName), ("llSetObjectDesc",llSetObjectDesc), ("llSetParcelMusicURL",llSetParcelMusicURL), ("llSetPayPrice",llSetPayPrice), ("llSetPos",llSetPos), ("llSetPrimitiveParams",llSetPrimitiveParams), ("llSetPrimURL",llSetPrimURL), ("llSetRemoteScriptAccessPin", llSetRemoteScriptAccessPin), ("llSetRot",llSetRot), ("llSetScale",llSetScale), ("llSetScriptState",llSetScriptState), ("llSetSoundQueueing",llSetSoundQueueing), ("llSetSoundRadius",llSetSoundRadius), ("llSetSitText",llSetSitText), ("llSetStatus",llSetStatus), ("llSetText",llSetText), ("llSetTexture",llSetTexture), ("llSetTorque",llSetTorque), ("llSetTouchText",llSetTouchText), ("llSetVehicleFlags",llSetVehicleFlags), ("llSitTarget",llSitTarget), ("llShout",llShout), ("llSleep", llSleep), ("llSetTimerEvent",llSetTimerEvent), ("llSound",llSound), ("llSoundPreload", llSoundPreload), ("llStartAnimation", llStartAnimation), ("llStopAnimation", llStopAnimation), ("llStopHover",llStopHover), ("llStopLookAt",llStopLookAt), ("llStopMoveToTarget", llStopMoveToTarget), ("llStopPointAt", llStopPointAt), ("llStopSound",llStopSound), ("llTakeCamera",llTakeCamera), ("llTakeControls",llTakeControls), ("llTarget",llTarget), ("llTargetRemove",llTargetRemove), ("llTeleportAgentHome",llTeleportAgentHome), ("llTriggerSound",llTriggerSound), ("llTriggerSoundLimited",llTriggerSoundLimited), ("llUnSit",llUnSit), ("llVolumeDetect", llVolumeDetect), ("llWhisper",llWhisper), ("llWind",llWind), ("llWater",llWater) ] ++ map (\ (n,f) -> (n, defaultPredef n (\ i args -> lift $ f i args))) internalLLFuncs allFuncs = (map (\ (name,_,_) -> name) funcSigs) implementedFuncs = (map fst $ M.toList (defaultPredefs::(M.Map String (PredefFunc Maybe)))) unimplementedFuncs = S.toList (S.difference (S.fromList allFuncs) (S.fromList implementedFuncs)) --------------------------------------------------------------------------------------------------- logFromScript :: Monad m => ScriptInfo Float -> String -> WorldM m () logFromScript scriptInfo msg = logAMessage LogInfo (infoToLogSource scriptInfo) msg infoToLogSource info = (scriptInfoPrimKey info ++ ": " ++ scriptInfoScriptName info) addScript prim invScript = prim { primInventory = (invScript:(primInventory prim)) } -- should monadify further... getPrimInfo pkey = do prims <- getPrims case M.lookup pkey prims of Nothing -> return Nothing Just p -> case primParent p of Nothing -> return $ Just (pkey, 0, primName p) Just p1Key -> do objects <- getObjects case M.lookup p1Key objects of Nothing -> return Nothing Just (LSLObject { primKeys = plist }) -> case elemIndex pkey plist of Nothing -> return Nothing Just i -> return $ Just (p1Key, i, primName p) pushEvent e key sid = do scripts <- getWorldScripts case M.lookup (key,sid) scripts of Nothing -> logAMessage LogWarn "sim" ("no such script: " ++ (show (key, sid)) ++ ", event: " ++ show e) Just script -> setWorldScripts (M.insert (key,sid) (script { scriptEventQueue = (scriptEventQueue script) ++ [e] } ) scripts) pushEventToPrim e key = runErrPrim key () (getPrimScripts key >>= mapM_ (lift . pushEvent e key) . (map invName)) pushEventToObject e key = do objects <- getObjects case M.lookup key objects of Nothing -> logAMessage LogWarn "sim" ("no such object: " ++ key) Just o -> mapM_ (pushEventToPrim e) (primKeys o) pushDataserverEvent pk sn key val = pushDeferredScriptEvent (Event "dataserver" [KVal key, SVal val] M.empty) pk sn 0 pushChangedEventToObject oid val = pushDeferredScriptEventToObject (Event "changed" [IVal val] M.empty) oid 0 pushAttachEvent pk k = pushDeferredScriptEventToPrim (Event "attach" [KVal k] M.empty) pk 0 pushDeferredScriptEvent event pk sn delay = putWorldEvent delay (DeferredScriptEvent event (DeferredScriptEventScriptTarget (pk,sn))) pushDeferredScriptEventToPrim event pk delay = putWorldEvent delay (DeferredScriptEvent event (DeferredScriptEventPrimTarget pk)) pushDeferredScriptEventToObject event oid delay = putWorldEvent delay (DeferredScriptEvent event (DeferredScriptEventObjectTarget oid)) putHTTPTimeoutEvent pk sn key delay = pushDeferredScriptEvent (Event "http_response" [KVal key, IVal 499, LVal [], SVal ""] M.empty) pk sn delay putHTTPResponseEvent pk sn key status metadata body delay = pushDeferredScriptEvent (Event "http_response" [KVal key, IVal status, LVal metadata, body] M.empty) pk sn delay getObject name = lift getObjects >>= mlookup name setObject oid obj = getObjects >>= setObjects . M.insert oid obj getObjectDynamics k = getObject k >>= return . objectDynamics getObjectPosition k = getObjectDynamics k >>= return . objectPosition getObjectRotation k = getObjectDynamics k >>= return . objectRotation newWorld slice maxt iq lib scripts avatars objs prims activeScripts regions keyIndex webHandling eventHandler log = World { sliceSize = slice, maxTick = maxt, nextPause = slice, wqueue = iq, wlisteners = IM.empty, nextListenerId = 0, wobjects = objs, wprims = prims, worldScripts = activeScripts, inventory = [], tick = 0, msglog = [LogMessage 0 LogWarn "init" s | s <- log ], predefs = defaultPredefs, randGen = mkStdGen 1, wlibrary = lib, wscripts = scripts, worldEventHandler = fmap (flip (,) []) eventHandler, worldAvatars = avatars, worldBreakpointManager = emptyBreakpointManager, worldSuspended = Nothing, worldRegions = regions, worldZeroTime = 0, worldKeyIndex = keyIndex, worldWebHandling = webHandling, worldOutputQueue = [], worldPendingHTTPRequests = [], worldOpenDataChannels = (M.empty,M.empty), worldXMLRequestRegistry = M.empty, worldPhysicsTime = 0, worldTargetCheckTime = 0, worldLastPositions = M.empty, worldCollisions = S.empty, worldLandCollisions = S.empty, worldTouches = M.empty, worldTouchCheckTime = 0 } putWorldEvent delay we = do weq <- getWQueue t <- getTick setWQueue $ putWQ (t + max (durationToTicks delay) 1) we weq checkBp bp sm = do bpm <- getWorldBreakpointManager let (result,bpm',sm') = checkBreakpoint bp bpm sm setWorldBreakpointManager bpm' return (result,sm') updatePrim f key = do prims <- getPrims case M.lookup key prims of Nothing -> logAMessage LogWarn "sim" ("prim " ++ key ++ " not found") Just p -> do p' <- f p setPrims (M.insert key p' prims) registerListener listener = do listeners <- getListeners id <- getNextListenerId let id' = id + 1 setNextListenerId id' setListeners $ IM.insert id (listener,True) listeners return id unregisterListener pk sname id = do listeners <- lift getListeners (listener,_) <- ilookup id listeners when (listenerScriptName listener /= sname && listenerPrimKey listener /= pk) (throwError ("listener " ++ show id ++ " not registered for calling script")) lift $ setListeners $ IM.delete id listeners updateListener pk sname id active = do listeners <- lift getListeners (listener,_) <- ilookup id listeners when (listenerScriptName listener /= sname && listenerPrimKey listener /= pk) (throwError ("listener " ++ show id ++ " not registered for calling script")) lift $ setListeners $ IM.insert id (listener,active) listeners processEvents :: (Monad m) => WorldM m () processEvents = do suspenseInfo <- getWorldSuspended when (isNothing suspenseInfo) $ do tick <- getTick weq <- getWQueue case takeWQ tick weq of (Nothing,_) -> return () (Just we,weq') -> do setWQueue weq' w <- queryWorld id processEvent we processEvents where isNothing = maybe True (const False) processEvent (DeferredScriptEvent event (DeferredScriptEventScriptTarget (pk,sn))) = pushEvent event pk sn processEvent (DeferredScriptEvent event (DeferredScriptEventPrimTarget pk)) = pushEventToPrim event pk processEvent (DeferredScriptEvent event (DeferredScriptEventObjectTarget oid)) = pushEventToObject event oid processEvent (CreatePrim name key) = do worldPrims <- getPrims objects <- getObjects let prim = emptyPrim name key setPrims (M.insert key prim worldPrims) setObjects (M.insert key (LSLObject [key] defaultDynamics) objects) processEvent (AddScript (name,script) key active) = do scripts <- getWScripts t <- getTick case lookup script scripts of Nothing -> logAMessage LogWarn "sim" ("no such script: " ++ script) Just (Left s) -> do scriptKey <- newKey updatePrim (\ p -> return $ addScript p (scriptInventoryItem name scriptKey script)) key -- scripts <- getWorldScripts -- setWorldScripts (M.insert (key,name) ((mkScript (Invalid s)) { scriptActive = False, scriptStartTick = t, scriptLastResetTick = t, scriptEventQueue = []}) scripts) Just (Right code) -> do scriptKey <- newKey updatePrim (\ p -> return $ addScript p (scriptInventoryItem name scriptKey script)) key let sstate = initLSLScript code scripts <- getWorldScripts setWorldScripts (M.insert (key,name) ((mkScript sstate) { scriptStartTick = t, scriptLastResetTick = t }) scripts) processEvent chat@(Chat chan name key msg location range) = do listeners <- getListeners locatedListeners <- mapM locateListener (IM.elems listeners) let listeners'= [ l | (l,_,_) <- filter (matchListener chat) locatedListeners] -- event goes to all UNIQUE addresses in list let addresses = nub $ map listenAddress listeners' mapM_ (\ (key',sid) -> pushEvent (Event "listen" [IVal chan, SVal name, KVal key, SVal msg] M.empty) key' sid) addresses when (chan == 0) $ case range of Nothing -> return () Just dist -> pushChatToAvatars location dist where locateListener (listener,active) = do (VVal x y z) <- getPos (listenerPrimKey listener) region <- getRegionIndex (listenerPrimKey listener) return (listener,active,(region,(x,y,z))) pushChatToAvatars location range = do avatars <- getWorldAvatars >>= return . M.elems mapM_ (pushChatToAvatar location range) avatars pushChatToAvatar (region,pos) range avatar = when (region == avatarRegion avatar && dist3d2 pos (avatarPosition avatar) <= range^2) $ do putWorldEvent 0 $ (AvatarInputEvent (avatarKey avatar) (AvatarHearsChat name key msg)) processEvent (WorldSimEvent name args) = case M.lookup name eventDescriptors of Nothing -> logAMessage LogWarn "sim" ("event " ++ name ++ " not understood") Just def -> handleSimInputEvent def args processEvent (PermissionRequestEvent pk sname ak mask) = runAndLogIfErr ("can't find prim/script: " ++ pk ++ "/" ++ sname) () $ do scripts <- lift getWorldScripts script <- mlookup (pk,sname) scripts let script' = script { scriptPermissions = M.insert ak mask (scriptPermissions script), scriptLastPerm = Just ak } lift $ setWorldScripts (M.insert (pk,sname) script' scripts) lift $ pushEvent (Event "run_time_permissions" [IVal mask] M.empty) pk sname processEvent evt@(TimerEvent interval (primKey,scriptName)) = do pushEvent (Event "timer" [] M.empty) primKey scriptName putWorldEvent interval evt processEvent evt@(SensorEvent (pk,sn) name key stype range arc rpt) = runAndLogIfErr "problem processing sensor even" () $ do t <- lift getTick maybe (return ()) (\ interval -> lift $ putWorldEvent interval evt) rpt sensedObjects <- senseObjects sensedAvatars <- senseAvatars let list = take 16 (sensedObjects ++ sensedAvatars) if null list then lift $ pushEvent (Event "no_sensor" [] M.empty) pk sn else lift $ pushEvent (Event "sensor" [(IVal $ length list)] (M.fromList (zipWith (\ i k -> ("key_" ++ show i,KVal k)) [0..] list))) pk sn where senseObjects = do pos <- getGlobalPos pk rot <- getGlobalRot pk root <- getRootPrim pk let fwd = fwdFromRot rot prims <- rootPrims root poss <- mapM getGlobalPos (map primKey prims) let pprims = zip poss prims statuses <- mapM objectStatus (map primKey prims) return [ primKey p | ((pos,p),stat) <- zip pprims statuses, withinSensorArea pos fwd range arc pos, stat .&. stype /= 0] senseAvatars = if stype .&. cAgent /= 0 then do pos <- getGlobalPos pk rot <- getGlobalRot pk attachKey <- getPrimAttachment pk >>= return . liftM attachmentKey let fwd = fwdFromRot rot avs <- allAvs attachKey return [ avatarKey av | av <- avs, withinSensorArea pos fwd range arc (avatarPosition av)] else return [] fwdFromRot rot = let ((x,_,_),(y,_,_),(z,_,_)) = quaternionToMatrix rot in (x,y,z) angleBetweenV (x0,y0,z0) (x1,y1,z1) = acos (x0*x1 + y0*y1 + z0*z1) withinSensorArea origin direction range arc pos = let v = diff3d pos origin m = mag3d v v' = norm3d v in if m == 0 then True else m <= range && (angleBetweenV v' direction) <= arc rootPrims exclude = do objs <- lift getObjects mapM getPrim [ k | LSLObject { primKeys = (k:_) } <- M.elems objs, exclude /= k] objectStatus root = do LSLObject { primKeys = pks } <- getObject root stat <- foldM (\ x k -> determineActivePassiveScripted k >>= return . (x .|.)) 0 pks if (stat .&. cActive /= 0 && stat .&. cPassive /= 0) then return (stat .&. complement cPassive) else return stat allAvs exclude = do avs <- lift getWorldAvatars return [ av | av <- M.elems avs, exclude /= Just (avatarKey av)] processEvent (HTTPRequestEvent (pk,sn) key url method mimetype maxlength verify body) = do logAMessage LogDebug "sim" "processing an HTTP request event" handling <- getWorldWebHandling case handling of WebHandlingByDoingNothing -> putHTTPTimeoutEvent pk sn key 60 WebHandlingByFunction -> runAndLogIfErr "problem with handler" () $ do (moduleName, state) <- lift getWorldEventHandler >>= maybe (throwError "no handler defined") return lib <- lift getWLibrary -- invoke the function to get the results case simFunc lib (moduleName,"httpRequest") state [SVal url, SVal method, SVal mimetype, IVal maxlength, IVal verify, SVal body] of Left s -> throwError s Right (SVal msg,results) | not (null msg) -> do lift $ setWorldEventHandler (Just (moduleName, results)) throwError msg | otherwise -> let IVal status = maybe (IVal 200) id (lookup "outHttpStatus" results >>= ( \ val -> if isIVal val then Just val else Nothing)) LVal metadata = maybe (LVal []) id (lookup "outHttpMetadata" results >>= ( \ val -> if isLVal val then Just val else Nothing)) body = maybe (SVal "") id (lookup "outHttpBody" results >>= ( \ val -> if isSVal val then Just val else Nothing)) events = maybe (LVal []) id (lookup "outEvents" results) in do lift $ putHTTPResponseEvent pk sn key status metadata body 2 lift $ processEventsList events lift $ setWorldEventHandler (Just (moduleName, results)) Right _ -> throwError ("invalid web handling function, must return a string") WebHandlingByInternet timeout -> do let event = SimEvent "http_request" [ SimEventArg "url" url, SimEventArg "prim" pk, SimEventArg "script" sn, SimEventArg "requestKey" key, SimEventArg "HTTP_METHOD" method, SimEventArg "HTTP_MIMETYPE" mimetype, SimEventArg "HTTP_BODY_MAXLENGTH" (show maxlength), SimEventArg "HTTP_VERIFY_CERT" (show verify), SimEventArg "body" body] 0 (getWorldOutputQueue >>= return . (event:) >>= setWorldOutputQueue) (getWorldPendingHTTPRequests >>= return . (key:) >>= setWorldPendingHTTPRequests) -- put a timeout event on the queue. 'real' time and sim time are much different, so the -- 'real' world timeout is much different putHTTPTimeoutEvent pk sn key timeout processEvent (XMLRequestEvent source channel idata sdata) = runAndLogIfErr "invalid xml request" () $ do lift $ logAMessage LogInfo "sim" "processing XMLRequestEvent" (pk,sn) <- lookupScriptFromChan channel <||> throwError ("no such channel" ++ channel) key <- lift newKey lift getWorldXMLRequestRegistry >>= return . (M.insert key source) >>= lift . setWorldXMLRequestRegistry lift $ pushEvent (Event "remote_data" [llcRemoteDataRequest, KVal channel, KVal nullKey, SVal "", IVal idata, SVal sdata] (M.fromList [("requestKey",KVal key)])) pk sn processEvent (XMLReplyEvent key channel messageId sdata idata) = do runAndLogIfErr "invalid xml reply" () $ do source <- (lift getWorldXMLRequestRegistry >>= mlookup key) <||> throwError "missing source for XML request" lift (getWorldXMLRequestRegistry >>= return . M.delete key >>= setWorldXMLRequestRegistry) case source of XMLRequestInternal tag -> do (moduleName, state) <- lift getWorldEventHandler >>= maybe (throwError "no handler defined") return lib <- lift getWLibrary case simFunc lib (moduleName, "xmlReply") state [SVal tag, SVal channel, SVal sdata, IVal idata] of Left s -> throwError s Right (SVal msg, results) | not (null msg) -> do lift $ setWorldEventHandler (Just (moduleName, results)) throwError msg | otherwise -> let events = maybe (LVal []) id (lookup "outEvents" results) in do lift $ processEventsList events lift $ setWorldEventHandler (Just (moduleName, results)) XMLRequestExternal tag -> do let event = SimEvent "xml_reply" [ SimEventArg "tag" tag, SimEventArg "channel" channel, SimEventArg "sdata" sdata, SimEventArg "idata" (show idata)] 0 lift $ (getWorldOutputQueue >>= return . (event:) >>= setWorldOutputQueue) processEvent (DialogEvent agent message buttons channel source) = runAndLogIfErr "invalid dialog event" () $ do lift getWorldEventHandler >>= (\ mhandler -> case mhandler of Nothing -> return () Just (moduleName,state) -> do lib <- lift getWLibrary avName <- (lift getWorldAvatars >>= mlookup agent >>= return . avatarName) <||> throwError "problem finding avatar" objName <- getPrimName source <||> throwError "problem finding object" case hasFunc lib (moduleName,"dialog") of Left s -> throwError s Right False -> return () Right True -> case simFunc lib (moduleName, "dialog") state [SVal avName, SVal message, LVal (map SVal buttons), IVal channel, SVal objName] of Left s -> throwError s Right (SVal msg, results) | not (null msg) -> do warn lift $ setWorldEventHandler (Just (moduleName, results)) throwError msg | otherwise -> let (IVal selection) = maybe (IVal (-1)) id (lookup "outDialogButtonSelected" results) events = maybe (LVal []) id (lookup "outEvents" results) in do warn when (selection >= 0 && selection < length buttons) $ lift $ putChat (Just 20.0) agent channel (buttons !! selection) lift $ processEventsList events lift $ setWorldEventHandler (Just (moduleName, results))) where warn = lift $ logAMessage LogWarn "sim" "the 'dialog' entry point for the world event handler is deprecated, use the avatar event handler instead" processEvent (RezObjectEvent links pos vel rot start pk copy atRoot) = runAndLogIfErr "invalid rez object event" () $ do when (null links) $ throwError "empty link set!" -- reset positions relative to root let geomCenter = scale3d ( 1 / fromIntegral (length links)) (foldl' add3d (0,0,0) (map ((flip diff3d (0,0,0)) . primPosition) links)) let pos' = if atRoot then pos else (pos `add3d` (neg3d geomCenter)) let update = if copy then (\ p -> updateKeys p) else return -- TODO: rotation and velocity links' <- mapM update links mapM activateScripts links' let rootKey = primKey (head links') lift (getObjects >>= return . M.insert rootKey (LSLObject (map primKey links') defaultDynamics { objectPosition = pos' }) >>= setObjects) lift $ (getPrims >>= (\ m -> return (foldl' (\ m l -> M.insert (primKey l) l m) m links')) >>= setPrims) lift $ pushEventToObject (Event "on_rez" [IVal start] M.empty) rootKey lift $ pushEventToPrim (Event "object_rez" [KVal rootKey] M.empty) pk where activateScripts prim = do let scripts = [ item | item <- primInventory prim, isInvScriptItem item ] let activateScriptItem item = let InvScript id state = inventoryItemData item name = inventoryItemName item in activateScript (primKey prim) name id state start mapM activateScriptItem scripts updateKeys prim = do key <- lift newKey newInventory <- mapM updateItemKeys (primInventory prim) return $ prim { primKey = key, primInventory = newInventory } updateItemKeys item = do key <- lift newKey let name = inventoryItemName item newData <- if isInvObjectItem item then mapM updateKeys (invObjectPrims $ inventoryItemData item) >>= return . InvObject else return (inventoryItemData item) return $ item { inventoryItemIdentification = InventoryItemIdentification (name,key), inventoryItemData = newData } processEvent (ResetScriptEvent pk sn) = runAndLogIfErr "invalid reset script event" () (resetScript pk sn) processEvent (DetachCompleteEvent oid ak) = runAndLogIfErr "invalid detach complete event" () $ do -- need to remove the object and it's prims and its active scripts from the live lists, but -- save the script states avatars <- lift getWorldAvatars avatar <- mlookup ak avatars LSLObject { primKeys = links } <- getObject oid prims <- mapM passivatePrim links when (null prims) $ throwError "object has no prims!" let root = head prims let object = InventoryItem (InventoryItemIdentification (primName root,primKey root)) (InventoryInfo (primCreator root) (0x0008e000,0x0008e000,0x0008e000,0x0008e000,0x0008e000)) (InvObject prims) let avInv = avatarInventory avatar lift $ setWorldAvatars (M.insert ak (avatar { avatarInventory = object:avInv }) avatars) objects <- lift getObjects lift $ setObjects (M.delete oid objects) where passivatePrim pk = do scriptItems <- getPrimScripts pk mapM_ (moveScriptStateToPrim pk) (map inventoryItemName scriptItems) prims <- lift getPrims prim <- mlookup pk prims lift $ setPrims $ M.delete pk prims return prim moveScriptStateToPrim pk sn = do scripts <- lift getWorldScripts script <- mlookup (pk,sn) scripts let img = scriptImage script primInv <- getPrimInventory pk let (xs,ys) = break (\ item -> sn == inventoryItemName item) primInv when (null ys) $ throwError ("script inexplicably not in inventory") (y:ys') <- return ys let scriptData = inventoryItemData y lift $ setPrimInventory pk (((y { inventoryItemData = scriptData { invScriptState = Just img } }) : xs) ++ ys) lift $ setWorldScripts (M.delete (pk,sn) scripts) processEvent (GiveAvatarInventoryEvent ak item) = logAMessage LogInfo "sim" "giving avatar inventory: not implemented" processEvent (AvatarOutputEvent ak avEv) = processAvatarOutputEvent ak avEv processEvent (AvatarInputEvent ak avEv) = processAvatarInputEvent ak avEv processEvent _ = error "not implemented" processEventsList (LVal []) = return () processEventsList (LVal ((IVal i):l)) = do processEventList (take i l) processEventsList (LVal (drop i l)) processEventsList _ = logAMessage LogWarn "sim" ("user supplied event handler has invalid type for 'outEvents' variable") processEventList [SVal "xml_request", SVal sourceId, KVal channel, IVal idata, SVal sdata, FVal delay] = do putWorldEvent delay (XMLRequestEvent (XMLRequestInternal sourceId) channel idata sdata) processEventList l = logAMessage LogWarn "sim" ("Invalid event from event handler: " ++ lslShowVal (LVal l)) processAvatarOutputEvent k (AvatarTouch {avatarTouchPrimKey = pk, avatarTouchDuration = secs}) = do touches <- getWorldTouches now <- getTick setWorldTouches (M.alter (alt now) pk touches) where alt start Nothing = Just [newTouch start] alt start (Just ts) = Just (newTouch start:ts) newTouch start = Touch {touchAvatarKey = k, touchPrimKey = pk, touchStartTick = start, touchEndTick = start + durationToTicks secs} processAvatarOutputEvent k (AvatarWhisper {avatarChatChannel = chan, avatarChatMessage = msg}) = avChat 10 msg k chan processAvatarOutputEvent k (AvatarSay {avatarChatChannel = chan, avatarChatMessage = msg}) = avChat 20 msg k chan processAvatarOutputEvent k (AvatarShout {avatarChatChannel = chan, avatarChatMessage = msg}) = avChat 100 msg k chan processAvatarOutputEvent k (AvatarPay {avatarPayPrimKey = pk, avatarPayAmount = val}) = runAndLogIfErr "problem handling avatar payment" () $ primHasActiveHandler k "money" >>= flip when (lift $ pushEventToPrim (Event "money" [KVal pk, IVal val] M.empty) pk) processAvatarOutputEvent k (AvatarControl { avatarNewControlBits = newBits }) = runAndLogIfErr "problem processing control change" () $ do av <- getWorldAvatar k let prev = avatarControls av lift $ setWorldAvatar k (av { avatarControls = newBits }) flip (maybe (return ())) (avatarControlListener av) $ \ (AvatarControlListener {avatarControlListenerMask = mask, avatarControlListenerScript = (pk,sn)}) -> lift $ pushEvent (Event "control" [KVal k, IVal newBits, IVal (newBits `xor` prev)] M.empty) pk sn --processAvatarOutputEvent _ _ = error "not yet implemented(1)" avChat range msg key chan = runAndLogIfErr "problem processing chat" () $ do lift $ logAMessage LogInfo ("av:" ++ key) ("chat! chan: " ++ show chan ++ ", range: " ++ show range ++ ", message: " ++ show msg) av <- getWorldAvatar key lift $ putWorldEvent 0 $ Chat chan (avatarName av) key msg (avatarRegion av,avatarPosition av) (Just range) processAvatarInputEvent k inputEvent = runAndLogIfErr "problem processing event for avatar" () $ do av <- getWorldAvatar k let avInfo = [ IVal lslPlusAvatarKey, KVal (avatarKey av), IVal lslPlusAvatarPos, ((vec2VVal . avatarPosition) av), IVal lslPlusAvatarRot, ((rot2RVal . avatarRotation) av), IVal lslPlusAvatarName, SVal (avatarName av) ] flip (maybe (return ())) (avatarEventHandler av) $ (\ (moduleName,state) -> do lib <- lift getWLibrary case callAvatarEventProcessor k moduleName inputEvent lib state avInfo of Nothing -> return () Just (Left s) -> throwError s Just (Right (LVal events,result)) -> do mapM_ (putAvatarOutputEvent k) events lift $ setWorldAvatar k (av { avatarEventHandler = Just (moduleName,result) })) avEventProcCallInfo (AvatarOwnerSay key msg) avInfo = ("onOwnerSay",[SVal key, SVal msg, LVal avInfo]) avEventProcCallInfo (AvatarHearsChat name key msg) avInfo = ("onChat",[SVal name, SVal key, SVal msg, LVal avInfo]) avEventProcCallInfo (AvatarDialog msg buttons chan source) avInfo = ("onDialog",[SVal msg, LVal $ map SVal buttons, IVal chan, SVal source, LVal avInfo]) avEventProcCallInfo (AvatarLoadURL msg url) avInfo = ("onLoadURL",[SVal msg, SVal url, LVal avInfo]) avEventProcCallInfo (AvatarMapDestination simName position) avInfo = ("onMapDestination",[SVal simName, vec2VVal position, LVal avInfo]) callAvatarEventProcessor k moduleName avEvent lib state avInfo = case hasFunc lib (moduleName,funcName) of Left s -> Just (Left s) Right True -> Just $ simFunc lib (moduleName, funcName) state args Right False -> Nothing where (funcName,args) = avEventProcCallInfo avEvent avInfo putAvatarOutputEvent k (SVal s) = case reads s of ((ev,_):_) -> lift $ putWorldEvent 0 (AvatarOutputEvent k ev) [] -> lift $ logAMessage LogWarn "sim" ("avatar event handler for " ++ k ++ " returned invalid event: " ++ show s) putAvatarOutputEvent k v = lift $ logAMessage LogWarn "sim" ("avatar event handler for " ++ k ++ " returned invalid event: " ++ lslShowVal v) activateScript pk sn scriptId Nothing startParam = do wscripts <- lift getWScripts worldScripts <- lift getWorldScripts case lookup scriptId wscripts of Nothing -> lift $ logAMessage LogWarn "sim" ("script " ++ scriptId ++ " not found") Just (Left s) -> lift $ logAMessage LogWarn "sim" ("script " ++ scriptId ++ " not valid") Just (Right code) -> lift $ setWorldScripts (M.insert (pk,sn) (mkScript (initLSLScript code)) worldScripts) activateScript pk sn _ (Just image) startParam = do worldScripts <- lift getWorldScripts lift $ setWorldScripts (M.insert (pk,sn) ((mkScript image) { scriptStartParameter = startParam }) worldScripts) matchListener (Chat chan' sender' key' msg' (region,position) range) ((Listener pkey sid chan sender key msg),active,(region',position')) = active && region == region' && chan == chan' && key' /= pkey && (sender == "" || sender == sender') && (key == "" || key == nullKey || key == key') && (msg == "" || msg == msg') && (case range of Nothing -> True Just dist -> dist3d2 position position' <= dist^2) listenAddress l = (listenerPrimKey l, listenerScriptName l) nextActivity :: (Monad (StateT (World a) a), Monad a) => StateT (World a) a (Maybe Int) nextActivity = do scripts <- getWorldScripts t <- getTick >>= return . (+1) let ns = foldl' (calcNxt t) Nothing $ M.elems scripts wq <- getWQueue let ne = case wq of [] -> Nothing ((i,x):_) -> Just $ max t i return $ mmin ne ns where calcNxt t n (Script { scriptActive = False }) = n calcNxt t n (Script { scriptImage = img , scriptEventQueue = q }) = case executionState img of Executing -> (Just t) Suspended _ -> (Just t) Waiting -> if null q then n else (Just t) WaitingTil i -> if isNothing n then Just (max t i) else fmap (max t . min i) n SleepingTil i -> if isNothing n then Just (max t i) else fmap (max t . min i) n _ -> n mmin Nothing Nothing = Nothing mmin Nothing (Just i) = (Just i) mmin (Just i) Nothing = (Just i) mmin (Just i) (Just j) = Just (min i j) runScripts :: Monad m => WorldM m () runScripts = do scripts <- getWorldScripts mapM_ findAndRunScript (M.keys scripts) findAndRunScript scriptKey = do scripts <- getWorldScripts case M.lookup scriptKey scripts of Nothing -> return () Just script -> checkAndRunScript scriptKey script checkAndRunScript _ (Script { scriptActive = False }) = return () checkAndRunScript k@(pkey,sname) (Script {scriptImage = img, scriptEventQueue = q}) = do pInfo <- getPrimInfo pkey suspenseInfo <- getWorldSuspended case suspenseInfo of Nothing -> run pInfo Just (suspKey,suspName) | pkey == suspKey && suspName == sname -> run pInfo | otherwise -> return () where run pInfo = case pInfo of Nothing -> logAMessage LogWarn "sim" ("script " ++ (show k) ++ ": prim not found!") Just (parent, index, primName) -> runScript parent index pkey sname primName img q runScript parent index pkey sname primName img q = do slice <- getSliceSize tick <- getTick let img' = img { scriptImageName = sname ++ "/" ++ primName ++ "/" ++ pkey } let log = logTrace (pkey ++ ":" ++ sname) --let checkBp _ sm = return (False,sm) result <- executeLsl img' parent index sname pkey doPredef log getTick setTick checkBp q (tick + slice) case result of Left s -> logAMessage LogWarn "sim" ("execution error in script " ++ "(" ++ pkey ++ "," ++ sname ++ ") ->" ++ s) Right (img'',q') -> do scripts <- getWorldScripts let result = M.lookup (pkey,sname) scripts case result of Nothing -> do logAMessage LogInfo "sim" ("script seems to have disappeared while executing (result of llDie?)") Just script -> do let script' = script { scriptImage = img'', scriptEventQueue = q' } setWorldScripts (M.insert (pkey,sname) script' scripts) case executionState img'' of Suspended bp -> setWorldSuspended (Just (pkey,sname)) _ -> setWorldSuspended Nothing handleTouches :: Monad m => WorldM m () handleTouches = do now <- getTick before <- getWorldTouchCheckTime when (now - before > durationToTicks 0.05) $ do touchLists <- getWorldTouches >>= return . M.toList runAndLogIfErr "problem handling touches" () $ do starts <- collectTouches "touch_start" M.empty $ concatMap (\ (_,tl) -> [ touch | touch@(Touch { touchStartTick = t }) <- tl, t > before]) touchLists ongoings <- collectTouches "touch" M.empty $ concatMap (\ (_,tl) -> [ touch | touch@(Touch { touchStartTick = ts, touchEndTick = te }) <- tl, te >= now && ts <= before]) touchLists ends <- collectTouches "touch_end" M.empty $ concatMap (\ (_,tl) -> [ touch | touch@(Touch { touchEndTick = te }) <- tl, te <= now]) touchLists lift $ mapM_ (uncurry (sendTouch "touch_start")) $ M.toList starts lift $ mapM_ (uncurry (sendTouch "touch")) $ M.toList ongoings lift $ mapM_ (uncurry (sendTouch "touch_end")) $ M.toList ends let nonends = [ (pk,[ t | t@(Touch { touchEndTick = te }) <- list, te > now]) | (pk,list) <- touchLists ] setWorldTouchCheckTime now setWorldTouches (M.fromList nonends) return () sendTouch ttype k tl = pushEventToPrim (Event ttype [IVal $ length tl] payload) k where payload = foldl' ins M.empty (zip [0..] tl) ins m (i,(Touch { touchAvatarKey = ak },link)) = (M.insert ("vector_" ++ show i) (VVal 0 0 0)) . (M.insert ("key_" ++ show i) (KVal ak)) . (M.insert ("integer_" ++ show i) (IVal link)) $ m collectTouches touchType acc [] = return acc collectTouches touchType acc (t@(Touch { touchPrimKey = pk }):ts) = do lneeds <- primHasActiveHandler pk touchType linkNum <- getPrimLinkNum pk rk <- getRootPrim pk if pk == rk && lneeds then collectTouches touchType (M.alter (alt (t,linkNum)) pk acc) ts else do pass <- getPrimPassTouches pk rneeds <- primHasActiveHandler rk touchType let r = if rneeds && pass then [(rk,(t { touchPrimKey = rk }, linkNum))] else [] let p = if lneeds then [(pk,(t, linkNum))] else [] collectTouches touchType (foldl' ( \ m (k,d) -> M.alter (alt d) k m) acc (r ++ p)) ts where alt i Nothing = Just [i] alt i (Just l) = Just (i:l) runPhysics :: Monad m => WorldM m () runPhysics = do t0 <- getWorldPhysicsTime t1 <- getTick os <- getObjects let tlist = [t0,(t0+10)..t1] ++ if (t1 - t0) `mod` 10 > 0 then [t1] else [] let intervals = zip tlist $ tail tlist forM_ intervals $ \ (t0,t1) -> do forM_ (M.toList os) $ \ (pk,obj) -> runErrPrim pk () $ do prim <- getPrim pk obj <- getObject pk when ((flip testBit) primPhysicsBit $ primStatus prim) $ do mass <- objectMass pk let dyn = objectDynamics obj let pos0@(_,_,z0) = objectPosition dyn let vel0@(_,_,vz0) = objectVelocity dyn let force = (fst (objectForce dyn) `rot3d` rotation) `add3d` (0,0,mass * (objectBuoyancy dyn) * (-gravC)) where rotation = if snd $ objectForce dyn then objectRotation dyn else (0,0,0,1) let impulse = ((fst . fst . objectImpulse) dyn `rot3d` rotation, (snd . objectImpulse) dyn) where rotation = if (snd . fst . objectImpulse) dyn then objectRotation dyn else (0,0,0,1) let impulseFNow = if snd impulse >= t1 then fst impulse else (0,0,0) let heightDampF tau z = (0,0, dampZForce tau z z0 mass vz0 fz0) where (_,_,fz0) = force `add3d` impulseFNow let dampF = case objectPositionTarget dyn of Nothing -> (0,0,0) Just (PositionTarget { positionTargetTau = tau, positionTargetLocation = l }) -> dampForce tau l pos0 mass vel0 (force `add3d` impulseFNow) Just (Repel { positionTargetTau = tau, positionTargetHeight = z }) -> if z0 <= 0.5 * z then heightDampF tau z else (0,0,0) Just (Hover { positionTargetTau = tau, positionTargetHeight = z}) -> heightDampF tau z let (pos,vel) = kin t0 t1 ticksToDuration 0 mass pos0 vel0 (force `add3d` dampF) impulse -- TODO: local vs global rotations in torque -- TODO: rotational impulses radius <- objRadius pk let torque = totalTorque t0 t1 ticksToDuration [(fst $ objectTorque dyn,t1),(fst $ fst $ objectRotationalImpulse dyn, snd $ objectRotationalImpulse dyn)] let dampingTorque = case objectRotationTarget dyn of Nothing -> (0,0,0) Just rt@(RotationTarget {rotationTargetTau = tau, rotationTargetStrength = strength, rotationTarget = target}) -> dampTorque tau strength target (objectRotation dyn) mass radius (objectOmega dyn) torque let (rot,omega) = rotDyn (ticksToDuration (t1 - t0)) radius mass (objectRotation dyn) (objectOmega dyn) (torque `add3d` dampingTorque) lift $ setObject pk $! (obj { objectDynamics = (objectDynamics obj) { objectVelocity = vel, objectPosition = pos, objectRotation = rot, objectOmega = omega }}) return () handleCollisions handleMovers handleTargets setWorldPhysicsTime $! t1 handleMovers :: Monad m => WorldM m () handleMovers = runAndLogIfErr "problem determining which objects moved" () $ do lastPositions <- lift $ getWorldLastPositions let lastKeys = S.fromList $ M.keys lastPositions curPositions <- lift getObjects >>= return . M.keys >>= mapM (\ k -> getObjectPosition k >>= return . ((,)k)) let curKeys = S.fromList $ map fst curPositions let newKeys = curKeys `S.difference` lastKeys let keysFromBefore = curKeys `S.difference` newKeys m <- return . M.fromList =<< mapM ( \ (k,pos) -> if k `S.member` keysFromBefore then do (moving,lpos) <- mlookup k lastPositions let moving' = lpos /= pos when (moving' && not moving) $ lift $ pushEventToPrim (Event "moving_start" [] M.empty) k when (moving && not moving') $ lift $ pushEventToPrim (Event "moving_end" [] M.empty) k return (k,(moving', pos)) else return (k,(False,pos))) curPositions lift $ setWorldLastPositions m handleObjectCollisions prims = do -- look at all non-phantom prims primBoxes <- mapM (\ (k,p) -> getPrimBox k >>= return . ((,) k ) . ((,)p) ) prims --let voldtct = map fst $ filter (primVolumeDetect . snd) prims voldtct <- flip filterM prims (\ (_,prim) -> let f k = (getObject k >>= return . objectVolumeDetect . objectDynamics) in case primParent prim of Nothing -> f (primKey prim) Just k -> f k ) >>= return . map fst let cmp x y = compare (fst x) (fst y) let curCollisions = S.fromList [ (k0,k1) | ((k0,(p0,_)),(k1,(p1,_))) <- checkIntersections (snd . snd) cmp primBoxes, primParent p0 /= Just k1 && primParent p1 /= Just k0 && not (primParent p0 == primParent p1 && isJust (primParent p0))] oldCollisions <- lift getWorldCollisions let formerCollisions = oldCollisions `S.difference` curCollisions let newCollisions = curCollisions `S.difference` oldCollisions toObjCollisions newCollisions "collision_start" >>= mapM_ (send "collision_start") (do objCollisions <- toObjCollisions curCollisions "collision" -- filter out volume detect objects, except for those objects that are attatched let attachment k = do parent <- getPrimParent k case parent of Nothing -> getPrimAttachment k Just ok -> getPrimAttachment ok objCollisions' <- (mapM (\ v@(k,_) -> (attachment k >>= return . ((,) v))) objCollisions) >>= return . (filter (\ ((k,_),mv) -> (k `notElem` voldtct) || isJust mv)) >>= return . (map fst) mapM_ (send "collision") objCollisions') toObjCollisions formerCollisions "collision_end" >>= mapM_ (send "collision_end") lift $ setWorldCollisions curCollisions where send :: Monad m => String -> (String,[(Int,String)]) -> ErrorT String (WorldM m) () send hn (pk,oinfo) = collisionScripts >>= mapM_ (sendScript hn pk oinfo) where collisionScripts = do scripts <- getPrimScripts pk >>= return . (map invName) filterM (\ sn -> scriptHasActiveHandler pk sn hn) scripts sendScript :: Monad m => String -> String -> [(Int,String)] -> String -> ErrorT String (WorldM m) () sendScript hn pk oinfo sn = do scripts <- lift $ getWorldScripts return () case M.lookup (pk,sn) scripts of Nothing -> throwError "can't find script" Just (Script { scriptCollisionFilter = (name,key,accept) }) | null name && (null key || nullKey == key) && accept -> pushit oinfo | null name && (null key || nullKey == key) && not accept -> return () | accept -> filterM (matchesIn name key) oinfo >>= pushit | otherwise -> filterM (matchesOut name key) oinfo >>= pushit where matchesIn name key (_,k) = if k == key then return True else (if null key || key == nullKey then (getPrimName k >>= return . (name==)) else return False) matchesOut name key (_,k) = if k == key then return False else (if null key || key == nullKey then (getPrimName k >>= return . not . (name==)) else return True) pushit oinfo = unless (null oinfo) $ lift (pushEvent ev pk sn) where ev = Event hn [IVal $ length oinfo] (M.fromList $ (zipWith (\ i (_,k) -> ("key_" ++ show i, KVal k)) [0..] oinfo) ++ (zipWith (\ i (n,_) -> ("integer_" ++ show i, IVal n)) [0..] oinfo)) toObjCollisions collisionsS hn = do passed <- passes primColliders colliders' <- mapM (\ (k,cs) -> (getPrimLinkNum k >>= \ i -> return (k,i,cs))) primColliders colliders'' <- mapM pk2ok (colliders' ++ passed) colliders''' <- mapM (\ (k,i,cs) -> filterM (objectHasVolDetect >=> (return . not)) cs >>= return . ((,,) k i)) colliders'' return $ M.toList (foldl' combine M.empty (map dist colliders''')) where collisions = S.toList collisionsS dist (pk,i,cs) = (pk, zip (repeat i) cs) combine m (k,lv) = case M.lookup k m of Nothing -> M.insert k lv m Just lv' -> M.insert k (lv ++ lv') m --prims = fromListOfPairs collisions primColliders = map (\ k -> (k, collectColliders collisions k)) (S.toList $ fromListOfPairs collisions) passes [] = return [] passes ((pk,cs):pcs) = do passed <- pass hn pk if passed then do parent <- getPrimParent pk >>= maybe (throwError "can't get parent") return rest <- passes pcs num <- getPrimLinkNum pk return ((parent,num,cs):rest) else passes pcs pk2ok (pk,i,cs) = primsToObjects cs >>= return . ((,,) pk i) primsToObjects ks = mapM getPrimParent ks >>= (\ parents -> (return (nub $ zipWith fromMaybe ks parents))) pass hn k = do parent <- getPrimParent k case parent of Nothing -> return False Just pk -> do passOverride <- getPrimPassTouches k pass <- (k `primHasActiveHandler` hn) >>= return . not return (pass || passOverride) fromListOfPairs [] = S.empty fromListOfPairs ((x,y):ps) = (S.insert x . S.insert y) (fromListOfPairs ps) collectColliders intsns pk = [ j | (Just j) <- map (other pk) intsns] objectHasVolDetect ok = do attach <- getPrimAttachment ok if isJust attach then return False else getObject ok >>= return . objectVolumeDetect . objectDynamics other k (x,y) | k == x = Just y | k == y = Just x | otherwise = Nothing handleLandCollisions prims = do primBoxes <- mapM (\ (k,p) -> getPrimBox k >>= return . ((,) k )) prims let curCollisions = S.fromList [ k | (k,((_,_,z),_)) <- primBoxes, z <= 0] oldCollisions <- lift getWorldLandCollisions let formerCollisions = oldCollisions `S.difference` curCollisions let newCollisions = curCollisions `S.difference` oldCollisions mapM_ (send "land_collision_end") $ S.toList formerCollisions mapM_ (send "land_collision") $ S.toList curCollisions mapM_ (send "land_collision_start") $ S.toList newCollisions lift $ setWorldLandCollisions curCollisions where send hn pk = do pass <- getPrimPassCollisions pk pos <- getGlobalPos pk >>= ( \ (x,y,_) -> return (x,y,0)) liveScripts <- getActualPrimScripts pk >>= (\ ss -> return [ s | s@(_,Script { scriptActive = True }) <- ss]) when (not $ null liveScripts) $ send' pos pk when (null liveScripts || pass) $ getRootPrim pk >>= send' pos where send' pos k = do scripts <- getPrimScripts k >>= return . (map invName) >>= filterM (\ sn -> scriptHasActiveHandler k sn hn) forM_ scripts $ (lift . pushEvent (Event hn [vec2VVal pos] M.empty) k) handleCollisions :: (Monad m) => WorldM m () handleCollisions = runAndLogIfErr "can't handle collisions" () $ do prims <- getNonPhantomPrims handleObjectCollisions prims handleLandCollisions prims getNonPhantomPrims :: (Monad m) => ErrorT String (WorldM m) [(String,Prim)] getNonPhantomPrims = lift getPrims >>= return . M.assocs >>= (return . filter ((==0) . (.&. cStatusPhantom) . primStatus . snd)) handleTargets :: Monad m => WorldM m () handleTargets = do t <- getTick t0 <- getWorldTargetCheckTime when (t - t0 > durationToTicks 0.1) $ do getObjects >>= return . M.keys >>= mapM_ (\ k -> do runErrPrim k () $ do pos <- getGlobalPos k rot <- getGlobalRot k scripts <- getActualPrimScripts k forM_ scripts (\ ((_,sn),script) -> do forM_ (IM.toList $ scriptPositionTargets script) $ (\ (i,(target,range)) -> let image = scriptImage script inRange = (dist3d2 target pos <= range^2) in if hasActiveHandler image "at_target" && inRange then lift $ pushEvent (Event "at_target" [IVal i, vec2VVal target, vec2VVal pos] M.empty) k sn else if hasActiveHandler image "not_at_target" && not inRange then lift $ pushEvent (Event "not_at_target" [] M.empty) k sn else return () ) forM_ (IM.toList $ scriptRotationTargets script) $ (\ (i,(target,range)) -> let image = scriptImage script inRange = (angleBetween target rot <= range) in if hasActiveHandler image "at_rot_target" && inRange then lift $ pushEvent (Event "at_rot_target" [IVal i, rot2RVal target, rot2RVal rot] M.empty) k sn else if hasActiveHandler image "not_at_rot_target" && not inRange then lift $ pushEvent (Event "not_at_rot_target" [] M.empty) k sn else return () ) ) ) simulate :: Monad m => WorldM m () simulate = do processEvents runScripts runPhysics handleTouches mn <- nextActivity t <- getTick let t' = case mn of Nothing -> t + 10 Just n -> min (t + 10) n setTick t' --setTick (t + 1) pauseTime <- getNextPause suspendInfo <- getWorldSuspended if t' >= pauseTime || isSuspended suspendInfo then return () else simulate where isSuspended Nothing = False isSuspended _ = True linkSet = -1::Int linkAllOthers = -2::Int linkAllChildren = -3::Int linkThis = -4::Int -- etrace :: Monad m => String -> m () -- etrace val = trace val $ return () -- trace1 s val = trace (s ++ ": " ++ show val) val -- -------------------------------------------------------------------------------------------- data SimCommand = SimContinue { simCmdBreakpoints :: [Breakpoint], simCmdEvents :: [SimEvent] } | SimStep { simCmdBreakpoints :: [Breakpoint], simCmdEvents :: [SimEvent] } | SimStepOver { simCmdBreakpoints :: [Breakpoint], simCmdEvents :: [SimEvent] } | SimStepOut { simCmdBreakpoints :: [Breakpoint], simCmdEvents :: [SimEvent] } deriving (Show) data SimStatus = SimEnded { simStatusMessage :: String, simStatusLog :: [LogMessage], simStatusState :: SimStateInfo } | SimInfo { simStatusEvents :: [SimEvent], simStatusLog :: [LogMessage], simStatusState :: SimStateInfo } | SimSuspended { simStatusEvents :: [SimEvent], simStatusSuspendInfo :: ExecutionInfo Float, simStatusLog :: [LogMessage], simStatusState :: SimStateInfo } deriving (Show) data SimStateInfo = SimStateInfo { simStateInfoTime :: Int, simStateInfoPrims :: [(String,String)], simStateInfoAvatars :: [(String,String)], simStateInfoScripts :: [(String,String)] } deriving (Show) nullSimState = SimStateInfo 0 [] [] [] stateInfoFromWorld world = SimStateInfo { simStateInfoTime = tick world, simStateInfoPrims = map (\ p -> (primKey p, primName p)) (M.elems $ wprims world), simStateInfoAvatars = map (\ (_,a) -> (avatarKey a, avatarName a)) (M.toList $ worldAvatars world), simStateInfoScripts = M.keys (worldScripts world) } data SimInputEventDefinition m = SimInputEventDefinition { simInputEventName :: String, simInputEventDescription :: String, simInputEventParameters :: [SimParam], simInputEventHandler :: String -> [LSLValue Float] -> WorldM m () } data SimParam = SimParam { simParamName :: String, simParamDescription :: String, simParamType :: SimParamType } deriving (Show) data SimParamType = SimParamPrim | SimParamAvatar | SimParamLSLValue LSLType | SimParamRootPrim | SimParamKey | SimParamScript deriving (Show) initWorld def scripts lib = worldFromFullWorldDef newWorld def lib scripts simStep init@(Left (worldDef, scripts, lib)) command = -- let world = initWorld worldDef scripts lib in simStep (Right world) command case initWorld worldDef scripts lib of Left s -> -- initialization failed (SimEnded ("Error initializing: " ++ s) [LogMessage 0 LogError "sim" ("Error initializing: " ++ s)] nullSimState, init) Right world -> simStep (Right world) command simStep (Right world) command = let t = tick world events = simCmdEvents command newBreakpointManager = replaceBreakpoints (simCmdBreakpoints command) (worldBreakpointManager world) slice = sliceSize world newScripts = case worldSuspended world of Nothing -> worldScripts world Just (k,s) -> let Just script = M.lookup (k,s) (worldScripts world) img = scriptImage script stepMgr = stepManager img img' = case command of SimStep _ _ -> img { stepManager = setStepBreakpoint stepMgr } SimStepOver _ _ -> img { stepManager = setStepOverBreakpoint stepMgr } SimStepOut _ _ -> img { stepManager = setStepOutBreakpoint stepMgr } _ -> img in M.insert (k,s) (script { scriptImage = img' }) (worldScripts world) simEventToWorldEvent (SimEvent name args delay) = (t + delay, WorldSimEvent name args) wq' = putManyWQ (map simEventToWorldEvent events) (wqueue world) world' = world { wqueue = wq', nextPause = t + slice, worldBreakpointManager = newBreakpointManager, worldScripts = newScripts } (_,world'') = runIdentity $ runStateT simulate world' log = msglog world'' outputEvents = reverse $ worldOutputQueue world'' world''' = world'' { msglog = [], worldOutputQueue = [] } in if (tick world''') < (maxTick world''') then case worldSuspended world''' of Nothing -> (SimInfo { simStatusEvents = outputEvents, simStatusLog = log, simStatusState = stateInfoFromWorld world''' }, Right world''') Just (k,s) -> let Just script = M.lookup (k,s) (worldScripts world''') -- TODO: non-exhaustive but MUST succeed img = scriptImage script (Suspended bp) = executionState img -- TODO: non-exhaustive but MUST succeed executionInfo = ExecutionInfo (breakpointFile bp) (breakpointLine bp) (frameInfo img) in (SimSuspended { simStatusEvents = outputEvents, simStatusSuspendInfo = executionInfo, simStatusLog = reverse log, simStatusState = stateInfoFromWorld world''' }, Right world''') else (SimEnded { simStatusMessage = "ended", simStatusLog = reverse log, simStatusState = stateInfoFromWorld world''' }, Right world''') -- Event Descriptions and Handlers ------------------------------------------- ------------------------------------------------------------------------------ --checkArgs def args = do checkEventArgs def args = do when (length params /= length args) $ fail "wrong number of parameters" mapM (uncurry checkEventArg) argList where params = simInputEventParameters def argList = map (\ p -> ( p , find (\ a -> simParamName p == simEventArgName a) args)) params checkEventArg (SimParam _ _ SimParamPrim) (Just arg) = return $ KVal (simEventArgValue arg) checkEventArg (SimParam _ _ SimParamRootPrim) (Just arg) = return $ KVal (simEventArgValue arg) checkEventArg (SimParam _ _ SimParamScript) (Just arg) = return $ SVal (simEventArgValue arg) checkEventArg (SimParam name _ SimParamAvatar) (Just arg) = return $ KVal (simEventArgValue arg) checkEventArg (SimParam name _ SimParamKey) (Just arg) = return $ KVal (simEventArgValue arg) checkEventArg (SimParam name _ (SimParamLSLValue t)) (Just arg) = case evaluateExpression t (simEventArgValue arg) of Nothing -> fail $ ("invalid " ++ (lslTypeString t) ++ " expression" ) Just v -> return v checkEventArg (SimParam name _ _) Nothing = fail ("event argument " ++ name ++ " not found") handleSimInputEvent def args = case checkEventArgs def args of Left s -> logAMessage LogWarn "sim" s Right argValues -> (simInputEventHandler def) (simInputEventName def) argValues mkTouchStartEvent pk nd ak ln = WorldSimEvent "touch_start" [SimEventArg "Prim Key" pk, SimEventArg "num_detected" nd, SimEventArg "Avatar key" ak, SimEventArg "Link Number" (show ln)] mkTouchEvent pk nd ak ln = WorldSimEvent "touch" [SimEventArg "Prim Key" pk, SimEventArg "num_detected" nd, SimEventArg "Avatar key" ak, SimEventArg "Grab vector" "<0.0,0.0,0.0>", SimEventArg "Link Number" (show ln)] mkTouchEndEvent pk nd ak ln = WorldSimEvent "touch_end" [SimEventArg "Prim Key" pk, SimEventArg "num_detected" nd, SimEventArg "Avatar key" ak, SimEventArg "Link Number" (show ln)] userTouchEventDef :: Monad m => SimInputEventDefinition m userTouchEventDef = SimInputEventDefinition { simInputEventName = "Touch Prim", simInputEventDescription = "Avatar touches a prim for a duration", simInputEventParameters = [ SimParam "Prim" "The prim the avatar should touch" SimParamPrim, SimParam "Avatar" "The avatar that should do the touching" SimParamAvatar, SimParam "Duration" "The duration of the touch (in seconds)" (SimParamLSLValue LLFloat)], simInputEventHandler = let f _ [KVal pk, KVal ak, FVal duration] = runAndLogIfErr "can't find prim? " () $ do -- should we pass touches? prim <- getPrim pk linkNum <- getPrimLinkNum pk -- linkNum <- (case primParent prim of -- Nothing -> return 0 -- Just parent -> do -- LSLObject { primKeys = links } <- getObject parent -- Just i <- return $ elemIndex pk links -- return (i + 1)) <||> -- (do lift $ logAMessage LogWarn "sim" ("can't figure out link number of prim: " ++ pk) -- return 0) needstouches <- liftM or $ mapM (primHasActiveHandler pk) ["touch","touch_start","touch_end"] let touchList = (if needstouches then [pk] else []) ++ (if (primPassTouches prim || not needstouches) then maybe [] return (primParent prim) else []) lift $ mapM_ (doTouch linkNum) touchList where doTouch linkNum k = do putWorldEvent 0 (mkTouchStartEvent k "1" ak linkNum) let tdur = floor (1000 * duration) let tTimes = map ((/1000.0) . fromIntegral) [1,(1 + 500) .. tdur] mapM_ ((flip putWorldEvent) (mkTouchEvent pk "1" ak linkNum)) tTimes putWorldEvent duration (mkTouchEndEvent pk "1" ak linkNum) f name _ = logAMessage LogWarn "sim" ("invalid event activation: " ++ name) in f } userChatEventDef :: Monad m => SimInputEventDefinition m userChatEventDef = SimInputEventDefinition { simInputEventName = "Chat", simInputEventDescription = "Avatar chats", simInputEventParameters = [ SimParam "Avatar" "The avatar that should do the chatting" SimParamAvatar, SimParam "Message" "What the avatar should say" (SimParamLSLValue LLString), SimParam "Channel" "The channel to chat on" (SimParamLSLValue LLInteger)], simInputEventHandler = let f _ [KVal ak, SVal message, IVal chan] = do avatars <- getWorldAvatars case M.lookup ak avatars of Nothing -> logAMessage LogWarn "sim" ("avatar with key " ++ ak ++ " not found") Just av -> do putWorldEvent 0 $ Chat chan (avatarName av) ak message (avatarRegion av,avatarPosition av) (Just 20.0) f name _ = logAMessage LogWarn "sim" ("invalid event activation: " ++ name) in f } eventDescriptors :: Monad m => Map [Char] (SimInputEventDefinition m) eventDescriptors = M.fromList $ mkEventDefList ([userTouchEventDef,userChatEventDef] ++ rawLslEventDescriptors) mkEventDefList eventDefs = map (\ e -> (simInputEventName e, e)) eventDefs rawLslEventDescriptors :: Monad m => [SimInputEventDefinition m] rawLslEventDescriptors = map lslEventDescriptorToSimInputDef lslEventDescriptors lslEventDescriptorToSimInputDef (name, params, delivery, additionalData, description) = SimInputEventDefinition { simInputEventName = name, simInputEventDescription = "This is a raw LSL event: " ++ description, simInputEventParameters = (case delivery of EventDeliveryScript -> [SimParam "Script" "name of script to deliver to" SimParamScript, SimParam "Prim Key" "key of prim to deliver to" SimParamPrim] EventDeliveryObject -> [SimParam "Object Key" "key of object to deliver to" SimParamRootPrim] EventDeliveryRoot -> [SimParam "Object Key" "key of object to deliver to" SimParamRootPrim] EventDeliveryPrim -> [SimParam "Prim Key" "key of prim to deliver to" SimParamPrim] ) ++ (flip map additionalData (\ d -> case d of EventAdditionalInts name description -> SimParam name description (SimParamLSLValue LLInteger) EventAdditionalKeys name description -> SimParam name description SimParamKey EventAdditionalAvatarKeys name description -> SimParam name description SimParamAvatar EventAdditionalVectors name description -> SimParam name description (SimParamLSLValue LLVector))) ++ map ( \ (t,name) -> SimParam name "" (SimParamLSLValue t)) params, simInputEventHandler = let f _ list = let lenAddl = length additionalData (df,rest) = case (delivery,list) of (EventDeliveryScript,SVal sn:KVal pk:vals) -> (\ e -> pushEvent e pk sn,vals) (EventDeliveryObject,KVal key:vals) -> (\ e -> pushEventToObject e key,vals) (EventDeliveryRoot, KVal key:vals) -> ((\ e -> pushEventToPrim e key), vals) (EventDeliveryPrim, KVal key:vals) -> ((\ e -> pushEventToPrim e key), vals) _ -> (\ _ -> logAMessage LogWarn "sim" "invalid user event - bad script address",[]) in df (Event name (drop lenAddl rest) (M.fromList (zipWith mkInfo additionalData (take lenAddl rest))) ) where mkInfo (EventAdditionalVectors _ _) val = ("vector_0",val) mkInfo (EventAdditionalInts _ _) val = ("integer_0",val) mkInfo _ val = ("key_0",val) in f }