diff --git a/Language/Lsl/Internal/Animation.hs b/Language/Lsl/Internal/Animation.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/Animation.hs @@ -0,0 +1,137 @@ +module Language.Lsl.Internal.Animation(builtInAnimations) where + +builtInAnimations :: [(String,String,Maybe Float)] +builtInAnimations = + [("aim_l_bow","46bb4359-de38-4ed8-6a22-f1f52fe8f506",Just 5), + ("aim_r_bazooka","b5b4a67d-0aee-30d2-72cd-77b333e932ef",Just 5), + ("aim_r_handgun","3147d815-6338-b932-f011-16b56d9ac18b",Just 5), + ("aim_r_rifle","ea633413-8006-180a-c3ba-96dd1d756720",Just 5), + ("angry_fingerwag","c1bc7f36-3ba0-d844-f93c-93be945d644f",Just 5), + ("angry_tantrum","11000694-3f41-adc2-606b-eee1d66f3724",Just 5), + ("away","fd037134-85d4-f241-72c6-4f42164fedee",Nothing), + ("backflip","c4ca6188-9127-4f31-0158-23c4e2f93304",Just 5), + ("blowkiss","db84829b-462c-ee83-1e27-9bbee66bd624",Just 5), + ("bow","82e99230-c906-1403-4d9c-3889dd98daba",Just 5), + ("brush","349a3801-54f9-bf2c-3bd0-1ac89772af01",Just 5), + ("busy","efcf670c-2d18-8128-973a-034ebc806b67",Nothing), + ("clap","9b0c1c4e-8ac7-7969-1494-28c874c4f668",Just 5), + ("courtbow","9ba1c942-08be-e43a-fb29-16ad440efc50",Just 5), + ("crouch","201f3fdf-cb1f-dbec-201f-7333e328ae7c",Just 5), + ("crouchwalk","47f5f6fb-22e5-ae44-f871-73aaaf4a6022",Just 5), + ("dance1","b68a3d7c-de9e-fc87-eec8-543d787e5b0d",Just 5), + ("dance2","928cae18-e31d-76fd-9cc9-2f55160ff818",Just 5), + ("dance3","30047778-10ea-1af7-6881-4db7a3a5a114",Just 5), + ("dance4","951469f4-c7b2-c818-9dee-ad7eea8c30b7",Just 5), + ("dance5","4bd69a1d-1114-a0b4-625f-84e0a5237155",Just 5), + ("dance6","cd28b69b-9c95-bb78-3f94-8d605ff1bb12",Just 5), + ("dance7","a54d8ee2-28bb-80a9-7f0c-7afbbe24a5d6",Just 5), + ("dance8","b0dc417c-1f11-af36-2e80-7e7489fa7cdc",Just 5), + ("dead","57abaae6-1d17-7b1b-5f98-6d11a6411276",Just 5), + ("drink","0f86e355-dd31-a61c-fdb0-3a96b9aad05f",Just 5), + ("express_afraid","6b61c8e8-4747-0d75-12d7-e49ff207a4ca",Just 5), + ("express_afraid_emote","aa2df84d-cf8f-7218-527b-424a52de766e",Just 5), + ("express_anger","5747a48e-073e-c331-f6f3-7c2149613d3e",Just 5), + ("express_anger_emote","1a03b575-9634-b62a-5767-3a679e81f4de",Just 5), + ("express_bored","b906c4ba-703b-1940-32a3-0c7f7d791510",Just 5), + ("express_bored_emote","214aa6c1-ba6a-4578-f27c-ce7688f61d0d",Just 5), + ("express_cry","92624d3e-1068-f1aa-a5ec-8244585193ed",Just 5), + ("express_cry_emote","d535471b-85bf-3b4d-a542-93bea4f59d33",Just 5), + ("express_disdain","d4416ff1-09d3-300f-4183-1b68a19b9fc1",Just 5), + ("express_embarrassed_emote","0b8c8211-d78c-33e8-fa28-c51a9594e424",Just 5), + ("express_frown","fee3df48-fa3d-1015-1e26-a205810e3001",Just 5), + ("express_kiss","1e8d90cc-a84e-e135-884c-7c82c8b03a14",Just 5), + ("express_laugh","18b3a4b5-b463-bd48-e4b6-71eaac76c515",Just 5), + ("express_laugh_emote","62570842-0950-96f8-341c-809e65110823",Just 5), + ("express_open_mouth","d63bc1f9-fc81-9625-a0c6-007176d82eb7",Just 5), + ("express_repulsed","36f81a92-f076-5893-dc4b-7c3795e487cf",Just 5), + ("express_repulsed_emote","f76cda94-41d4-a229-2872-e0296e58afe1",Just 5), + ("express_sad","0eb702e2-cc5a-9a88-56a5-661a55c0676a",Just 5), + ("express_sad_emote","eb6ebfb2-a4b3-a19c-d388-4dd5c03823f7",Just 5), + ("express_shrug","70ea714f-3a97-d742-1b01-590a8fcd1db5",Just 5), + ("express_shrug_emote","a351b1bc-cc94-aac2-7bea-a7e6ebad15ef",Just 5), + ("express_smile","b7c7c833-e3d3-c4e3-9fc0-131237446312",Just 5), + ("express_surprise","313b9881-4302-73c0-c7d0-0e7a36b6c224",Just 5), + ("express_surprise_emote","728646d9-cc79-08b2-32d6-937f0a835c24",Just 5), + ("express_tongue_out","835965c6-7f2f-bda2-5deb-2478737f91bf",Just 5), + ("express_toothsmile","b92ec1a5-e7ce-a76b-2b05-bcdb9311417e",Just 5), + ("express_wink","869ecdad-a44b-671e-3266-56aef2e3ac2e",Just 5), + ("express_wink_emote","da020525-4d94-59d6-23d7-81fdebf33148",Just 5), + ("express_worry","9f496bd2-589a-709f-16cc-69bf7df1d36c",Just 5), + ("express_worry_emote","9c05e5c7-6f07-6ca4-ed5a-b230390c3950",Just 5), + ("falldown","666307d9-a860-572d-6fd4-c3ab8865c094",Just 5), + ("female_walk","f5fc7433-043d-e819-8298-f519a119b688",Nothing), + ("fist_pump","7db00ccd-f380-f3ee-439d-61968ec69c8a",Just 5), + ("fly","aec4610c-757f-bc4e-c092-c6e9caf18daf",Nothing), + ("flyslow","2b5a38b2-5e00-3a97-a495-4c826bc443e6",Just 5), + ("hello","9b29cd61-c45b-5689-ded2-91756b8d76a9",Just 5), + ("hold_l_bow","8b102617-bcba-037b-86c1-b76219f90c88",Just 5), + ("hold_r_bazooka","ef62d355-c815-4816-2474-b1acc21094a6",Just 5), + ("hold_r_handgun","efdc1727-8b8a-c800-4077-975fc27ee2f2",Just 5), + ("hold_r_rifle","3d94bad0-c55b-7dcc-8763-033c59405d33",Just 5), + ("hold_throw_r","7570c7b5-1f22-56dd-56ef-a9168241bbb6",Just 5), + ("hover","4ae8016b-31b9-03bb-c401-b1ea941db41d",Nothing), + ("hover_down","20f063ea-8306-2562-0b07-5c853b37b31e",Just 5), + ("hover_up","62c5de58-cb33-5743-3d07-9e4cd4352864",Just 5), + ("impatient","5ea3991f-c293-392e-6860-91dfa01278a3",Just 5), + ("jump","2305bd75-1ca9-b03b-1faa-b176b8a8c49e",Just 5), + ("jumpforjoy","709ea28e-1573-c023-8bf8-520c8bc637fa",Just 5), + ("kick_roundhouse_r","49aea43b-5ac3-8a44-b595-96100af0beda",Just 5), + ("kissmybutt","19999406-3a3a-d58c-a2ac-d72e555dcf51",Just 5), + ("land","7a17b059-12b2-41b1-570a-186368b6aa6f",Just 5), + ("laugh_short","ca5b3f14-3194-7a2b-c894-aa699b718d1f",Just 5), + ("motorcycle_sit","08464f78-3a8e-2944-cba5-0c94aff3af29",Just 5), + ("musclebeach","315c3a41-a5f3-0ba4-27da-f893f769e69b",Just 5), + ("no_head","5a977ed9-7f72-44e9-4c4c-6e913df8ae74",Just 5), + ("no_unhappy","d83fa0e5-97ed-7eb2-e798-7bd006215cb4",Just 5), + ("nyanya","f061723d-0a18-754f-66ee-29a44795a32f",Just 5), + ("peace","b312b10e-65ab-a0a4-8b3c-1326ea8e3ed9",Just 5), + ("point_me","17c024cc-eef2-f6a0-3527-9869876d7752",Just 5), + ("point_you","ec952cca-61ef-aa3b-2789-4d1344f016de",Just 5), + ("prejump","7a4e87fe-de39-6fcb-6223-024b00893244",Just 5), + ("punch_l","f3300ad9-3462-1d07-2044-0fef80062da0",Just 5), + ("punch_onetwo","eefc79be-daae-a239-8c04-890f5d23654a",Just 5), + ("punch_r","c8e42d32-7310-6906-c903-cab5d4a34656",Just 5), + ("rps_countdown","35db4f7e-28c2-6679-cea9-3ee108f7fc7f",Just 5), + ("rps_paper","0836b67f-7f7b-f37b-c00a-460dc1521f5a",Just 5), + ("rps_rock","42dd95d5-0bc6-6392-f650-777304946c0f",Just 5), + ("rps_scissors","16803a9f-5140-e042-4d7b-d28ba247c325",Just 5), + ("run","05ddbff8-aaa9-92a1-2b74-8fe77a29b445",Nothing), + ("salute","cd7668a6-7011-d7e2-ead8-fc69eff1a104",Just 5), + ("shoot_l_bow","e04d450d-fdb5-0432-fd68-818aaf5935f8",Just 5), + ("shout","6bd01860-4ebd-127a-bb3d-d1427e8e0c42",Just 5), + ("sit","1a5fe8ac-a804-8a5d-7cbd-56bd83184568",Just 5), + ("sit_female","b1709c8d-ecd3-54a1-4f28-d55ac0840782",Nothing), + ("sit_generic","245f3c54-f1c0-bf2e-811f-46d8eeb386e7",Nothing), + ("sit_ground","1c7600d6-661f-b87b-efe2-d7421eb93c86",Nothing), + ("sit_to_stand","a8dee56f-2eae-9e7a-05a2-6fb92b97e21e",Just 5), + ("sleep","f2bed5f9-9d44-39af-b0cd-257b2a17fe40",Nothing), + ("smoke_idle","d2f2ee58-8ad1-06c9-d8d3-3827ba31567a",Just 5), + ("smoke_inhale","6802d553-49da-0778-9f85-1599a2266526",Just 5), + ("smoke_throw_down","0a9fb970-8b44-9114-d3a9-bf69cfe804d6",Just 5), + ("snapshot","eae8905b-271a-99e2-4c0e-31106afd100c",Just 5), + ("soft_land","f4f00d6e-b9fe-9292-f4cb-0ae06ea58d57",Just 5), + ("stand","2408fe9e-df1d-1d7d-f4ff-1384fa7b350f",Just 5), + ("stand_1","15468e00-3400-bb66-cecc-646d7c14458e",Just 5), + ("stand_2","370f3a20-6ca6-9971-848c-9a01bc42ae3c",Just 5), + ("stand_3","42b46214-4b44-79ae-deb8-0df61424ff4b",Just 5), + ("stand_4","f22fed8b-a5ed-2c93-64d5-bdd8b93c889f",Just 5), + ("standup","3da1d753-028a-5446-24f3-9c9b856d9422",Just 5), + ("stretch","80700431-74ec-a008-14f8-77575e73693f",Just 5), + ("stride","1cb562b0-ba21-2202-efb3-30f82cdf9595",Just 5), + ("surf","41426836-7437-7e89-025d-0aa4d10f1d69",Just 5), + ("sword_strike_r","85428680-6bf9-3e64-b489-6f81087c24bd",Just 5), + ("talk","5c682a95-6da4-a463-0bf6-0f5b7be129d1",Just 5), + ("throw_r","aa134404-7dac-7aca-2cba-435f9db875ca",Just 5), + ("tryon_shirt","83ff59fe-2346-f236-9009-4e3608af64c1",Just 5), + ("turn_180","038fcec9-5ebd-8a8e-0e2e-6e71a0a1ac53",Just 5), + ("turnback_180","6883a61a-b27b-5914-a61e-dda118a9ee2c",Just 5), + ("turnleft","56e0ba0d-4a9f-7f27-6117-32f2ebbf6135",Just 5), + ("turnright","2d6daa51-3192-6794-8e2e-a15f8338ec30",Just 5), + ("type","c541c47f-e0c0-058b-ad1a-d6ae3a4584d9",Just 5), + ("walk","6ed24bd8-91aa-4b12-ccc7-c97c857ab4e0",Nothing), + ("whisper","7693f268-06c7-ea71-fa21-2b30d6533f8f",Just 5), + ("whistle","b1ed7982-c68e-a982-7561-52a88a5298c0",Just 5), + ("wink_hollywood","c0c4030f-c02b-49de-24ba-2331f43fe41c",Just 5), + ("yes_happy","b8c8b2a3-9008-1771-3bfc-90924955ab2d",Just 5), + ("yes_head","15dd911d-be82-2856-26db-27659b142875",Just 5), + ("yoga_float","42ecd00b-9947-a97c-400a-bbc9174c7aeb",Just 5)] diff --git a/Language/Lsl/Internal/AvEvents.hs b/Language/Lsl/Internal/AvEvents.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/AvEvents.hs @@ -0,0 +1,19 @@ +module Language.Lsl.Internal.AvEvents(AvatarOutputEvent(..), + AvatarInputEvent(..)) where + +data AvatarOutputEvent = + AvatarTouch { avatarTouchPrimKey :: String, avatarTouchDuration :: Float } + | AvatarWhisper { avatarChatChannel :: Int, avatarChatMessage :: String } + | AvatarSay { avatarChatChannel :: Int, avatarChatMessage :: String } + | AvatarShout { avatarChatChannel :: Int, avatarChatMessage :: String } + | AvatarPay { avatarPayPrimKey :: String, avatarPayAmount :: Int } + | AvatarControl { avatarNewControlBits :: Int } deriving (Read,Show) + +data AvatarInputEvent = + AvatarOwnerSay { avatarOwnerSayPrimKey :: String, avatarOwnerSayMsg :: String } + | AvatarHearsChat { avatarHearsChatFromName :: String, avatarHearsChatFromKey :: String, avatarHearsChatMsg :: String } + | AvatarDialog { avatarDialogMessage :: String, avatarDialogButtons :: [String], + avatarDialogChannel :: Int, avatarDialogSourceObject :: String } + | AvatarLoadURL { avatarLoadURLMessage :: String, avatarLoadURLAddress :: String } + | AvatarMapDestination { avatarMapDestination :: String, avatarMapDestinationPosition :: (Float,Float,Float) } + deriving (Read,Show) diff --git a/Language/Lsl/Internal/Breakpoint.hs b/Language/Lsl/Internal/Breakpoint.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/Breakpoint.hs @@ -0,0 +1,90 @@ +module Language.Lsl.Internal.Breakpoint( + Breakpoint, + BreakpointManager, + StepManager, + mkBreakpoint, -- :: String -> Int -> Int -> Breakpoint + replaceBreakpoints, -- :: [Breakpoint] -> BreakpointManager -> BreakpointManager + checkBreakpoint, -- :: Breakpoint -> BreakpointManager -> StepManager -> (Bool,BreakpointManager,StepManager) + addFixedBreakpoint, -- :: Breakpoint -> BreakpointManager -> BreakpointManager + removeFixedBreakpoint, -- :: Breakpoint -> BreakpointManager -> BreakpointManager + pushStepManagerFrame, -- :: StepManager -> StepManager + popStepManagerFrame, -- :: StepManager -> StepManager + setStepOutBreakpoint, -- :: StepManager -> StepManager + setStepBreakpoint, -- :: StepManager -> StepManager + setStepOverBreakpoint, -- :: StepManager -> StepManager + emptyBreakpointManager, -- :: BreakpointManager + emptyStepManager, -- :: StepManager + breakpointFile, -- :: Breakpoint -> String + breakpointLine -- :: Breakpoint -> Int + ) where + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S + +--trace1 v = trace ("--> " ++ show v) v + +data Breakpoint = Breakpoint { breakpointFile :: String, breakpointLine :: Int, breakpointColumn :: Int } + deriving (Show,Eq,Ord) +data DynamicBreakpoint = NoDynamicBreakpoint | NextStatement | NextStatementInFrame | NextStatementAboveFrame + deriving (Show,Eq) + +newtype StepManager = StepManager [DynamicBreakpoint] deriving (Show) + +mkBreakpoint name line col = Breakpoint name line col + +data BreakpointManager = BreakpointManager { fixedBreakpoints :: (Map String (Set (Int,Int))) } + deriving (Show) + +emptyStepManager = StepManager [] + +emptyBreakpointManager = BreakpointManager M.empty + +replaceBreakpoints bps bpm = + foldl (flip addFixedBreakpoint) (bpm { fixedBreakpoints = M.empty }) bps + +checkBreakpoint bp bpm sm@(StepManager dynBreakpts) = + case dynBreakpts of + (NextStatement:frames) -> (True,bpm, StepManager (NoDynamicBreakpoint : frames)) + (NextStatementInFrame:frames) -> (True,bpm, StepManager (NoDynamicBreakpoint : frames)) + _ -> let (result,bpm') = hasFixedBreakpoint bp bpm in (result,bpm',sm) + +hasFixedBreakpoint bp bpm = + case M.lookup (breakpointFile bp) map of + Nothing -> (False,bpm) + Just set -> ((breakpointLine bp, breakpointColumn bp) `S.member` set, bpm) + where map = fixedBreakpoints bpm + +addFixedBreakpoint (Breakpoint file line col) bpm = + let map = fixedBreakpoints bpm in + case M.lookup file map of + Nothing -> bpm { fixedBreakpoints = M.insert file (S.singleton (line,col)) map } + Just set -> bpm { fixedBreakpoints = M.insert file (S.insert (line,col) set) map } + +removeFixedBreakpoint (Breakpoint file line col) bpm = + let map = fixedBreakpoints bpm in + case M.lookup file map of + Nothing -> bpm + Just set -> bpm { fixedBreakpoints = M.insert file (S.delete (line,col) set) map } + +pushStepManagerFrame (StepManager dynBps) = + StepManager $ case dynBps of + (NextStatement:frames) -> (NextStatement:NoDynamicBreakpoint:frames) + frames -> (NoDynamicBreakpoint:frames) + +popStepManagerFrame (StepManager dynBps) = + StepManager $ case dynBps of + (NoDynamicBreakpoint:NextStatementInFrame:frames) -> NextStatement:frames + (NoDynamicBreakpoint:x:frames) -> x:frames + (_:_:frames) -> NextStatement:frames + _ -> [] + +setStepOutBreakpoint = setDynamicBreakpoint NextStatementAboveFrame +setStepBreakpoint = setDynamicBreakpoint NextStatement +setStepOverBreakpoint = setDynamicBreakpoint NextStatementInFrame + +setDynamicBreakpoint dbp (StepManager dynBps) = + StepManager $ case dynBps of + (_:frames) -> dbp:frames + [] -> [] diff --git a/Language/Lsl/Internal/BreakpointsDeserialize.hs b/Language/Lsl/Internal/BreakpointsDeserialize.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/BreakpointsDeserialize.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -XFlexibleContexts #-} +module Language.Lsl.Internal.BreakpointsDeserialize(breakpointsElement, module Language.Lsl.Internal.Breakpoint) where + +import Control.Monad.Error(MonadError) +import Language.Lsl.Internal.DOMProcessing(ElemAcceptor(..),elementList,findElement,simple) +import Language.Lsl.Internal.Breakpoint(Breakpoint(..),mkBreakpoint) +import Text.XML.HaXml(Content(..),Element(..)) + +breakpointsElement :: MonadError String m => ElemAcceptor m [Breakpoint] +breakpointsElement = elementList "breakpoints" breakpointElement + +breakpointElement :: MonadError String m => ElemAcceptor m Breakpoint +breakpointElement = + let f (Elem _ _ contents) = do + (file,contents1) <- findElement (ElemAcceptor "file" simple) [ e | e@(CElem _ _) <- contents ] + (lineStr,contents2) <- findElement (ElemAcceptor "line" simple) contents1 + return $ mkBreakpoint file (read lineStr) 0 + in ElemAcceptor "breakpoint" f diff --git a/Language/Lsl/Internal/BuiltInModules.hs b/Language/Lsl/Internal/BuiltInModules.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/BuiltInModules.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -XQuasiQuotes #-} +module Language.Lsl.Internal.BuiltInModules(avEventGen) where + +import Language.Lsl.Syntax +import Language.Lsl.QQ(lslm) + +avEventGenAST = [$lslm|$module + string mkTouch(string primKey, float duration) { + return "AvatarTouch {avatarTouchPrimKey = \"" + primKey + "\", avatarTouchDuration = " + (string) duration + "}"; + } + string mkWhisper(integer chan, string message) { + return "AvatarWhisper { avatarChatChannel = " + (string)chan + ", avatarChatMessage = \"" + message + "\"}"; + } + string mkSay(integer chan, string message) { + return "AvatarSay { avatarChatChannel = " + (string)chan + ", avatarChatMessage = \"" + message + "\"}"; + } + string mkShout(integer chan, string message) { + return "AvatarShout { avatarChatChannel = " + (string)chan + ", avatarChatMessage = \"" + message + "\"}"; + } + string mkPay(string primKey, integer amount) { + return "AvatarPay { avatarPayPrimKey = \"" + primKey + "\", avatarPayAmount = " + (string) amount + "}"; + } + string mkControl(integer newControlBits) { + return "AvatarControl { avatarNewControlBits = " + (string) newControlBits + "}"; + } + |] + +avEventGen = ("$avEventGen", avEventGenAST) diff --git a/Language/Lsl/Internal/CodeHelper.hs b/Language/Lsl/Internal/CodeHelper.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/CodeHelper.hs @@ -0,0 +1,8 @@ +-- a place to put shared, LSL code related utilities. Some of these are already in Lsl.Type, +-- could be moved here. +module Language.Lsl.Internal.CodeHelper(renderCall) where + +import Data.List(intersperse) +import Language.Lsl.Internal.Type(lslShowVal) + +renderCall n a = concat ([n, "("] ++ (intersperse "," $ map lslShowVal a) ++ [")"]) diff --git a/Language/Lsl/Internal/Compiler.hs b/Language/Lsl/Internal/Compiler.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/Compiler.hs @@ -0,0 +1,140 @@ +-- The Lsl "compiler" parses LSL+ 'modules' and 'scripts', and can then: +-- issue a report on all the errors it has found +-- generate LSL scripts for those LSL+ scripts that successfully 'compiled' + +module Language.Lsl.Internal.Compiler(compile,main0) where + +import Control.Monad(when) +import IO(Handle,hGetContents,stdin) +import Language.Lsl.Internal.DOMSourceDescriptor(sourceFiles) +import Language.Lsl.Internal.Load(loadModules,loadScripts) +import Language.Lsl.Render(renderCompiledScript) +import Language.Lsl.Syntax(AugmentedLibrary(..),CompiledLSLScript(..),Ctx(..),Func(..),Global(..), + GlobDef(..),Handler(..),LModule(..),SourceContext(..),State(..),Validity,Var(..), + funcName,funcParms,funcType,libFromAugLib) +import Language.Lsl.Internal.Type(lslTypeString) +import System.Directory(doesFileExist,removeFile) +import System.FilePath(replaceExtension) +import System.Time(calendarTimeToString,getClockTime,toCalendarTime) +import Text.XML.HaXml(Document(..),xmlParse) --hiding (when,xmlEscape) +import Text.XML.HaXml.Posn(Posn(..)) +import Language.Lsl.Internal.Optimize(optimizeScript) +import Language.Lsl.Internal.XmlCreate hiding (emit) +import qualified Language.Lsl.Internal.XmlCreate as E + +emit s = E.emit s [] + +readCompileEmit :: Handle -> IO () +readCompileEmit h = + do sourceInfo@(_,scriptInfo) <- readSourceList h + results@(_,compiledScripts) <- compile sourceInfo + renderScriptsToFiles compiledScripts scriptInfo + putStr $ formatCompilationSummary results + +main0 = readCompileEmit stdin + +compile :: ([(String,String)],[(String,String)]) -> IO (AugmentedLibrary,[(String,Validity CompiledLSLScript)]) +compile (moduleInfo,scriptInfo) = + do augLib <- loadModules moduleInfo + scripts <- loadScripts (libFromAugLib augLib) scriptInfo + return (augLib,scripts) + +formatCompilationSummary :: (AugmentedLibrary,[(String,Validity CompiledLSLScript)]) -> String +formatCompilationSummary (augLib, scripts) = + let emitModules = emit "modules" (map formatModuleCompilationSummary augLib) + emitScripts = emit "scripts" (map formatScriptCompilationSummary scripts) + in emit "summary" [emitModules , emitScripts] "" + +formatScriptCompilationSummary (name,result) = + emit "item" + ([emit "name" [showString name]] ++ + case result of + Left err -> [formatErr err] + Right (CompiledLSLScript globals funcs states) -> + [emit "status" [emit "ok" [showString "true"]], + emit "entryPoints" (map emitFunc funcs ++ concatMap stateEntryPointEmitters states), + emit "globals" (map emitGlobal globals)]) + where funcNames = map (\ (Func dec _) -> ctxItem $ funcName dec) + handlerPaths = concatMap (\ (State ctxName handlers) -> map (\ (Handler ctxName1 _ _) -> ctxItem ctxName ++ "." ++ ctxItem ctxName1) handlers) + +formatModuleCompilationSummary (name,result) = + emit "item" + ([emit "name" [showString name]] ++ + case result of + Left err -> [formatErr err] + Right (LModule globdefs freevars,(globals,_)) -> + [emit "status" [emit "ok" [showString "true"]], + emit "entryPoints" (map emitFunc (funcs globdefs)), + emit "globals" (map emitGlobal globals ++ map emitFreeVar freevars)]) + where funcs globdefs = [ f | GF f <- globdefs] + +emitFunc (Func fd _) = + emit "entryPoint" [ + emit "name" [showString (ctxItem $ funcName fd)], + emit "returnType" [showString (lslTypeString $ funcType fd)], + emit "params" (emitParams $ map ctxItem (funcParms fd))] + +emitGlobal (GDecl (Var n t) _) = emit "global" (emitNameTypePair n t) + +emitFreeVar ctxvar = + let (Var n t) = ctxItem ctxvar in emit "global" (emitNameTypePair n t) + +emitNameTypePair n t = [emit "name" [showString n], emit "type" [showString $ lslTypeString t]] + +stateEntryPointEmitters (State ctxName handlers) = map (emitHandler $ ctxItem ctxName) handlers + +emitHandler state (Handler ctxName ctxVars _) = + emit "entryPoint" [ + emit "name" [showString (state ++ "." ++ ctxItem ctxName)], + emit "returnType" [showString "void"], + emit "params" (emitParams $ map ctxItem ctxVars)] + +emitParams = map emitParam + +emitParam var = emit "param" [emit "name" [showString $ varName var], emit "type" [showString $ lslTypeString $ varType var]] + +formatErr (ctx,msg) = + emit "status" [emit "ok" [showString "false"] , formatCtx ctx , emit "msg" [showString (xmlEscape msg)]] + +formatCtx UnknownSourceContext = id +formatCtx (TextLocation { textLine0 = l0, textColumn0 = c0, textLine1 = l1, textColumn1 = c1, textName = n }) = + emit "errLoc" (map (\ (x,y) -> emit x [showString y]) + [("lineStart",show l0), + ("columnStart",show c0), + ("lineEnd",show l1), + ("columnEnd",show c1)]) + +readSourceList :: Handle -> IO ([(String,String)],[(String,String)]) +readSourceList handle = do + input <- hGetContents handle + let doc = xmlParse "" input + return $ processCompileList doc + +processCompileList :: Document Posn -> ([(String,String)],[(String,String)]) +processCompileList (Document _ _ root _) = + case sourceFiles root of + Left s -> error s + Right v -> v + +renderScriptsToFiles :: [(String,Validity CompiledLSLScript)] -> [(String,String)] -> IO () +renderScriptsToFiles compiledScripts pathTable = + let scriptsToRender = + [(path,script) | (Just path,Right script) <- map (\ (name,vs) -> (lookup name pathTable,vs)) compiledScripts] + scriptsToRemove = + [path | (Just path,Left _) <- map (\ (name,vs) -> (lookup name pathTable,vs)) compiledScripts] + in do + clockTime <- getClockTime + calTime <- toCalendarTime clockTime + let stamp = calendarTimeToString calTime + mapM_ (\ (path,script) -> renderScriptToFile stamp path script) scriptsToRender + mapM_ (removeOutputScript) scriptsToRemove + +renderScriptToFile stamp path script = + let newPath = replaceExtension path ".lsl" + text = renderCompiledScript stamp (optimizeScript script) in writeFile newPath text + +removeOutputScript path = + do exists <- doesFileExist outpath + when exists $ removeFile outpath + where outpath = replaceExtension path ".lsl" + diff --git a/Language/Lsl/Internal/Constants.hs b/Language/Lsl/Internal/Constants.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/Constants.hs @@ -0,0 +1,574 @@ +module Language.Lsl.Internal.Constants where + +import Data.Bits((.|.),shiftL) +import Language.Lsl.Internal.Type(LSLValue(..),typeOfLSLValue) +import Language.Lsl.Internal.Util(findM) + +data Constant = Constant { constName :: String, constVal :: LSLValue } + deriving (Show) + +llcInventoryAll = IVal (-1) +llcInventoryAnimation = IVal 20 +llcInventoryBodyPart = IVal 13 +llcInventoryClothing = IVal 5 +llcInventoryGesture = IVal 21 +llcInventoryLandmark = IVal 3 +llcInventoryNotecard = IVal 7 +llcInventoryNone = IVal (-1) +llcInventoryObject = IVal 6 +llcInventoryScript = IVal 10 +llcInventorySound = IVal 1 +llcInventoryTexture = IVal 0 +cPermissionChangeLinks = 0x80 :: Int +llcPermissionChangeLinks = IVal cPermissionChangeLinks + +cChangedLink = 0x20 :: Int +llcChangedLink = IVal cChangedLink +(cChangedInventory,llcChangedInventory) = mkIConst 0x1 +(cChnagedAllowedDrop,llcChangedAllowedDrop) = mkIConst 0x40 + +(cMaskBase,llcMaskBase) = mkIConst 0 +(cMaskOwner,llcMaskOwner) = mkIConst 1 +(cMaskGroup,llcMaskGroup) = mkIConst 2 +(cMaskEveryone,llcMaskEveryone) = mkIConst 3 +(cMaskNext,llcMaskNext) = mkIConst 4 + +(cPermModify,llcPermModify) = mkIConst 0x00004000 +(cPermCopy,llcPermCopy) = mkIConst 0x00008000 +(cPermTransfer,llcPermTransfer) = mkIConst 0x00002000 +(cPermMove,llcPermMove) = mkIConst 0x00080000 +cFullPerm = cPermModify .|. cPermMove .|. cPermTransfer .|. cPermCopy + +(cPrimTypeBox,llcPrimTypeBox) = mkIConst 0 +(cPrimTypeCylinder,llcPrimTypeCylinder) = mkIConst 1 +(cPrimTypePrism,llcPrimTypePrism) = mkIConst 2 +(cPrimTypeRing,llcPrimTypeRing) = mkIConst 6 +(cPrimTypeSphere,llcPrimTypeSphere) = mkIConst 3 +(cPrimTypeSculpt,llcPrimTypeSculpt) = mkIConst 7 +(cPrimTypeTorus,llcPrimTypeTorus) = mkIConst 4 +(cPrimTypeTube,llcPrimTypeTube) = mkIConst 5 + +validAttachmentPoints = [0..36]::[Int] + +cDebugChannel = 2147483647 :: Int +llcDebugChannel = IVal cDebugChannel + +cEOF = "\n\n\n" +llcEOF = (SVal cEOF) + +cPermissionControlCamera = 0x800 :: Int +llcPermissionControlCamera = IVal cPermissionControlCamera +(cPermissionTrackCamera,llcPermissionTrackCamera) = mkIConst 0x400 +(cPermissionTriggerAnimation,llcPermissionTriggerAnimation) = mkIConst 0x10 +(cPermissionDebit,llcPermissionDebit) = mkIConst 0x2 +(cPermissionAttach,llcPermissionAttach) = mkIConst 0x20 +(cPermissionTakeControls,llcPermissionTakeControls) = mkIConst 0x4 + +(cActive,llcActive) = mkIConst 0x2 +(cAgent,llcAgent) = mkIConst 0x1 +(cPassive,llcPassive) = mkIConst 0x4 +(cScripted,llcScripted) = mkIConst 0x8 + + +(cStatusPhysics,llcStatusPhysics) = mkIConst 1 +(cStatusRotateX,llcStatusRotateX) = mkIConst 2 +(cStatusRotateY,llcStatusRotateY) = mkIConst 4 +(cStatusRotateZ,llcStatusRotateZ) = mkIConst 8 +(cStatusPhantom,llcStatusPhantom) = mkIConst 16 +(cStatusSandbox,llcStatusSandbox) = mkIConst 32 +(cStatusBlockGrab,llcStatusBlockGrab) = mkIConst 64 +(cStatusDieAtEdge,llcStatusDieAtEdge) = mkIConst 128 +(cStatusReturnAtEdge,llcStatusReturnAtEdge) = mkIConst 256 +(cStatusCastShadows,llcStatusCastShadows) = mkIConst 512 + +(cPrimBumpShiny,llcPrimBumpShiny) = mkIConst 19 +(cPrimColor,llcPrimColor) = mkIConst 18 +(cPrimTexture,llcPrimTexture) = mkIConst 17 +(cPrimTexgen,llcPrimTexgen) = mkIConst 22 +(cPrimFullbright,llcPrimFullbright) = mkIConst 20 + +(cPrimMaterial,llcPrimMaterial) = mkIConst 2 +(cPrimPhantom,llcPrimPhantom) = mkIConst 5 +(cPrimPhysics,llcPrimPhysics) = mkIConst 3 +(cPrimFlexible,llcPrimFlexible) = mkIConst 21 +(cPrimPointLight,llcPrimPointLight) = mkIConst 23 +(cPrimPosition,llcPrimPosition) = mkIConst 6 +(cPrimRotation,llcPrimRotation) = mkIConst 8 +(cPrimSize,llcPrimSize) = mkIConst 7 +(cPrimTempOnRez,llcPrimTempOnRez) = mkIConst 4 +(cPrimType,llcPrimType) = mkIConst 9 + +(cParcelDetailsName,llcParcelDetailsName) = mkIConst 0 +(cParcelDetailsDesc,llcParcelDetailsDesc) = mkIConst 1 +(cParcelDetailsOwner,llcParcelDetailsOwner) = mkIConst 2 +(cParcelDetailsGroup,llcParcelDetailsGroup) = mkIConst 3 +(cParcelDetailsArea,llcParcelDetailsArea) = mkIConst 4 + +(cClickActionNone,llcClickActionNone) = mkIConst 0 +(cClickActionTouch,llcClickActionTouch) = mkIConst 0 +(cClickActionSit,llcClickActionSit) = mkIConst 1 +(cClickActionBuy,llcClickActionBuy) = mkIConst 2 +(cClickActionPay,llcClickActionPay) = mkIConst 3 +(cClickActionOpen,llcClickActionOpen) = mkIConst 4 +(cClickActionPlay,llcClickActionPlay) = mkIConst 5 +(cClickActionOpenMedia,llcClickActionOpenMedia) = mkIConst 6 +cClickActions = [cClickActionTouch,cClickActionSit,cClickActionBuy,cClickActionPay,cClickActionOpen,cClickActionPlay,cClickActionOpenMedia] + +(cDataBorn,llcDataBorn) = mkIConst 3 +(cDataName,llcDataName) = mkIConst 2 +(cDataOnline,llcDataOnline) = mkIConst 1 +(cDataPayinfo,llcDataPayinfo) = mkIConst 8 +(cDataRating,llcDataRating) = mkIConst 4 +(cDataSimPos,llcDataSimPos) = mkIConst 5 +(cDataSimRating,llcDataSimRating) = mkIConst 7 +(cDataSimStatus,llcDataSimStatus) = mkIConst 6 + +(cHTTPBodyMaxlength,llcHTTPBodyMaxlength) = mkIConst 2 +(cHTTPBodyTruncated,llcHTTPBodyTruncated) = mkIConst 0 +(cHTTPMethod,llcHTTPMethod) = mkIConst 0 +(cHTTPMimetype,llcHTTPMimetype) = mkIConst 1 +(cHTTPVerifyCert,llcHTTPVerifyCert) = mkIConst 3 + +(cRemoteDataChannel,llcRemoteDataChannel) = mkIConst 1 +(cRemoteDataRequest,llcRemoteDataRequest) = mkIConst 2 +(cRemoteDataReply,llcRemoteDataReply) = mkIConst 3 + +llcZeroVector = VVal 0 0 0 +llcZeroRotation = RVal 0 0 0 1 + +mkIConst :: Int -> (Int,LSLValue) +mkIConst i = (i,IVal i) + +allConstants :: [Constant] +allConstants = [ + Constant "ACTIVE" llcActive, + Constant "AGENT" llcAgent, + Constant "AGENT_ALWAYS_RUN" (IVal 0x1000), + Constant "AGENT_ATTACHMENTS" (IVal 0x2), + Constant "AGENT_AWAY" (IVal 0x40), + Constant "AGENT_BUSY" (IVal 0x800), + Constant "AGENT_CROUCHING" (IVal 0x400), + Constant "AGENT_FLYING" (IVal 0x1), + Constant "AGENT_IN_AIR" (IVal 0x100), + Constant "AGENT_MOUSELOOK" (IVal 0x8), + Constant "AGENT_ON_OBJECT" (IVal 0x20), + Constant "AGENT_SCRIPTED" (IVal 0x4), + Constant "AGENT_SITTING" (IVal 0x10), + Constant "AGENT_TYPING" (IVal 0x200), + Constant "AGENT_WALKING" (IVal 0x80), + Constant "ALL_SIDES" (IVal (-1)), + Constant "ANIM_ON" (IVal 0x1), + Constant "ATTACH_BACK" (IVal 9), + Constant "ATTACH_BELLY" (IVal 28), + Constant "ATTACH_CHEST" (IVal 1), + Constant "ATTACH_CHIN" (IVal 12), + Constant "ATTACH_HEAD" (IVal 2), + Constant "ATTACH_HUD_BOTTOM" (IVal 37), + Constant "ATTACH_HUD_BOTTOM_LEFT" (IVal 36), + Constant "ATTACH_HUD_BOTTOM_RIGHT" (IVal 38), + Constant "ATTACH_HUD_CENTER_1" (IVal 35), + Constant "ATTACH_HUD_CENTER_2" (IVal 31), + Constant "ATTACH_HUD_TOP_CENTER" (IVal 33), + Constant "ATTACH_HUD_TOP_LEFT" (IVal 34), + Constant "ATTACH_HUD_TOP_RIGHT" (IVal 32), + Constant "ATTACH_LEAR" (IVal 13), + Constant "ATTACH_LEYE" (IVal 15), + Constant "ATTACH_LFOOT" (IVal 7), + Constant "ATTACH_LHAND" (IVal 5), + Constant "ATTACH_LHIP" (IVal 25), + Constant "ATTACH_LLARM" (IVal 21), + Constant "ATTACH_LLLEG" (IVal 27), + Constant "ATTACH_LPEC" (IVal 30), + Constant "ATTACH_LSHOULDER" (IVal 3), + Constant "ATTACH_LUARM" (IVal 20), + Constant "ATTACH_LULEG" (IVal 26), + Constant "ATTACH_MOUTH" (IVal 11), + Constant "ATTACH_NOSE" (IVal 17), + Constant "ATTACH_PELVIS" (IVal 10), + Constant "ATTACH_REAR" (IVal 14), + Constant "ATTACH_REYE" (IVal 16), + Constant "ATTACH_RFOOT" (IVal 8), + Constant "ATTACH_RHAND" (IVal 6), + Constant "ATTACH_RHIP" (IVal 22), + Constant "ATTACH_RLARM" (IVal 19), + Constant "ATTACH_RLLEG" (IVal 24), + Constant "ATTACH_RPEC" (IVal 29), + Constant "ATTACH_RSHOULDER" (IVal 4), + Constant "ATTACH_RUARM" (IVal 18), + Constant "ATTACH_RULEG" (IVal 23), + Constant "CAMERA_ACTIVE" (IVal 12), + Constant "CAMERA_BEHINDNESS_ANGLE" (IVal 8), + Constant "CAMERA_BEHINDNESS_LAG" (IVal 9), + Constant "CAMERA_DISTANCE" (IVal 7), + Constant "CAMERA_FOCUS" (IVal 17), + Constant "CAMERA_FOCUS_LAG" (IVal 6), + Constant "CAMERA_FOCUS_LOCKED" (IVal 22), + Constant "CAMERA_FOCUS_OFFSET" (IVal 1), + Constant "CAMERA_FOCUS_THRESHOLD" (IVal 11), + Constant "CAMERA_PITCH" (IVal 0), + Constant "CAMERA_POSITION" (IVal 13), + Constant "CAMERA_POSITION_LAG" (IVal 5), + Constant "CAMERA_POSITION_LOCKED" (IVal 21), + Constant "CAMERA_POSITION_THRESHOLD" (IVal 10), + Constant "CHANGED_ALLOWED_DROP" llcChangedAllowedDrop, + Constant "CHANGED_COLOR" (IVal 0x2), + Constant "CHANGED_INVENTORY" llcChangedInventory, + Constant "CHANGED_LINK" llcChangedLink, + Constant "CHANGED_OWNER" (IVal 0x80), + Constant "CHANGED_REGION" (IVal 0x100), + Constant "CHANGED_SCALE" (IVal 0x8), + Constant "CHANGED_SHAPE" (IVal 0x4), + Constant "CHANGED_TELEPORT" (IVal 0x200), + Constant "CHANGED_TEXTURE" (IVal 0x10), + Constant "CLICK_ACTION_NONE" llcClickActionNone, + Constant "CLICK_ACTION_TOUCH" llcClickActionTouch, + Constant "CLICK_ACTION_SIT" llcClickActionSit, + Constant "CLICK_ACTION_BUY" llcClickActionBuy, + Constant "CLICK_ACTION_PAY" llcClickActionPay, + Constant "CLICK_ACTION_OPEN" llcClickActionOpen, + Constant "CLICK_ACTION_PLAY" llcClickActionPlay, + Constant "CLICK_ACTION_OPEN_MEDIA" llcClickActionOpenMedia, + Constant "CONTROL_BACK" (IVal 0x2), + Constant "CONTROL_DOWN" (IVal 0x20), + Constant "CONTROL_FWD" (IVal 0x1), + Constant "CONTROL_LBUTTON" (IVal 0x10000000), + Constant "CONTROL_LEFT" (IVal 0x4), + Constant "CONTROL_ML_LBUTTON" (IVal 0x40000000), + Constant "CONTROL_RIGHT" (IVal 0x8), + Constant "CONTROL_ROT_LEFT" (IVal 0x100), + Constant "CONTROL_ROT_RIGHT" (IVal 0x200), + Constant "CONTROL_UP" (IVal 0x10), + Constant "DATA_BORN" llcDataBorn, + Constant "DATA_NAME" llcDataName, + Constant "DATA_ONLINE" llcDataOnline, + Constant "DATA_PAYINFO" llcDataPayinfo, + Constant "DATA_RATING" llcDataRating, + Constant "DATA_SIM_POS" llcDataSimPos, + Constant "DATA_SIM_RATING" llcDataSimRating, + Constant "DATA_SIM_STATUS" llcDataSimStatus, + Constant "DEBUG_CHANNEL" llcDebugChannel, + Constant "DEG_TO_RAD" (FVal 0.01745329238), + Constant "EOF" llcEOF, + Constant "FALSE" (IVal 0), + Constant "HTTP_BODY_MAXLENGTH" llcHTTPBodyMaxlength, + Constant "HTTP_BODY_TRUNCATED" llcHTTPBodyTruncated, + Constant "HTTP_METHOD" llcHTTPMethod, + Constant "HTTP_MIMETYPE" llcHTTPMimetype, + Constant "HTTP_VERIFY_CERT" llcHTTPVerifyCert, + Constant "INVENTORY_ALL" llcInventoryAll, + Constant "INVENTORY_ANIMATION" llcInventoryAnimation, + Constant "INVENTORY_BODYPART" llcInventoryBodyPart, + Constant "INVENTORY_CLOTHING" llcInventoryClothing, + Constant "INVENTORY_GESTURE" llcInventoryGesture, + Constant "INVENTORY_LANDMARK" llcInventoryLandmark, + Constant "INVENTORY_NONE" llcInventoryNone, + Constant "INVENTORY_NOTECARD" llcInventoryNotecard, + Constant "INVENTORY_OBJECT" llcInventoryObject, + Constant "INVENTORY_SCRIPT" llcInventoryScript, + Constant "INVENTORY_SOUND" llcInventorySound, + Constant "INVENTORY_TEXTURE" llcInventoryTexture, + Constant "LAND_LARGE_BRUSH" (IVal 3), + Constant "LAND_LEVEL" (IVal 0), + Constant "LAND_LOWER" (IVal 2), + Constant "LAND_MEDIUM_BRUSH" (IVal 2), + Constant "LAND_NOISE" (IVal 4), + Constant "LAND_RAISE" (IVal 1), + Constant "LAND_REVERT" (IVal 5), + Constant "LAND_SMALL_BRUSH" (IVal 1), + Constant "LAND_SMOOTH" (IVal 3), + Constant "LINK_ALL_CHILDREN" (IVal (-3)), + Constant "LINK_ALL_OTHERS" (IVal (-2)), + Constant "LINK_ROOT" (IVal 1), + Constant "LINK_SET" (IVal (-1)), + Constant "LINK_THIS" (IVal (-4)), + Constant "LIST_STAT_GEOMETRIC_MEAN" (IVal 9), + Constant "LIST_STAT_MAX" (IVal 2), + Constant "LIST_STAT_MEAN" (IVal 3), + Constant "LIST_STAT_MEDIAN" (IVal 4), + Constant "LIST_STAT_MIN" (IVal 1), + Constant "LIST_STAT_NUM_COUNT" (IVal 8), + Constant "LIST_STAT_RANGE" (IVal 0), + Constant "LIST_STAT_STD_DEV" (IVal 5), + Constant "LIST_STAT_SUM" (IVal 6), + Constant "LIST_STAT_SUM_SQUARES" (IVal 7), + Constant "LOOP" (IVal 0x2), + Constant "MASK_BASE" llcMaskBase, + Constant "MASK_EVERYONE" llcMaskEveryone, + Constant "MASK_GROUP" llcMaskGroup, + Constant "MASK_NEXT" llcMaskNext, + Constant "MASK_OWNER" llcMaskOwner, + Constant "NULL_KEY" (SVal "00000000-0000-0000-0000-000000000000"), + Constant "OBJECT_CREATOR" (IVal 8), + Constant "OBJECT_DESC" (IVal 2), + Constant "OBJECT_NAME" (IVal 1), + Constant "OBJECT_OWNER" (IVal 6), + Constant "OBJECT_POS" (IVal 3), + Constant "OBJECT_ROT" (IVal 4), + Constant "OBJECT_VELOCITY" (IVal 5), + Constant "OBJECT_GROUP" (IVal 7), + Constant "OBJECT_UNKNOWN_DETAIL" (IVal (-1)), + Constant "PARCEL_COUNT_GROUP" (IVal 2), + Constant "PARCEL_COUNT_OTHER" (IVal 3), + Constant "PARCEL_COUNT_OWNER" (IVal 1), + Constant "PARCEL_COUNT_SELECTED" (IVal 4), + Constant "PARCEL_COUNT_TEMP" (IVal 5), + Constant "PARCEL_COUNT_TOTAL" (IVal 0), + Constant "PARCEL_DETAILS_AREA" llcParcelDetailsArea, + Constant "PARCEL_DETAILS_DESC" llcParcelDetailsDesc, + Constant "PARCEL_DETAILS_GROUP" llcParcelDetailsGroup, + Constant "PARCEL_DETAILS_NAME" llcParcelDetailsName, + Constant "PARCEL_DETAILS_OWNER" llcParcelDetailsOwner, + Constant "PARCEL_FLAG_ALLOW_ALL_OBJECT_ENTRY" (IVal (1 `shiftL` 27)), + Constant "PARCEL_FLAG_ALLOW_CREATE_GROUP_OBJECTS" (IVal (1 `shiftL` 26)), + Constant "PARCEL_FLAG_ALLOW_CREATE_OBJECTS" (IVal (1 `shiftL` 6)), + Constant "PARCEL_FLAG_ALLOW_DAMAGE" (IVal (1 `shiftL` 5)), + Constant "PARCEL_FLAG_ALLOW_FLY" (IVal 0), + Constant "PARCEL_FLAG_ALLOW_GROUP_OBJECT_ENTRY" (IVal (1 `shiftL` 28)), + Constant "PARCEL_FLAG_ALLOW_GROUP_SCRIPTS" (IVal (1 `shiftL` 25)), + Constant "PARCEL_FLAG_ALLOW_LANDMARK" (IVal (1 `shiftL` 3)), + Constant "PARCEL_FLAG_ALLOW_SCRIPTS" (IVal (1 `shiftL` 1)), + Constant "PARCEL_FLAG_ALLOW_TERRAFORM" (IVal (1 `shiftL` 4)), + Constant "PARCEL_FLAG_LOCAL_SOUND_ONLY" (IVal (1 `shiftL` 15)), + Constant "PARCEL_FLAG_RESTRICT_PUSHOBJECT" (IVal (1 `shiftL` 21)), + Constant "PARCEL_FLAG_USE_ACCESS_GROUP" (IVal (1 `shiftL` 8)), + Constant "PARCEL_FLAG_USE_ACCESS_LIST" (IVal (1 `shiftL` 9)), + Constant "PARCEL_FLAG_USE_BAN_LIST" (IVal (1 `shiftL` 10)), + Constant "PARCEL_FLAG_USE_LAND_PASS_LIST" (IVal (1 `shiftL` 11)), + Constant "PARCEL_MEDIA_COMMAND_AGENT" (IVal 7), + Constant "PARCEL_MEDIA_COMMAND_AUTO_ALIGN" (IVal 9), + Constant "PARCEL_MEDIA_COMMAND_DESC" (IVal 12), + Constant "PARCEL_MEDIA_COMMAND_LOOP" (IVal 3), + Constant "PARCEL_MEDIA_COMMAND_LOOP_SET" (IVal 13), + Constant "PARCEL_MEDIA_COMMAND_PAUSE" (IVal 1), + Constant "PARCEL_MEDIA_COMMAND_PLAY" (IVal 2), + Constant "PARCEL_MEDIA_COMMAND_SIZE" (IVal 11), + Constant "PARCEL_MEDIA_COMMAND_STOP" (IVal 0), + Constant "PARCEL_MEDIA_COMMAND_TEXTURE" (IVal 4), + Constant "PARCEL_MEDIA_COMMAND_TIME" (IVal 6), + Constant "PARCEL_MEDIA_COMMAND_TYPE" (IVal 10), + Constant "PARCEL_MEDIA_COMMAND_UNLOAD" (IVal 8), + Constant "PARCEL_MEDIA_COMMAND_URL" (IVal 5), + Constant "PASSIVE" llcPassive, + Constant "PAYMENT_INFO_ON_FILE" (IVal 1), + Constant "PAYMENT_INFO_USED" (IVal 2), + Constant "PAY_DEFAULT" (IVal (-2)), + Constant "PAY_HIDE" (IVal (-1)), + Constant "PERMISSION_ATTACH" llcPermissionAttach, + Constant "PERMISSION_CHANGE_JOINTS" (IVal 0x100), + Constant "PERMISSION_CHANGE_LINKS" llcPermissionChangeLinks, + Constant "PERMISSION_CHANGE_PERMISSIONS" (IVal 0x200), + Constant "PERMISSION_CONTROL_CAMERA" llcPermissionControlCamera, + Constant "PERMISSION_DEBIT" llcPermissionDebit, + Constant "PERMISSION_RELEASE_OWNERSHIP" (IVal 0x40), + Constant "PERMISSION_REMAP_CONTROLS" (IVal 0x8), + Constant "PERMISSION_TAKE_CONTROLS" llcPermissionTakeControls, + Constant "PERMISSION_TRACK_CAMERA" (IVal 0x400), + Constant "PERMISSION_TRIGGER_ANIMATION" llcPermissionTriggerAnimation, + Constant "PERM_ALL" (IVal 0x7FFFFFFF), + Constant "PERM_COPY" llcPermCopy, + Constant "PERM_MODIFY" llcPermModify, + Constant "PERM_MOVE" llcPermMove, + Constant "PERM_TRANSFER" llcPermTransfer, + Constant "PI" (FVal 3.14159274), + Constant "PING_PONG" (IVal 0x8), + Constant "PI_BY_TWO" (FVal 1.57079637), + Constant "PRIM_BUMP_BARK" (IVal 4), + Constant "PRIM_BUMP_BLOBS" (IVal 12), + Constant "PRIM_BUMP_BRICKS" (IVal 5), + Constant "PRIM_BUMP_BRIGHT" (IVal 1), + Constant "PRIM_BUMP_CHECKER" (IVal 6), + Constant "PRIM_BUMP_CONCRETE" (IVal 7), + Constant "PRIM_BUMP_DARK" (IVal 2), + Constant "PRIM_BUMP_DISKS" (IVal 10), + Constant "PRIM_BUMP_GRAVEL" (IVal 11), + Constant "PRIM_BUMP_LARGETILE" (IVal 14), + Constant "PRIM_BUMP_NONE" (IVal 0), + Constant "PRIM_BUMP_SHINY" llcPrimBumpShiny, + Constant "PRIM_BUMP_SIDING" (IVal 13), + Constant "PRIM_BUMP_STONE" (IVal 9), + Constant "PRIM_BUMP_STUCCO" (IVal 15), + Constant "PRIM_BUMP_SUCTION" (IVal 16), + Constant "PRIM_BUMP_TILE" (IVal 8), + Constant "PRIM_BUMP_WEAVE" (IVal 17), + Constant "PRIM_BUMP_WOOD" (IVal 3), + Constant "PRIM_CAST_SHADOWS" (IVal 24), + Constant "PRIM_COLOR" llcPrimColor, + Constant "PRIM_FLEXIBLE" llcPrimFlexible, + Constant "PRIM_FULLBRIGHT" llcPrimFullbright, + Constant "PRIM_HOLE_CIRCLE" (IVal 0x10), + Constant "PRIM_HOLE_DEFAULT" (IVal 0x0), + Constant "PRIM_HOLE_SQUARE" (IVal 0x20), + Constant "PRIM_HOLE_TRIANGLE" (IVal 0x30), + Constant "PRIM_MATERIAL" llcPrimMaterial, + Constant "PRIM_MATERIAL_FLESH" (IVal 4), + Constant "PRIM_MATERIAL_GLASS" (IVal 2), + Constant "PRIM_MATERIAL_LIGHT" (IVal 7), + Constant "PRIM_MATERIAL_METAL" (IVal 1), + Constant "PRIM_MATERIAL_PLASTIC" (IVal 5), + Constant "PRIM_MATERIAL_RUBBER" (IVal 6), + Constant "PRIM_MATERIAL_STONE" (IVal 0), + Constant "PRIM_MATERIAL_WOOD" (IVal 3), + Constant "PRIM_PHANTOM" llcPrimPhantom, + Constant "PRIM_PHYSICS" llcPrimPhysics, + Constant "PRIM_POINT_LIGHT" llcPrimPointLight, + Constant "PRIM_POSITION" llcPrimPosition, + Constant "PRIM_ROTATION" llcPrimRotation, + Constant "PRIM_SCULPT_TYPE_CYLINDER" (IVal 4), + Constant "PRIM_SCULPT_TYPE_PLANE" (IVal 3), + Constant "PRIM_SCULPT_TYPE_SPHERE" (IVal 1), + Constant "PRIM_SCULPT_TYPE_TORUS" (IVal 2), + Constant "PRIM_SHINY_HIGH" (IVal 3), + Constant "PRIM_SHINY_LOW" (IVal 1), + Constant "PRIM_SHINY_MEDIUM" (IVal 2), + Constant "PRIM_SHINY_NONE" (IVal 0), + Constant "PRIM_SIZE" llcPrimSize, + Constant "PRIM_TEMP_ON_REZ" llcPrimTempOnRez, + Constant "PRIM_TEXGEN" llcPrimTexgen, + Constant "PRIM_TEXGEN_DEFAULT" (IVal 0), + Constant "PRIM_TEXGEN_PLANAR" (IVal 1), + Constant "PRIM_TEXTURE" llcPrimTexture, + --Constant "PRIM_TYPE" (IVal 1), + Constant "PRIM_TYPE" llcPrimType, + Constant "PRIM_TYPE_BOX" llcPrimTypeBox, + Constant "PRIM_TYPE_CYLINDER" llcPrimTypeCylinder, + Constant "PRIM_TYPE_PRISM" llcPrimTypePrism, + Constant "PRIM_TYPE_RING" llcPrimTypeRing, + Constant "PRIM_TYPE_SPHERE" llcPrimTypeSphere, + Constant "PRIM_TYPE_SCULPT" llcPrimTypeSculpt, + Constant "PRIM_TYPE_TORUS" llcPrimTypeTorus, + Constant "PRIM_TYPE_TUBE" llcPrimTypeTube, + Constant "PSYS_PART_BOUNCE_MASK" (IVal 0x4), + Constant "PSYS_PART_EMISSIVE_MASK" (IVal 0x100), + Constant "PSYS_PART_END_ALPHA" (IVal 4), + Constant "PSYS_PART_END_COLOR" (IVal 3), + Constant "PSYS_PART_END_SCALE" (IVal 6), + Constant "PSYS_PART_FLAGS" (IVal 0), + Constant "PSYS_PART_FOLLOW_SRC_MASK" (IVal 0x10), + Constant "PSYS_PART_FOLLOW_VELOCITY_MASK" (IVal 0x20), + Constant "PSYS_PART_INTERP_COLOR_MASK" (IVal 0x1), + Constant "PSYS_PART_INTERP_SCALE_MASK" (IVal 0x2), + Constant "PSYS_PART_MAX_AGE" (IVal 7), + Constant "PSYS_PART_START_ALPHA" (IVal 2), + Constant "PSYS_PART_START_COLOR" (IVal 1), + Constant "PSYS_PART_START_SCALE" (IVal 5), + Constant "PSYS_PART_TARGET_LINEAR_MASK" (IVal 0x80), + Constant "PSYS_PART_TARGET_POS_MASK" (IVal 0x40), + Constant "PSYS_PART_WIND_MASK" (IVal 0x8), + Constant "PSYS_SRC_ACCEL" (IVal 8), + Constant "PSYS_SRC_ANGLE_BEGIN" (IVal 22), + Constant "PSYS_SRC_ANGLE_END" (IVal 23), + Constant "PSYS_SRC_BURST_PART_COUNT" (IVal 15), + Constant "PSYS_SRC_BURST_RADIUS" (IVal 16), + Constant "PSYS_SRC_BURST_RATE" (IVal 13), + Constant "PSYS_SRC_BURST_SPEED_MAX" (IVal 18), + Constant "PSYS_SRC_BURST_SPEED_MIN" (IVal 17), + Constant "PSYS_SRC_INNERANGLE" (IVal 10), + Constant "PSYS_SRC_MAX_AGE" (IVal 19), + Constant "PSYS_SRC_OBJ_REL_MASK" (IVal 1), + Constant "PSYS_SRC_OMEGA" (IVal 21), + Constant "PSYS_SRC_OUTERANGLE" (IVal 11), + Constant "PSYS_SRC_PATTERN" (IVal 9), + Constant "PSYS_SRC_PATTERN_ANGLE" (IVal 0x4), + Constant "PSYS_SRC_PATTERN_ANGLE_CONE" (IVal 0x8), + Constant "PSYS_SRC_PATTERN_ANGLE_CONE_EMPTY" (IVal 0x10), + Constant "PSYS_SRC_PATTERN_DROP" (IVal 0x1), + Constant "PSYS_SRC_PATTERN_EXPLODE" (IVal 0x2), + Constant "PSYS_SRC_TARGET_KEY" (IVal 20), + Constant "PSYS_SRC_TEXTURE" (IVal 12), + Constant "PUBLIC_CHANNEL" (IVal 0), + Constant "RAD_TO_DEG" (FVal 57.29578), + Constant "REGION_FLAG_ALLOW_DAMAGE" (IVal 0), + Constant "REGION_FLAG_ALLOW_DIRECT_TELEPORT" (IVal (1 `shiftL` 20)), + Constant "REGION_FLAG_BLOCK_FLY" (IVal (1 `shiftL` 19)), + Constant "REGION_FLAG_BLOCK_TERRAFORM" (IVal (1 `shiftL` 6)), + Constant "REGION_FLAG_DISABLE_COLLISIONS" (IVal (1 `shiftL` 12)), + Constant "REGION_FLAG_DISABLE_PHYSICS" (IVal (1 `shiftL` 14)), + Constant "REGION_FLAG_FIXED_SUN" (IVal (1 `shiftL` 4)), + Constant "REGION_FLAG_RESTRICT_PUSHOBJECT" (IVal (1 `shiftL` 22)), + Constant "REGION_FLAG_SANDBOX" (IVal (1 `shiftL` 8)), + Constant "REMOTE_DATA_CHANNEL" llcRemoteDataChannel, + Constant "REMOTE_DATA_REPLY" llcRemoteDataReply, + Constant "REMOTE_DATA_REQUEST" llcRemoteDataRequest, + Constant "REVERSE" (IVal 0x4), + Constant "ROTATE" (IVal 0x20), + Constant "SCALE" (IVal 0x40), + Constant "SCRIPTED" llcScripted, + Constant "SMOOTH" (IVal 0x10), + Constant "SQRT2" (FVal 1.414213538), + Constant "STATUS_BLOCK_GRAB" (IVal 0x40), + Constant "STATUS_CAST_SHADOWS" (IVal 0x200), + Constant "STATUS_DIE_AT_EDGE" (IVal 0x80), + Constant "STATUS_PHANTOM" (IVal 0x10), + Constant "STATUS_PHYSICS" (IVal 0x1), + Constant "STATUS_RETURN_AT_EDGE" (IVal 0x100), + Constant "STATUS_ROTATE_X" (IVal 0x2), + Constant "STATUS_ROTATE_Y" (IVal 0x4), + Constant "STATUS_ROTATE_Z" (IVal 0x8), + Constant "STATUS_SANDBOX" (IVal 0x20), + Constant "STRING_TRIM" (IVal 0x03), + Constant "STRING_TRIM_HEAD" (IVal 0x01), + Constant "STRING_TRIM_TAIL" (IVal 0x02), + Constant "TEXTURE_BLANK" (KVal "5748decc-f629-461c-9a36-a35a221fe21f"), + Constant "TEXTURE_DEFAULT" (KVal "8b5fec65-8d8d-9dc5-cda8-8fdf2716e361"), + Constant "TEXTURE_PLYWOOD" (KVal "89556747-24cb-43ed-920b-47caed15465f"), + Constant "TEXTURE_TRANSPARENT" (KVal "59facb66-4a72-40a2-815c-7d9b42c56f60"), + Constant "TRUE" (IVal 1), + Constant "TWO_PI" (FVal 6.28318548), + Constant "TYPE_FLOAT" (IVal 2), + Constant "TYPE_INTEGER" (IVal 1), + Constant "TYPE_INVALID" (IVal 0), + Constant "TYPE_KEY" (IVal 4), + Constant "TYPE_ROTATION" (IVal 6), + Constant "TYPE_STRING" (IVal 3), + Constant "TYPE_VECTOR" (IVal 5), + Constant "VEHICLE_ANGULAR_DEFLECTION_EFFICIENCY" (IVal 32), + Constant "VEHICLE_ANGULAR_DEFLECTION_TIMESCALE" (IVal 33), + Constant "VEHICLE_ANGULAR_FRICTION_TIMESCALE" (IVal 17), + Constant "VEHICLE_ANGULAR_MOTOR_DECAY_TIMESCALE" (IVal 35), + Constant "VEHICLE_ANGULAR_MOTOR_DIRECTION" (IVal 19), + Constant "VEHICLE_ANGULAR_MOTOR_TIMESCALE" (IVal 34), + Constant "VEHICLE_BANKING_EFFICIENCY" (IVal 38), + Constant "VEHICLE_BANKING_MIX" (IVal 39), + Constant "VEHICLE_BANKING_TIMESCALE" (IVal 40), + Constant "VEHICLE_BUOYANCY" (IVal 27), + Constant "VEHICLE_FLAG_CAMERA_DECOUPLED" (IVal 0x200), + Constant "VEHICLE_FLAG_HOVER_GLOBAL_HEIGHT" (IVal 0x10), + Constant "VEHICLE_FLAG_HOVER_TERRAIN_ONLY" (IVal 0x8), + Constant "VEHICLE_FLAG_HOVER_UP_ONLY" (IVal 0x20), + Constant "VEHICLE_FLAG_HOVER_WATER_ONLY" (IVal 0x4), + Constant "VEHICLE_FLAG_LIMIT_MOTOR_UP" (IVal 0x40), + Constant "VEHICLE_FLAG_LIMIT_ROLL_ONLY" (IVal 0x2), + Constant "VEHICLE_FLAG_MOUSELOOK_BANK" (IVal 0x100), + Constant "VEHICLE_FLAG_MOUSELOOK_STEER" (IVal 0x80), + Constant "VEHICLE_FLAG_NO_DEFLECTION_UP" (IVal 0x1), + Constant "VEHICLE_FLAG_NO_FLY_UP" (IVal 0x1), + Constant "VEHICLE_HOVER_EFFICIENCY" (IVal 25), + Constant "VEHICLE_HOVER_HEIGHT" (IVal 24), + Constant "VEHICLE_HOVER_TIMESCALE" (IVal 26), + Constant "VEHICLE_LINEAR_DEFLECTION_EFFICIENCY" (IVal 28), + Constant "VEHICLE_LINEAR_DEFLECTION_TIMESCALE" (IVal 29), + Constant "VEHICLE_LINEAR_FRICTION_TIMESCALE" (IVal 16), + Constant "VEHICLE_LINEAR_MOTOR_DECAY_TIMESCALE" (IVal 31), + Constant "VEHICLE_LINEAR_MOTOR_DIRECTION" (IVal 18), + Constant "VEHICLE_LINEAR_MOTOR_OFFSET" (IVal 20), + Constant "VEHICLE_LINEAR_MOTOR_TIMESCALE" (IVal 30), + Constant "VEHICLE_REFERENCE_FRAME" (IVal 44), + Constant "VEHICLE_TYPE_AIRPLANE" (IVal 4), + Constant "VEHICLE_TYPE_BALLOON" (IVal 5), + Constant "VEHICLE_TYPE_BOAT" (IVal 3), + Constant "VEHICLE_TYPE_CAR" (IVal 2), + Constant "VEHICLE_TYPE_NONE" (IVal 0), + Constant "VEHICLE_TYPE_SLED" (IVal 1), + Constant "VEHICLE_VERTICAL_ATTRACTION_EFFICIENCY" (IVal 36), + Constant "VEHICLE_VERTICAL_ATTRACTION_TIMESCALE" (IVal 37), + Constant "ZERO_ROTATION" llcZeroRotation, + Constant "ZERO_VECTOR" llcZeroVector + ] + +findConstant s = findM (\ c -> s == constName c) allConstants +findConstVal s = fmap constVal $ findConstant s +findConstType s = fmap typeOfLSLValue $ findConstVal s +isConstant s = + case findConstant s of + Nothing -> False + _ -> True diff --git a/Language/Lsl/Internal/DOMProcessing.hs b/Language/Lsl/Internal/DOMProcessing.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/DOMProcessing.hs @@ -0,0 +1,132 @@ +module Language.Lsl.Internal.DOMProcessing(ElemAcceptor(..), + findElement, + findOptionalElement, + findOrDefault, + findSimple, + findSimpleOrDefault, + findValueOrDefault, + findValue, + valueAcceptor, -- String -> ElemAcceptor m t + ctxelem, + simple, + simpleElement, + matchChoice, + matchMaybe, + cmatch, + match, + attValueString, + acceptList, -- + elementList, + elementListWith, + elementsOnly, + attrString, + Content(..), + Document(..), + Element(..), + xmlParse, + --module Text.XML.HaXml, + --module Text.XML.HaXml.Posn + ) where + +import Control.Monad(MonadPlus(..),liftM2) +import Control.Monad.Error(MonadError(..)) +import Language.Lsl.Internal.Util(readM) +import Text.XML.HaXml(AttValue(..),Document(..),Element(..),Content(..),Reference(..),xmlParse) +import Text.XML.HaXml.Posn(Posn(..)) + +data Monad m => ElemAcceptor m t = ElemAcceptor { acceptorTag :: String, acceptorFunc :: (Element Posn -> m t) } + +findElement (ElemAcceptor tag acceptor) list = + let find' _ [] = throwError ("element not found: " ++ tag) + find' bs (ce@(CElem (Elem nm _ _) _):cs) | nm == tag = + do val <- ctxelem acceptor ce + return (val, reverse bs ++ cs) + | otherwise = find' (ce:bs) cs + in find' [] list + +findOptionalElement (ElemAcceptor tag acceptor) list = + let find' bs [] = return (Nothing,bs) + find' bs (ce@(CElem (Elem nm _ _) _):cs) | nm == tag = + do val <- ctxelem acceptor ce + return (Just val, reverse bs ++ cs) + | otherwise = find' (ce:bs) cs + in find' [] list + +findOrDefault def acceptor list = + do (v,rest) <- findOptionalElement acceptor list + return $ case v of Nothing -> (def, rest); Just v' -> (v',rest) + +findSimpleOrDefault def tag = findOrDefault def (simpleElement tag) + +ctxelem f (CElem e i) = catchError (f e) handler + where handler s = throwError ("at " ++ (show i) ++ ": " ++ s) + +cmatch acceptor (CElem e@(Elem n _ _) i) = catchError (match acceptor e) handler + where handler s = throwError ("at " ++ (show i) ++ ": " ++ s) + +match acceptor e@(Elem n _ _) | n /= acceptorTag acceptor = throwError ("unexpected element " ++ n ++ " (expected " ++ acceptorTag acceptor ++ ")") + | otherwise = acceptorFunc acceptor e + +simple (Elem _ _ []) = return "" +simple (Elem _ _ contents) = return (processContents contents) + +simpleElement s = ElemAcceptor s simple + +findSimple s = findElement (simpleElement s) + +processContents = concatMap processContentItem +processContentItem (CElem (Elem name _ _) _) = error ("unexpected content element (" ++ name ++ ")") +processContentItem (CString _ s _) = s +processContentItem (CRef (RefEntity "lt") _) = "<" +processContentItem (CRef (RefEntity "gt") _) = ">" +processContentItem (CRef (RefEntity "amp") _) = "&" +processContentItem (CRef (RefEntity "quot") _) = "\"" +processContentItem (CRef (RefEntity "apos") _) = "'" +processContentItem (CMisc _ _) = error "unexpected content" + +matchChoice acceptors (CElem e@(Elem name _ _) i) = + do result <- foldl (liftM2 mplus) (return Nothing) $ map (matchMaybe e) acceptors + case result of + Nothing -> throwError ("at " ++ show i ++ ": unexpected element " ++ name) + Just val -> return val + +matchMaybe e@(Elem n a c) (ElemAcceptor name f) | n /= name = return Nothing + | otherwise = f e >>= return . Just + +attValueString (AttValue list) = concat [ s | Left s <- list ] + +acceptList itemAcceptor (Elem _ _ contents) = mapM (cmatch itemAcceptor) (elementsOnly contents) + +elementList name itemAcceptor = ElemAcceptor name (acceptList itemAcceptor) + +acceptListWith f (Elem _ _ contents) = mapM f (elementsOnly contents) +elementListWith name f = ElemAcceptor name (acceptListWith f) + +elementsOnly cs = [ e | e@(CElem _ _) <- cs] + +acceptValue e = do + s <- simple e + value <- readM s + return value + +valueAcceptor s = ElemAcceptor s acceptValue + +findValue name contents = + do (sval,rest) <- findSimple name contents + value <- readM sval + return (value,rest) + +findValueOrDefault def name contents = + do (sval,rest) <- findOptionalElement (simpleElement name) contents + case sval of + Nothing -> return (def, contents) + Just s -> do + value <- readM s + return (value, contents) + +-- for backwards compatibility +attrString (AttValue v) = concatMap decode v + where + decode (Left v) = v + decode (Right (RefEntity ent)) = "&"++ent++";" + decode (Right (RefChar cref)) = "&"++show cref++";" diff --git a/Language/Lsl/Internal/DOMSourceDescriptor.hs b/Language/Lsl/Internal/DOMSourceDescriptor.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/DOMSourceDescriptor.hs @@ -0,0 +1,34 @@ +{-# OPTIONS_GHC -XFlexibleContexts #-} +module Language.Lsl.Internal.DOMSourceDescriptor(sourceFiles,sourceFilesElement) where + +import Control.Monad.Error(MonadError(..)) +import Language.Lsl.Internal.DOMProcessing(ElemAcceptor(..),elementList,findElement,match,simple) +import Text.XML.HaXml(Element(..),Content(..)) + +sourceFiles e = match sourceFilesElement e + +sourceFilesElement :: MonadError String m => ElemAcceptor m ([(String,String)],[(String,String)]) +sourceFilesElement = + let f (Elem _ _ contents) = do + (m,contents1) <- findElement modulesElement [ e | e@(CElem _ _) <- contents ] + (s,[]) <- findElement scriptsElement contents1 + return (m,s) + in ElemAcceptor "source_files" f + +modulesElement :: MonadError String m => ElemAcceptor m [(String,String)] +modulesElement = elementList "modules" itemElement +scriptsElement :: MonadError String m => ElemAcceptor m [(String,String)] +scriptsElement = elementList "scripts" itemElement + +itemElement :: MonadError String m => ElemAcceptor m (String,String) +itemElement = + let f (Elem _ _ contents) = do + (id,contents1) <- findElement idElement [ e | e@(CElem _ _) <- contents ] + (p,[]) <- findElement pathElement contents1 + return (id,p) + in ElemAcceptor "item" f + +idElement :: MonadError String m => ElemAcceptor m String +idElement = ElemAcceptor "identifier" simple +pathElement :: MonadError String m => ElemAcceptor m String +pathElement = ElemAcceptor "path" simple diff --git a/Language/Lsl/Internal/DOMUnitTestDescriptor.hs b/Language/Lsl/Internal/DOMUnitTestDescriptor.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/DOMUnitTestDescriptor.hs @@ -0,0 +1,201 @@ +{-# OPTIONS_GHC -XFlexibleContexts #-} +module Language.Lsl.Internal.DOMUnitTestDescriptor(testsElement) where + +import Control.Monad.Error(MonadError(..)) +import Data.List(find,isSuffixOf) +import Language.Lsl.Internal.DOMProcessing(ElemAcceptor(..),Element(..), + attValueString,elementList,elementsOnly,findElement,findOptionalElement,matchChoice,simple) +import Language.Lsl.Internal.ExpressionHandler(evaluateExpression) +import Language.Lsl.Internal.Type(LSLType(..),LSLValue(..)) +import Language.Lsl.UnitTest(LSLUnitTest(..),EntryPoint(..),FuncCallExpectations(..),ExpectationMode(..)) + +--trace1 v = trace (show v) v + +testsElement :: MonadError String m => ElemAcceptor m [LSLUnitTest] +testsElement = elementList "tests" testElement + +testElement :: MonadError String m => ElemAcceptor m LSLUnitTest +testElement = + let f (Elem _ _ contents) = + do (nm,contents1) <- findElement nameElement (elementsOnly contents) + (ep,contents2) <- findElement entryPointElement contents1 + (args,contents3) <- findElement argumentsElement contents2 + (callExpectations, contents4) <- findElement expectationsElement contents3 + (er,contents5) <- findElement expectedReturnElement contents4 + (gb,contents6) <- findElement initialBindingsElement contents5 + (fb,[]) <- findElement finalBindingsElement contents6 + return $ LSLUnitTest { + unitTestName = nm, + entryPoint = ep, + initialGlobs = gb, + arguments = args, + expectedCalls = callExpectations, + expectedReturn = er, + expectedGlobalVals = fb, + expectedNewState = Nothing + } + in ElemAcceptor "lsl-test" f + +nameElement :: MonadError String m => ElemAcceptor m String +nameElement = ElemAcceptor "name" simple + +entryPointElement :: MonadError String m => ElemAcceptor m EntryPoint +entryPointElement = + let f (Elem _ _ contents) = + do (fn,contents1) <- findElement fileNameElement (elementsOnly contents) + (p,[]) <- findElement pathElement contents1 + if "lslm" `isSuffixOf` fn then return (ModuleFunc fn p) + else case parts p of + [a,b] -> return $ ScriptHandler fn a b + [a] -> return $ ScriptFunc fn a + _ -> fail "invalid function/handler path" + in ElemAcceptor "entryPoint" f + +fileNameElement :: MonadError String m => ElemAcceptor m String +fileNameElement = ElemAcceptor "fileName" simple +pathElement :: MonadError String m => ElemAcceptor m String +pathElement = ElemAcceptor "path" simple + +argumentsElement :: MonadError String m => ElemAcceptor m [LSLValue] +argumentsElement = + let f (Elem _ _ contents) = + mapM (matchChoice [lslString, lslInteger, lslFloat, lslVector, lslRotation, lslKey, lslList1]) (elementsOnly contents) + in ElemAcceptor "arguments" f + +lslString :: MonadError String m => ElemAcceptor m LSLValue +lslString = ElemAcceptor "lsl-string" (\ e -> do + s <- simple e + case evaluateExpression LLString s of + Just k -> return k + Nothing -> fail "invalid content for lsl-string") +lslKey :: MonadError String m => ElemAcceptor m LSLValue +lslKey = ElemAcceptor "lsl-key" (\ e -> do + s <- simple e + case evaluateExpression LLKey s of + Just k -> return k + Nothing -> fail "invalid content for lsl-key") +lslInteger :: MonadError String m => ElemAcceptor m LSLValue +lslInteger = ElemAcceptor "lsl-integer" (\ e -> do + s <- simple e + case evaluateExpression LLInteger s of + Just f -> return f + Nothing -> fail "invalid content for lsl-integer") +lslFloat :: MonadError String m => ElemAcceptor m LSLValue +lslFloat = ElemAcceptor "lsl-float" (\ e -> do + s <- simple e + case evaluateExpression LLFloat s of + Just f -> return f + Nothing -> fail "invalid content for lsl-float") + +lslVector :: MonadError String m => ElemAcceptor m LSLValue +lslVector = ElemAcceptor "lsl-vector" (\ e -> do + s <- simple e + case evaluateExpression LLVector s of + Just f -> return f + Nothing -> fail "invalid content for lsl-vector") +lslRotation :: MonadError String m => ElemAcceptor m LSLValue +lslRotation = ElemAcceptor "lsl-rotation" (\ e -> do + s <- simple e + case evaluateExpression LLRot s of + Just f -> return f + Nothing -> fail "invalid content for lsl-rotation") + +lslList :: MonadError String m => ElemAcceptor m LSLValue +lslList = + let f (Elem _ _ contents) = + do list <- mapM (matchChoice [lslString,lslInteger,lslKey,lslVector,lslRotation,lslFloat]) (elementsOnly contents) + return (LVal list) + in ElemAcceptor "lsl-list" f + +lslList1 :: MonadError String m => ElemAcceptor m LSLValue +lslList1 =ElemAcceptor "lsl-list1" (\ e -> do + s <- simple e + case evaluateExpression LLList s of + Just f -> return f + Nothing -> fail "invalid content for lsl-list1") + + +lslVoid :: MonadError String m => ElemAcceptor m LSLValue +lslVoid = + let f (Elem _ _ []) = return VoidVal + f (Elem name _ _) = fail ("unexpected content in " ++ name ++ " tag.") + in ElemAcceptor "lsl-void" f + + +expectedReturnElement :: MonadError String m => ElemAcceptor m (Maybe LSLValue) +expectedReturnElement = maybeSomeVal "expectedReturn" + +expectationsElement :: MonadError String m => ElemAcceptor m FuncCallExpectations +expectationsElement = + let f (Elem _ _ contents) = do + (modeString,contents1) <- findElement modeElement (elementsOnly contents) + mode <- case modeString of + "nice" -> return Nice + "exhaust" -> return Exhaust + "strict" -> return Strict + "normal" -> return Normal + s -> fail ("illegal mode " ++ s) + (calls,[]) <- findElement callsElement contents1 + return $ FuncCallExpectations { + expectationMode = mode, + callList = filter (not . null . fst . fst) calls + } + in ElemAcceptor "expectations" f + +modeElement :: MonadError String m => ElemAcceptor m String +modeElement = ElemAcceptor "mode" simple + +callsElement :: MonadError String m => ElemAcceptor m [((String, [Maybe LSLValue]),LSLValue)] +callsElement = elementList "calls" callElement + +callElement :: MonadError String m => ElemAcceptor m ((String, [Maybe LSLValue]),LSLValue) +callElement = + let f (Elem _ _ contents) = do + (name,contents1) <- findElement (ElemAcceptor "name" simple) (elementsOnly contents) + (args,contents2) <- findElement callArgsElement contents1 + (retval, []) <- findElement returnsElement contents2 + return ((name,args),retval) + in ElemAcceptor "call" f + +callArgsElement :: MonadError String m => ElemAcceptor m [Maybe LSLValue] +callArgsElement = elementList "args" (maybeSomeVal "maybe-value") + +returnsElement :: MonadError String m => ElemAcceptor m LSLValue +returnsElement = someVal "returns" + +initialBindingsElement :: MonadError String m => ElemAcceptor m [(String,LSLValue)] +initialBindingsElement = elementList "initialBindings" globalBindingElement + +finalBindingsElement :: MonadError String m => ElemAcceptor m [(String,LSLValue)] +finalBindingsElement = elementList "finalBindings" globalBindingElement + +globalBindingElement :: MonadError String m => ElemAcceptor m (String,LSLValue) +globalBindingElement = + let f (Elem _ _ contents) = do + (name,contents1) <- findElement (ElemAcceptor "name" simple) (elementsOnly contents) + (value,[]) <- findElement (someVal "value") contents1 + return (name,value) + in ElemAcceptor "globalBinding" f + +maybeSomeVal tag = + let f e@(Elem _ _ contents) = do + (val,[]) <- findOptionalElement (someVal "val") (elementsOnly contents) + return val + in ElemAcceptor tag f + +someVal tag = + let f e@(Elem _ [("class",v)] contents) = + let valString = attValueString v in + case find (\ acceptor -> valString == acceptorTag acceptor) [lslString,lslKey,lslInteger,lslList1,lslFloat, + lslVector,lslRotation,lslVoid] of + Nothing -> fail ("unknown lsl value class: " ++ valString) + Just (ElemAcceptor _ f1) -> f1 e + f e@(Elem name _ _) = fail ("'class' attribute required in " ++ name ++ " element") + in ElemAcceptor tag f + +parts :: String -> [String] +parts "" = [] +parts s = let (l, s') = break (== '.') s + in l : case s' of + [] -> [] + (_:s'') -> parts s'' diff --git a/Language/Lsl/Internal/Evaluation.hs b/Language/Lsl/Internal/Evaluation.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/Evaluation.hs @@ -0,0 +1,24 @@ +module Language.Lsl.Internal.Evaluation( + ScriptInfo(..), + EvalResult(..), + Event(..)) where + +import Data.Map(Map) +import Language.Lsl.Internal.Type(LSLValue) +import Language.Lsl.Internal.Breakpoint(Breakpoint) + +--type ScriptInfo = (String,Int,String,String) -- (object id, prim index, script name, prim key) +data ScriptInfo = ScriptInfo { scriptInfoObjectKey :: String, + scriptInfoPrimIndex :: Int, + scriptInfoScriptName :: String, + scriptInfoPrimKey :: String, + scriptInfoCurrentEvent :: Maybe Event } + deriving (Show) + +data EvalResult = EvalIncomplete | EvalComplete (Maybe String) | YieldTil Int + | BrokeAt Breakpoint + deriving (Show) + +data Event = Event { eventName :: String, eventValues :: [LSLValue], eventInfo :: Map String LSLValue } + deriving (Show) + diff --git a/Language/Lsl/Internal/EventSigs.hs b/Language/Lsl/Internal/EventSigs.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/EventSigs.hs @@ -0,0 +1,90 @@ +module Language.Lsl.Internal.EventSigs(lslEventDescriptors,simpleLslEventDescriptors, EventDelivery(..), EventAdditionalData(..)) where + +import Language.Lsl.Internal.Type(LSLType(..)) + +data EventDelivery = EventDeliveryScript | EventDeliveryPrim | EventDeliveryObject | EventDeliveryRoot +data EventAdditionalData = EventAdditionalKeys String String | EventAdditionalAvatarKeys String String | EventAdditionalVectors String String + | EventAdditionalInts String String + +lslEventDescriptors = [ + ("at_rot_target", [(LLInteger,"tnum"),(LLRot,"targetRot"),(LLRot,"ourrot")], EventDeliveryScript, [], + "raised when a scripted object comes within an angular distance of a target rotation"), + ("at_target", [(LLInteger,"tnum"),(LLVector,"targetPos"),(LLVector,"ourpos")], EventDeliveryScript, [], + "raised when a scripted object comes within a distance of a target posisition"), + ("attach",[(LLKey,"id")], EventDeliveryRoot, [], + "raised whenever the scripted object becomes attached or detached from an avatar"), + ("changed", [(LLInteger,"change")], EventDeliveryObject, [], + "raised whenever one of a variety of changes occur to a prim/object containing the script"), + ("collision",[(LLInteger, "num_detected")], EventDeliveryPrim, [EventAdditionalKeys "Avatar/Object key" "Avatar/Object key for collision", + EventAdditionalInts "Link Number" "Link Source of Collision"], + "raised when a scripted object collides with another object/avatar"), + ("collision_end",[(LLInteger, "num_detected")], EventDeliveryPrim, [EventAdditionalKeys "Avatar/Object key" "Avatar/Object key for collision", + EventAdditionalInts "Link Number" "Link Source of Collision"], + "raised when a scripted object stops colliding with another object/avatar"), + ("collision_start",[(LLInteger, "num_detected")], EventDeliveryPrim, [EventAdditionalKeys "Avatar/Object key" "Avatar/Object key for collision", + EventAdditionalInts "Link Number" "Link Source of Collision"], + "raised when a scripted object starts colliding with another object/avatar"), + ("control",[(LLKey,"id"),(LLInteger,"held"),(LLInteger,"change")], EventDeliveryScript, [], + "raised when a the state of controls change, if the script has 'taken controls'"), + ("dataserver",[(LLKey,"queryid"),(LLString,"data")], EventDeliveryScript, [], + "raised when data is received from the dataserver (in response to one of a variety of ll-function calls)"), + ("email",[(LLString,"time"),(LLString,"address"),(LLString,"subj"),(LLString,"message"),(LLInteger,"num_left")], EventDeliveryScript, [], + "raised when the llGetNextEmail function call is answered"), + ("http_response",[(LLKey,"request_id"),(LLInteger,"status"),(LLList,"metadata"),(LLString,"body")], EventDeliveryScript, [], + "raised when an http response is received for an http request that is pending"), + ("land_collision",[(LLVector,"pos")], EventDeliveryPrim, [], + "raised when a scripted object is colliding with the ground"), + ("land_collision_end",[(LLVector,"pos")], EventDeliveryPrim, [], + "raised when a scripted object stops colliding with the ground"), + ("land_collision_start",[(LLVector,"pos")], EventDeliveryPrim, [], + "raised when a scripted object starts colliding with the ground"), + ("link_message", [(LLInteger,"sender_num"), (LLInteger,"num"), (LLString,"str"), (LLKey,"id")], EventDeliveryPrim, [], + "raised when a scripted prim receives a link message, sent via llMessageLinked"), + ("listen", [(LLInteger, "channel"), (LLString,"name"), (LLKey,"id"), (LLString,"message")], EventDeliveryScript, [], + "raised whenever 'chat' is detected that matches constraints specified via a llListen call"), + ("money",[(LLKey,"id"),(LLInteger,"amount")], EventDeliveryPrim, [], + "raised when an agent pays a Linden dollar amount to the object"), + ("moving_end",[], EventDeliveryObject, [], + "raised when a scripted object stops moving or has entered a different region"), + ("moving_start",[], EventDeliveryObject, [], + "raised when a scripted object starts moving or has entered a different region"), + ("no_sensor",[], EventDeliveryScript, [], + "raised when sensors are active, but are not sensing anything"), + ("not_at_rot_target",[], EventDeliveryScript, [], + "raised when a scripted object is outside the specified angular distance of a target set by llRotTarget"), + ("not_at_target",[], EventDeliveryScript, [], + "raised when a scripted object is outside a specified range of a target set by llTarget"), + ("object_rez",[(LLKey,"id")], EventDeliveryPrim, [], + "raised when a script rezzes another object. The id is the GUID of the object that it rezzed"), + ("on_rez", [(LLInteger,"start_param")], EventDeliveryObject, [], + "raised when an object rezzes (from an agents inventory, an objects inventory, or as an attachment when an user logs on)"), + ("remote_data", [(LLInteger,"event_type"),(LLKey,"channel"),(LLKey,"message_id"),(LLString,"sender"),(LLInteger,"idata"),(LLString,"sdata")], + EventDeliveryScript, [], + "raised when something XML-RPC related happens"), + ("run_time_permissions", [(LLInteger,"perm")], EventDeliveryScript, [], + "raised when permissions granted to a script change, or a user responds to a permission request from the script"), + ("sensor",[(LLInteger,"num_detected")], EventDeliveryScript, [EventAdditionalKeys "Avatar/Object key" "Sensed Avatar/Ojbect Key"], + "raised when the sensor set up by llSensor/llSensorRepeat senses something"), + ("state_entry", [], EventDeliveryScript, [], + "raised when a state is entered"), + ("state_exit", [], EventDeliveryScript, [], + "raised when a state is exited"), + ("timer", [], EventDeliveryScript, [], + "raised when the timer set up by llSetTimerEvent triggers"), + ("touch", [(LLInteger,"num_detected")], EventDeliveryPrim, + [EventAdditionalAvatarKeys "Avatar key" "Key of agent touching prim", + EventAdditionalVectors "Grab vector" "Force applied by agent grabbing prim", + EventAdditionalInts "Link Number" "Link source of touch"], + "raised when an agent touches a scripted object"), + ("touch_start",[(LLInteger,"num_detected")], EventDeliveryPrim, + [EventAdditionalAvatarKeys "Avatar key" "Key of agent touching prim", + EventAdditionalInts "Link Number" "Link source of touch"], + "raised when an agent starts touching a scripted object"), + ("touch_end",[(LLInteger,"num_detected")], EventDeliveryPrim, + [EventAdditionalAvatarKeys "Avatar key" "Key of agent touching prim", + EventAdditionalInts "Link Number" "Link source of touch"], + "raised when an agent stops touching a scripted object")] + +simpleLslEventDescriptors = + map (\ (name,params,_,_,_) -> + (name, map (\ (t,_) -> t) params)) lslEventDescriptors diff --git a/Language/Lsl/Internal/Exec.hs b/Language/Lsl/Internal/Exec.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/Exec.hs @@ -0,0 +1,1105 @@ +module Language.Lsl.Internal.Exec( + ScriptImage(..), + EvalState, + ExecutionInfo(..), + ExecutionState(..), + FrameInfo(..), + MemRegion, + Binding, + executeLsl, + frameInfo, + initLSLScript, + initStateSimple, + setupSimple, + evalSimple, + emptyMemRegion, + runEval, + scriptImage, + softReset, + hardReset, + hasActiveHandler) where + +--import Debug.Trace +import Data.Bits((.&.),(.|.),xor,shiftL,shiftR,complement) +import Data.List(intersperse,find) +import qualified Data.Map as M +import Data.Maybe(isJust) + +import Language.Lsl.Internal.Breakpoint(Breakpoint(..),StepManager(..),pushStepManagerFrame,popStepManagerFrame,emptyStepManager,mkBreakpoint) +import Language.Lsl.Internal.CodeHelper(renderCall) +import Language.Lsl.Internal.FuncSigs(funcSigs) +import Language.Lsl.Internal.Util(fromInt,lookupM,ctx,findM) +import Language.Lsl.Syntax(Expr(..), + CompiledLSLScript(..), + Statement(..), + Func(..), + FuncDec(..), + Var(..), + State(..), + Ctx(..), + Global(..), + SourceContext(..), + Handler(..), + ctxVr2Vr, + findFunc, + findFuncDec, + ctxItems, + findState, + fromMCtx, + predefFuncs, + isTextLocation) +import Language.Lsl.Internal.Type(LSLType(..),LSLValue(..),typeOfLSLComponent,typeOfLSLValue,toFloat,toSVal, + lslShowVal,replaceLslValueComponent,vecMulScalar,rotMulVec, + parseInt,parseFloat,invRot,rotMul,vcross,Component(..),lslValueComponent) +import Language.Lsl.Internal.Key(nullKey,nextKey) +import Language.Lsl.Internal.Evaluation(EvalResult(..),Event(..),ScriptInfo(..)) +import Language.Lsl.Internal.Constants(findConstVal,llcZeroRotation,llcZeroVector) +import Control.Monad(foldM_,when,mplus,msum,join,zipWithM) +import Control.Monad.State(lift,StateT(..)) +import Control.Monad.Error(ErrorT(..)) + +-- initialize a script for execution +initLSLScript :: CompiledLSLScript -> ScriptImage +initLSLScript (CompiledLSLScript globals fs ss) = + ScriptImage { + scriptImageName = "", + curState = "default", + executionState = Waiting, + glob = initGlobals globals, + funcs = fs, + states = ss, + valueStack = [], + callStack = [], + stepManager = emptyStepManager, + globals = globals, + currentEvent = Nothing } + +initStateSimple script perfAction log qtick utick chkBp = + EvalState { scriptImage = initLSLScript script, + objectId = nextKey nullKey, + primId = 0, + scriptName = "script", + myPrimKey = nextKey nullKey, + performAction = perfAction, + logMessage = log, + qwtick = qtick, + uwtick = utick, + checkBreakpoint = chkBp, + nextEvent = undefined } + +runEval = (runStateT . runErrorT) +executeLsl img oid pid sid pkey perfAction log qtick utick chkBp queue maxTick = + do let state = (EvalState { scriptImage = img, + objectId = oid, + primId = pid, + scriptName = sid, + myPrimKey = pkey, + performAction = perfAction, + logMessage = log, + qwtick = qtick, + uwtick = utick, + checkBreakpoint = chkBp, + nextEvent = undefined}) + result <- (runEval $ evalScript maxTick queue) state + case result of + (Left s,_) -> return $ Left s + (Right queue',evalState) -> return $ Right $ (scriptImage evalState, queue') + +-- The state of evaluation for a script. +data EvalState m = EvalState { + scriptImage :: ScriptImage, + objectId :: String, + primId :: Int, + scriptName :: String, + myPrimKey :: String, + performAction :: String -> ScriptInfo -> [LSLValue] -> m (EvalResult,LSLValue), + logMessage :: String -> m (), + qwtick :: m Int, + uwtick :: Int -> m (), + checkBreakpoint :: Breakpoint -> StepManager -> m (Bool, StepManager), + nextEvent :: String -> String -> m (Maybe Event) } + +type Eval m = ErrorT String (StateT (EvalState m) m) + +evalT :: Monad m => ((EvalState m) -> (a,EvalState m)) -> Eval m a +evalT v = lift ((\ f -> StateT (\ s -> return (f s))) v) + +-- the image, or 'memory state' of a running script. Includes the +-- status of all stacks, global variables, and immutable items like +-- the functions and state definitions. +data ScriptImage = ScriptImage { + scriptImageName :: String, + curState :: StateName, + executionState :: ExecutionState, + glob :: MemRegion, + funcs :: [Func], + states :: [State], + valueStack :: ValueStack, + callStack :: CallStack, + stepManager :: StepManager, + globals :: [Global], + currentEvent :: Maybe Event + } deriving (Show) + +data FrameInfo = FrameInfo { frameInfoImageName :: String, frameInfoFrames :: [(String,SourceContext,Maybe Int,[(String,LSLValue)])] } + deriving (Show) + +frameInfo scriptImage = FrameInfo (scriptImageName scriptImage) $ + frames ++ [("glob", bottomContext, Nothing, glob scriptImage)] + where frames = (map collapseFrame $ callStack scriptImage) + (bottomContext,bottomLine) = case frames of + [] -> (UnknownSourceContext,Nothing) + _ -> let (_,ctx,_,_) = last frames in (ctx,Just 1) + collapseFrame (Frame name ctx line (ss,_)) = + (name,ctx,line,concat $ map fst ss) +-- a soft reset occurs when a script that has been running, but +-- has been persisted to inventory, is reactivated. The curState +-- stays the same, but if the script was running or sleeping, the +-- script goes to the 'waiting' state, with its call stack and value +-- stack cleared. + +-- if a script was halted, it stays halted; if it was waiting, it +-- stays waiting; if it was erroneous, it stays erroneous +softReset image = + let image' = image { valueStack = [], callStack = [] } in + case executionState image' of + SleepingTil _ -> image' { executionState = Waiting } + Executing -> image' { executionState = Waiting } + _ -> image' + +-- a hard reset occurs when a script is explicitly reset, either +-- via an LSL call, or 'manually' (in the real SL, via the GUI) +hardReset image = + case executionState image of + Erroneous _ -> image -- no effect + Halted -> image -- halted scripts are scripts that are explicitly not in the run state + _ -> image { + curState = "default", + executionState = Waiting, + glob = initGlobals (globals image), + valueStack = [], + callStack = [] } + +type StateName = String + +-- a labeled block: a label and all the statements that follow it. +data LBlock = LBlock String [Ctx Statement] + deriving (Show) + +-- find a block in a list of labeled blocks +findLBlock name = find (\ (LBlock n _) -> name == n) + +-- label the blocks in a list of statements `(i.e. +-- (EXAMPLE: +-- { +-- @foo; +-- if (i == 7) jump bar; +-- @bar; +-- llSay(0, (string) (i + j)); +-- if (j == 10) jump foo; +-- } +-- In the above code, there are two labels, and there for two labelled +-- blocks. The first is 'foo', labelling the block: +-- if (i == 7) jump bar; +-- @bar; +-- llSay(0, (string) (i + j)); +-- if (j == 10) jump foo; +-- +-- The 2nd is 'bar', labelling the block: +-- llSay(0, (string) (i + j)); +-- if (j == 10) jump foo; +-- +labelBlocks [] = [] +-- labelBlocks ((Label s):stmts) = (LBlock s stmts):(labelBlocks stmts) +-- labelBlocks (_:stmts) = (labelBlocks stmts) +labelBlocks (ctxStmt:stmts) = + case ctxItem ctxStmt of + Label s -> (LBlock s stmts):(labelBlocks stmts) + _ -> (labelBlocks stmts) + +-- A name/element pair is the basic unit of memory. Each memory +-- location has a name (rather than an address) and can hold a value +-- which can be of any LSL type. So 1 memory location can hold a +-- vector, or a string, or a list, etc. +type Binding = (String,LSLValue) + +-- a memory region is just a collection of NameElementPairs +type MemRegion = [Binding] +emptyMemRegion = [] + +initVar name LLInteger Nothing = (name,IVal 0) +initVar name LLFloat Nothing = (name,FVal 0.0) +initVar name LLString Nothing = (name,SVal "") +initVar name LLKey Nothing = (name,SVal "") +initVar name LLList Nothing = (name,LVal []) +initVar name LLVector Nothing = (name,VVal 0.0 0.0 0.0) +initVar name LLRot Nothing = (name,RVal 0.0 0.0 0.0 1.0) +initVar name LLKey (Just (SVal s)) = (name,KVal s) +initVar name LLString (Just (KVal k)) = (name, SVal k) +initVar name LLFloat (Just (IVal i)) = (name,FVal $ fromInt i) +initVar name LLInteger (Just (FVal f)) = (name,IVal $ floor f) +initVar name _ (Just v) = (name,v) + +writeMem :: Monad m => String -> LSLValue -> MemRegion -> m MemRegion +writeMem name value cells = + case break (\(name',element) -> name' == name) cells of + (cells',[]) -> fail "no such variable" + (xs,y:ys) -> return ((name,value):(xs ++ ys)) + +readMem :: Monad m => String -> MemRegion -> m LSLValue +readMem = lookupM + +initGlobals :: [Global] -> MemRegion +initGlobals globals = map (initGlobal globals) globals + +initGlobal globals (GDecl (Var name t) mexpr) = initVar name t $ fmap (evalLit globals) mexpr + +evalCtxLit globals (Ctx _ expr) = evalLit globals expr + +evalLit globals expr = + let litExpr2Float expr = + case evalCtxLit globals expr of + (FVal f) -> f + (IVal i) -> fromInteger $ toInteger i + _ -> error "invalid float expression" + in case expr of + Neg (Ctx _ (IntLit i)) -> IVal (-i) + Neg (Ctx _ (FloatLit f)) -> FVal (-f) + IntLit i -> IVal i + FloatLit f -> FVal f + StringLit s -> SVal s + KeyLit k -> KVal k + ListExpr l -> LVal $ map (evalCtxLit globals) l + VecExpr a b c -> VVal (litExpr2Float a) (litExpr2Float b) (litExpr2Float c) + RotExpr a b c d -> RVal (litExpr2Float a) (litExpr2Float b) (litExpr2Float c) (litExpr2Float d) + Get (Ctx _ nm,All) -> + case find (\ (GDecl (Var nm' t) mexpr') -> nm == nm') globals of + Nothing -> + case findConstVal nm of + Nothing -> error ("invalid global " ++ nm ++ " referenced in initializer") + Just v -> v + Just g -> + let (_,v) = initGlobal globals g in v + +bindParm (Var name t) lslVal = if typeOfLSLValue lslVal == t then return (name,lslVal) else fail "type mismatch!" +bindParms vars vals = zipWithM bindParm vars vals + +bindParmForgiving (Var name t) lslVal = + case (t,typeOfLSLValue lslVal) of + (LLInteger,LLFloat) -> let FVal v = lslVal in return (name,IVal $ floor v) + (LLFloat,LLInteger) -> let IVal v = lslVal in return (name,FVal $ fromInt v) + (LLKey,LLString) -> let SVal s = lslVal in return (name,KVal s) + (LLString,LLKey) -> let KVal k = lslVal in return (name,SVal k) + (t0,t1) | t0 == t1 -> return (name,lslVal) + | otherwise -> fail "type mismatch!" + +bindParmsForgiving vars vals = zipWithM bindParmForgiving vars vals + +toBool x = if x == 0 then False else True + +--type Frame = (ScopeStack,EvalStack) +data Frame = Frame { frameName :: String, frameContext :: SourceContext, frameSourceLine :: Maybe Int, + frameStacks :: (ScopeStack, EvalStack) } + deriving (Show) +type LabelSet = [LBlock] +type Scope = (MemRegion,LabelSet) +type ScopeStack = [Scope] +type CallStack = [Frame] + + +readVarScope :: String -> Scope -> Maybe LSLValue +readVarScope name (mem,_) = readMem name mem +readVarSStack :: String -> ScopeStack -> Maybe LSLValue +readVarSStack name ss = foldl mplus Nothing $ map (readVarScope name) ss +readVarFrame :: String -> Frame -> Maybe LSLValue +readVarFrame name = (readVarSStack name) . fst . frameStacks +readVarCallStack :: String -> CallStack -> Maybe LSLValue +readVarCallStack name = (readVarFrame name) . head + +writeVarScope :: String -> LSLValue -> Scope -> Maybe Scope +writeVarScope name val (mem,l) = writeMem name val mem >>= return . (flip (,) l) +writeVarSStack rs name val [] = Nothing +writeVarSStack rs name val (s:ss) = + case writeVarScope name val s of + Nothing -> writeVarSStack (s:rs) name val ss + Just s' -> Just $ (reverse rs) ++ (s':ss) +writeVarFrame name val frame = + let (ss,es) = frameStacks frame in + case writeVarSStack [] name val ss of + Nothing -> Nothing + Just ss' -> Just frame { frameStacks = (ss',es) } +writeVarCallStack name val (frame:cs) = writeVarFrame name val frame >>= return . (flip (:) cs) + +type EvalStack = [EvalElement] + +type ValueStack = [LSLValue] + +data EvalElement = EvBlock [Ctx Statement] | EvCtxStatement (Ctx Statement) + | EvStatement Statement | EvExpr Expr | EvMexpr (Maybe Expr) + | EvAdd | EvSub | EvMul | EvDiv | EvMod | EvBAnd | EvBOr | EvBXor | EvBInv | EvNeg + | EvNot | EvAnd | EvOr | EvLe | EvLt | EvGe | EvGt | EvEq | EvNe + | EvShiftL | EvShiftR | EvCast LSLType | EvGet (String,Component) | EvSet (String,Component) + | EvCons | EvMkVec | EvMkRot | EvPop + | EvReturn | EvDiscard | EvBind String LSLType + | EvCond Statement Statement | EvCall String SourceContext [Var] [Ctx Statement] Bool + | EvPredef String | EvLoop Expr [Ctx Expr] Statement + deriving (Show) + +-- Note: lifted from Hudak, p.273 +queryState :: Monad w => (EvalState w -> a) -> Eval w a +queryState q = evalT (\s -> (q s, s)) +updateState :: Monad w => (EvalState w -> EvalState w) -> Eval w () +updateState u = evalT (\s -> ((), u s)) +queryExState q = queryState (q . scriptImage) +updateExState :: Monad w => (ScriptImage -> ScriptImage) -> Eval w () +updateExState u = updateState (\s -> s { scriptImage = u $ scriptImage s }) + +getTick :: Monad w => Eval w Int +getTick = join $ evalT (\s -> (lift $ lift $ qwtick s,s)) +setTick v = do f <- (queryState uwtick) + lift $ lift $ f v +getNextEvent key name = do f <- (queryState nextEvent) + lift $ lift $ f key name +doAction name scriptInfo args = do perform <- (queryState performAction) + lift $ lift $ perform name scriptInfo args +logMsg s = do log <- queryState logMessage + lift $ lift $ log s + +checkBp bp = do sm <- getStepManager + chk <- queryState checkBreakpoint + (result,sm') <- lift $ lift $ chk bp sm + setStepManager sm' + return result + +getGlob :: Monad w => Eval w MemRegion +getGlob = queryExState glob +getFuncs :: Monad w => Eval w [Func] +getFuncs = queryExState funcs +getVStack :: Monad w => Eval w ValueStack +getVStack = queryExState valueStack +getCallStack :: Monad w => Eval w CallStack +getCallStack = queryExState callStack +getStates :: Monad w => Eval w [State] +getStates = queryExState states +getCurrentEvent :: Monad w => Eval w (Maybe Event) +getCurrentEvent = queryExState currentEvent +getExecutionState :: Monad w => Eval w ExecutionState +getExecutionState = queryExState executionState +getCurState :: Monad w => Eval w String +getCurState = queryExState curState +getEvalState :: Monad w => Eval w (EvalState w) +getEvalState = queryState id +getObjectId :: Monad w => Eval w String +getObjectId = queryState objectId +getPrimId :: Monad w => Eval w Int +getPrimId = queryState primId +getScriptName :: Monad w => Eval w String +getScriptName = queryState scriptName +getScriptImageName :: Monad w => Eval w String +getScriptImageName = queryExState scriptImageName +getMyPrimKey :: Monad w => Eval w String +getMyPrimKey = queryState myPrimKey +getStepManager :: Monad w => Eval w StepManager +getStepManager = queryExState stepManager + +setGlob g = updateExState (\e -> e { glob = g }) +setVStack v = updateExState (\e -> e { valueStack = v }) +setCallStack c = updateExState (\e -> e { callStack = c }) +setStepManager m = updateExState (\e -> e { stepManager = m }) +setExecutionState state = updateExState (\e -> e { executionState = state }) +setCurState state = updateExState (\e -> e { curState = state }) +setCurrentEvent event = updateExState (\e -> e { currentEvent = Just event }) +setScriptImageName n = updateExState (\ e -> e { scriptImageName = n }) + +initStacks :: Monad w => Eval w () +initStacks = + do setVStack [] + setCallStack [] + +popScope :: Monad w => Eval w Scope +popScope = + do --((s:ss,es):cs) <- getCallStack + (frame:frames) <- getCallStack + let (s:ss,es) = frameStacks frame + setCallStack (frame { frameStacks = (ss,es) }:frames) + return s + +pushScope :: Monad w => MemRegion -> LabelSet -> Eval w () +pushScope mem labels = + do (frame:frames) <- getCallStack + let (ss,es) = frameStacks frame + setCallStack (frame { frameStacks = ((mem,labels):ss,es) }:frames) + +pushVal value = + do vstack <- getVStack + setVStack (value:vstack) + +popVal :: Monad w => Eval w LSLValue +popVal = + do vstack <- getVStack + case vstack of + [] -> fail "empty value stack" + (v:vs) -> do + setVStack vs + return v + +peekVal :: Monad w => Eval w LSLValue +peekVal = + do vstack <- getVStack + case vstack of + [] -> fail "empty value stack" + (v:_) -> return v + +valStackEmpty :: Monad w => Eval w Bool +valStackEmpty = getVStack >>= (return . (==[])) + +elementStackEmpty :: Monad w => Eval w Bool +elementStackEmpty = + do (frame:cs) <- getCallStack + case frameStacks frame of + (_,[]) -> return True + _ -> return False + +popElement :: Monad w => Eval w EvalElement +popElement = + do (frame:frames) <- getCallStack + let (ss,e:es) = frameStacks frame + setCallStack (frame { frameStacks = (ss,es) }:frames) + return e + +popElements 0 = return () +popElements n = + do popElement + popElements (n - 1) + +pushElement element = + do (frame:frames) <- getCallStack + let (ss,es) = frameStacks frame + setCallStack (frame { frameStacks = (ss,element:es) }:frames) + +pushElements elements = + do mapM pushElement elements + return EvalIncomplete + +callStackEmpty :: Monad w => Eval w Bool +callStackEmpty = getCallStack >>= return . null + +popFrame :: Monad w => Eval w () +popFrame = + do (f:cs) <- getCallStack + stepMgr <- getStepManager + let stepMgr' = popStepManagerFrame stepMgr + setStepManager stepMgr' + setCallStack cs + +--pushFrame :: Monad w => Eval w () +pushFrame name ctx line = + do stepMgr <- getStepManager + let stepMgr' = pushStepManagerFrame stepMgr + setStepManager stepMgr' + cs <- getCallStack + setCallStack (Frame { frameName = name, frameContext = ctx, frameSourceLine = line, frameStacks = ([],[])}:cs) + +getFunc :: Monad w => String -> Eval w Func +getFunc name = + do funcs <- getFuncs + incontext ("func: " ++ name) $ findFunc name funcs + +setVar :: Monad w => String -> LSLValue -> Eval w () +setVar name val = + do cs <- getCallStack + case writeVarCallStack name val cs of + Just cs' -> setCallStack cs' + Nothing -> + do glob <- getGlob + glob' <- incontext ("setting " ++ name ++ ":") $ writeMem name val glob + setGlob glob' + +getVar :: Monad w => String -> Eval w LSLValue +getVar name = + do cs <- getCallStack + glob <- getGlob + case msum [findConstVal name, readVarCallStack name cs, readMem name glob] of + Nothing -> fail ("no such variable " ++ name) + Just val -> return val + +initVar1 :: Monad w => String -> LSLType -> Maybe LSLValue -> Eval w () +initVar1 name t mval = + do --(((m,l):ss,es):cs) <- getCallStack + (frame:frames) <- getCallStack + let ((m,l):ss,es) = frameStacks frame + let frame' = frame { frameStacks = (((initVar name t mval):m,l):ss,es) } + setCallStack (frame':frames) + +initVars1 :: Monad w => [Var] -> [LSLValue] -> Eval w () +initVars1 vars vals = + foldM_ (\_ -> \ (Var n t, v) -> initVar1 n t $ Just v) () $ zip vars vals + +unwindToLabel name = + let f n = + do (frame:frames) <- getCallStack + let (ss,es) = frameStacks frame + case ss of + [] -> fail ("label " ++ name ++ " not found") + ((m,l):ss') -> + case findLBlock name l of + Just (LBlock _ stmts) -> return $ (n,stmts) + Nothing -> + do setCallStack (frame { frameStacks = (ss',es) }:frames) + f (n + 1) + in f 1 + + +data ExecutionState = Waiting | Executing | Halted | SleepingTil Int | Erroneous String | Crashed String | Suspended Breakpoint + | WaitingTil Int -- in a waiting state, but won't process new events until time t + deriving (Show,Eq) + +matchEvent (Event name _ _) [] = fail ("no such handler" ++ name) +matchEvent event@(Event name values _) ((Handler (Ctx ctx name') parms stmts):hs) + | name == name' = do mem <- bindParms (ctxItems parms) values + return (mem,stmts,name,ctx) + | otherwise = matchEvent event hs + +findHandler name handlers = ctx ("finding handler " ++ name) $ + findM (\ (Handler (Ctx _ name') _ _) -> name' == name) handlers + + +evalScriptSimple :: Monad w => Int -> [String] -> [Binding] -> [LSLValue] -> Eval w (EvalResult,Maybe LSLValue) +evalScriptSimple maxTick path globbindings args = + do setupSimple path globbindings args + evalSimple maxTick + +evalSimple maxTick = + do result <- eval maxTick + glob <- getGlob + case result of + EvalComplete Nothing -> + do empty <- valStackEmpty + if empty then return (result,Just VoidVal) else do + val <- popVal + return (result,Just val) + _ -> return (result,Nothing) + +setupSimple path globbindings args = + do setScriptImageName (concat (intersperse "." path)) + updateGlobals globbindings + (params,stmts,ctx) <- getEntryPoint path + mem <- bindParmsForgiving params args + initStacks + pushFrame (concat $ intersperse "." path) ctx Nothing + pushScope mem $ labelBlocks stmts + pushElement (EvBlock stmts) + setExecutionState Executing + where updateGlobals [] = return () + updateGlobals ((name,val):bs) = + do glob <- getGlob + glob' <- writeMem name val glob + setGlob glob' + updateGlobals bs + getEntryPoint [funcName] = + do funcs <- getFuncs + (Func (FuncDec name _ params) stmts) <- findFunc funcName funcs + return (ctxItems params,stmts,srcCtx name) + getEntryPoint [stateName,handlerName] = + do states <- getStates + (State _ handlers) <- findState stateName states + (Handler name params stmts) <- findHandler handlerName handlers + return (ctxItems params,stmts, srcCtx name) + +incontext s f = + case f of + Left s -> fail s + Right v -> return v + +evalScript :: Monad w => Int -> [Event] -> Eval w [Event] +evalScript maxTick queue = + do executionState <- getExecutionState + case executionState of + Suspended _ -> setExecutionState Executing >> evalScript maxTick queue + Erroneous _ -> return queue + Waiting -> + do oid <- getObjectId + pid <- getPrimId + primKey <- getMyPrimKey + scriptName <- getScriptName + case queue of + [] -> return queue + (event:queue') -> + do states <- getStates + curState <- case event of + -- when a state_exit event occurs we've already changed the state variable in the image + -- to the new state. the event itself contains the name of the old state, so we can + -- find the right event handler. + Event "state_exit" _ m -> + case M.lookup "last_state" m of + Just (SVal s) -> return s + Nothing -> logMsg "not a valid state exit!" >> getCurState + _ -> getCurState + (State _ handlers) <- incontext ("state " ++ curState ++ ":") $ findState curState states + case matchEvent event handlers of + Nothing -> return queue' + Just (mem,stmts,name,ctx) -> + do initStacks + pushFrame name ctx Nothing + pushScope mem $ labelBlocks stmts + pushElement (EvBlock stmts) + setExecutionState Executing + setCurrentEvent event + evalScript maxTick queue' + Executing -> do result <- eval maxTick + case result of + EvalComplete (Just newState) -> + do curState <- getCurState + setCurState newState + setExecutionState Waiting + if curState /= newState + -- the event queue gets cleared, with the state exit/entry events added. + then return [Event "state_exit" [] $ M.singleton "last_state" (SVal curState), + Event "state_entry" [] $ M.empty] + else return queue + EvalComplete _ -> setExecutionState Waiting >> return queue + YieldTil i -> setExecutionState (SleepingTil i) >> return queue + BrokeAt bp -> setExecutionState (Suspended bp) >> return queue + _ -> return queue + SleepingTil i -> do tick <- getTick + if (tick >= i) + then setExecutionState Executing >> evalScript maxTick queue + else return queue + WaitingTil i -> do tick <- getTick + if (tick >= i) + then setExecutionState Waiting >> evalScript maxTick queue + else return queue + Halted -> return queue + +eval :: Monad w => Int -> Eval w EvalResult +eval maxTick = + do + t <- getTick + let t' = t + 1 + setTick t' + (if (t' <= maxTick) then + do result <- eval' + case result of + EvalIncomplete -> eval maxTick + x -> return x + else + return EvalIncomplete) + +eval' :: Monad w => Eval w EvalResult +eval' = + let continue = return EvalIncomplete + popAndCheck :: Monad w => Eval w EvalResult + popAndCheck = do + popFrame + noMoreFrames <- callStackEmpty + return (if noMoreFrames then EvalComplete Nothing else EvalIncomplete) + in + do cs <- getCallStack + vs <- getVStack + noMoreElements <- elementStackEmpty + if noMoreElements then popAndCheck + else do + element <- popElement + case element of + EvReturn -> do + val <- peekVal + logMsg ("return: " ++ lslShowVal val) + popAndCheck + EvBlock [] -> popScope >> eval' + EvBlock (s:ss) -> pushElements [EvBlock ss,EvCtxStatement s] + EvCtxStatement s -> do + pushElements [EvStatement $ ctxItem s] + if (isTextLocation $ srcCtx s) then + let bp = mkBreakpoint (textName $ srcCtx s) (textLine0 $ srcCtx s) 0 in + do brk <- checkBp bp + if brk then return $ BrokeAt bp + else continue + else continue + EvStatement (Return mexpr) -> pushElements [EvReturn,EvMexpr $ fromMCtx mexpr] + EvStatement (NullStmt) -> eval' + EvStatement (StateChange s) -> return $ EvalComplete $ Just s + EvStatement (Do expr) -> pushElements [EvDiscard,EvExpr $ ctxItem expr] + EvStatement (Decl (Var name t) Nothing) -> + do initVar1 name t Nothing + continue + EvStatement (Decl (Var name t) mexpr) -> pushElements [EvBind name t,EvMexpr $ fromMCtx mexpr] + EvStatement (If expr stmt1 stmt2) -> pushElements [EvCond stmt1 stmt2,EvExpr $ ctxItem expr] + EvStatement (While expr stmt) -> pushElements [EvLoop (ctxItem expr) [] stmt,EvExpr $ ctxItem expr] + EvStatement (DoWhile stmt expr) -> + pushElements [EvLoop (ctxItem expr) [] stmt, EvExpr (ctxItem expr),EvStatement stmt] + EvStatement (For mexpr1 mexpr2 mexpr3 stmt) -> + do let expr = case mexpr2 of + Nothing -> (IntLit 1) + Just expr2 -> ctxItem expr2 + pushElement (EvLoop expr (mexpr3) stmt) + pushElement (EvExpr $ expr) + pushElements [EvDiscard, EvExpr (ListExpr mexpr1)] + continue + EvStatement (Compound ss) -> + do pushScope [] $ labelBlocks ss + pushElement (EvBlock ss) + continue + EvStatement (Label _) -> eval' + EvStatement (Jump name) -> + do (n,stmts) <- unwindToLabel name + popElements n + pushElement (EvBlock stmts) + continue + EvMexpr Nothing -> pushVal VoidVal >> continue + EvMexpr (Just expr) -> pushElements [EvExpr expr] + EvDiscard -> popVal >> continue + EvBind name t -> + do val <- popVal + initVar1 name t (Just val) + continue + EvLoop expr mexpr stmt -> + do val <- popVal + when (trueCondition val) $ do + pushElement element -- last, re-evaluate loop + pushElement (EvExpr expr) -- next-to-last, re-evaluate expr) + pushElements [EvDiscard, EvExpr (ListExpr mexpr)] -- evaluate end-of-loop expressions + pushElement (EvStatement stmt) -- first, evaluate statement) + continue + EvCond stmt1 stmt2 -> + do val <- popVal + pushElement (EvStatement (if trueCondition val then stmt1 else stmt2)) + continue + EvExpr (IntLit i) -> pushVal (IVal i) >> continue + EvExpr (FloatLit f) -> pushVal (FVal f) >> continue + EvExpr (StringLit s) -> pushVal (SVal s) >> continue + EvExpr (KeyLit k) -> pushVal (KVal k) >> continue + EvExpr (VecExpr e1 e2 e3) -> + -- TODO: this is probably the WRONG order of evaluation!!! + pushElements [EvMkVec,EvExpr $ ctxItem e3, EvExpr $ ctxItem e2, EvExpr $ ctxItem e1] + EvExpr (RotExpr e1 e2 e3 e4) -> + pushElements [EvMkRot,EvExpr $ ctxItem e4, EvExpr $ ctxItem e3, EvExpr $ ctxItem e2, EvExpr $ ctxItem e1] + EvExpr (ListExpr []) -> pushVal (LVal []) >> continue + EvExpr (ListExpr ((Ctx _ e):es)) -> + pushElements [EvCons,EvExpr (ListExpr es), EvExpr e] + EvExpr (Add expr1 expr2) -> pushBinary EvAdd expr1 expr2 + EvExpr (Sub expr1 expr2) -> pushBinary EvSub expr1 expr2 + EvExpr (Mul expr1 expr2) -> pushBinary EvMul expr1 expr2 + EvExpr (Div expr1 expr2) -> pushBinary EvDiv expr1 expr2 + EvExpr (Mod expr1 expr2) -> pushBinary EvMod expr1 expr2 + EvExpr (BAnd expr1 expr2) -> pushBinary EvBAnd expr1 expr2 + EvExpr (BOr expr1 expr2) -> pushBinary EvBOr expr1 expr2 + EvExpr (Xor expr1 expr2) -> pushBinary EvBXor expr1 expr2 + EvExpr (And expr1 expr2) -> pushBinary EvAnd expr1 expr2 + EvExpr (Or expr1 expr2) -> pushBinary EvOr expr1 expr2 + EvExpr (Lt expr1 expr2) -> pushBinary EvLt expr1 expr2 + EvExpr (Le expr1 expr2) -> pushBinary EvLe expr1 expr2 + EvExpr (Gt expr1 expr2) -> pushBinary EvGt expr1 expr2 + EvExpr (Ge expr1 expr2) -> pushBinary EvGe expr1 expr2 + EvExpr (Equal expr1 expr2) -> pushBinary EvEq expr1 expr2 + EvExpr (NotEqual expr1 expr2) -> pushBinary EvNe expr1 expr2 + EvExpr (ShiftL expr1 expr2) -> pushBinary EvShiftL expr1 expr2 + EvExpr (ShiftR expr1 expr2) -> pushBinary EvShiftR expr1 expr2 + EvExpr (Not expr) -> pushUnary EvNot expr + EvExpr (Neg expr) -> pushUnary EvNeg expr + EvExpr (Inv expr) -> pushUnary EvBInv expr + EvExpr (Cast t expr) -> pushElements [EvCast t,EvExpr $ ctxItem expr] + EvExpr (Get var) -> pushElements [EvGet $ ctxVr2Vr var] + EvExpr (Set var expr) -> pushElements [EvSet $ ctxVr2Vr var, EvExpr $ ctxItem expr] + EvExpr (IncBy var expr) -> pushModBy var EvAdd $ ctxItem expr + EvExpr (DecBy var expr) -> pushModBy var EvSub $ ctxItem expr + EvExpr (MulBy var expr) -> pushModBy var EvMul $ ctxItem expr + EvExpr (DivBy var expr) -> pushModBy var EvDiv $ ctxItem expr + EvExpr (ModBy var expr) -> pushModBy var EvMod $ ctxItem expr + EvExpr (PreInc var) -> pushModBy var EvAdd (IntLit 1) + EvExpr (PreDec var) -> pushModBy var EvSub (IntLit 1) + EvExpr (PostInc var) -> + do -- after all operations, top of stack should be var value prior to increment + pushElement (EvPop) -- take that value off, leaving the original value + pushModBy var EvAdd (IntLit 1) + pushElement (EvGet $ ctxVr2Vr var) -- put the current value on the stack + continue + EvExpr (PostDec var) -> + do -- after all operations, top of stack should be var value prior to increment + pushElement (EvPop) + pushModBy var EvSub (IntLit 1) + pushElement (EvGet $ ctxVr2Vr var) -- put the current value on the stack + continue + EvExpr (Call (Ctx _ name) exprs) -> + case findFuncDec name predefFuncs of + Just (FuncDec _ t parms) -> pushElements [EvPredef name, EvExpr (ListExpr exprs)] + Nothing -> + do + (Func (FuncDec ctxName t parms) stmts) <- getFunc name + pushElement (EvCall (ctxItem ctxName) (srcCtx ctxName) (ctxItems parms) stmts (t == LLVoid)) + pushElement (EvExpr (ListExpr exprs)) -- first evaluate the arguments + continue + EvCons -> + do (LVal l) <- popVal + val <- popVal + pushVal (LVal (val:l)) + continue + EvCall name ctx parms stmts voidFunc -> + do (LVal val) <- popVal -- should be the list of arguments + logMsg ("call: " ++ renderCall name val) + pushFrame name ctx Nothing + pushScope [] $ labelBlocks stmts + initVars1 parms val + -- a void function may not have an explicit return; if it does, this + -- element will get popped off without being evaluated. + when voidFunc (pushElement EvReturn >> pushElement (EvMexpr Nothing)) + pushElement (EvBlock stmts) + continue + EvPredef name -> evalPredef' name + EvGet (name,c) -> + do val <- getVar name + pushVal $ lslValueComponent c val + continue + EvPop -> popVal >> continue + EvSet (name,c) -> + do val <- peekVal + varVal <- getVar name + let t = typeOfLSLComponent varVal c + let val' = case (t,val) of + (LLFloat,IVal i) -> FVal (fromInt i) + (LLString,KVal k) -> SVal k + (LLKey,SVal s) -> KVal s + (t, v) | t == typeOfLSLValue v -> v + | otherwise -> error ("can't implicitly convert from " ++ + (show $ typeOfLSLValue v) ++ + " to " ++ (show t)) + let varVal' = replaceLslValueComponent c varVal val' + setVar name varVal' + continue + EvAdd -> evalBinary $ \val1 val2 -> case (val1,val2) of + (IVal v1, IVal v2) -> IVal (v1 + v2) + (FVal v1, IVal v2) -> FVal (v1 + fromInt v2) + (IVal v1, FVal v2) -> FVal (v2 + fromInt v1) + (FVal v1, FVal v2) -> FVal (v1 + v2) + (VVal x1 y1 z1, VVal x2 y2 z2) -> VVal (x1 + x2) (y1 + y2) (z1 + z2) + (RVal x1 y1 z1 s1,RVal x2 y2 z2 s2) -> RVal (x1 + x2) (y1 + y2) (z1 + z2) (s1 + s2) + (LVal l1,LVal l2) -> LVal (l1 ++ l2) + (v,LVal l2) -> LVal (v:l2) + (LVal l1, v) -> LVal (l1 ++ [v]) + (SVal s1,SVal s2) -> SVal (s1 ++ s2) + _ -> error ("invalid Add operands: " ++ (show val1) ++ ", " ++ (show val2)) + EvSub -> evalBinary $ \ val1 val2 -> case (val1,val2) of + (IVal i1,IVal i2) -> IVal (i1 - i2) + (IVal i1,FVal f2) -> FVal (fromInt i1 - f2) + (FVal f1,IVal i2) -> FVal (f1 - fromInt i2) + (FVal f1,FVal f2) -> FVal (f1 - f2) + (VVal x1 y1 z1,VVal x2 y2 z2) -> VVal (x1 - x2) (y1 - y2) (z1 - z2) + (RVal x1 y1 z1 s1,RVal x2 y2 z2 s2) -> RVal (x1 - x2) (y1 - y2) (z1 - z2) (s1 - s2) + _ -> error ("cannot apply - operator to " ++ (show val1) ++ " and " ++ (show val2)) + EvMul -> evalBinary $ \ val1 val2 -> case (val1,val2) of + (IVal i1,IVal i2) -> IVal (i1*i2) + (IVal i1,FVal f2) -> FVal (fromInt i1 * f2) + (FVal f1,IVal i2) -> FVal (f1 * fromInt i2) + (FVal f1,FVal f2) -> FVal (f1 * f2) + (v@(VVal _ _ _),IVal i) -> let f = fromInt i in vecMulScalar v f + (v@(VVal _ _ _),FVal f) -> vecMulScalar v f + ((VVal x1 y1 z1),(VVal x2 y2 z2)) -> FVal $ x1 * x2 + y1 * y2 + z1 * z2 + (v@(VVal _ _ _),r@(RVal _ _ _ _)) -> rotMulVec r v + (r1@(RVal _ _ _ _),r2@(RVal _ _ _ _)) -> rotMul r1 r2 + _ -> error ("cannot apply * operator to " ++ (show val1) ++ " and " ++ (show val2)) + EvDiv -> evalBinary $ \ val1 val2 -> case (val1,val2) of + (IVal i1,IVal i2) -> IVal (i1 `div` i2) -- TODO: how does SL handle divide by zero? + (IVal i1,FVal f2) -> FVal (fromInt i1 / f2) + (FVal f1,IVal i2) -> FVal (f1 / fromInt i2) + (FVal f1,FVal f2) -> FVal (f1/f2) + (v@(VVal _ _ _),IVal i) -> let f = 1.0 / fromInt i in vecMulScalar v f + (v@(VVal _ _ _),FVal f) -> vecMulScalar v f + (v@(VVal _ _ _),r@(RVal _ _ _ _)) -> rotMulVec (invRot r) v + (r1@(RVal _ _ _ _),r2@(RVal _ _ _ _)) -> rotMul r1 $ invRot r2 + _ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2)) + EvMod -> evalBinary $ \ val1 val2 -> case (val1,val2) of + (IVal i1,IVal i2) -> IVal (i1 `mod` i2) + (v1@(VVal _ _ _),v2@(VVal _ _ _)) -> v1 `vcross` v2 + _ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2)) + EvBAnd -> evalBinary $ \ val1 val2 -> case (val1,val2) of + (IVal i1,IVal i2) -> IVal (i1 .&. i2) + _ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2)) + EvBOr -> evalBinary $ \ val1 val2 -> case (val1,val2) of + (IVal i1,IVal i2) -> IVal (i1 .|. i2) + _ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2)) + EvBXor -> evalBinary $ \ val1 val2 -> case (val1,val2) of + (IVal i1,IVal i2) -> IVal (i1 `xor` i2) + _ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2)) + EvAnd -> evalBinary $ \ val1 val2 -> case (val1,val2) of + (IVal i1,IVal i2) -> IVal (if (toBool i1 && toBool i2) then 1 else 0) + _ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2)) + EvOr -> evalBinary $ \ val1 val2 -> case (val1,val2) of + (IVal i1,IVal i2) -> IVal (if (toBool i1 || toBool i2) then 1 else 0) + _ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2)) + EvLt -> evalBinary $ \ val1 val2 -> case (val1,val2) of + (IVal i1,IVal i2) -> toLslBool $ i1 < i2 + (FVal f1,FVal f2) -> toLslBool $ f1 < f2 + (FVal f1,IVal i2) -> toLslBool $ f1 < fromInt i2 + (IVal i1,FVal f2) -> toLslBool $ fromInt i1 < f2 + _ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2)) + EvLe -> evalBinary $ \ val1 val2 -> case (val1,val2) of + (IVal i1,IVal i2) -> toLslBool $ i1 <= i2 + (FVal f1,FVal f2) -> toLslBool $ f1 <= f2 + (FVal f1,IVal i2) -> toLslBool $ f1 <= fromInt i2 + (IVal i1,FVal f2) -> toLslBool $ fromInt i1 <= f2 + _ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2)) + EvGt -> evalBinary $ \ val1 val2 -> case (val1,val2) of + (IVal i1,IVal i2) -> toLslBool $ i1 > i2 + (FVal f1,FVal f2) -> toLslBool $ f1 > f2 + (FVal f1,IVal i2) -> toLslBool $ f1 > fromInt i2 + (IVal i1,FVal f2) -> toLslBool $ fromInt i1 > f2 + _ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2)) + EvGe -> evalBinary $ \ val1 val2 -> case (val1,val2) of + (IVal i1,IVal i2) -> toLslBool $ i1 >= i2 + (FVal f1,FVal f2) -> toLslBool $ f1 >= f2 + (FVal f1,IVal i2) -> toLslBool $ f1 >= fromInt i2 + (IVal i1,FVal f2) -> toLslBool $ fromInt i1 >= f2 + _ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2)) + EvEq -> evalBinary $ \ val1 val2 -> case (val1,val2) of + (LVal l1, LVal l2) -> toLslBool $ length l1 == length l2 -- special case of LSL weirdness + (SVal s, KVal k) -> toLslBool $ s == k + (KVal k, SVal s) -> toLslBool $ k == s + (FVal f1,IVal i2) -> toLslBool $ f1 == fromInt i2 + (IVal i1,FVal f2) -> toLslBool $ fromInt i1 == f2 + (v1,v2) -> toLslBool $ v1 == v2 + EvNe -> evalBinary $ \ val1 val2 -> case (val1,val2) of + (LVal l1, LVal l2) -> toLslBool $ length l1 /= length l2 -- special case of LSL weirdness + (SVal s, KVal k) -> toLslBool $ s /= k + (KVal k, SVal s) -> toLslBool $ k /= s + (FVal f1,IVal i2) -> toLslBool $ f1 /= fromInt i2 + (IVal i1,FVal f2) -> toLslBool $ fromInt i1 /= f2 + (v1,v2) -> toLslBool $ v1 /= v2 + EvShiftL -> evalBinary $ \ val1 val2 -> case (val1,val2) of + (IVal i1,IVal i2) -> IVal (i1 `shiftL` i2) + _ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2)) + EvShiftR -> evalBinary $ \ val1 val2 -> case (val1,val2) of + (IVal i1,IVal i2) -> IVal (i1 `shiftR` i2) + _ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2)) + EvNot -> do + val <- popVal + pushVal $ case val of + (IVal i) -> IVal (if i == 0 then 1 else 0) + _ -> error ("cannot apply operator to " ++ (show val)) + continue + EvBInv -> do + val <- popVal + pushVal $ case val of + (IVal i) -> IVal $ complement i + _ -> error ("cannot apply operator to " ++ (show val)) + continue + EvNeg -> do + val <- popVal + pushVal $ case val of + (IVal i) -> IVal (-i) + (FVal f) -> FVal (-f) + (VVal x y z) -> VVal (-x) (-y) (-z) + (RVal x y z s) -> RVal (-x) (-y) (-z) (-s) + _ -> error ("cannot apply operator to " ++ (show val)) + continue + EvCast t -> do + -- TODO: what are the valid typecasts? + -- TODO: what are the formats? + val <- popVal + pushVal $ case (t,val) of + (LLInteger,IVal i) -> IVal i + (LLInteger,FVal f) -> IVal (truncate f) + (LLInteger,SVal s) -> IVal (parseInt s) + -- TODO: can you cast a key to an int? + (LLFloat,FVal f) -> FVal f + (LLFloat,IVal i) -> FVal (fromInteger $ toInteger i) + (LLFloat,SVal s) -> FVal (parseFloat s) + -- TODO: can you cast a key to a float? + (LLString,v) -> toSVal v + -- TODO: can you cast anything but a string to a key? + (LLVector,SVal s) -> parseVector s + (LLRot,SVal s) -> parseRotation s + (LLList,SVal s) -> LVal [SVal s] + (LLKey,SVal s) -> KVal s + (LLKey,KVal s) -> KVal s + (LLVector, v@(VVal _ _ _)) -> v + (LLRot, v@(RVal _ _ _ _)) -> v + (LLList, LVal l) -> LVal l + continue + EvMkVec -> do + z <- popVal + y <- popVal + x <- popVal + pushVal $ VVal (toFloat x) (toFloat y) (toFloat z) + continue + EvMkRot -> do + s <- popVal + z <- popVal + y <- popVal + x <- popVal + pushVal $ RVal (toFloat x) (toFloat y) (toFloat z) (toFloat s) + continue + +trueCondition (IVal i) = (i /= 0) +trueCondition (FVal f) = (f /= 0) +trueCondition (SVal s) = not (null s) +trueCondition (LVal l) = not (null l) +trueCondition v@(VVal _ _ _) = v /= llcZeroVector +trueCondition r@(RVal _ _ _ _) = r /= llcZeroRotation +trueCondition (KVal k) = k /= nullKey && + case map tr k of + "ffffffff-ffff-ffff-ffff-ffffffffffff" -> True + _ -> False + where tr c = if c `elem` "0123456789abcdef" then 'f' else c +-- TODO: LSL also will parse hex notation for strings and floats... +parseVector s = + case [(VVal x y z,t) | ("<",t0) <- lex s, + (x,t1) <- reads t0, + (",",t2) <- lex t1, + (y,t3) <- reads t2, + (",",t4) <- lex t3, + (z,t5) <- reads t4, + (">",t) <- lex t5] of + [] -> VVal 0.0 0.0 0.0 + (v,_):_ -> v +parseRotation s = + case [(RVal x y z w,t) | ("<",t0) <- lex s, + (x,t1) <- reads t0, + (",",t2) <- lex t1, + (y,t3) <- reads t2, + (",",t4) <- lex t3, + (z,t5) <- reads t4, + (",",t6) <- lex t5, + (w,t7) <- reads t6, + (">",t) <- lex t7] of + [] -> RVal 0.0 0.0 0.0 0.0 + (v,_):_ -> v + +toLslBool bool = IVal (if bool then 1 else 0) +evalBinary f = + do val1 <- popVal + val2 <- popVal + pushVal $ f val1 val2 + return EvalIncomplete + +pushUnary evalElement expr = pushElements [evalElement,EvExpr $ ctxItem expr] +pushBinary evalElement expr1 expr2 = pushElements [evalElement,EvExpr $ ctxItem expr1,EvExpr $ ctxItem expr2] +pushModBy var evalElement expr = pushElements [EvSet $ ctxVr2Vr var,evalElement,EvGet $ ctxVr2Vr var,EvExpr expr] + +evalPredef' name = + do (LVal args) <- popVal + let args' = case find (\ (fname,_,_) -> name == fname) funcSigs of + Nothing -> args + Just (_,_,argTypes) -> convertArgs argTypes args + key <- getMyPrimKey + sid <- getScriptName + oid <- getObjectId + pid <- getPrimId + event <- getCurrentEvent + let scriptInfo = ScriptInfo oid pid sid key event + (evalResult,retval) <- doAction name scriptInfo args' + pushVal retval + return evalResult + where convertArgs argTypes args = zipWith convertArg argTypes args + convertArg LLFloat (IVal i) = FVal $ fromInt i + convertArg LLInteger (FVal f) = IVal $ floor f + convertArg LLKey (SVal s) = KVal s + convertArg LLString (KVal k) = SVal k + convertArg _ v = v + +ctxList es = map (Ctx UnknownSourceContext) es + +data ExecutionInfo = ExecutionInfo String Int FrameInfo deriving (Show) + +hasActiveHandler simage handler = + case find ( \ (State ctxname _) -> curState simage == ctxItem ctxname) (states simage) of + Nothing -> False + Just (State _ handlers) -> isJust $ find (\ (Handler ctxname _ _) -> handler == ctxItem ctxname) handlers diff --git a/Language/Lsl/Internal/ExecInfo.hs b/Language/Lsl/Internal/ExecInfo.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/ExecInfo.hs @@ -0,0 +1,51 @@ +module Language.Lsl.Internal.ExecInfo(emitExecutionInfo) where + +import Language.Lsl.Internal.Exec(ExecutionInfo(..),FrameInfo(..)) +import Language.Lsl.Syntax(SourceContext(..)) +import Language.Lsl.Internal.Type(LSLValue(..)) +import Language.Lsl.Internal.XmlCreate(emit,emitSimple) + +emitExecutionInfo (ExecutionInfo name line threadInfo) = + emit "script-state" [] [emitSimple "sourceElement" [] name, + emitSimple "currentLine" [] (show line), + emitThreadInfo threadInfo] + +emitThreadInfo (FrameInfo name frames) = + emit "threadInfo" [] [emitSimple "name" [] name, + emitFrames frames] + +emitFrames frames = + emit "frames" [] (map emitFrame frames) + +emitFrame (name,ctx,line,bindings) = + emit "frame" [] [emitSimple "name" [] name, + emitCtx ctx, + emitLine line, + emit "bindings" [] (map emitBinding bindings)] + where emitCtx UnknownSourceContext = id + emitCtx ctx = emitSimple "file" [] ( textName ctx ) + emitLine Nothing = id + emitLine (Just i) = emitSimple "line" [] (show i) + +emitBinding (name,val) = + emit "binding" [] [emitSimple "name" [] name, + emitVal val] + +emitVal' t s = emitSimple "val" [("class",t)] s +emitVal (IVal i) = emitVal' "integer-value" (show i) +emitVal (FVal f) = emitVal' "float-value" (show f) +emitVal (SVal s) = emitVal' "string-value" s +emitVal (KVal s) = emitVal' "key-value" s +emitVal (VVal x y z) = + emit "val" [("class","vector-value")] + [emitSimple "x" [] (show x), + emitSimple "y" [] (show y), + emitSimple "z" [] (show z)] +emitVal (RVal x y z s) = + emit "val" [("class","rotation-value")] + [emitSimple "x" [] (show x), + emitSimple "y" [] (show y), + emitSimple "z" [] (show z), + emitSimple "s" [] (show s)] +emitVal (LVal l) = + emit "val" [("class","list-value")] [emit "elements" [] (map emitVal l)] diff --git a/Language/Lsl/Internal/ExpressionHandler.hs b/Language/Lsl/Internal/ExpressionHandler.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/ExpressionHandler.hs @@ -0,0 +1,350 @@ +{-# OPTIONS_GHC -XFlexibleContexts #-} +module Language.Lsl.Internal.ExpressionHandler(validateExpression,evaluateExpression) where + +import Control.Monad.Error +import Data.Bits +import IO + +import Language.Lsl.Internal.Constants +import Language.Lsl.Internal.DOMProcessing +import Language.Lsl.Parse +import Language.Lsl.Syntax +import Language.Lsl.Internal.Type +import Language.Lsl.Internal.Util +import Language.Lsl.Internal.XmlCreate hiding (emit) +import qualified Language.Lsl.Internal.XmlCreate as E + +emit s = E.emit s [] + +validPrimitiveCtxExpr (Ctx _ expr) = validPrimitiveExpr expr + +validPrimitiveExpr (Get (Ctx _ name,All)) = findConstType name +validPrimitiveExpr (Neg expr) = + do t <- validPrimitiveCtxExpr expr + when (t `notElem` [LLFloat,LLInteger,LLVector,LLRot]) $ fail "operator only valid for integer, float, vector, and rotation expressions" + return t +validPrimitiveExpr (Inv expr) = + do t <- validPrimitiveCtxExpr expr + when (t /= LLInteger) $ fail "operator only valid for integer expressions" + return LLInteger +validPrimitiveExpr (Not expr) = + do t <- validPrimitiveCtxExpr expr + when (t /= LLInteger) $ fail "operator only valid for integer expressions" + return LLInteger +validPrimitiveExpr (IntLit i) = return LLInteger +validPrimitiveExpr (FloatLit f) = return LLFloat +validPrimitiveExpr (StringLit s) = return LLString +validPrimitiveExpr (KeyLit k) = return LLKey +validPrimitiveExpr (VecExpr x y z) = do + t0 <- validPrimitiveCtxExpr x + t1 <- validPrimitiveCtxExpr y + t2 <- validPrimitiveCtxExpr z + when (not (all (`elem` [LLInteger,LLFloat]) [t0,t1,t2])) $ fail "vector expression must contain only integer or float components" + return LLVector +validPrimitiveExpr (RotExpr x y z s) = do + t0 <- validPrimitiveCtxExpr x + t1 <- validPrimitiveCtxExpr y + t2 <- validPrimitiveCtxExpr z + t3 <- validPrimitiveCtxExpr s + when (not (all (`elem` [LLInteger,LLFloat]) [t0,t1,t2,t3])) $ fail "vector expression must contain only integer or float components" + return LLRot +validPrimitiveExpr (ListExpr l) = do + ts <- mapM validPrimitiveCtxExpr l + when (LLList `elem` ts) $ fail "lists can't contain lists" + return LLList +validPrimitiveExpr (Add e0 e1) = + do (t0,t1) <- validPrimEach e0 e1 + case (t0,t1) of + (LLInteger,LLFloat) -> return LLFloat + (LLFloat,LLInteger) -> return LLFloat + (LLFloat,LLFloat) -> return LLFloat + (LLInteger,LLInteger) -> return LLInteger + (LLVector,LLVector) -> return LLVector + (LLRot,LLRot) -> return LLVector + (LLString,LLString) -> return LLString + _ -> fail "incompatible operands" +validPrimitiveExpr (Sub e0 e1) = + do (t0,t1) <- validPrimEach e0 e1 + case (t0,t1) of + (LLInteger,LLFloat) -> return LLFloat + (LLInteger,LLInteger) -> return LLInteger + (LLFloat,LLInteger) -> return LLFloat + (LLFloat,LLFloat) -> return LLFloat + (LLVector,LLVector) -> return LLVector + (LLRot,LLRot) -> return LLRot + _ -> fail "incompatible operands" +validPrimitiveExpr (Mul e0 e1) = + do (t0,t1) <- validPrimEach e0 e1 + case (t0,t1) of + (LLInteger,LLFloat) -> return LLFloat + (LLFloat,LLFloat) -> return LLFloat + (LLInteger,LLInteger) -> return LLInteger + (LLFloat,LLInteger) -> return LLFloat + (LLFloat,LLVector) -> return LLVector + (LLVector,LLFloat) -> return LLVector + (LLInteger,LLVector) -> return LLVector + (LLVector,LLInteger) -> return LLVector + (LLVector,LLRot) -> return LLVector + (LLRot,LLRot) -> return LLRot + _ -> fail "incompatible operands" +validPrimitiveExpr (Div e0 e1) = + do (t0,t1) <- validPrimEach e0 e1 + case (t0,t1) of + (LLInteger,LLInteger) -> return LLInteger + (LLInteger,LLFloat) -> return LLFloat + (LLFloat,LLInteger) -> return LLFloat + (LLFloat,LLFloat) -> return LLFloat + (LLVector,LLInteger) -> return LLVector + (LLVector,LLFloat) -> return LLVector + (LLVector,LLRot) -> return LLVector + (LLRot,LLRot) -> return LLRot + _ -> fail "incompatible operands" +validPrimitiveExpr (Mod e0 e1) = + do (t0,t1) <- validPrimEach e0 e1 + case (t0,t1) of + (LLInteger,LLInteger) -> return LLInteger + (LLVector,LLVector) -> return LLVector + _ -> fail "incompatible operands" +validPrimitiveExpr (BAnd e0 e1) = validIntegerExpr e0 e1 +validPrimitiveExpr (BOr e0 e1) = validIntegerExpr e0 e1 +validPrimitiveExpr (Xor e0 e1) = validIntegerExpr e0 e1 +validPrimitiveExpr (ShiftL e0 e1) = validIntegerExpr e0 e1 +validPrimitiveExpr (ShiftR e0 e1) = validIntegerExpr e0 e1 +validPrimitiveExpr (And e0 e1) = validIntegerExpr e0 e1 +validPrimitiveExpr (Or e0 e1) = validIntegerExpr e0 e1 +validPrimitiveExpr (Equal e0 e1) = validEqExpr e0 e1 +validPrimitiveExpr (NotEqual e0 e1) = validEqExpr e0 e1 +validPrimitiveExpr (Lt e0 e1) = validRelExpr e0 e1 +validPrimitiveExpr (Le e0 e1) = validRelExpr e0 e1 +validPrimitiveExpr (Gt e0 e1) = validRelExpr e0 e1 +validPrimitiveExpr (Ge e0 e1) = validRelExpr e0 e1 +validPrimitiveExpr expr = fail "expression not valid in this context" + +validPrimEach e0 e1 = + do t0 <- validPrimitiveCtxExpr e0 + t1 <- validPrimitiveCtxExpr e1 + return (t0,t1) + +validIntegerExpr e0 e1 = + do (t0,t1) <- validPrimEach e0 e1 + case (t0,t1) of + (LLInteger,LLInteger) -> return LLInteger + _ -> fail "incompatible operands" + +validRelExpr e0 e1 = + do (t0,t1) <- validPrimEach e0 e1 + case (t0,t1) of + (LLInteger,LLFloat) -> return LLInteger + (LLFloat,LLInteger) -> return LLInteger + (LLFloat,LLFloat) -> return LLInteger + (LLInteger,LLInteger) -> return LLInteger + _ -> fail "incompatible operands" + +validEqExpr e0 e1 = + do (t0,t1) <- validPrimEach e0 e1 + case (t0,t1) of + (LLInteger,LLFloat) -> return LLInteger + (LLInteger,LLInteger) -> return LLInteger + (LLFloat,LLFloat) -> return LLInteger + (LLFloat,LLInteger) -> return LLInteger + (LLString,LLString) -> return LLInteger + (LLKey,LLKey) -> return LLInteger + _ -> fail "incompatible operands" + +checkExpr t text = + case exprParser text of + Left _ -> fail "syntax error" + Right expr -> + case validPrimitiveCtxExpr expr of + Right t' -> + case (t,t') of + (LLString,LLKey) -> return expr + (LLKey,LLString) -> return expr + (LLFloat,LLInteger) -> return expr + (t,t') | t == t' -> return expr + | otherwise -> fail (lslTypeString t ++ " expected") + Left s -> fail s + +evaluateExpression t text = + case checkExpr t text of + Left s -> fail s + Right expr -> + do v <- evalCtxExpr expr + case (t,v) of + (LLKey,SVal s) -> return $ KVal s + (LLString,KVal k) -> return $ SVal k + (LLFloat,IVal i) -> return $ FVal (fromInt i) + _ -> return v + +unexpectedValue :: Monad m => m a +unexpectedValue = fail "unexpected value" + +evalCtxExpr (Ctx _ expr) = evalExpr expr + +evalExpr (Get (Ctx _ name,All)) = findConstVal name +evalExpr (Neg expr) = + do v <- evalCtxExpr expr + case v of + (IVal i) -> return (IVal (-i)) + (FVal f) -> return (FVal (-f)) + _ -> unexpectedValue +evalExpr (Inv expr) = + do t <- evalCtxExpr expr + case t of + (IVal i) -> return (IVal $ complement i) + _ -> unexpectedValue +evalExpr (Not expr) = + do t <- evalCtxExpr expr + case t of + (IVal i) -> return $ IVal (if i == 0 then 1 else 0) +evalExpr (IntLit i) = return (IVal i) +evalExpr (FloatLit f) = return (FVal f) +evalExpr (StringLit s) = return (SVal s) +evalExpr (KeyLit k) = return (KVal k) +evalExpr (VecExpr xExpr yExpr zExpr) = + do x <- evalCtxExpr xExpr + y <- evalCtxExpr yExpr + z <- evalCtxExpr zExpr + return (VVal (toFloat x) (toFloat y) (toFloat z)) +evalExpr (RotExpr xExpr yExpr zExpr sExpr) = + do x <- evalCtxExpr xExpr + y <- evalCtxExpr yExpr + z <- evalCtxExpr zExpr + s <- evalCtxExpr sExpr + return (RVal (toFloat x) (toFloat y) (toFloat z) (toFloat s)) +evalExpr (ListExpr l) = + do vals <- mapM evalCtxExpr l + return (LVal vals) +evalExpr (Add e0 e1) = + do (v0,v1) <- evalEach e0 e1 + case (v0,v1) of + (IVal i,FVal f) -> return $ FVal (f + fromInt i) + (FVal f,IVal i) -> return $ FVal (f + fromInt i) + (FVal f0,FVal f1) -> return $ FVal (f0 + f1) + (IVal i0,IVal i1) -> return $ IVal (i0 + i1) + (SVal s0,SVal s1) -> return $ SVal (s0 ++ s1) + (VVal x y z,VVal x' y' z') -> return $ VVal (x + x') (y + y') (z + z') + (RVal x1 y1 z1 s1,RVal x2 y2 z2 s2) -> return $ RVal (x1 + x2) (y1 + y2) (z1 + z2) (s1 + s2) + _ -> fail "incompatible operands" +evalExpr (Sub e0 e1) = + do (v0,v1) <- evalEach e0 e1 + case (v0,v1) of + (IVal i1,IVal i2) -> return $ IVal (i1 - i2) + (IVal i1,FVal f2) -> return $ FVal (fromInt i1 - f2) + (FVal f1,IVal i2) -> return $ FVal (f1 - fromInt i2) + (FVal f1,FVal f2) -> return $ FVal (f1 - f2) + (VVal x1 y1 z1,VVal x2 y2 z2) -> return $ VVal (x1 - x2) (y1 - y2) (z1 - z2) + (RVal x1 y1 z1 s1,RVal x2 y2 z2 s2) -> return $ RVal (x1 - x2) (y1 - y2) (z1 - z2) (s1 - s2) + _ -> fail "incompatible operands" +evalExpr (Mul e0 e1) = + do (v0,v1) <- evalEach e0 e1 + case (v0,v1) of + (IVal i1,IVal i2) -> return $ IVal (i1*i2) + (IVal i1,FVal f2) -> return $ FVal (fromInt i1 * f2) + (FVal f1,IVal i2) -> return $ FVal (f1 * fromInt i2) + (FVal f1,FVal f2) -> return $ FVal (f1 * f2) + (v@(VVal _ _ _),IVal i) -> let f = fromInt i in return $ vecMulScalar v f + (v@(VVal _ _ _),FVal f) -> return $ vecMulScalar v f + ((VVal x1 y1 z1),(VVal x2 y2 z2)) -> return $ FVal $ x1 * x2 + y1 * y2 + z1 * z2 + (v@(VVal _ _ _),r@(RVal _ _ _ _)) -> return $ rotMulVec r v + (r1@(RVal _ _ _ _),r2@(RVal _ _ _ _)) -> return $ rotMul r1 r2 + _ -> fail "incompatible operands" +evalExpr (Div e0 e1) = + do (v0,v1) <- evalEach e0 e1 + case (v0,v1) of + (IVal i1,IVal i2) -> return $ IVal (i1 `div` i2) -- TODO: how does SL handle divide by zero? + (IVal i1,FVal f2) -> return $ FVal (fromInt i1 / f2) + (FVal f1,IVal i2) -> return $ FVal (f1 / fromInt i2) + (FVal f1,FVal f2) -> return $ FVal (f1/f2) + (v@(VVal _ _ _),IVal i) -> let f = 1.0 / fromInt i in return $ vecMulScalar v f + (v@(VVal _ _ _),FVal f) -> return $ vecMulScalar v f + (v@(VVal _ _ _),r@(RVal _ _ _ _)) -> return $ rotMulVec (invRot r) v + (r1@(RVal _ _ _ _),r2@(RVal _ _ _ _)) -> return $ rotMul r1 $ invRot r2 + _ -> fail "incompatible operands" +evalExpr (Mod e0 e1) = + do (v0,v1) <- evalEach e0 e1 + case (v0,v1) of + (IVal i1,IVal i2) -> return $ IVal (i1 `mod` i2) + (v1@(VVal _ _ _),v2@(VVal _ _ _)) ->return $ v1 `vcross` v2 + _ -> fail "incompatible operands" +evalExpr (BAnd e0 e1) = evalIntExpr (.&.) e0 e1 +evalExpr (BOr e0 e1) = evalIntExpr (.|.) e0 e1 +evalExpr (Xor e0 e1) = evalIntExpr xor e0 e1 +evalExpr (ShiftL e0 e1) = evalIntExpr shiftL e0 e1 +evalExpr (ShiftR e0 e1) = evalIntExpr shiftR e0 e1 +evalExpr (And e0 e1) = evalIntExpr (\ x y -> if x /= 0 && y /= 0 then 1 else 0) e0 e1 +evalExpr (Or e0 e1) = evalIntExpr (\ x y -> if x /= 0 || y /= 0 then 1 else 0) e0 e1 +evalExpr (Equal e0 e1) = evalEqExpr (==) e0 e1 +evalExpr (NotEqual e0 e1) = evalEqExpr (/=) e0 e1 +evalExpr (Lt e0 e1) = evalRelExpr (<) (<) e0 e1 +evalExpr (Le e0 e1) = evalRelExpr (<=) (<=) e0 e1 +evalExpr (Gt e0 e1) = evalRelExpr (>) (>) e0 e1 +evalExpr (Ge e0 e1) = evalRelExpr (>=) (>=) e0 e1 +evalExpr expr = fail "expression not valid in this context" + +evalArithExpr fi ff e0 e1 = + do (v0,v1) <- evalEach e0 e1 + case (v0,v1) of + (IVal i0, IVal i1) -> return $ IVal (fi i0 i1) + (FVal f0, IVal i1) -> return $ FVal (ff f0 $ fromInt i1) + (FVal f0, FVal f1) -> return $ FVal (ff f0 f1) + (IVal i0, FVal f1) -> return $ FVal (ff (fromInt i0) f1) + +evalEqExpr f e0 e1 = + do (v0,v1) <- evalEach e0 e1 + let b = case (v0,v1) of + (FVal f0, IVal i1) -> f (FVal f0) (FVal $ fromInt i1) + (IVal i0, FVal f1) -> f (FVal $ fromInt i0) (FVal f1) + (SVal s, KVal k) -> f (SVal s) (SVal k) + (KVal k, SVal s) -> f (SVal s) (SVal k) + (x,y) -> f x y + return $ IVal $ if b then 1 else 0 + +evalRelExpr fi ff e0 e1 = + do (v0,v1) <- evalEach e0 e1 + let b = case (v0,v1) of + (FVal f, IVal i) -> ff f (fromInt i) + (IVal i, FVal f) -> ff (fromInt i) f + (FVal f0, FVal f1) -> ff f0 f1 + (IVal i0, IVal i1) -> fi i0 i1 + return $ IVal $ if b then 1 else 0 + +evalIntExpr f e0 e1 = + do (IVal i0, IVal i1) <- evalEach e0 e1 + return $ IVal $ f i0 i1 + +evalEach e0 e1 = + do v0 <- evalCtxExpr e0 + v1 <- evalCtxExpr e1 + return (v0,v1) + +extractExpressionFromXML s = + let doc = xmlParse "" s in processDOMExpr doc + +processDOMExpr (Document _ _ root _) = + case match expressionElementAcceptor root of + Left s -> error s + Right v -> v + +expressionElementAcceptor :: MonadError String m => ElemAcceptor m (String,String) +expressionElementAcceptor = + let f (Elem _ _ contents) = do + (t,contents1) <- findElement (ElemAcceptor "type" simple) (elementsOnly contents) + (text,[]) <- findElement (ElemAcceptor "text" simple) contents1 + return (t,text) + in ElemAcceptor "expression" f + +expressionValidatorEmitter (Left s) = + (emit "result" [ emit "ok" [showString "false"], emit "msg" [showString $ xmlEscape s]]) "" +expressionValidatorEmitter (Right _) = + (emit "result" [ emit "ok" [showString "true"]]) "" + +validateExpression hIn hOut = + do input <- hGetContents hIn + let (tstring,text) = extractExpressionFromXML input + let t = case parseType tstring of + Right v -> v + Left s -> error (show s) + putStr $ expressionValidatorEmitter (checkExpr t text) + + diff --git a/Language/Lsl/Internal/FuncSigs.hs b/Language/Lsl/Internal/FuncSigs.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/FuncSigs.hs @@ -0,0 +1,686 @@ +module Language.Lsl.Internal.FuncSigs( + funcDescriptions, + funcMeta, + funcSigs) where + +import Language.Lsl.Internal.Type(LSLType(..)) + +-- TODO: import real info into funcMeta, and derive funcSigs from that +funcMeta :: [(String,LSLType,[(String,LSLType)],String)] +funcMeta = + let dummyNames = zipWith (++) (repeat "arg") (map show [1..]) + sig2Meta (name,rt,args) = + let (argNames,description) = case lookup name funcDescriptions of + Nothing -> (dummyNames,"no description") + Just (names,desc) -> (names ++ dummyNames,desc) + in (name, rt,zip argNames args,description) + in map sig2Meta funcSigs + +funcSigs :: [(String,LSLType,[LSLType])] +funcSigs = [ + ("llAbs",LLInteger,[LLInteger]), + ("llAcos",LLFloat,[LLFloat]), + ("llAddToLandBanList",LLVoid,[LLKey, LLFloat]), + ("llAddToLandPassList",LLVoid,[LLKey, LLFloat]), + ("llAdjustSoundVolume",LLVoid,[LLFloat]), + ("llAllowInventoryDrop",LLVoid,[LLInteger]), + ("llAngleBetween",LLFloat,[LLRot,LLRot]), + ("llApplyImpulse",LLVoid,[LLVector,LLInteger]), + ("llApplyRotationalImpulse",LLVoid,[LLVector,LLInteger]), + ("llAsin",LLFloat,[LLFloat]), + ("llAtan2",LLFloat,[LLFloat,LLFloat]), + ("llAttachToAvatar",LLVoid,[LLInteger]), + ("llAvatarOnSitTarget",LLKey,[]), + ("llAxes2Rot",LLRot,[LLVector,LLVector,LLVector]), + ("llAxisAngle2Rot",LLRot,[LLVector,LLFloat]), + ("llBase64ToInteger",LLInteger,[LLString]), + ("llBase64ToString",LLString,[LLString]), + ("llBreakAllLinks",LLVoid,[]), + ("llBreakLink",LLVoid,[LLInteger]), + ("llCSV2List",LLList,[LLString]), + ("llCeil",LLInteger,[LLFloat]), + ("llClearCameraParams",LLVoid,[]), + ("llCloseRemoteDataChannel",LLVoid,[LLKey]), + ("llCloud",LLFloat,[LLVector]), + ("llCollisionFilter",LLVoid,[LLString,LLKey,LLInteger]), + ("llCollisionSound",LLVoid,[LLString,LLFloat]), + ("llCollisionSprite",LLVoid,[LLString]), + ("llCos",LLFloat,[LLFloat]), + ("llCreateLink",LLVoid,[LLKey,LLInteger]), + ("llDeleteSubList",LLList,[LLList,LLInteger,LLInteger]), + ("llDeleteSubString",LLString,[LLString,LLInteger,LLInteger]), + ("llDetachFromAvatar",LLVoid,[]), + ("llDetectedGrab",LLVector,[LLInteger]), + ("llDetectedGroup",LLInteger,[LLInteger]), + ("llDetectedKey",LLKey,[LLInteger]), + ("llDetectedLinkNumber",LLInteger,[LLInteger]), + ("llDetectedName",LLString,[LLInteger]), + ("llDetectedOwner",LLKey,[LLInteger]), + ("llDetectedPos",LLVector,[LLInteger]), + ("llDetectedRot",LLRot,[LLInteger]), + ("llDetectedType",LLInteger,[LLInteger]), + ("llDetectedVel",LLVector,[LLInteger]), + ("llDialog",LLVoid,[LLKey,LLString,LLList,LLInteger]), + ("llDie",LLVoid,[]), + ("llDumpList2String",LLString,[LLList,LLString]), + ("llEdgeOfWorld",LLInteger,[LLVector,LLVector]), + ("llEjectFromLand",LLVoid,[LLKey]), + ("llEmail",LLVoid,[LLString,LLString,LLString]), + ("llEscapeURL",LLString,[LLString]), + ("llEuler2Rot",LLRot,[LLVector]), + ("llFabs",LLFloat,[LLFloat]), + ("llFloor",LLInteger,[LLFloat]), + ("llForceMouselook",LLVoid,[LLInteger]), + ("llFrand",LLFloat,[LLFloat]), + ("llGetAccel",LLVector,[]), + ("llGetAgentInfo",LLInteger,[LLKey]), + ("llGetAgentSize",LLVector,[LLKey]), + ("llGetAlpha",LLFloat,[LLInteger]), + ("llGetAndResetTime",LLFloat,[]), + ("llGetAnimation",LLString,[LLKey]), + ("llGetAnimationList",LLList,[LLKey]), + ("llGetAttached",LLInteger,[]), + ("llGetBoundingBox",LLList,[LLKey]), + ("llGetCameraPos",LLVector,[]), + ("llGetCameraRot",LLRot,[]), + ("llGetCenterOfMass",LLVector,[]), + ("llGetColor",LLVector,[LLInteger]), + ("llGetCreator",LLKey,[]), + ("llGetDate",LLString,[]), + ("llGetEnergy",LLFloat,[]), + ("llGetForce",LLVector,[]), + ("llGetFreeMemory",LLInteger,[]), -- SEMI-INTERNAL!!! + ("llGetGMTclock",LLFloat,[]), + ("llGetGeometricCenter",LLVector,[]), + ("llGetInventoryCreator",LLKey,[LLString]), + ("llGetInventoryKey",LLKey,[LLString]), + ("llGetInventoryName",LLString,[LLInteger,LLInteger]), + ("llGetInventoryNumber",LLInteger,[LLInteger]), + ("llGetInventoryPermMask",LLInteger,[LLString,LLInteger]), + ("llGetInventoryType",LLInteger,[LLString]), + ("llGetKey",LLKey,[]), + ("llGetLandOwnerAt",LLKey,[LLVector]), + ("llGetLinkKey",LLKey,[LLInteger]), + ("llGetLinkName",LLString,[LLInteger]), + ("llGetLinkNumber",LLInteger,[]), + ("llGetListEntryType",LLInteger,[LLList,LLInteger]), + ("llGetListLength",LLInteger,[LLList]), + ("llGetLocalPos",LLVector,[]), + ("llGetLocalRot",LLRot,[]), + ("llGetMass",LLFloat,[]), + ("llGetNextEmail",LLVoid,[LLString,LLString]), + ("llGetNotecardLine",LLKey,[LLString,LLInteger]), + ("llGetNumberOfNotecardLines",LLKey,[LLString]), + ("llGetNumberOfPrims",LLInteger,[]), + ("llGetNumberOfSides",LLInteger,[]), + ("llGetObjectDesc",LLString,[]), + ("llGetObjectDetails",LLList,[LLKey,LLList]), + ("llGetObjectMass",LLFloat,[LLKey]), + ("llGetObjectName",LLString,[]), + ("llGetObjectPermMask",LLInteger,[LLInteger]), + ("llGetObjectPrimCount",LLInteger,[LLKey]), + ("llGetOmega",LLVector,[]), + ("llGetOwner",LLKey,[]), + ("llGetOwnerKey",LLKey,[LLKey]), + ("llGetParcelDetails",LLList,[LLVector,LLList]), + ("llGetParcelFlags",LLInteger,[LLVector]), + ("llGetParcelMaxPrims",LLInteger,[LLVector,LLInteger]), + ("llGetParcelPrimCount",LLInteger,[LLVector,LLInteger,LLInteger]), + ("llGetParcelPrimOwners",LLList,[LLVector]), + ("llGetPermissions",LLInteger,[]), + ("llGetPermissionsKey",LLKey,[]), + ("llGetPos",LLVector,[]), + ("llGetPrimitiveParams",LLList,[LLList]), + ("llGetRegionCorner",LLVector,[]), + ("llGetRegionFPS",LLFloat,[]), + ("llGetRegionFlags",LLInteger,[]), + ("llGetRegionName",LLString,[]), + ("llGetRegionTimeDilation",LLFloat,[]), + ("llGetRootPosition",LLVector,[]), + ("llGetRootRotation",LLRot,[]), + ("llGetRot",LLRot,[]), + ("llGetScale",LLVector,[]), + ("llGetScriptName",LLString,[]), + ("llGetScriptState",LLInteger,[LLString]), + ("llGetSimulatorHostname",LLString,[]), + ("llGetStartParameter",LLInteger,[]), + ("llGetStatus",LLInteger,[LLInteger]), + ("llGetSubString",LLString,[LLString,LLInteger,LLInteger]), + ("llGetSunDirection",LLVector,[]), + ("llGetTexture",LLString,[LLInteger]), + ("llGetTextureOffset",LLVector,[LLInteger]), + ("llGetTextureRot",LLFloat,[LLInteger]), + ("llGetTextureScale",LLVector,[LLInteger]), + ("llGetTime",LLFloat,[]), + ("llGetTimeOfDay",LLFloat,[]), + ("llGetTimestamp",LLString,[]), + ("llGetTorque",LLVector,[]), + ("llGetUnixTime",LLInteger,[]), + ("llGetVel",LLVector,[]), + ("llGetWallclock",LLFloat,[]), + ("llGiveInventory",LLVoid,[LLKey,LLString]), + ("llGiveInventoryList",LLVoid,[LLKey,LLString,LLList]), + ("llGiveMoney",LLInteger,[LLKey,LLInteger]), + ("llGodLikeRezObject",LLVoid,[LLKey,LLVector]), + ("llGround",LLFloat,[LLVector]), + ("llGroundContour",LLVector,[LLVector]), + ("llGroundNormal",LLVector,[LLVector]), + ("llGroundRepel",LLVoid,[LLFloat,LLInteger,LLFloat]), + ("llGroundSlope",LLVector,[LLVector]), + ("llHTTPRequest",LLKey,[LLString,LLList,LLString]), + ("llInsertString",LLString,[LLString,LLInteger,LLString]), + ("llInstantMessage",LLVoid,[LLKey,LLString]), + ("llIntegerToBase64",LLString,[LLInteger]), + ("llKey2Name",LLString,[LLKey]), + ("llList2CSV",LLString,[LLList]), + ("llList2Float",LLFloat,[LLList,LLInteger]), + ("llList2Integer",LLInteger,[LLList,LLInteger]), + ("llList2Key",LLKey,[LLList,LLInteger]), + ("llList2List",LLList,[LLList,LLInteger,LLInteger]), + ("llList2ListStrided",LLList,[LLList,LLInteger,LLInteger,LLInteger]), + ("llList2Rot",LLRot,[LLList,LLInteger]), + ("llList2String",LLString,[LLList,LLInteger]), + ("llList2Vector",LLVector,[LLList,LLInteger]), + ("llListFindList",LLInteger,[LLList,LLList]), + ("llListInsertList",LLList,[LLList,LLList,LLInteger]), + ("llListRandomize",LLList,[LLList,LLInteger]), + ("llListReplaceList",LLList,[LLList,LLList,LLInteger,LLInteger]), + ("llListSort",LLList,[LLList,LLInteger,LLInteger]), + ("llListStatistics",LLFloat,[LLInteger,LLList]), + ("llListen",LLInteger,[LLInteger,LLString,LLKey,LLString]), + ("llListenControl",LLVoid,[LLInteger,LLInteger]), + ("llListenRemove",LLVoid,[LLInteger]), + ("llLoadURL",LLVoid,[LLKey,LLString,LLString]), + ("llLog",LLFloat,[LLFloat]), + ("llLog10",LLFloat,[LLFloat]), + ("llLookAt",LLVoid,[LLVector,LLFloat,LLFloat]), + ("llLoopSound",LLVoid,[LLString,LLFloat]), + ("llLoopSoundMaster",LLVoid,[LLString,LLFloat]), + ("llLoopSoundSlave",LLVoid,[LLString,LLFloat]), + ("llMD5String",LLString,[LLString,LLInteger]), + ("llMakeExplosion",LLVoid,[LLInteger,LLFloat,LLFloat,LLFloat,LLFloat,LLString,LLVector]), + ("llMakeFire",LLVoid,[LLInteger,LLFloat,LLFloat,LLFloat,LLFloat,LLString,LLVector]), + ("llMakeFountain",LLVoid,[LLInteger,LLFloat,LLFloat,LLFloat,LLFloat,LLInteger,LLString,LLVector,LLFloat]), + ("llMakeSmoke",LLVoid,[LLInteger,LLFloat,LLFloat,LLFloat,LLFloat,LLString,LLVector]), + ("llMapDestination",LLVoid,[LLString,LLVector,LLVector]), + ("llMessageLinked",LLVoid,[LLInteger,LLInteger,LLString,LLKey]), + ("llMinEventDelay",LLVoid,[LLFloat]), + ("llModPow",LLInteger,[LLInteger,LLInteger,LLInteger]), + ("llModifyLand",LLVoid,[LLInteger,LLInteger]), + ("llMoveToTarget",LLVoid,[LLVector,LLFloat]), + ("llOffsetTexture",LLVoid,[LLFloat,LLFloat,LLInteger]), + ("llOpenRemoteDataChannel",LLVoid,[]), + ("llOverMyLand",LLInteger,[LLKey]), + ("llOwnerSay",LLVoid,[LLString]), + ("llParcelMediaCommandList",LLVoid,[LLList]), + ("llParcelMediaQuery",LLList,[LLList]), + ("llParseString2List",LLList,[LLString,LLList,LLList]), + ("llParseStringKeepNulls",LLList,[LLString,LLList,LLList]), + ("llParticleSystem",LLVoid,[LLList]), + ("llPassCollisions",LLVoid,[LLInteger]), + ("llPassTouches",LLVoid,[LLInteger]), + ("llPlaySound",LLVoid,[LLString,LLFloat]), + ("llPlaySoundSlave",LLVoid,[LLString,LLFloat]), + ("llPointAt",LLVoid,[LLVector]), + ("llPow",LLFloat,[LLFloat,LLFloat]), + ("llPreloadSound",LLVoid,[LLString]), + ("llPushObject",LLVoid,[LLKey,LLVector,LLVector,LLInteger]), + ("llRefreshPrimURL",LLVoid,[]), + ("llRegionSay",LLVoid,[LLInteger,LLString]), + ("llReleaseCamera",LLVoid,[LLKey]), + ("llReleaseControls",LLVoid,[]), + ("llRemoteDataReply",LLVoid,[LLKey,LLKey,LLString,LLInteger]), + ("llRemoteDataSetRegion",LLVoid,[]), + ("llRemoteLoadScript",LLVoid,[LLKey,LLString,LLInteger,LLInteger]), -- deprecated/removed + ("llRemoteLoadScriptPin",LLVoid,[LLKey,LLString,LLInteger,LLInteger,LLInteger]), + ("llRemoveFromLandBanList",LLVoid,[LLKey]), + ("llRemoveFromLandPassList",LLVoid,[LLKey]), + ("llRemoveInventory",LLVoid,[LLString]), + ("llRemoveVehicleFlags",LLVoid,[LLInteger]), + ("llRequestAgentData",LLKey,[LLKey,LLInteger]), + ("llRequestInventoryData",LLKey,[LLString]), + ("llRequestPermissions",LLVoid,[LLKey,LLInteger]), + ("llRequestSimulatorData",LLKey,[LLString,LLInteger]), + ("llResetLandBanList",LLVoid,[]), + ("llResetLandPassList",LLVoid,[]), + ("llResetOtherScript",LLVoid,[LLString]), + ("llResetScript",LLVoid,[]), + ("llResetTime",LLVoid,[]), + ("llRezAtRoot",LLVoid,[LLString,LLVector,LLVector,LLRot,LLInteger]), + ("llRezObject",LLVoid,[LLString,LLVector,LLVector,LLRot,LLInteger]), + ("llRot2Angle",LLFloat,[LLRot]), + ("llRot2Axis",LLVector,[LLRot]), + ("llRot2Euler",LLVector,[LLRot]), + ("llRot2Fwd",LLVector,[LLRot]), + ("llRot2Left",LLVector,[LLRot]), + ("llRot2Up",LLVector,[LLRot]), + ("llRotBetween",LLRot,[LLVector,LLVector]), + ("llRotLookAt",LLVoid,[LLRot,LLFloat,LLFloat]), + ("llRotTarget",LLInteger,[LLRot,LLFloat]), + ("llRotTargetRemove",LLVoid,[LLInteger]), + ("llRotateTexture",LLVoid,[LLFloat,LLInteger]), + ("llRound",LLInteger,[LLFloat]), + ("llSameGroup",LLInteger,[LLKey]), + ("llSay",LLVoid,[LLInteger,LLString]), + ("llScaleTexture",LLVoid,[LLFloat,LLFloat,LLInteger]), + ("llScriptDanger",LLInteger,[LLVector]), + ("llSendRemoteData",LLKey,[LLKey,LLString,LLInteger,LLString]), + ("llSensor",LLVoid,[LLString,LLKey,LLInteger,LLFloat,LLFloat]), + ("llSensorRemove",LLVoid,[]), + ("llSensorRepeat",LLVoid,[LLString,LLKey,LLInteger,LLFloat,LLFloat,LLFloat]), + ("llSetAlpha",LLVoid,[LLFloat,LLInteger]), + ("llSetBuoyancy",LLVoid,[LLFloat]), + ("llSetCameraAtOffset",LLVoid,[LLVector]), + ("llSetCameraEyeOffset",LLVoid,[LLVector]), + ("llSetCameraParams",LLVoid,[LLList]), + ("llSetClickAction",LLVoid,[LLInteger]), + ("llSetColor",LLVoid,[LLVector,LLInteger]), + ("llSetDamage",LLVoid,[LLFloat]), + ("llSetForce",LLVoid,[LLVector,LLInteger]), + ("llSetForceAndTorque",LLVoid,[LLVector,LLVector,LLInteger]), + ("llSetHoverHeight",LLVoid,[LLFloat,LLInteger,LLFloat]), + ("llSetLinkAlpha",LLVoid,[LLInteger,LLFloat,LLInteger]), + ("llSetLinkColor",LLVoid,[LLInteger,LLVector,LLInteger]), + ("llSetLinkPrimitiveParams",LLVoid,[LLInteger,LLList]), + ("llSetLinkTexture",LLVoid,[LLInteger,LLString,LLInteger]), + ("llSetLocalRot",LLVoid,[LLRot]), + ("llSetObjectDesc",LLVoid,[LLString]), + ("llSetObjectName",LLVoid,[LLString]), + ("llSetParcelMusicURL",LLVoid,[LLString]), + ("llSetPayPrice",LLVoid,[LLInteger,LLList]), + ("llSetPos",LLVoid,[LLVector]), + ("llSetPrimURL",LLVoid,[LLString]), + ("llSetPrimitiveParams",LLVoid,[LLList]), + ("llSetRemoteScriptAccessPin",LLVoid,[LLInteger]), + ("llSetRot",LLVoid,[LLRot]), + ("llSetScale",LLVoid,[LLVector]), + ("llSetScriptState",LLVoid,[LLString,LLInteger]), + ("llSetSitText",LLVoid,[LLString]), + ("llSetSoundQueueing",LLVoid,[LLInteger]), + ("llSetSoundRadius",LLVoid,[LLFloat]), + ("llSetStatus",LLVoid,[LLInteger,LLInteger]), + ("llSetText",LLVoid,[LLString,LLVector,LLFloat]), + ("llSetTexture",LLVoid,[LLString,LLInteger]), + ("llSetTextureAnim",LLVoid,[LLInteger,LLInteger,LLInteger,LLInteger,LLFloat,LLFloat,LLFloat]), + ("llSetTimerEvent",LLVoid,[LLFloat]), + ("llSetTorque",LLVoid,[LLVector,LLInteger]), + ("llSetTouchText",LLVoid,[LLString]), + ("llSetVehicleFlags",LLVoid,[LLInteger]), + ("llSetVehicleFloatParam",LLVoid,[LLInteger,LLFloat]), + ("llSetVehicleRotationParam",LLVoid,[LLInteger,LLRot]), + ("llSetVehicleType",LLVoid,[LLInteger]), + ("llSetVehicleVectorParam",LLVoid,[LLInteger,LLVector]), + ("llShout",LLVoid,[LLInteger,LLString]), + ("llSin",LLFloat,[LLFloat]), + ("llSitTarget",LLVoid,[LLVector,LLRot]), + ("llSleep",LLVoid,[LLFloat]), + ("llSound",LLVoid,[LLString,LLFloat,LLInteger,LLInteger]), -- deprecated + ("llSoundPreload",LLVoid,[LLString]), + ("llSqrt",LLFloat,[LLFloat]), + ("llStartAnimation",LLVoid,[LLString]), + ("llStopAnimation",LLVoid,[LLString]), + ("llStopHover",LLVoid,[]), + ("llStopLookAt",LLVoid,[]), + ("llStopMoveToTarget",LLVoid,[]), + ("llStopPointAt",LLVoid,[]), + ("llStopSound",LLVoid,[]), + ("llStringLength",LLInteger,[LLString]), + ("llStringToBase64",LLString,[LLString]), + ("llStringTrim",LLString,[LLString,LLInteger]), + ("llSubStringIndex",LLInteger,[LLString,LLString]), + ("llTakeCamera",LLVoid,[LLKey]), + ("llTakeControls",LLVoid,[LLInteger,LLInteger,LLInteger]), + ("llTan",LLFloat,[LLFloat]), + ("llTarget",LLInteger,[LLVector,LLFloat]), + ("llTargetOmega",LLVoid,[LLVector,LLFloat,LLFloat]), + ("llTargetRemove",LLVoid,[LLInteger]), + ("llTeleportAgentHome",LLVoid,[LLKey]), + ("llToLower",LLString,[LLString]), + ("llToUpper",LLString,[LLString]), + ("llTriggerSound",LLVoid,[LLString,LLFloat]), + ("llTriggerSoundLimited",LLVoid,[LLString,LLFloat,LLVector,LLVector]), + ("llUnSit",LLVoid,[LLKey]), + ("llUnescapeURL",LLString,[LLString]), + ("llVecDist",LLFloat,[LLVector,LLVector]), + ("llVecMag",LLFloat,[LLVector]), + ("llVecNorm",LLVector,[LLVector]), + ("llVolumeDetect",LLVoid,[LLInteger]), + ("llWater",LLFloat,[LLVector]), + ("llWhisper",LLVoid,[LLInteger,LLString]), + ("llWind",LLVector,[LLVector]), + ("llXorBase64Strings",LLString,[LLString,LLString]), + ("llXorBase64StringsCorrect",LLString,[LLString,LLString])] + +funcDescriptions = [ + ("llSin",(["theta"],"theta in radians\n")), + ("llCos",(["theta"],"theta in radians\n")), + ("llTan",(["theta"],"theta radians\n")), + ("llAtan2",(["y","x"],"")), + ("llSqrt",(["val"],"returns 0 and triggers a Math Error for imaginary results\n")), + ("llPow",(["base","exponent"],"returns 0 and triggers Math Error for imaginary results\n")), + ("llAbs",(["val"],"")), + ("llFabs",(["val"],"")), + ("llFrand",(["mag"],"returns random number in range [0,mag)\n")), + ("llFloor",(["val"],"returns largest integer value <= val\n")), + ("llCeil",(["val"],"returns smallest integer value >= val\n")), + ("llRound",(["val"],"returns val rounded to the nearest integer\n")), + ("llVecMag",(["v"],"returns the magnitude of v\n")), + ("llVecNorm",(["v"],"returns the v normalized\n")), + ("llVecDist",(["v1","v2"],"returns the 3D distance between v1 and v2\n")), + ("llRot2Euler",(["q"],"returns the Euler representation (roll, pitch, yaw) of q\n")), + ("llEuler2Rot",(["v"],"returns the rotation representation of Euler Angles v\n")), + ("llAxes2Rot",(["fwd","left","up"],"returns the rotation defined by the coordinate axes\n")), + ("llRot2Fwd",(["q"],"returns the forward vector defined by q\n")), + ("llRot2Left",(["q"],"returns the left vector defined by q\n")), + ("llRot2Up",(["q"],"returns the up vector defined by q\n")), + ("llRotBetween",(["v1","v2"],"returns the rotation to rotate v1 to v2\n")), + ("llWhisper",(["channel","msg"],"whispers msg on channel\n")), + ("llSay",(["channel","msg"],"says msg on channel\n")), + ("llRegionSay",(["channel","msg"],"Broadcasts message on the specified chat channel to the whole region.\n")), + ("llShout",(["channel","msg"],"shouts msg on channel\n")), + ("llListen",(["channel","name","id","msg"],"sets a callback for msg on channel from name and id (name, id, and/or msg can be empty) and returns an identifier that can be used to deactivate or remove the listen\n")), + ("llListenControl",(["number","active"],"makes a listen event callback active or inactive\n")), + ("llListenRemove",(["number"],"removes listen event callback number\n")), + ("llSensor",(["name","id","type","range","arc"],"Performs a single scan for name and id with type (AGENT, ACTIVE, PASSIVE, and/or SCRIPTED) within range meters and arc radians of forward vector (name, id, and/or keytype can be empty or 0)\n")), + ("llSensorRepeat",(["name","id","type","range","arc","rate"],"sets a callback for name and id with type (AGENT, ACTIVE, PASSIVE, and/or SCRIPTED) within range meters and arc radians of forward vector (name, id, and/or keytype can be empty or 0) and repeats every rate seconds\n")), + ("llSensorRemove",([],"removes sensor\n")), + ("llDetectedName",(["number"],"returns the name of detected object number (returns empty string if number is not valid sensed object)\n")), + ("llDetectedKey",(["number"],"returns the key of detected object number (returns empty key if number is not valid sensed object)\n")), + ("llDetectedOwner",(["number"],"returns the key of detected object's owner (returns empty key if number is not valid sensed object)\n")), + ("llDetectedType",(["number"],"returns the type (AGENT, ACTIVE, PASSIVE, SCRIPTED) of detected object (returns 0 if number is not valid sensed object)\n")), + ("llDetectedPos",(["number"],"returns the position of detected object number (returns <0,0,0> if number is not valid sensed object)\n")), + ("llDetectedVel",(["number"],"returns the velocity of detected object number (returns <0,0,0> if number is not valid sensed object)\n")), + ("llDetectedGrab",(["number"],"returns the grab offset of the user touching object (returns <0,0,0> if number is not valid sensed object)\n")), + ("llDetectedRot",(["number"],"returns the rotation of detected object number (returns <0,0,0,1> if number is not valid sensed object)\n")), + ("llDetectedGroup",(["number"],"Returns TRUE if detected object is part of same group as owner\n")), + ("llDetectedLinkNumber",(["number"],"returns the link position of the triggered event for touches and collisions only\n")), + ("llDie",([],"deletes the object\n")), + ("llGround",(["v"],"returns the ground height below the object position + v\n")), + ("llCloud",(["v"],"returns the cloud density at the object position + v\n")), + ("llWind",(["v"],"returns the wind velocity at the object position + v\n")), + ("llSetStatus",(["status","value"],"sets status (STATUS_PHYSICS, STATUS_PHANTOM, STATUS_BLOCK_GRAB,\nSTATUS_ROTATE_X, STATUS_ROTATE_Y, and/or STATUS_ROTATE_Z) to value\n")), + ("llGetStatus",(["status"],"gets value of status (STATUS_PHYSICS, STATUS_PHANTOM, STATUS_BLOCK_GRAB,\nSTATUS_ROTATE_X, STATUS_ROTATE_Y, and/or STATUS_ROTATE_Z)\n")), + ("llSetScale",(["scale"],"sets the scale\n")), + ("llGetScale",([],"gets the scale\n")), + ("llSetColor",(["color","face"],"sets the color\n")), + ("llGetAlpha",(["face"],"gets the alpha\n")), + ("llSetAlpha",(["alpha","face"],"sets the alpha\n")), + ("llGetColor",(["face"],"gets the color\n")), + ("llSetTexture",(["texture","face"],"sets the texture of face\n")), + ("llScaleTexture",(["scales","scalet","face"],"sets the texture s, t scales for the chosen face\n")), + ("llOffsetTexture",(["offsets","offsett","face"],"sets the texture s, t offsets for the chosen face\n")), + ("llRotateTexture",(["rotation","face"],"sets the texture rotation for the chosen face\n")), + ("llGetTexture",(["face"],"gets the texture of face (if it's a texture in the object inventory, otherwise the key in a string)\n")), + ("llSetPos",(["pos"],"sets the position (if the script isn't physical)\n")), + ("llGetPos",([],"gets the position (if the script isn't physical)\n")), + ("llGetLocalPos",([],"gets the position relative to the root (if the script isn't physical)\n")), + ("llSetRot",(["rot"],"sets the rotation (if the script isn't physical)\n")), + ("llGetRot",([],"gets the rotation (if the script isn't physical)\n")), + ("llGetLocalRot",([],"gets the rotation local to the root (if the script isn't physical)\n")), + ("llSetForce",(["force","local"],"sets force on object, in local coords if local == TRUE (if the script is physical)\n")), + ("llGetForce",([],"gets the force (if the script is physical)\n")), + ("llTarget",(["position","range"],"set positions within range of position as a target and return an ID for the target\n")), + ("llTargetRemove",(["number"],"removes target number\n")), + ("llRotTarget",(["rot","error"],"set rotations with error of rot as a rotational target and return an ID for the rotational target\n")), + ("llRotTargetRemove",(["number"],"removes rotational target number\n")), + ("llMoveToTarget",(["target","tau"],"critically damp to target in tau seconds (if the script is physical)\n")), + ("llStopMoveToTarget",([],"Stops critically damped motion\n")), + ("llApplyImpulse",(["force","local"],"applies impulse to object, in local coords if local == TRUE (if the script is physical)\n")), + ("llApplyRotationalImpulse",(["force","local"],"applies rotational impulse to object, in local coords if local == TRUE (if the script is physical)\n")), + ("llSetTorque",(["torque","local"],"sets the torque of object, in local coords if local == TRUE (if the script is physical)\n")), + ("llGetTorque",([],"gets the torque (if the script is physical)\n")), + ("llSetForceAndTorque",(["force","torque","local"],"sets the force and torque of object, in local coords if local == TRUE (if the script is physical)\n")), + ("llGetVel",([],"gets the velocity\n")), + ("llGetAccel",([],"gets the acceleration\n")), + ("llGetOmega",([],"gets the omega\n")), + ("llGetTimeOfDay",([],"gets the time in seconds since Second Life server midnight (or since server up-time; whichever is smaller)\n")), + ("llGetWallclock",([],"gets the time in seconds since midnight\n")), + ("llGetTime",([],"gets the time in seconds since creation\n")), + ("llResetTime",([],"sets the time to zero\n")), + ("llGetAndResetTime",([],"gets the time in seconds since creation and sets the time to zero\n")), + ("llSound",(["sound","volume","queue","loop"],"plays sound at volume and whether it should loop or not\n")), + ("llPlaySound",(["sound","volume"],"plays attached sound once at volume (0.0 - 1.0)\n")), + ("llLoopSound",(["sound","volume"],"plays attached sound looping indefinitely at volume (0.0 - 1.0)\n")), + ("llLoopSoundMaster",(["sound","volume"],"plays attached sound looping at volume (0.0 - 1.0), declares it a sync master\n")), + ("llLoopSoundSlave",(["sound","volume"],"plays attached sound looping at volume (0.0 - 1.0), synced to most audible sync master\n")), + ("llPlaySoundSlave",(["sound","volume"],"plays attached sound once at volume (0.0 - 1.0), synced to next loop of most audible sync master\n")), + ("llTriggerSound",(["sound","volume"],"plays sound at volume (0.0 - 1.0), centered at but not attached to object\n")), + ("llStopSound",([],"Stops currently attached sound\n")), + ("llPreloadSound",(["sound"],"preloads a sound on viewers within range\n")), + ("llGetSubString",(["src","start","end"],"returns the indicated substring\n")), + ("llDeleteSubString",(["src","start","end"],"removes the indicated substring and returns the result\n")), + ("llInsertString",(["dst","position","src"],"inserts src into dst at position and returns the result\n")), + ("llToUpper",(["src"],"convert src to all upper case and returns the result\n")), + ("llToLower",(["src"],"convert src to all lower case and returns the result\n")), + ("llGiveMoney",(["destination","amount"],"transfer amount of money from script owner to destination\n")), + ("llMakeExplosion",(["particles","scale","vel","lifetime","arc","texture","offset"],"Make a round explosion of particles\n")), + ("llMakeFountain",(["particles","scale","vel","lifetime","arc","bounce","texture","offset","bounce_offset"],"Make a fountain of particles\n")), + ("llMakeSmoke",(["particles","scale","vel","lifetime","arc","texture","offset"],"Make smoke like particles\n")), + ("llMakeFire",(["particles","scale","vel","lifetime","arc","texture","offset"],"Make fire like particles\n")), + ("llRezObject",(["inventory","pos","vel","rot","param"],"Instanciate owners inventory object at pos with velocity vel and rotation rot with start parameter param\n")), + ("llLookAt",(["target","strength","damping"],"Cause object name to point it's forward axis towards target\n")), + ("llStopLookAt",([],"Stop causing object name to point at a target\n")), + ("llSetTimerEvent",(["sec"],"Cause the timer event to be triggered every sec seconds\n")), + ("llSleep",(["sec"],"Put script to sleep for sec seconds\n")), + ("llGetMass",([],"Get the mass of task name that script is attached to\n")), + ("llCollisionFilter",(["name","id","accept"],"if accept == TRUE, only accept collisions with objects name and id (either is optional), otherwise with objects not name or id\n")), + ("llTakeControls",(["controls","accept","pass_on"],"Take controls from agent task has permissions for. If (accept == (controls & input)), send input to task. If pass_on send to agent also.\n")), + ("llReleaseControls",([],"Stop taking inputs\n")), + ("llAttachToAvatar",(["attachment"],"Attach to avatar task has permissions for at point attachment\n")), + ("llDetachFromAvatar",([],"Drop off of avatar\n")), + ("llTakeCamera",(["avatar"],"Move avatar's viewpoint to task\n")), + ("llReleaseCamera",(["avatar"],"Return camera to agent\n")), + ("llGetOwner",([],"Returns the owner of the task\n")), + ("llInstantMessage",(["user","message"],"IMs message to the user\n")), + ("llEmail",(["address","subject","message"],"Sends email to address with subject and message\n")), + ("llGetNextEmail",(["address","subject"],"Get the next waiting email with appropriate address and/or subject (if blank they are ignored)\n")), + ("llGetKey",([],"Get the key for the task the script is attached to\n")), + ("llSetBuoyancy",(["buoyancy"],"Set the tasks buoyancy (0 is none, < 1.0 sinks, 1.0 floats, > 1.0 rises)\n")), + ("llSetHoverHeight",(["height","water","tau"],"Critically damps to a height (either above ground level or above the higher of land and water if water == TRUE)\n")), + ("llStopHover",([],"Stop hovering to a height\n")), + ("llMinEventDelay",(["delay"],"Set the minimum time between events being handled\n")), + ("llSoundPreload",(["sound"],"preloads a sound on viewers within range\n")), + ("llRotLookAt",(["target","strength","damping"],"Cause object name to point it's forward axis towards target\n")), + ("llStringLength",(["str"],"Returns the length of string\n")), + ("llStartAnimation",(["anim"],"Start animation anim for agent that owns object\n")), + ("llStopAnimation",(["anim"],"Stop animation anim for agent that owns object\n")), + ("llPointAt",(["pos"],"Make agent that owns object point at pos\n")), + ("llStopPointAt",([],"Stop agent that owns object pointing\n")), + ("llTargetOmega",(["axis","spinrate","gain"],"Attempt to spin at spinrate with strength gain\n")), + ("llGetStartParameter",([],"Get's the start paramter passed to llRezObject\n")), + ("llGodLikeRezObject",(["inventory","pos"],"rez directly off of a UUID if owner has dog-bit set\n")), + ("llRequestPermissions",(["agent","perm"],"ask agent to allow the script to do perm (NB: Debit, ownership, link, joint, and permission requests can only go to the task's owner)\n")), + ("llGetPermissionsKey",([],"Return agent that permissions are enabled for. NULL_KEY if not enabled\n")), + ("llGetPermissions",([],"return what permissions have been enabled\n")), + ("llGetLinkNumber",([],"Returns what number in a link set the script is attached to (0 means no link, 1 the root, 2 for first child, etc.)\n")), + ("llSetLinkColor",(["linknumber","color","face"],"If a task exists in the link chain at linknumber, set face to color\n")), + ("llCreateLink",(["target","parent"],"Attempt to link task script is attached to and target (requires permission PERMISSION_CHANGE_LINKS be set). If parent == TRUE, task script is attached to is the root\n")), + ("llBreakLink",(["linknum"],"Delinks the task with the given link number (requires permission PERMISSION_CHANGE_LINKS be set)\n")), + ("llBreakAllLinks",([],"Delinks all tasks in the link set (requires permission PERMISSION_CHANGE_LINKS be set)\n")), + ("llGetLinkKey",(["linknum"],"Get the key of linknumber in link set\n")), + ("llGetLinkName",(["linknum"],"Get the name of linknumber in link set\n")), + ("llGetInventoryNumber",(["type"],"Get the number of items of a given type in the task's inventory.\nValid types: INVENTORY_TEXTURE, INVENTORY_SOUND, INVENTORY_OBJECT, INVENTORY_SCRIPT, INVENTORY_CLOTHING, INVENTORY_BODYPART, INVENTORY_NOTECARD, INVENTORY_LANDMARK, INVENTORY_ALL\n")), + ("llGetInventoryName",(["type","number"],"Get the name of the inventory item number of type\n")), + ("llSetScriptState",(["name","run"],"Control the state of a script name.\n")), + ("llGetEnergy",([],"Returns how much energy is in the object as a percentage of maximum\n")), + ("llGiveInventory",(["destination","inventory"],"Give inventory to destination\n")), + ("llRemoveInventory",(["inventory"],"Remove the named inventory item\n")), + ("llSetText",(["text","color","alpha"],"Set text floating over object\n")), + ("llWater",(["v"],"returns the water height below the object position + v\n")), + ("llPassTouches",(["pass"],"if pass == TRUE, touches are passed from children on to parents (default is FALSE)\n")), + ("llRequestAgentData",(["id","data"],"Requests data about agent id. When data is available the dataserver event will be raised\n")), + ("llRequestInventoryData",(["name"],"Requests data from object's inventory object. When data is available the dataserver event will be raised\n")), + ("llSetDamage",(["damage"],"Sets the amount of damage that will be done to an object that this task hits. Task will be killed.\n")), + ("llTeleportAgentHome",(["id"],"Teleports agent on owner's land to agent's home location\n")), + ("llModifyLand",(["action","size"],"Modify land with action (LAND_LEVEL, LAND_RAISE, LAND_LOWER, LAND_SMOOTH, LAND_NOISE, LAND_REVERT)\non size (LAND_SMALL_BRUSH, LAND_MEDIUM_BRUSH, LAND_LARGE_BRUSH)\n")), + ("llCollisionSound",(["impact_sound","impact_volume"],"Suppress default collision sounds, replace default impact sounds with impact_sound (empty string to just suppress)\n")), + ("llCollisionSprite",(["impact_sprite"],"Suppress default collision sprites, replace default impact sprite with impact_sprite (empty string to just suppress)\n")), + ("llGetAnimation",(["id"],"Get the currently playing locomotion animation for avatar id\n")), + ("llResetScript",([],"Resets the script\n")), + ("llMessageLinked",(["linknum","num","str","id"],"Sends num, str, and id to members of the link set (LINK_ROOT sends to root task in a linked set,\nLINK_SET sends to all tasks,\nLINK_ALL_OTHERS to all other tasks,\nLINK_ALL_CHILDREN to all children,\nLINK_THIS to the task the script it is in)\n")), + ("llPushObject",(["id","impulse","ang_impulse","local"],"Applies impulse and ang_impulse to object id\n")), + ("llPassCollisions",(["pass"],"if pass == TRUE, collisions are passed from children on to parents (default is FALSE)\n")), + ("llGetScriptName",([],"Returns the script name\n")), + ("llGetNumberOfSides",([],"Returns the number of sides\n")), + ("llAxisAngle2Rot",(["axis","angle"],"Returns the rotation generated angle about axis\n")), + ("llRot2Axis",(["rot"],"Returns the rotation axis represented by rot\n")), + ("llRot2Angle",(["rot"],"Returns the rotation angle represented by rot\n")), + ("llAcos",(["val"],"Returns the arccosine in radians of val\n")), + ("llAsin",(["val"],"Returns the arcsine in radians of val\n")), + ("llAngleBetween",(["a","b"],"Returns angle between rotation a and b\n")), + ("llGetInventoryKey",(["name"],"Returns the key of the inventory name\n")), + ("llAllowInventoryDrop",(["add"],"If add == TRUE, users without permissions can still drop inventory items onto task\n")), + ("llGetSunDirection",([],"Returns the sun direction on the simulator\n")), + ("llGetTextureOffset",(["side"],"Returns the texture offset of side in the x and y components of a vector\n")), + ("llGetTextureScale",(["side"],"Returns the texture scale of side in the x and y components of a vector\n")), + ("llGetTextureRot",(["side"],"Returns the texture rotation of side\n")), + ("llSubStringIndex",(["source","pattern"],"Finds index in source where pattern first appears (returns -1 if not found)\n")), + ("llGetOwnerKey",(["id"],"Find the owner of id\n")), + ("llGetCenterOfMass",([],"Get the object's center of mass\n")), + ("llListSort",(["src","stride","ascending"],"Sort the list into blocks of stride in ascending order if ascending == TRUE. Note that sort only works between same types.\n")), + ("llGetListLength",(["src"],"Get the number of elements in the list\n")), + ("llList2Integer",(["src","index"],"Copy the integer at index in the list\n")), + ("llList2Float",(["src","index"],"Copy the float at index in the list\n")), + ("llList2String",(["src","index"],"Copy the string at index in the list\n")), + ("llList2Key",(["src","index"],"Copy the key at index in the list\n")), + ("llList2Vector",(["src","index"],"Copy the vector at index in the list\n")), + ("llList2Rot",(["src","index"],"Copy the rotation at index in the list\n")), + ("llList2List",(["src","start","end"],"Copy the slice of the list from start to end\n")), + ("llDeleteSubList",(["src","start","end"],"Remove the slice from the list and return the remainder\n")), + ("llGetListEntryType",(["src","index"],"Returns the type of the index entry in the list\n(TYPE_INTEGER, TYPE_FLOAT, TYPE_STRING, TYPE_KEY, TYPE_VECTOR, TYPE_ROTATION, or TYPE_INVALID if index is off list)\n")), + ("llList2CSV",(["src"],"Create a string of comma separated values from list\n")), + ("llCSV2List",(["src"],"Create a list from a string of comma separated values\n")), + ("llListRandomize",(["src","stride"],"Returns a randomized list of blocks of size stride\n")), + ("llList2ListStrided",(["src","start","end","stride"],"Copy the strided slice of the list from start to end\n")), + ("llGetRegionCorner",([],"Returns a vector with the south west corner x,y position of the region the object is in\n")), + ("llListInsertList",(["dest","src","start"],"Inserts src into dest at position start\n")), + ("llListFindList",(["src","test"],"Returns the start of the first instance of test in src, -1 if not found\n")), + ("llGetObjectName",([],"Returns the name of the object script is attached to\n")), + ("llSetObjectName",(["name"],"Sets the objects name\n")), + ("llGetDate",([],"Gets the date as YYYY-MM-DD\n")), + ("llEdgeOfWorld",(["pos","dir"],"Checks to see whether the border hit by dir from pos is the edge of the world (has no neighboring simulator)\n")), + ("llGetAgentInfo",(["id"],"Gets information about agent ID.\nReturns AGENT_FLYING, AGENT_ATTACHMENTS, AGENT_SCRIPTED, AGENT_SITTING, AGENT_ON_OBJECT, AGENT_MOUSELOOK, AGENT_AWAY, AGENT_BUSY, AGENT_TYPING, AGENT_CROUCHING, AGENT_ALWAYS_RUN, AGENT_WALKING and/or AGENT_IN_AIR.\n")), + ("llAdjustSoundVolume",(["volume"],"adjusts volume of attached sound (0.0 - 1.0)\n")), + ("llSetSoundQueueing",(["queue"],"determines whether attached sound calls wait for the current sound to finish (0 = no [default], nonzero = yes)\n")), + ("llSetSoundRadius",(["radius"],"establishes a hard cut-off radius for audibility of scripted sounds (both attached and triggered)\n")), + ("llKey2Name",(["id"],"Returns the name of the object key, iff the object is in the current simulator, otherwise the empty string\n")), + ("llSetTextureAnim",(["mode","face","sizex","sizey","start","length","rate"],"Animate the texture on the specified face/faces\n")), + ("llTriggerSoundLimited",(["sound","volume","tne","bsw"],"plays sound at volume (0.0 - 1.0), centered at but not attached to object, limited to AABB defined by vectors top-north-east and bottom-south-west\n")), + ("llEjectFromLand",(["pest"],"Ejects pest from land that you own\n")), + ("llParseString2List",(["src","separators","spacers"],"Breaks src into a list, discarding separators, keeping spacers (separators and spacers must be lists of strings, maximum of 8 each)\n")), + ("llOverMyLand",(["id"],"Returns TRUE if id is over land owner of object owns, FALSE otherwise\n")), + ("llGetLandOwnerAt",(["pos"],"Returns the key of the land owner, NULL_KEY if public\n")), + ("llGetNotecardLine",(["name","line"],"Returns line line of notecard name via the dataserver event\n")), + ("llGetAgentSize",(["id"],"If the agent is in the same sim as the object, returns the size of the avatar\n")), + ("llSameGroup",(["id"],"Returns TRUE if ID is in the same sim and has the same active group, otherwise FALSE\n")), + ("llUnSit",(["id"],"If agent identified by id is sitting on the object the script is attached to or is over land owned by the objects owner, the agent is forced to stand up\n")), + ("llGroundSlope",(["v"],"returns the ground slope below the object position + v\n")), + ("llGroundNormal",(["v"],"returns the ground normal below the object position + v\n")), + ("llGroundContour",(["v"],"returns the ground contour below the object position + v\n")), + ("llGetAttached",([],"returns the object attachment point or 0 if not attached\n")), + ("llGetFreeMemory",([],"returns the available heap space for the current script\n")), + ("llGetRegionName",([],"returns the current region name\n")), + ("llGetRegionTimeDilation",([],"returns the current time dilation as a float between 0 and 1\n")), + ("llGetRegionFPS",([],"returns the mean region frames per second\n")), + ("llParticleSystem",(["rules"],"Creates a particle system based on rules. Empty list removes particle system from object.\nList format is [ rule1, data1, rule2, data2 . . . rulen, datan ]\n")), + ("llGroundRepel",(["height","water","tau"],"Critically damps to height if within height*0.5 of level (either above ground level or above the higher of land and water if water == TRUE)\n")), + ("llGiveInventoryList",(["destination","category","inventory"],"Give inventory to destination in a new category\n")), + ("llSetVehicleType",(["type"],"sets vehicle to one of the default types\n")), + ("llSetVehicleFloatParam",(["param","value"],"sets the specified vehicle float parameter\n")), + ("llSetVehicleVectorParam",(["param","vec"],"sets the specified vehicle vector parameter\n")), + ("llSetVehicleRotationParam",(["param","rot"],"sets the specified vehicle rotation parameter\n")), + ("llSetVehicleFlags",(["flags"],"sets the enabled bits in 'flags'\n")), + ("llRemoveVehicleFlags",(["flags"],"removes the enabled bits in 'flags'\n")), + ("llSitTarget",(["offset","rot"],"Set the sit location for this object (if offset == <0,0,0> clear it)\n")), + ("llAvatarOnSitTarget",([],"If an avatar is sitting on the sit target, return the avatar's key, NULL_KEY otherwise\n")), + ("llAddToLandPassList",(["avatar","hours"],"Add avatar to the land pass list for hours\n")), + ("llSetTouchText",(["text"],"Displays text in pie menu that acts as a touch\n")), + ("llSetSitText",(["text"],"Displays text rather than sit in pie menu\n")), + ("llSetCameraEyeOffset",(["offset"],"Sets the camera eye offset used in this object if an avatar sits on it\n")), + ("llSetCameraAtOffset",(["offset"],"Sets the camera at offset used in this object if an avatar sits on it\n")), + ("llDumpList2String",(["src","separator"],"Write the list out in a single string using separator between values\n")), + ("llScriptDanger",(["pos"],"Returns true if pos is over public land, sandbox land, land that doesn't allow everyone to edit and build, or land that doesn't allow outside scripts\n")), + ("llDialog",(["avatar","message","buttons","chat_channel"],"Shows a dialog box on the avatar's screen with the message.\nUp to 12 strings in the list form buttons.\nIf a button is clicked, the name is chatted on chat_channel.\n")), + ("llVolumeDetect",(["detect"],"If detect = TRUE, object becomes phantom but triggers collision_start and collision_end events\nwhen other objects start and stop interpenetrating.\nMust be applied to the root object.\n")), + ("llResetOtherScript",(["name"],"Resets script name\n")), + ("llGetScriptState",(["name"],"Resets TRUE if script name is running\n")), + ("llRemoteLoadScript",([],"Deprecated. Please use llRemoteLoadScriptPin instead.\n")), + ("llSetRemoteScriptAccessPin",(["pin"],"If pin is set to a non-zero number, the task will accept remote script\nloads via llRemoteLoadScriptPin if it passes in the correct pin.\nOthersise, llRemoteLoadScriptPin is ignored.\n")), + ("llRemoteLoadScriptPin",(["target","name","pin","running","start_param"],"If the owner of the object this script is attached can modify target,\nthey are in the same region,\nand the matching pin is used,\ncopy script name onto target,\nif running == TRUE, start the script with param.\n")), + ("llOpenRemoteDataChannel",([],"Creates a channel to listen for XML-RPC calls. Will trigger a remote_data event with channel id once it is available.\n")), + ("llSendRemoteData",(["channel","dest","idata","sdata"],"Send an XML-RPC request to dest through channel with payload of channel (in a string), integer idata and string sdata.\nA message identifier key is returned.\nAn XML-RPC reply will trigger a remote_data event and reference the message id.\nThe message_id is returned.\n")), + ("llRemoteDataReply",(["channel","message_id","sdata","idata"],"Send an XML-RPC reply to message_id on channel with payload of string sdata and integer idata\n")), + ("llCloseRemoteDataChannel",(["channel"],"Closes XML-RPC channel.\n")), + ("llMD5String",(["src","nonce"],"Performs a RSA Data Security, Inc. MD5 Message-Digest Algorithm on string with nonce. Returns a 32 character hex string.\n")), + ("llSetPrimitiveParams",(["rules"],"Set primitive parameters based on rules.\n")), + ("llStringToBase64",(["str"],"Converts a string to the Base 64 representation of the string.\n")), + ("llBase64ToString",(["str"],"Converts a Base 64 string to a conventional string. If the conversion creates any unprintable characters, they are converted to spaces.\n")), + ("llXorBase64Strings",(["s1","s2"],"DEPRECATED! Please use llXorBase64StringsCorrect instead!! Incorrectly performs an exclusive or on two Base 64 strings and returns a Base 64 string. s2 repeats if it is shorter than s1. Retained for backwards compatability.\n")), + ("llRemoteDataSetRegion",([],"If an object using remote data channels changes regions, you must call this function to reregister the remote data channels.\nYou do not need to make this call if you don't change regions.\n")), + ("llLog10",(["val"],"Returns the base 10 log of val if val > 0, otherwise returns 0.\n")), + ("llLog",(["val"],"Returns the base e log of val if val > 0, otherwise returns 0.\n")), + ("llGetAnimationList",(["id"],"Gets a list of all playing animations for avatar id\n")), + ("llSetParcelMusicURL",(["url"],"Sets the streaming audio URL for the parcel object is on\n")), + ("llGetRootPosition",([],"Gets the global position of the root object of the object script is attached to\n")), + ("llGetRootRotation",([],"Gets the global rotation of the root object of the object script is attached to\n")), + ("llGetObjectDesc",([],"Returns the description of the object the script is attached to\n")), + ("llSetObjectDesc",(["name"],"Sets the object's description\n")), + ("llGetCreator",([],"Returns the creator of the object\n")), + ("llGetTimestamp",([],"Gets the timestamp in the format: YYYY-MM-DDThh:mm:ss.ff..fZ\n")), + ("llSetLinkAlpha",(["linknumber","alpha","face"],"If a prim exists in the link chain at linknumber, set face to alpha\n")), + ("llGetNumberOfPrims",([],"Returns the number of prims in a link set the script is attached to\n")), + ("llGetNumberOfNotecardLines",(["name"],"Returns number of lines in notecard 'name' via the dataserver event (cast return value to integer)\n")), + ("llGetBoundingBox",(["object"],"Returns the bounding box around an object (including any linked prims) relative to the root prim, in a list: [ (vector) min_corner, (vector) max_corner ]\n")), + ("llGetGeometricCenter",([],"Returns the geometric center of the linked set the script is attached to.\n")), + ("llGetPrimitiveParams",(["params"],"Gets primitive parameters specified in the params list.\n")), + ("llIntegerToBase64",(["number"],"Big endian encode of of integer as a Base64 string.\n")), + ("llBase64ToInteger",(["str"],"Big endian decode of a Base64 string into an integer.\n")), + ("llGetGMTclock",([],"Gets the time in seconds since midnight in GMT\n")), + ("llGetSimulatorHostname",([],"Gets the hostname of the machine script is running on (same as string in viewer Help dialog)\n")), + ("llSetLocalRot",(["rot"],"sets the rotation of a child prim relative to the root prim\n")), + ("llParseStringKeepNulls",(["src","separators","spacers"],"Breaks src into a list, discarding separators, keeping spacers (separators and spacers must be lists of strings, maximum of 8 each), keeping any null values generated.\n")), + ("llRezAtRoot",(["inventory","pos","vel","rot","param"],"Instantiate owner's inventory object at pos with velocity vel and rotation rot with start parameter param.\nThe last selected root object's location will be set to pos\n")), + ("llGetObjectPermMask",(["mask"],"Returns the requested permission mask for the root object the task is attached to.\n")), + ("llSetObjectPermMask",(["mask","value"],"Sets the given permission mask to the new value on the root object the task is attached to.\n")), + ("llGetInventoryPermMask",(["item","mask"],"Returns the requested permission mask for the inventory item.\n")), + ("llSetInventoryPermMask",(["item","mask","value"],"Sets the given permission mask to the new value on the inventory item.\n")), + ("llGetInventoryCreator",(["item"],"Returns the key for the creator of the inventory item.\n")), + ("llOwnerSay",(["msg"],"says msg to owner only (if owner in sim)\n")), + ("llRequestSimulatorData",(["simulator","data"],"Requests data about simulator. When data is available the dataserver event will be raised\n")), + ("llForceMouselook",(["mouselook"],"If mouselook is TRUE any avatar that sits on this object is forced into mouselook mode\n")), + ("llGetObjectMass",(["id"],"Get the mass of the object with key id\n")), + ("llListReplaceList",(["dest","src","start","end"],"Replaces start through end of dest with src.\n")), + ("llLoadURL",(["avatar_id","message","url"],"Shows dialog to avatar avatar_id offering to load web page at URL. If user clicks yes, launches their web browser.\n")), + ("llParcelMediaCommandList",(["command"],"Sends a list of commands, some with arguments, to a parcel.\n")), + ("llParcelMediaQuery",(["query"],"Sends a list of queries, returns a list of results.\n")), + ("llModPow",(["a","b","c"],"Returns a raised to the b power, mod c. ( (a**b)%c ). b is capped at 0xFFFF (16 bits).\n")), + ("llGetInventoryType",(["name"],"Returns the type of the inventory name\n")), + ("llSetPayPrice",(["price","quick_pay_buttons"],"Sets the default amount when someone chooses to pay this object.\n")), + ("llGetCameraPos",([],"Gets current camera position for agent task has permissions for.\n")), + ("llGetCameraRot",([],"Gets current camera orientation for agent task has permissions for.\n")), + ("llSetPrimURL",(["url"],"Updates the URL for the web page shown on the sides of the object.\n")), + ("llRefreshPrimURL",([],"Reloads the web page shown on the sides of the object.\n")), + ("llEscapeURL",(["url"],"Returns and escaped/encoded version of url, replacing spaces with %20 etc.\n")), + ("llUnescapeURL",(["url"],"Returns and unescaped/unencoded version of url, replacing %20 with spaces etc.\n")), + ("llMapDestination",(["simname","pos","look_at"],"Opens world map centered on region with pos highlighted.\nOnly works for scripts attached to avatar, or during touch events.\n(NOTE: look_at currently does nothing)\n")), + ("llAddToLandBanList",(["avatar","hours"],"Add avatar to the land ban list for hours\n")), + ("llRemoveFromLandPassList",(["avatar"],"Remove avatar from the land pass list\n")), + ("llRemoveFromLandBanList",(["avatar"],"Remove avatar from the land ban list\n")), + ("llSetCameraParams",(["rules"],"Sets multiple camera parameters at once.\nList format is [ rule1, data1, rule2, data2 . . . rulen, datan ]\n")), + ("llClearCameraParams",([],"Resets all camera parameters to default values and turns off scripted camera control.\n")), + ("llListStatistics",(["operation","l"],"Perform statistical aggregate functions on list l using LIST_STAT_* operations.\n")), + ("llGetUnixTime",([],"Get the number of seconds elapsed since 00:00 hours, Jan 1, 1970 UTC from the system clock.\n")), + ("llGetParcelFlags",(["pos"],"Get the parcel flags (PARCEL_FLAG_*) for the parcel including the point pos.\n")), + ("llGetRegionFlags",([],"Get the region flags (REGION_FLAG_*) for the region the object is in.\n")), + ("llXorBase64StringsCorrect",(["s1","s2"],"Correctly performs an exclusive or on two Base 64 strings and returns a Base 64 string. s2 repeats if it is shorter than s1.\n")), + ("llHTTPRequest",(["url","parameters","body"],"Send an HTTP request.\n")), + ("llResetLandBanList",([],"Removes all residents from the land ban list.\n")), + ("llResetLandPassList",([],"Removes all residents from the land access/pass list.\n")), + ("llGetObjectPrimCount",(["object_id"],"Returns the total number of prims for an object.\n")), + ("llGetParcelPrimOwners",(["pos"],"Returns a list of all residents who own objects on the parcel and the number of objects they own.\nRequires owner-like permissions for the parcel.\n")), + ("llGetParcelPrimCount",(["pos","category","sim_wide"],"Gets the number of prims on the parcel of the given category.\nCategories: PARCEL_COUNT_TOTAL, _OWNER, _GROUP, _OTHER, _SELECTED, _TEMP.\n")), + ("llGetParcelMaxPrims",(["pos","sim_wide"],"Gets the maximum number of prims allowed on the parcel at pos.\n")), + ("llGetParcelDetails",(["pos","params"],"Gets the parcel details specified in params for the parcel at pos.\nParams is one or more of: PARCEL_DETAILS_NAME, _DESC, _OWNER, _GROUP, _AREA\n")), + ("llSetLinkPrimitiveParams",(["linknumber","rules"],"Set primitive parameters for linknumber based on rules.\n")), + ("llSetLinkTexture",(["link_pos","texture","face"],"Sets the texture of face for link_pos\n")), + ("llStringTrim",(["src","trim_type"],"Trim leading and/or trailing spaces from a string.\nUses trim_type of STRING_TRIM, STRING_TRIM_HEAD or STRING_TRIM_TAIL.\n"))] diff --git a/Language/Lsl/Internal/InternalLLFuncs.hs b/Language/Lsl/Internal/InternalLLFuncs.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/InternalLLFuncs.hs @@ -0,0 +1,650 @@ +{- + The 'Internal Functions' of LSL are not a formal grouping of functions, but by my definition + are all the functions that - + * do not affect the SL environment in any way. I.e. they don't communicate information + 'outside' the script in any way. + * do not have any state. Call them with the same arguments, and they will return the same + result, each and every time. + + Note that this notion of affecting the SL environment excludes cetain types of effects: + * time usage. All actions within a script take time, and this indirectly affects the + SL environment. + * energy cost. SL has a notion of the 'energy' of an object that sometimes comes into + play. These functions may affect that energy, but that has no impact on the results + of the functions themselves. + + Note that a couple of functions that don't affect the SL environment don't fall into + my category of 'internal' because they are not stateless. Those functions are + * llFrand: each time you call this function it returns a different number, even if + you pass the exact same argument. SL completely hides the seed and sequence generator + from the script. + * llRandomizeList. Essentially the same issue as for llFrand. + + To implement these functions, either the execution model for the script must hava some + storage set aside for the state of the pseudo-random number generator, or the 'world + state' must contain this state. I've chosen to make this part of the 'world state' + so the execution model doesn't know anything about the pseudo random number generator. + + Not that anybody was wondering... + + So this module implements the functions that are left, and my assumption is that these + implementations would be used regardless of how the SL 'world' the scripts run in is + modelled. Thus, the operation of all other LSL predefined functions is specific to + the implementation of the 'world', but these are not. +-} +module Language.Lsl.Internal.InternalLLFuncs( + -- String Functions + llStringLength, + llGetSubString, + llDeleteSubString, + llInsertString, + llParseString2List, + llParseStringKeepNulls, + llToUpper, + llToLower, + llSubStringIndex, + llEscapeURL, + llUnescapeURL, + llIntegerToBase64, + llBase64ToInteger, + llBase64ToString, + llStringToBase64, + llStringTrim, + llXorBase64Strings, + llXorBase64StringsCorrect, + -- Math functions + llCos, + llSin, + llAcos, + llAsin, + llSqrt, + llFabs, + llLog, + llLog10, + llTan, + llAtan2, + llAbs, + llCeil, + llFloor, + llRound, + llPow, + llModPow, + llListStatistics, + -- Math Vector/Rotation + llAngleBetween, + llEuler2Rot, + llAxisAngle2Rot, + llRot2Angle, + llRot2Axis, + llAxes2Rot, + llRot2Fwd, + llRot2Left, + llRot2Up, + llRot2Euler, + llRotBetween, + llVecMag, + llVecDist, + llVecNorm, + -- List functions + llGetListLength, + llList2List, + llDeleteSubList, + llDumpList2String, + llListFindList, + llListInsertList, + llListReplaceList, + llList2ListStrided, + llListSort, + llGetListEntryType, + llList2Float, + llList2Integer, + llList2Key, + llList2Rot, + llList2String, + llList2Vector, + llList2CSV, + llCSV2List, + internalLLFuncs, + internalLLFuncNames + ) where + +import Language.Lsl.Internal.Util(Permutation3(..),axisAngleToRotation,cut,dist3d,elemAtM, + filtMap,fromInt,indexOf,mag3d,mag3d2,matrixToQuaternion,quaternionToMatrix, + quaternionToRotations,rotationBetween,rotationsToQuaternion) +import Language.Lsl.Internal.Type(LSLType(..),LSLValue(..),lslValString,parseFloat,parseInt,rot2RVal,toSVal,typeOfLSLValue,vVal2Vec) +import Language.Lsl.Internal.Evaluation(EvalResult(..)) +import Language.Lsl.Internal.Constants(findConstVal) +import Data.List(elemIndex,find,foldl',intersperse,isPrefixOf,sort) +import Data.Char(toLower,toUpper) +import Data.Bits((.|.),(.&.),shiftL,shiftR,xor) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.Digest.Pure.MD5 as MD5 +import qualified Data.ByteString.UTF8 as UTF8 +import Network.URI(escapeURIChar,unEscapeString) + +internalLLFuncNames :: [String] +internalLLFuncNames = map fst (internalLLFuncs :: [(String, a -> [LSLValue] -> Maybe (EvalResult,LSLValue))]) + +internalLLFuncs :: (Monad m) => [(String, a -> [LSLValue] -> m (EvalResult,LSLValue))] +internalLLFuncs = [ + ("llAbs",llAbs), + ("llAcos",llAcos), + ("llAngleBetween",llAngleBetween), + ("llAsin",llAsin), + ("llAtan2",llAtan2), + ("llAxes2Rot",llAxes2Rot), + ("llAxisAngle2Rot",llAxisAngle2Rot), + ("llBase64ToInteger",llBase64ToInteger), + ("llBase64ToString",llBase64ToString), + ("llCeil",llCeil), + ("llCos",llCos), + ("llCSV2List",llCSV2List), + ("llDeleteSubList",llDeleteSubList), + ("llDeleteSubString",llDeleteSubString), + ("llDumpList2String",llDumpList2String), + ("llEscapeURL",llEscapeURL), + ("llEuler2Rot",llEuler2Rot), + ("llFabs",llFabs), + ("llFloor",llFloor), + ("llGetListEntryType",llGetListEntryType), + ("llGetListLength",llGetListLength), + ("llGetSubString",llGetSubString), + ("llInsertString",llInsertString), + ("llIntegerToBase64",llIntegerToBase64), + ("llList2CSV",llList2CSV), + ("llList2Float",llList2Float), + ("llList2Integer",llList2Integer), + ("llList2Key",llList2Key), + ("llList2List",llList2List), + ("llList2ListStrided",llList2ListStrided), + ("llList2Rot",llList2Rot), + ("llList2String",llList2String), + ("llList2Vector",llList2Vector), + ("llListFindList",llListFindList), + ("llListInsertList",llListInsertList), + ("llListReplaceList",llListReplaceList), + ("llListSort",llListSort), + ("llListStatistics",llListStatistics), + ("llLog",llLog), + ("llLog10",llLog10), + ("llMD5String",llMD5String), + ("llModPow",llModPow), + ("llParseString2List",llParseString2List), + ("llParseStringKeepNulls",llParseStringKeepNulls), + ("llPow",llPow), + ("llRot2Angle",llRot2Angle), + ("llRot2Axis",llRot2Axis), + ("llRotBetween",llRotBetween), + ("llRot2Euler",llRot2Euler), + ("llRot2Fwd",llRot2Fwd), + ("llRot2Left",llRot2Left), + ("llRot2Up",llRot2Up), + ("llRound",llRound), + ("llSin",llSin), + ("llSqrt",llSqrt), + ("llStringLength",llStringLength), + ("llStringToBase64",llStringToBase64), + ("llStringTrim", llStringTrim), + ("llSubStringIndex",llSubStringIndex), + ("llTan",llTan), + ("llToLower",llToLower), + ("llToUpper",llToUpper), + ("llUnescapeURL",llUnescapeURL), + ("llVecDist",llVecDist), + ("llVecMag",llVecMag), + ("llVecNorm",llVecNorm), + ("llXorBase64Strings",llXorBase64Strings), + ("llXorBase64StringsCorrect", llXorBase64StringsCorrect)] + +continueWith x = return (EvalIncomplete,x) + +-- String Functions +llStringLength _ [SVal s] = continueWith $ IVal (length s) +llGetSubString _ [SVal source, IVal start, IVal end] = continueWith $ SVal (subList source start end) +llDeleteSubString _ [SVal source, IVal start, IVal end] = continueWith $ SVal (deleteSubList source start end) +llInsertString _ [SVal dst, IVal pos, SVal src] = + -- TODO: wiki says this function does not support negative indices... + -- how does it deal with out of range indices? + let (x,y) = splitAt pos dst in continueWith $ SVal $ x ++ src ++ y + + +separate :: Eq a => [a] -> [[a]] -> [[a]] -> [a] -> Bool -> [[a]] +separate [] _ _ accum keepNulls = if keepNulls || length accum > 0 then [reverse accum] else [] +separate l seps spacers accum keepNulls = + case find ((flip isPrefixOf) l) seps of + Nothing -> + case find ((flip isPrefixOf) l) spacers of + Nothing -> let rest = tail l in separate rest seps spacers (head l:accum) keepNulls + Just p -> let rest = drop (length p) l in + if accum == [] && not keepNulls then + p:(separate rest seps spacers [] keepNulls) + else (reverse accum):p:(separate rest seps spacers [] keepNulls) + Just p -> let rest = drop (length p) l in + if accum == [] && not keepNulls then + separate rest seps spacers [] keepNulls + else (reverse accum):(separate rest seps spacers [] keepNulls) + + +llStringTrim _ [SVal string, trimType ] = + let trimEnd = reverse . dropWhile (==' ') . reverse + trimBegin = dropWhile (==' ') + trimBoth = trimBegin . trimEnd in + continueWith $ SVal $ (case trimType of + tt | Just tt == findConstVal "STRING_TRIM_HEAD" -> trimBegin + | Just tt == findConstVal "STRING_TRIM_TAIL" -> trimEnd + | Just tt == findConstVal "STRING_TRIM" -> trimBoth + | otherwise -> id) string + +llParseString2List _ [SVal string, LVal separators, LVal spacers] = + continueWith $ LVal $ map SVal $ separate string (map lslValString separators) (map lslValString spacers) [] False + +llParseStringKeepNulls _ [SVal string, LVal separators, LVal spacers] = + continueWith $ LVal $ map SVal $ separate string (map lslValString separators) (map lslValString spacers) [] True + +llToUpper _ [SVal string] = continueWith $ SVal $ map toUpper string +llToLower _ [SVal string] = continueWith $ SVal $ map toLower string + +llSubStringIndex _ [SVal source, SVal pattern] = continueWith $ IVal $ + case indexOf pattern source of + Nothing -> (-1) + Just i -> i + +unescapedChars = ['A'..'Z'] ++ ['0'..'9'] ++ ['a'..'z'] + +escapeURL "" n = "" +escapeURL (c:cs) n = + let s = escapeURIChar (`elem` unescapedChars) c + len = length s + in if len > n then "" else s ++ escapeURL cs (n - len) +maxResult = 254::Int + +llEscapeURL _ [SVal string] = + continueWith $ SVal $ escapeURL string maxResult + +llUnescapeURL _ [SVal string] = + continueWith $ SVal $ take maxResult $ unEscapeString string + +llMD5String _ [SVal string, IVal nonce] = + continueWith $ SVal $ (show . MD5.md5 . L.pack . B.unpack . UTF8.fromString) (string ++ ":" ++ show nonce) +-- Math functions + +unaryToLL :: (Monad m) => (Float -> Float) -> [LSLValue] -> m (EvalResult,LSLValue) +unaryToLL f [FVal v] = continueWith $ FVal (f v) + +llCos _ = unaryToLL cos +llSin _ = unaryToLL sin +llAcos _ = unaryToLL acos +llAsin _ = unaryToLL asin +llSqrt _ = unaryToLL sqrt +llFabs _ = unaryToLL abs +llLog _ = unaryToLL log +llLog10 _ = unaryToLL (logBase 10) +llTan _ = unaryToLL tan + +llAtan2 _ [FVal x,FVal y] = continueWith $ FVal (atan2 x y) +llAbs _ [IVal i] = continueWith $ IVal (abs i) +llCeil _ [FVal f] = continueWith $ IVal (ceiling f) +llFloor _ [FVal f] = continueWith $ IVal (floor f) +llRound _ [FVal f] = continueWith $ IVal (round f) +-- llRand is not an 'internal' function, in the sense that it +-- is not stateless, like the other 'internal' functions. +-- this is because of its seed, and current position in +-- the sequence. + +llPow _ [FVal base, FVal exp] = continueWith $ FVal (base ** exp) +llModPow _ [IVal base, IVal exp, IVal modulus] = continueWith $ IVal (modpow base exp modulus) + +modpow a b c | b < 0 = 0 + | otherwise = + let b' = (if b > 0xFFFF then 0xFFFF else b) + pow _ 0 = 1 `mod` c + pow x n = (let p' = pow x (n `div` 2) in ((if odd n then (x *) else id) (p' * p')) `mod` c) + in pow (a `mod` c) b' + +-- should use a map for this, but have been using lists for everything, so will stick with it... +statFuncs :: [(Int, [Float] -> Float)] +statFuncs = map (\(Just (IVal op), f) -> (op,f)) [ + (findConstVal "LIST_STAT_RANGE", listStatRange), + (findConstVal "LIST_STAT_MAX", listStatMax), + (findConstVal "LIST_STAT_MIN", listStatMin), + (findConstVal "LIST_STAT_MEAN", listStatMean), + (findConstVal "LIST_STAT_MEDIAN", listStatMedian), + (findConstVal "LIST_STAT_STD_DEV", listStatStdDev), + (findConstVal "LIST_STAT_SUM", sum), + (findConstVal "LIST_STAT_SUM_SQUARES", sum . map (\x -> x * x )), + (findConstVal "LIST_STAT_NUM_COUNT", fromInt . length), + (findConstVal "LIST_STAT_GEOMETRIC_MEAN", listStatGeometricMean)] + +toF :: LSLValue -> Maybe Float +toF (IVal i) = Just (fromInt i) +toF (FVal f) = Just f +toF _ = Nothing + +fvals list = filtMap toF list + +llListStatistics _ [IVal operation,LVal list] = + case lookup operation statFuncs of + Nothing -> continueWith $ FVal 0 -- this seems to be what lsl does... + Just f -> continueWith $ FVal (f $ fvals list) + +listStatRange l = listStatMax l - listStatMin l +listStatMax [] = 0.0 +listStatMax l = foldl1 max l +listStatMin [] = 0.0 +listStatMin l = foldl1 min l + +listStatMean l = sum l / fromInt (length l) +listStatMedian [] = 0.0 +listStatMedian l = + let l' = sort l + n = length l + in if odd n then l' !! (n `div` 2) else ((l' !! (n `div` 2)) + (l' !! (n `div` 2 - 1))) / 2.0 + +listStatStdDev l = + let mean = listStatMean l in + sqrt $ listStatMean $ map ((**2.0).(mean-)) l +listStatSumSquares l = sum $ map (**2.0) l +listStatGeometricMean l = product l ** (1.0 / fromInt (length l)) + +llRot2Angle _ [RVal _ _ _ w] = continueWith $ FVal (2.0 * acos w) +llRot2Axis _ [RVal x y z w] = + let sinVal = sqrt (1.0 - w*w) + v = if sinVal == 0.0 then VVal 0.0 0.0 0.0 + else VVal (x/sinVal) (y/sinVal) (z/sinVal) in + continueWith $ v + +llAxisAngle2Rot _ [vval@(VVal x y z), FVal r] = return (axisAngleToRotation (vVal2Vec vval) r) >>= continueWith . rot2RVal + +llAxes2Rot _ [VVal xf yf zf, VVal xl yl zl, VVal xu yu zu] = + let (x,y,z,s) = matrixToQuaternion ((xf,xl,xu),(yf,yl,yu),(zf,zl,zu)) in + continueWith $ RVal x y z s + +llRot2Fwd _ [RVal x y z s] = + let ((x,_,_),(y,_,_),(z,_,_)) = quaternionToMatrix (x,y,z,s) in + continueWith $ VVal x y z +llRot2Left _ [RVal x y z s] = + let ((_,x,_),(_,y,_),(_,z,_)) = quaternionToMatrix (x,y,z,s) in + continueWith $ VVal x y z +llRot2Up _ [RVal x y z s] = + let ((_,_,x),(_,_,y),(_,_,z)) = quaternionToMatrix (x,y,z,s) in + continueWith $ VVal x y z + +llRot2Euler _ [RVal x y z s] = + let (x',y',z') = quaternionToRotations P123 False (x,y,z,s) + in continueWith $ VVal x' y' z' + +llEuler2Rot _ [VVal x y z] = + let (x',y',z',s) = rotationsToQuaternion P123 (x,y,z) + in continueWith $ RVal x' y' z' s + +llRotBetween n [v0@(VVal x1 y1 z1),v1@(VVal x2 y2 z2)] = return (rotationBetween (vVal2Vec v0) (vVal2Vec v1)) >>= continueWith . rot2RVal + +llAngleBetween _ [RVal aX aY aZ aS,RVal bX bY bZ bS] = + continueWith $ FVal $ 2 * acos ((aX * bX + aY * bY + aZ * bZ + aS * bS) + / sqrt ((aX^2 + aY^2 + aZ^2 + aS^2) * + (bX^2 + bY^2 + bZ^2 + bS^2))) + +llVecMag _ [v@(VVal x y z)] = + continueWith $ FVal $ mag3d (vVal2Vec v) + +llVecDist _ [v1@(VVal x1 y1 z1),v2@(VVal x2 y2 z2)] = + continueWith $ FVal $ dist3d (vVal2Vec v1) (vVal2Vec v2) + +llVecNorm _ [v@(VVal x y z)] = + let mag2 = mag3d2 (vVal2Vec v) in + continueWith $ if mag2 == 0.0 then VVal 0.0 0.0 0.0 + else let mag = sqrt mag2 in + VVal (x/mag) (y/mag) (z/mag) + +-- List Functions + +--llGetListLength Gets the number of elements in a list +llGetListLength _ [LVal list] = continueWith $ IVal (length list) +llList2List _ [LVal source, IVal start, IVal end] = continueWith $ LVal (subList source start end) +llDeleteSubList _ [LVal source, IVal start, IVal end] = continueWith $ LVal (deleteSubList source start end) + +llDumpList2String _ [LVal list, SVal sep] = + continueWith $ SVal $ concat $ intersperse sep (map lslValString list) + +deleteSubList source start end = + let n = length source + s = convertIndex n start + e = convertIndex n end + in if s <= e then take s source ++ drop (e + 1) source + else drop (e + 1) $ take s source + +subList source start end = + let n = length source + s = convertIndex n start + e = convertIndex n end + in + if s <= e then take (e - s + 1) $ drop s source + else take (e+1) source ++ drop s source + +convertIndex length index = if index < 0 then length + index else index + + +-- llCSV2List Converts comma-separated values (CSV) to a list +-- llList2CSV Converts a list to comma-separated values (CSV) + +llCSV2List _ [SVal s] = + continueWith $ LVal $ map SVal (lslCsvToList [] s) +llList2CSV _ [LVal l] = + continueWith $ SVal $ concat (intersperse "," (map lslValToString l)) + +lslValToString (VVal x y z) = "<" ++ (show x) ++ "," ++ (show y) ++ "," ++ (show z) ++ ">" +lslValToString (RVal x y z s) = "<" ++ (show x) ++ "," ++ (show y) ++ "," ++ (show z) ++ "," ++ (show s) ++ ">" +lslValToString (SVal s) = s +lslValToString (KVal k) = k +lslValToString (IVal i) = show i +lslValToString (FVal f) = show f + +lslCsvToList partial [] = [reverse partial] +lslCsvToList partial (',':rst) = (reverse partial) : (lslCsvToList [] rst) +lslCsvToList partial ('<':rst) = bracketPattern 0 ('<':partial) rst +lslCsvToList partial (x:rst) = lslCsvToList (x:partial) rst + +bracketPattern 0 partial ('>':rst) = lslCsvToList ('>':partial) rst +bracketPattern n partial ('>':rst) = bracketPattern (n-1) ('>':partial) rst +bracketPattern n partial ('<':rst) = bracketPattern (n+1) ('<':partial) rst +bracketPattern n partial (x:rst) = bracketPattern n (x:partial) rst +bracketPattern n partial [] = lslCsvToList partial [] + +llListFindList _ [LVal source, LVal pattern] = continueWith $ IVal $ + case indexOf pattern source of + Nothing -> (-1) + Just i -> i +llListInsertList _ [LVal dst, LVal src, IVal pos] = + let (x,y) = splitAt pos dst in continueWith $ LVal $ x ++ src ++ y + +-- TODO: does SL handle start > end? +llListReplaceList _ [LVal dst, LVal src, IVal start, IVal end] = + let n = length src + s = convertIndex n start + e = convertIndex n end + (x,y) = cut s (e+1) dst in continueWith $ LVal $ x ++ src ++ y + +-- llList2ListStrided Extracts a subset of a strided list +-- TODO: assumes this works like llList2List, but first extracting every nth elem +llList2ListStrided _ [LVal src, IVal start, IVal end, IVal stride] = + let start' = (start `div` stride) + (if start `mod` stride /= 0 then 1 else 0) + end' = (end `div` stride) + stridedSrc = filtMap (\ (x,y) -> if x `mod` stride == 0 then Just y else Nothing) $ zip [0..] src + in + continueWith $ LVal $ subList stridedSrc start' end' + +strideList l stride = + if length l <= stride || stride <= 1 then [l] else (take stride l):(strideList (drop stride l) stride) + +llListSort _ [LVal list, IVal stride, IVal ascending] = + let Just (IVal true) = findConstVal "TRUE" -- this will crash if true isn't defined... + -- according to the documentation for this function + -- ascending must EQUAL the constant TRUE, or sort + -- will be descending (which is odd) + direction = if ascending == true then id else reverse + in continueWith $ LVal $ + concat (direction $ sort $ strideList list stride) + + +typeCodes = map (\ (t,Just v) -> (t,v)) [ + (LLInteger, findConstVal "TYPE_INTEGER"), + (LLFloat, findConstVal "TYPE_FLOAT"), + (LLString, findConstVal "TYPE_STRING"), + (LLKey, findConstVal "TYPE_KEY"), + (LLVector, findConstVal "TYPE_VECTOR"), + (LLRot, findConstVal "TYPE_ROTATION")] + +invalidType = let Just v = findConstVal "TYPE_INVALID" in v + +-- TODO: might this function work with negative indices? assuming no. +llGetListEntryType _ [LVal l, IVal index] = + continueWith $ + if index < 0 || index >= length l then invalidType + else let Just v = lookup (typeOfLSLValue $ l !! index) typeCodes in v + +llList2Float _ [LVal l, IVal index] = + continueWith $ FVal $ + case elemAtM index l of + Just (SVal s) -> parseFloat s + Just (IVal i) -> fromInt i + Just (FVal f) -> f + _ -> 0.0 + +llList2Integer _ [LVal l, IVal index] = + continueWith $ IVal $ + case elemAtM index l of + Just (SVal s) -> parseInt s + Just (IVal i) -> i + Just (FVal f) -> truncate f + _ -> 0 + +llList2Key _ [LVal l, IVal index] = + continueWith $ + case elemAtM index l of + Just v -> let (SVal v') = toSVal v in KVal v' + _ -> let (Just (SVal v)) = findConstVal "NULL_KEY" in KVal v +llList2Rot _ [LVal l, IVal index] = + continueWith $ case elemAtM index l of + Just r@(RVal _ _ _ _) -> r + _ -> let (Just r) = findConstVal "ZERO_ROTATION" in r + +llList2String _ [LVal l, IVal index] = + continueWith $ + case elemAtM index l of + Nothing -> SVal "" + Just v -> toSVal v + +llList2Vector _ [LVal l, IVal index] = + continueWith $ case elemAtM index l of + Just v@(VVal _ _ _) -> v + _ -> let (Just v) = findConstVal "ZERO_VECTOR" in v + + +base64chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" + +llIntegerToBase64 _ [IVal i] = + let digit1 = 63 .&. (i `shiftR` 26) + digit2 = 63 .&. (i `shiftR` 20) + digit3 = 63 .&. (i `shiftR` 14) + digit4 = 63 .&. (i `shiftR` 8) + digit5 = 63 .&. (i `shiftR` 2) + digit6 = 63 .&. (i `shiftR` (-4)) + in continueWith $ SVal $ map (base64chars !!) [digit1,digit2,digit3,digit4,digit5,digit6] ++ "==" + +charToBits :: Char -> Int +charToBits c = case elemIndex c base64chars of + Nothing -> 0 + Just i -> i + +llBase64ToInteger _ [SVal s] = + let n = length s + s' = if n >= 8 then s else (s ++ (replicate (6 - n) 'A')) + charToBits c = case elemIndex c base64chars of + Nothing -> 0 + Just i -> i + in continueWith $ IVal $ foldl' (.|.) 0 $ zipWith (shiftL) (map charToBits (take 6 s')) [26,20..] + +slPrintable :: String +slPrintable = map toEnum (10:[32..127]) + +mkPrintable c = if c `elem` slPrintable then c else '?' + +-- some valid cases +decodeB64 :: String -> String +decodeB64 [] = [] +decodeB64 (x:y:'=':'=':[]) = + let (c1,c2,_) = decodeQuartet(charToBits x,charToBits y,0,0) in [c1] +decodeB64 (x:y:z:'=':[]) = + let (c1,c2,_) = decodeQuartet(charToBits x,charToBits y,charToBits z,0) in [c1,c2] +decodeB64 (w:x:y:z:rest) = + let (c1,c2,c3) = decodeQuartet(charToBits w,charToBits x,charToBits y,charToBits z) in + (c1:c2:c3:(decodeB64 rest)) +-- some invalid ones +decodeB64 (x:[]) = + let (c1,_,_) = decodeQuartet(charToBits x,0,0,0) in [c1] +decodeB64 (x:y:[]) = + let (c1,_,_) = decodeQuartet(charToBits x,charToBits y,0,0) in [c1] +decodeB64 (x:y:z:[]) = + let (c1,c2,_) = decodeQuartet(charToBits x,charToBits y,charToBits z,0) in [c1] + +decodeQuartet :: (Int,Int,Int,Int) -> (Char,Char,Char) +decodeQuartet (w,x,y,z) = + let c1 = (w `shiftL` 2) .|. (x `shiftR` 4) + c2 = ((x `shiftL` 4) .|. (y `shiftR` 2)) .&. 255 + c3 = ((y `shiftL` 6) .|. z) .&. 255 + in (toEnum c1,toEnum c2, toEnum c3) + + +stripPadChars ('=':'=':[]) = [] +stripPadChars ('=':[]) = [] +stripPadChars [] = [] +stripPadChars (x:xs) = x:(stripPadChars xs) + +llXorBase64Strings _ [SVal s1, SVal s2] = + let i1 = map charToBits $ stripPadChars s1 + i2 = map charToBits $ stripPadChars s2 + n = length i2 + i3 = zipWith (\ v i -> v `xor` (i2 !! (i `mod` n))) i1 [0..] + in continueWith $ SVal $ map (base64chars !!) i3 + +-- test strings s1 = YWJjZGVm, s2 = eHl6 => GRsZHBwc +-- s1 = YWJjZGVm, s2 = eHl6dw== => GRsZEx0f +-- s1 = YWJjZGVm, s2 = eHl6d3h5 => GRsZEx0f + +--trace1 v = trace (show v) v +llXorBase64StringsCorrect _ [SVal s1, SVal s2] = + let s1' = map fromEnum $ decodeB64 s1 + s2' = map fromEnum $ decodeB64 s2 + n = length s2' + s3 = zipWith (\ v i -> v `xor` (s2' !! (i `mod` n))) s1' [0..] + in continueWith $ SVal $ encodeB64 (map toEnum s3) +llBase64ToString _ [SVal s] = continueWith $ SVal $ map mkPrintable $ decodeB64 s + +llStringToBase64 _ [SVal s] = + let s' = (encodeB64 s) in + continueWith $ SVal s' + +encodeB64 [] = [] +encodeB64 [x] = encode1 x +encodeB64 [x,y] = encode2 (x,y) +encodeB64 (x:y:z:rest) = encode3 (x,y,z) ++ (encodeB64 rest) + +encode3 :: (Char,Char,Char) -> [Char] +encode3 (c1,c2,c3) = + let b1 = ((fromEnum c1) `shiftR` 2) .&. 63 + b2 = (((fromEnum c1) `shiftL` 4) .|. ((fromEnum c2) `shiftR` 4)) .&. 63 + b3 = (((fromEnum c2) `shiftL` 2) .|. ((fromEnum c3) `shiftR` 6)) .&. 63 + b4 = (fromEnum c3) .&. 63 + in [base64chars !! b1,base64chars !! b2,base64chars !! b3,base64chars !! b4] +encode2 :: (Char,Char) -> [Char] +encode2 (c1,c2) = + let b1 = ((fromEnum c1) `shiftR` 2) .&. 63 + b2 = (((fromEnum c1) `shiftL` 4) .|. ((fromEnum c2) `shiftR` 4)) .&. 63 + b3 = ((fromEnum c2) `shiftL` 2) .&. 63 + in [base64chars !! b1,base64chars !! b2,base64chars !! b3,'='] +encode1 :: Char -> [Char] +encode1 c1 = + let b1 = ((fromEnum c1) `shiftR` 2) .&. 63 + b2 = ((fromEnum c1) `shiftL` 4) .&. 63 + in [base64chars !! b1,base64chars !! b2,'=','='] diff --git a/Language/Lsl/Internal/Key.hs b/Language/Lsl/Internal/Key.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/Key.hs @@ -0,0 +1,21 @@ +module Language.Lsl.Internal.Key (nextKey, nullKey, mkKey) where +import Data.List(elemIndex) +import Text.Printf(printf) +nullKey = "00000000-0000-0000-0000-000000000000" +keyCharSet = ['0'..'9'] ++ ['a'..'z'] + +nextKey [] = error "can't generate a successor key!" +nextKey ('-':cs) = '-':(nextKey cs) +nextKey (c:cs) = + case elemIndex c keyCharSet of + Nothing -> c:(nextKey cs) + Just i -> if i == length keyCharSet then '0' : (nextKey cs) else (keyCharSet !! (i+1)):cs + +mkKey :: Integer -> String +mkKey i = + let s0 = printf "%032x" i + (p1,s1) = splitAt 8 s0 + (p2,s2) = splitAt 4 s1 + (p3,s3) = splitAt 4 s2 + (p4,p5) = splitAt 4 s3 + in p1 ++ ('-':p2) ++ ('-':p3) ++ ('-':p4) ++ ('-':p5) diff --git a/Language/Lsl/Internal/Load.hs b/Language/Lsl/Internal/Load.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/Load.hs @@ -0,0 +1,39 @@ +module Language.Lsl.Internal.Load( + loadScripts, + loadModules) where + +import Control.Exception(SomeException(..),tryJust) +import Control.Monad.Error(liftIO) +import Language.Lsl.Internal.BuiltInModules(avEventGen) +import Language.Lsl.Syntax(validLSLScript,validLibrary,SourceContext(..)) +import Language.Lsl.Parse(parseModule, parseScript) + +parseFiles p files = + let parseFile (name,path) = + do result <- tryJust (\ e@(SomeException x) -> Just (show e)) $ p path + case result of + Left msg -> return (name,Left (UnknownSourceContext,msg)) + Right (Left err) -> return (name,Left err) + Right (Right m) -> return (name,Right m) + in liftIO $ mapM parseFile files + +loadModules files = + do parseResults <- parseFiles parseModule files + let (bad,ok) = splitResults parseResults + let augLib = validLibrary (avEventGen:ok) + return (augLib ++ (map (\ (n,err) -> (n,Left err)) bad)) + --return (validated ++ (map (\ (n,err) -> (n,Left err)) bad)) + +loadScripts library files = + do parseResults <- parseFiles parseScript files + let (bad,ok) = splitResults parseResults + return $ (map (\ (n,script) -> (n,validLSLScript library script)) ok) ++ + (map (\ (n,err) -> (n,Left err)) bad) + +splitResults [] = ([],[]) +splitResults ((name,Left err):xs) = + let (lefts,rights) = splitResults xs in + ((name,err):lefts,rights) +splitResults ((name, Right m):xs) = + let (lefts,rights) = splitResults xs in + (lefts,(name,m):rights) diff --git a/Language/Lsl/Internal/Log.hs b/Language/Lsl/Internal/Log.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/Log.hs @@ -0,0 +1,15 @@ +module Language.Lsl.Internal.Log(LogLevel(..), LogMessage(..),logLevelToName) where + +data LogLevel = LogTrace | LogDebug | LogInfo | LogWarn | LogError + deriving (Show,Eq,Ord) + +data LogMessage = LogMessage { logMessageTime :: Int, logMessageLevel :: LogLevel, + logMessageSource :: String, logMessageText :: String } + deriving (Show) + +logLevelToName logLevel = case logLevel of + LogTrace -> "TRACE" + LogDebug -> "DEBUG" + LogInfo -> "INFO" + LogWarn -> "WARN" + LogError -> "ERROR" diff --git a/Language/Lsl/Internal/Math.hs b/Language/Lsl/Internal/Math.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/Math.hs @@ -0,0 +1,129 @@ +module Language.Lsl.Internal.Math( + dist3d2, + dist3d, + mag3d2, + mag3d, + dot3d, + norm3d, + diff3d, + add3d, + neg3d, + scale3d, + rot3d, + Permutation3(..), + quaternionToMatrix, + matrixToQuaternion, + quaternionMultiply, + invertQuaternion, + quaternionToRotations, + rotationsToQuaternion, + cross, + rotationBetween, + angleBetween, + axisAngleToRotation, + axisAngleFromRotation) where + +-- import Debug.Trace +dist3d2 (x1,y1,z1) (x2,y2,z2) = ((x2-x1)^2 + (y2-y1)^2 + (z2-z1)^2) +dist3d v0 v1 = sqrt $ dist3d2 v0 v1 + +dot3d (x1,y1,z1) (x2,y2,z2) = x1 * x2 + y1 * y2 + z1 * z2 + +mag3d2 (x,y,z) = (x^2 + y^2 + z^2) +mag3d v = sqrt $ mag3d2 v + +norm3d v@(x,y,z) = let mag = mag3d v in (x/mag,y/mag,z/mag) + +diff3d (x,y,z) (x',y',z') = (x - x', y - y', z - z') +add3d (x,y,z) (x',y',z') = (x + x', y + y', z + z') +neg3d (x,y,z) = (-x,-y,-z) + +scale3d v (x,y,z) = (v*x,v*y,v*z) + +quaternionToMatrix (x,y,z,s) = + ((s*s + x*x - y*y - z*z, 2*x*y - 2*s*z, 2*x*z + 2*s*y), + (2*x*y + 2*s*z, s*s - x*x + y*y - z*z, 2*y*z - 2*s*x), + (2*x*z - 2*s*y, 2*y*z + 2*s*x, s*s - x*x - y*y + z*z)) + +-- reversing the conversion: +matrixToQuaternion ((r00,r01,r02),(r10,r11,r12),(r20,r21,r22)) = + (sign (r21 - r12) * (sqrt (max 0 (1 + r00 - r11 - r22 ))) / 2, + sign (r02 - r20) * (sqrt (max 0 (1 - r00 + r11 - r22))) / 2, + sign (r10 - r01) * (sqrt (max 0 (1 - r00 - r11 + r22 ))) / 2, + (sqrt (max 0 (1 + r00 + r11 + r22))) / 2) + +quaternionMultiply (x1,y1,z1,s1) (x2,y2,z2,s2) = + ((s1 * x2 + x1 * s2 + y1 * z2 - z1 * y2), + (s1 * y2 - x1 * z2 + y1 * s2 + z1 * x2), + (s1 * z2 + x1 * y2 - y1 * x2 + z1 * s2), + (s1 * s2 - x1*x2 - y1 * y2 - z1 * z2)) + +rot3d vec rotation = + (quaternionToMatrix rotation) `matMulVec` vec + where matMulVec ((a1,b1,c1),(a2,b2,c2),(a3,b3,c3)) (a,b,c) = + ((a1 * a + b1 * b + c1 * c),(a2 * a + b2 * b + c2 * c),(a3 * a + b3 * b + c3 * c)) + +invertQuaternion (x,y,z,s) = (-x,-y,-z,s) + +rotationsToQuaternion :: Permutation3 -> (Float,Float,Float) -> (Float,Float,Float,Float) +rotationsToQuaternion order (x,y,z) = + let rx = (sin (x/2), 0.0, 0.0, cos (x/2)) + ry = (0.0, sin (y/2), 0.0, cos (y/2)) + rz = (0.0, 0.0, sin (z/2), cos (z/2)) + (r3,r2,r1) = permute order (rx,ry,rz) + in ((r3 `quaternionMultiply` r2) `quaternionMultiply` r1) + +data Permutation3 = P123 | P132 | P213 | P231 | P312 | P321 + +permute P123 (x,y,z) = (x,y,z) +permute P132 (x,y,z) = (x,z,y) +permute P213 (x,y,z) = (y,x,z) +permute P231 (x,y,z) = (y,z,x) +permute P312 (x,y,z) = (z,x,y) +permute P321 (x,y,z) = (z,y,x) + +quatPermute (x,y,z,w) p = let (p1,p2,p3) = permute p (x,y,z) in (p1,p2,p3,w) + +sign f = if f < 0 then -1 else 1 + +quaternionToRotations :: Permutation3 -> Bool -> (Float,Float,Float,Float) -> (Float,Float,Float) +quaternionToRotations rotOrder lh quat= + let (p1,p2,p3,p0) = quatPermute quat rotOrder + mult = if lh then -1 else 1 + sinTheta2 = 2 * (p0 * p2 + mult * p1 * p3) + (sinTheta2',singularity) = + if (abs sinTheta2 >= 0.9999999) then (sign sinTheta2,True) else (sinTheta2,False) + theta2 = asin sinTheta2' + theta3 = if singularity then atan2 (p3*p0 + p1*p2) (0.5 - p1*p1 - p3*p3) + else atan2 (2 * (p0 * p3 - mult * p1 * p2)) (1 - 2 * (p2 * p2 + p3 * p3)) + theta1 = if singularity then 0 + else atan2 (2 * ( p0 * p1 - mult * p2 * p3)) (1 - 2 * (p1 * p1 + p2 * p2)) + in (theta1,theta2,theta3) + +cross (x1,y1,z1) (x2,y2,z2) = ((y1 * z2 - z1 * y2),(z1 * x2 - x1 * z2),(x1 * y2 - y1 * x2)) + +rotationBetween v0 v1 = + let (v0',v1') = (norm3d v0,norm3d v1) + axis = v0' `cross` v1' + angle = acos (v0' `dot3d` v1') + in axisAngleToRotation axis angle + +angleBetween (aX,aY,aZ,aS) (bX,bY,bZ,bS) = + 2 * acos ((aX * bX + aY * bY + aZ * bZ + aS * bS) / sqrt ((aX^2 + aY^2 + aZ^2 + aS^2) * (bX^2 + bY^2 + bZ^2 + bS^2))) + +axisAngleToRotation (x,y,z) angle = + let w = cos (angle/2.0) + sinVal = sin (angle/2.0) + x' = x * sinVal + y' = y * sinVal + z' = z * sinVal + in (x',y',z',w) + +axisAngleFromRotation (x,y,z,s) = + let s' = max (-1) (min 1 s) + angle = 2 * acos s' + sinVal = sin (angle/2) + x' = x / sinVal + y' = y / sinVal + z' = z / sinVal + in if sinVal == 0 then ((1,0,0),0) else ((x',y',z'),angle) diff --git a/Language/Lsl/Internal/MetaData.hs b/Language/Lsl/Internal/MetaData.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/MetaData.hs @@ -0,0 +1,59 @@ +module Language.Lsl.Internal.MetaData where + +-- constructs meta-data about the LSL+ language, and emits it as XML. + +import Language.Lsl.Internal.Constants(Constant(..),allConstants) +import Language.Lsl.Internal.EventSigs(lslEventDescriptors) +import Language.Lsl.Internal.FuncSigs(funcMeta) +import Language.Lsl.Internal.InternalLLFuncs(internalLLFuncNames) +import Language.Lsl.Internal.Type(LSLValue(..),LSLType(..),lslTypeString,lslValString,typeOfLSLValue) +import qualified Language.Lsl.Internal.XmlCreate as X + +emit t = X.emit t [] +emitSimple t s = X.emitSimple t [] s + +-- this is the main function... +printMeta = putStr buildMeta + +buildMeta :: String +buildMeta = + emit "lslmeta" [handlers,functions,constants] "" + +emitHandler (name,params,_,_,description) = + emit "handler" [ + emitSimple "name" name, + emitParams params', + emitSimple "description" description] + where params' = map (\ (x,y) -> (y,x)) params + +emitParams params = emit "params" (map emitParam params) +emitParam (name,t) = emit "param" [emitSimple "name" name, emitSimple "type" (lslTypeString t)] + +handlers = + emit "handlers" (map emitHandler lslEventDescriptors) + +functions = + emit "functions" (map emitFunction funcMeta) + +emitFunction (name,rtype,params,description) = + emit "function" [ + emitSimple "name" name, + emitSimple "returns" (if (rtype == LLVoid) then "" else lslTypeString rtype), + emitParams params, + emitSimple "description" description, + emitSimple "stateless" (if (name `elem` internalLLFuncNames) then "true" else "false")] + +constants = + emit "constants" (map emitConstant allConstants) + +emitConstant (Constant name value) = + emit "constant" [ + emitSimple "name" name, + emitSimple "type" (lslTypeString $ typeOfLSLValue value), + emitSimple "value" $ case value of + SVal s -> (show s) + KVal k -> (show k) + VVal x y z -> ("<" ++ show x ++ "," ++ show y ++ "," ++ show z ++ ">") + RVal x y z s -> ("<" ++ show x ++ "," ++ show y ++ "," ++ show z ++ "," ++ show s ++ ">") + _ -> lslValString value, + emitSimple "description" "no description"] diff --git a/Language/Lsl/Internal/NumberParsing.hs b/Language/Lsl/Internal/NumberParsing.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/NumberParsing.hs @@ -0,0 +1,59 @@ +module Language.Lsl.Internal.NumberParsing(readHexFloat,readInt) where + +import Data.Char(digitToInt) +import Text.ParserCombinators.Parsec(GenParser(..),(<|>),char,digit,hexDigit,many,many1,oneOf,option,parse,satisfy) + +hexFloat = + do char '0' + oneOf "xX" + wholeDigits <- many1 hexDigit + let w = foldl (\ x y -> x * 16.0 + y) 0.0 $ map (fromIntegral . digitToInt) wholeDigits + frac <- option 0.0 fractionalPart + p <- expPart + return $ (w + frac) * p + +fractionalPart = + do char '.' + digits <- many1 hexDigit + return $ foldr (\ x y -> (x + y) / 16.0) 0.0 $ map (fromIntegral . digitToInt) digits + +expPart = + do oneOf "pP" + f <- option (2^) ((char '+' >> return (2^)) <|> (char '-' >> return ((1/).(2^)))) + digits <- many1 digit + let exp = foldl (\ x y -> 10 * x + y) 0 $ map digitToInt digits + return $ f exp + +hexFloatAndTail :: Fractional a => GenParser Char b [(a,String)] +hexFloatAndTail = + do v <- hexFloat + rest <- many (satisfy (const True)) + return [(realToFrac v,rest)] + +readHexFloat s = + case parse hexFloatAndTail "" s of + Left _ -> [] + Right v -> v + +hexInt = + do oneOf "xX" + digits <- many1 hexDigit + return $ foldl (\ x y -> x * 16 + y) 0 $ map digitToInt digits + +decimalInt = + do digits <- many1 digit + return $ foldl (\ x y -> x * 10 + y) 0 $ map digitToInt digits + +int = do char '0' + (hexInt <|> decimalInt <|> return 0) + <|> decimalInt + +intAndTail = + do i <- int + rest <- many (satisfy (const True)) + return (i,rest) + +readInt s = + case parse intAndTail "" s of + Left _ -> [] + Right v -> [v] diff --git a/Language/Lsl/Internal/Optimize.hs b/Language/Lsl/Internal/Optimize.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/Optimize.hs @@ -0,0 +1,73 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} +module Language.Lsl.Internal.Optimize(optimizeScript) where + +import Language.Lsl.Syntax(CompiledLSLScript(..),Expr(..),Statement(..),Global(..),Func(..),FuncDec(..),State(..),Ctx(..),Handler(..)) + +optimizeScript :: CompiledLSLScript -> CompiledLSLScript +optimizeScript (CompiledLSLScript gs fs ss) = (CompiledLSLScript gs fs' ss) + where usedFuncs = concatMap stateUsesFuncs ss ++ concatMap funcUsesFuncs fs + fs' = [ f | f@(Func fd _) <- fs, (ctxItem . funcName) fd `elem` usedFuncs ] + +exprUsesFuncs :: Expr -> [String] +exprUsesFuncs (Call (ctxName) es) = ctxItem ctxName : (exprsUsesFuncs es) +exprUsesFuncs (IntLit _) = [] +exprUsesFuncs (FloatLit _) = [] +exprUsesFuncs (StringLit _) = [] +exprUsesFuncs (KeyLit _) = [] +exprUsesFuncs (ListExpr es) = exprsUsesFuncs es +exprUsesFuncs (VecExpr x y z) = exprsUsesFuncs [x,y,z] +exprUsesFuncs (RotExpr x y z s) = exprsUsesFuncs [x,y,z,s] +exprUsesFuncs (Add e1 e2) = exprsUsesFuncs [e1,e2] +exprUsesFuncs (Sub e1 e2) = exprsUsesFuncs [e1,e2] +exprUsesFuncs (Mul e1 e2) = exprsUsesFuncs [e1,e2] +exprUsesFuncs (Div e1 e2) = exprsUsesFuncs [e1,e2] +exprUsesFuncs (Mod e1 e2) = exprsUsesFuncs [e1,e2] +exprUsesFuncs (Set _ e) = exprUsesFuncs' e +exprUsesFuncs (BAnd e1 e2) = exprsUsesFuncs [e1,e2] +exprUsesFuncs (BOr e1 e2) = exprsUsesFuncs [e1,e2] +exprUsesFuncs (Xor e1 e2) = exprsUsesFuncs [e1,e2] +exprUsesFuncs (ShiftL e1 e2) = exprsUsesFuncs [e1,e2] +exprUsesFuncs (ShiftR e1 e2) = exprsUsesFuncs [e1,e2] +exprUsesFuncs (And e1 e2) = exprsUsesFuncs [e1,e2] +exprUsesFuncs (Or e1 e2) = exprsUsesFuncs [e1,e2] +exprUsesFuncs (Equal e1 e2) = exprsUsesFuncs [e1,e2] +exprUsesFuncs (NotEqual e1 e2) = exprsUsesFuncs [e1,e2] +exprUsesFuncs (Lt e1 e2) = exprsUsesFuncs [e1,e2] +exprUsesFuncs (Gt e1 e2) = exprsUsesFuncs [e1,e2] +exprUsesFuncs (Le e1 e2) = exprsUsesFuncs [e1,e2] +exprUsesFuncs (Ge e1 e2) = exprsUsesFuncs [e1,e2] +exprUsesFuncs (IncBy _ e) = exprUsesFuncs' e +exprUsesFuncs (DecBy _ e) = exprUsesFuncs' e +exprUsesFuncs (MulBy _ e) = exprUsesFuncs' e +exprUsesFuncs (DivBy _ e) = exprUsesFuncs' e +exprUsesFuncs (ModBy _ e) = exprUsesFuncs' e +exprUsesFuncs (Not e) = exprUsesFuncs' e +exprUsesFuncs (Neg e) = exprUsesFuncs' e +exprUsesFuncs (Inv e) = exprUsesFuncs' e +exprUsesFuncs (Cast _ e) = exprUsesFuncs' e +exprUsesFuncs _ = [] + +exprUsesFuncs' = exprUsesFuncs . ctxItem +exprsUsesFuncs = concatMap exprUsesFuncs' + +statementUsesFuncs :: Statement -> [String] +statementUsesFuncs (Compound ss) = concatMap (statementUsesFuncs . ctxItem) ss +statementUsesFuncs (While e s) = exprUsesFuncs' e ++ statementUsesFuncs s +statementUsesFuncs (DoWhile s e) = statementUsesFuncs s ++ exprUsesFuncs' e +statementUsesFuncs (For e1 me2 e3 s) = + exprsUsesFuncs e1 ++ maybe [] exprUsesFuncs' me2 ++ exprsUsesFuncs e3 ++ statementUsesFuncs s +statementUsesFuncs (If e s1 s2) = exprUsesFuncs' e ++ statementUsesFuncs s1 ++ statementUsesFuncs s2 +statementUsesFuncs (Decl _ (Just e)) = exprUsesFuncs' e +statementUsesFuncs (Return (Just e)) = exprUsesFuncs' e +statementUsesFuncs (Do e) = exprUsesFuncs' e +statementUsesFuncs _ = [] + +statementUsesFuncs' = statementUsesFuncs . ctxItem + +funcUsesFuncs :: Func -> [String] +funcUsesFuncs (Func _ stmts) = concatMap statementUsesFuncs' stmts +handlerUsesFuncs :: Handler -> [String] +handlerUsesFuncs (Handler _ _ stmts) = concatMap statementUsesFuncs' stmts + +stateUsesFuncs :: State -> [String] +stateUsesFuncs (State _ handlers) = concatMap handlerUsesFuncs handlers diff --git a/Language/Lsl/Internal/Physics.hs b/Language/Lsl/Internal/Physics.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/Physics.hs @@ -0,0 +1,133 @@ +module Language.Lsl.Internal.Physics( + bbIntersect, + kin, + rotDyn, + totalTorque, + calcAccel, + dampZForce, + dampForce, + dampTorque, + primMassApprox, + checkIntersections, + momentOfInertia, + gravC + )where + +import Language.Lsl.Internal.Math(add3d,axisAngleFromRotation,axisAngleToRotation,diff3d, + invertQuaternion,mag3d,norm3d,quaternionMultiply,scale3d) +import Language.Lsl.WorldDef(Prim(..),PrimType(..)) +import Language.Lsl.Internal.Constants(cPrimTypeBox,cPrimTypeCylinder,cPrimTypeSculpt,cPrimTypeSphere) + +rangeOverlap (mn0,mx0) (mn1,mx1) = mn0 >= mn1 && mn0 <= mx1 || mx0 >= mn1 && mx0 <= mx1 || mn0 <= mn1 && mx0 >= mx1 +bbIntersect ((mnX0,mnY0,mnZ0),(mxX0,mxY0,mxZ0)) ((mnX1,mnY1,mnZ1),(mxX1,mxY1,mxZ1)) = + rangeOverlap (mnX0,mxX0) (mnX1,mxX1) && + rangeOverlap (mnY0,mxY0) (mnY1,mxY1) && + rangeOverlap (mnZ0,mxZ0) (mnZ1,mxZ1) + +-- really poor mass approximations, especially when tapering, shearing is involved, or non-box/cyl/spheres are used +boxMassSimple (x,y,z) c1 c2 h = realToFrac 10.0 * x * y * z * c1 * c2 * h +cylMassSimple (x,y,z) c1 c2 h = realToFrac 10.0 * pi * (x/2) * (y/2) * z * c1 * c2 * h +sphMassSimple (x,y,z) c1 c2 h = realToFrac 10.0 * (4/3) * pi * (x/2) * (y/2) * (z/2) * c1 * c2 * h +otherMassSimple :: Floating a => (a,a,a) -> a -> a -> a -> a +otherMassSimple = sphMassSimple + +-- volume of a torus = (pi * r^2) * (2 * pi * R) = (x-section-area) * length +-- perimeter of an ellipse = pi * (a + b) * (1 + 3 * h / (10 + sqrt (4 - 3 * h))) where h = (a - b)^2 / (a + b)^2 + +primMassApprox :: Prim -> Float +primMassApprox (Prim { primScale = scale, primTypeInfo = primType }) = primMassApprox' scale primType + +primMassApprox' :: (Float,Float,Float) -> PrimType -> Float +primMassApprox' scale primType = + case primType of + PrimTypeUnknown -> otherMassSimple scale 1 1 1 + PrimType { primTypeCode = code } -> + case code of + c | c == cPrimTypeBox -> boxMassSimple scale c1 c2 h + | c == cPrimTypeCylinder -> cylMassSimple scale c1 c2 h + | c == cPrimTypeSphere -> sphMassSimple scale c1 c2 h + | c == cPrimTypeSculpt -> otherMassSimple scale 1 1 1 + | otherwise -> otherMassSimple scale c1 c2 h + where c1 = let (x,y,_) = primCut primType in y - x + c2 = let (x,y,_) = primAdvancedCut primType in y - x + h = 1 - primHollow primType + +gravC = -9.80665 :: Float +gravA = (0,0,gravC) :: (Float,Float,Float) +belowGround zoffset (_,_,z) = z + zoffset <= 0 + +kin t0 t1 t2d zoffs m p0 v0 f (i,ti) = + let accel = gravA `add3d` scale3d (1/m) f + accel1 = scale3d (1/m) i + limit (p@(x,y,z),v@(vx,vy,vz)) = if belowGround zoffs p then ((x,y,0),(vx,vy, if vz < 0 then 0 else vz)) else (p,v) + d = t2d $ t1 - t0 + di = max 0 (min (t2d (ti - t0)) d) + in limit (p0 `add3d` (scale3d d v0) `add3d` (scale3d (d^2 / 2) accel) `add3d` (scale3d (di^2/2) accel1), + v0 `add3d` (scale3d d accel) `add3d` (scale3d di accel1)) + +calcAccel t zoffs m p f (i,ti) = + let (x,y,z) = gravA `add3d` scale3d (1/m) f `add3d` (if ti < t then (0,0,0) else scale3d (1/m) i) in + (x, y, if belowGround zoffs p then 0 else z) + +-- i have no enthusiasm to work out if this is right... :( +-- rotDyn t0 t1 t2d radius mass rot0 omega0@(ox0,oy0,oz0) torques = +-- let inertia = momentOfIntertia mass radius +-- dt = t2d $ t1 - t0 +-- accels = map ( \ ((tx,ty,tz),tf) -> ((tx/inertia,ty/inertia,tz/inertia), max 0 (min (t2d (tf - t0)) dt))) torques +-- lim theta = let rev = theta / (2 * pi) +-- (_,frac) = properFraction rev in rev * 2 * pi +-- lim3 (x,y,z) = (lim x, lim y, lim z) +-- limscale scale v = lim3 $ scale3d scale v +-- rot = foldl ( \ r r1 -> r `quaternionMultiply` r1) rot0 $ +-- ((rotationsToQuaternion P123 $ limscale dt omega0) : +-- (map (\ (a,d) -> rotationsToQuaternion P123 (limscale (d^2 * 0.5) a)) accels)) +-- omega = foldl (\ o (a,d) -> lim3 $ o `add3d` (scale3d d a)) omega0 accels +-- in (rot, omega) + +rotDyn dt radius mass rot0 omega0 torque = + let inertia = momentOfInertia mass radius + angularAcceleration = scale3d (1/inertia) torque + domega = scale3d dt angularAcceleration + drotV = (scale3d dt omega0) `add3d` (scale3d (dt^2/2) angularAcceleration) + drot = let mag = mag3d drotV in if mag == 0 then (0,0,0,1) else axisAngleToRotation (norm3d drotV) mag + in (rot0 `quaternionMultiply` drot, omega0 `add3d` domega) + +totalTorque t0 t1 t2d torques = + let dt = t2d $ t1 - t0 + torques' = map (\ (torque,tf) -> scale3d ((max 0 (min (t2d (tf - t0)) dt)) / dt) torque) torques + in foldl add3d (0,0,0) torques' + +checkIntersections toBB cmp objects = concat (go objects) + where go [] = [] + go (o:os) = [ pair o o' | (True,o') <- zip (map (bbIntersect (toBB o) . toBB ) os) os] : (go os) + pair o o' = if cmp o o' == LT then (o,o') else (o',o) + +dampZForce tau zt z0 m vz0 f = m * ((2 * (p - tau * vz0) / (tau^2)) - (gravC + f * m)) where p = zt - z0 + +dampForce tau pt p0 m v0 f = + scale3d m ((scale3d (2/(tau^2)) (p `diff3d` (scale3d tau v0))) `diff3d` (gravA `add3d` (scale3d m f))) + where p = pt `diff3d` p0 + +-- I of sphere +momentOfInertia mass r = (2/5) * mass * r^2 + +-- ignoring strength for now... +dampTorque tau strength rt r0 mass radius omega0 torque0 = + let inertia = momentOfInertia mass radius + r1 = let mag = mag3d omega0 in + if mag == 0 then r0 else r0 `quaternionMultiply` (axisAngleToRotation (norm3d omega0) (mag*tau)) + rotNeeded = ((invertQuaternion r1) `quaternionMultiply` rt) + (axis,angle) = axisAngleFromRotation rotNeeded + -- angle = tau^2 * ((1/inertia*2) * (torque + torque0)) + in scale3d (angle * 2 * inertia / (tau^2)) axis `diff3d` torque0 +-- testing... +iterativeDampingZ m z v zt tau dt = let f = dampZForce tau zt z m v 0 + z' = z + v * dt + v' = v + (f/m) * dt in + ((z',v',f) : iterativeDampingZ m z' v' zt tau dt) + +iterativeDamping m p v pt tau dt = let f = dampForce tau pt p m v (0,0,0) + p' = p `add3d` (scale3d dt v) + v' = v `add3d` (scale3d (dt/m) f) in + ((p',v',f) : iterativeDamping m p' v' pt tau dt) + diff --git a/Language/Lsl/Internal/SimMetaData.hs b/Language/Lsl/Internal/SimMetaData.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/SimMetaData.hs @@ -0,0 +1,32 @@ +module Language.Lsl.Internal.SimMetaData where + +import Control.Monad.Identity(Identity(..)) +import qualified Data.Map as M + +import Language.Lsl.Internal.Type(lslTypeString) +import Language.Lsl.Sim(SimInputEventDefinition(..),SimParam(..),SimParamType(..),eventDescriptors) +import Language.Lsl.Internal.XmlCreate(emit,emitList,emitSimple) + +printSimMeta = putStr buildSimMetaData + +buildSimMetaData = + emit "sim-meta-data" [] [ + emitList "eventDescriptors" emitEventDescriptor (M.toList (eventDescriptors :: M.Map String (SimInputEventDefinition Identity))) + ] "" + +emitEventDescriptor (_,def) = + emit "event-def" [] [emitSimple "name" [] (simInputEventName def), + emitSimple "description" [] (simInputEventDescription def), + emitList "params" emitParam (simInputEventParameters def)] + +emitParam p = + emit "param" [] [emitSimple "name" [] (simParamName p), + emitSimple "description" [] (simParamDescription p), + emitParamType (simParamType p)] + +emitParamType SimParamPrim = emit "type" [("class","prim")] [] +emitParamType SimParamAvatar = emit "type" [("class","avatar")] [] +emitParamType (SimParamLSLValue t) = emit "type" [("class","value")] [emitSimple "valueType" [] (lslTypeString t)] +emitParamType (SimParamRootPrim) = emit "type" [("class","object")] [] +emitParamType (SimParamKey) = emit "type" [("class","any-key")] [] +emitParamType (SimParamScript) = emit "type" [("class","script")] [] diff --git a/Language/Lsl/Internal/SystemTester.hs b/Language/Lsl/Internal/SystemTester.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/SystemTester.hs @@ -0,0 +1,118 @@ +{-# OPTIONS_GHC -XFlexibleContexts #-} +module Language.Lsl.Internal.SystemTester where + +import Control.Monad(MonadPlus(..)) +import Control.Monad.Error(MonadError(..),ErrorT(..)) +import Control.Monad.State(evalState) +import qualified Data.Map as M +import IO +import Language.Lsl.Internal.BreakpointsDeserialize(breakpointsElement) +import Language.Lsl.Internal.Compiler(compile) +import Language.Lsl.Internal.DOMProcessing(Content(..),Document(..),Element(..),ElemAcceptor(..), + elementList,simple,findElement,findOptionalElement,match,xmlParse) +import Language.Lsl.Internal.DOMSourceDescriptor(sourceFilesElement) +import Language.Lsl.Internal.ExecInfo(emitExecutionInfo) +import Language.Lsl.Internal.Log(LogMessage(..),logLevelToName) +import Language.Lsl.Syntax(libFromAugLib) +import Language.Lsl.Internal.Util(unescape,processLinesS) +import Language.Lsl.Sim(SimCommand(..),SimEvent(..),SimEventArg(..),SimStatus(..),SimStateInfo(..),simStep) +import Language.Lsl.WorldDef(worldElement) +import Language.Lsl.Internal.XmlCreate(emit,emitList,emitSimple) + +initializationFromXML xml = let doc = xmlParse "" xml in parseInitialization doc + +parseInitialization (Document _ _ root _) = match initSimElement root + +--initSimElement :: MonadError String m => ElemAcceptor m (([(String,String)],[(String,String)]),FullWorldDef) +initSimElement = + let f (Elem _ _ contents) = + do (sources,contents1) <- findElement sourceFilesElement [ e | e@(CElem _ _) <- contents] + (worldDef,[]) <- findElement worldElement contents1 + return (sources,worldDef) + in ElemAcceptor "sim-descriptor" f + +commandFromXML xml = + let (Document _ _ root _) = xmlParse "" xml in + case simCommand root of + Left s -> error s + Right command -> command + +--simCommand e = match (ElemAcceptor "sim-continue" simple) e >> return (SimContinue [] []) +simCommand e = --execCmd "sim-continue" SimContinue e + (matchSimContinue e) `mplus` (matchSimStep e) `mplus` (matchSimStepOver e) `mplus` (matchSimStepOut e) + +matchSimContinue e = execCmd "sim-continue" SimContinue e +matchSimStep e = execCmd "sim-step" SimStep e +matchSimStepOver e = execCmd "sim-step-over" SimStepOver e +matchSimStepOut e = execCmd "sim-step-out" SimStepOut e + +execCmd s f e = do + (bp,events) <- match (ElemAcceptor s commandContent) e + return (f bp events) + +commandContent (Elem _ _ contents) = do + (breakpoints,contents1) <- findOptionalElement breakpointsElement [ e | e@(CElem _ _) <- contents] + (events,[]) <- findOptionalElement (elementList "events" simEventElement) contents1 + return $ (maybe [] id breakpoints, maybe [] id events) + +simEventElement :: MonadError String m => ElemAcceptor m SimEvent +simEventElement = + let f (Elem _ _ contents) = + do (name,contents1) <- findElement (ElemAcceptor "name" simple) [ e | e@(CElem _ _) <- contents] + (delay,contents2) <- findElement (ElemAcceptor "delay" simple) contents1 + (args,[]) <- findOptionalElement (elementList "args" simArgElement) contents2 + case reads delay of + [] -> fail "invalid delay: expected integer" + ((i,_):_) -> return $ SimEvent name (maybe [] id args) i + in ElemAcceptor "event" f + +simArgElement :: MonadError String m => ElemAcceptor m SimEventArg +simArgElement = + let f (Elem _ _ contents) = + do (name,contents1) <- findElement (ElemAcceptor "name" simple) [ e | e@(CElem _ _) <- contents] + (value,[]) <- findElement (ElemAcceptor "value" simple) contents1 + return $ SimEventArg name value + in ElemAcceptor "arg" f + +outputToXML (SimInfo _ log state) = (emit "sim-info" [] [emitLog log,emitState state]) "" +outputToXML (SimEnded _ log state) = (emit "sim-ended" [] [emitLog log,emitState state]) "" +outputToXML (SimSuspended _ suspendInfo log state) = (emit "sim-suspended" [] [emitExecutionInfo suspendInfo, + emitLog log, + emitState state]) "" + +emitLog log = + emit "messages" [] $ map emitMessage (log) + +emitMessage logMessage = + emit "message" [] [ emitSimple "time" [] (show $ logMessageTime logMessage), + emitSimple "level" [] (logLevelToName $ logMessageLevel logMessage), + emitSimple "source" [] (logMessageSource logMessage), + emitSimple "text" [] (logMessageText logMessage)] + +emitState state = + emit "state" [] [ emitSimple "time" [] (show $ simStateInfoTime state), + emitPrims (simStateInfoPrims state), + emitAvatars (simStateInfoAvatars state), + emitScripts (simStateInfoScripts state) ] +emitPrims prims = emitList "prims" emitPrim prims +emitAvatars avatars = emitList "avatars" emitAvatar avatars +emitScripts scripts = emitList "scripts" emitScript scripts + +emitPrim (key,name) = emit "prim" [] [emitSimple "key" [] key, emitSimple "name" [] name] +emitAvatar (key,name) = emit "avatar" [] [emitSimple "key" [] key, emitSimple "name" [] name] +emitScript (pk,sname) = emit "script" [] [emitSimple "primKey" [] pk, emitSimple "scriptName" [] sname] + +testSystem :: IO () +testSystem = + do input <- getLine + --hPutStrLn stderr input + let result = (evalState . runErrorT) (initializationFromXML (unescape input)) (M.empty,1) + case result of + Left s -> fail s + Right (src,worldDef) -> do + (augLib,scripts) <- compile src + let runStep state s = + let command = commandFromXML s + (e,state') = simStep state command + in (state',outputToXML e) + processLinesS (Left (worldDef,scripts,libFromAugLib augLib)) "quit" runStep diff --git a/Language/Lsl/Internal/TestResult.hs b/Language/Lsl/Internal/TestResult.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/TestResult.hs @@ -0,0 +1,40 @@ +module Language.Lsl.Internal.TestResult(TestResult(..),resultToXML, emitTestResult) where + +import Language.Lsl.Internal.XmlCreate(emit,emitSimple) +import qualified Language.Lsl.Internal.XmlCreate as X + +data TestResult = ErrorResult String String [(Int,String)] | + FailureResult String String [(Int,String)] | + Timeout String [(Int,String)] | + SuccessResult String [(Int,String)] + deriving Show + +okResult = 0 +failureResult = 1 +errorResult = 2 + +resultToXML = flip emitTestResult "" + +emitTestResult (ErrorResult name msg log) = emitResult name errorResult msg log +emitTestResult (FailureResult name msg log) = emitResult name failureResult msg log +emitTestResult (Timeout name log) = emitResult name failureResult "timeout" log +emitTestResult (SuccessResult name log) = emitResult name okResult "ok" log + +emitResult name code msg log = + emit "test-result" [] [emitSimple "name" [] name, emitResultInfo code msg, emitLog log] + +emitResultInfo code msg = + emit "resultInfo" [] [emitSimple "resultCode" [] (show code), emitSimple "resultMessage" [] msg] + +emitLog log = + emit "messages" [] $ map emitMessage (reverse log) + +emitMessage (time,text) = + emit "message" [] [emitSimple "time" [] (show time), emitSimple "text" [] text] + + +-- escapeString = +-- let escape [] = [] +-- escape ('\n':cs) = '\\':'n':(escape cs) +-- escape (c:cs) = c:(escape cs) +-- in escape . xmlEscape diff --git a/Language/Lsl/Internal/Type.hs b/Language/Lsl/Internal/Type.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/Type.hs @@ -0,0 +1,259 @@ +{-# OPTIONS_GHC -XFlexibleContexts -XDeriveDataTypeable #-} +module Language.Lsl.Internal.Type( + LSLType(..), + LSLValue(..), + Component(..), + typeOfLSLValue, + typeOfLSLComponent, + parseFloat, + parseInt, + lslValueComponent, + replaceLslValueComponent, + lslValString, + lslTypeString, + lslShowVal, + toSVal, + isIVal, + isFVal, + isSVal, + isKVal, + isLVal, + isVVal, + isRVal, + lslValueElement, + defaultValue, + vecMulScalar, + rotMulVec, + rotMul, + invRot, + vcross, + toFloat, + vVal2Vec, + vec2VVal, + rVal2Rot, + rot2RVal, + liftV1, + liftV2) where + +import Control.Monad.Error(MonadError) +import Data.Data(Data,Typeable) +import Data.List(intersperse) +import Language.Lsl.Internal.NumberParsing(readInt,readHexFloat) +import Language.Lsl.Internal.Key(nullKey) +import Language.Lsl.Internal.Util(lookupM,readM,cross,quaternionMultiply,quaternionToMatrix,fromInt) +import Language.Lsl.Internal.DOMProcessing(Element(..),ElemAcceptor(..),findValue,elementsOnly,simple,attrString,acceptList) + +import Text.Printf(printf) + +data LSLType = LLList | LLInteger | LLVector | LLFloat | LLString | LLRot | LLKey | LLVoid + deriving (Eq, Show, Typeable, Data) + +-- A value. Values correspond to the built in types (LSLType) that LSL +-- supports. A value is an item that can be pushed onto the value stack. +data LSLValue = IVal Int | FVal Float | SVal String | VVal Float Float Float + | RVal Float Float Float Float | LVal [LSLValue] | KVal String + | VoidVal deriving (Show,Eq,Ord) + +data Component = X | Y | Z | S | All deriving (Eq,Show, Typeable, Data) + +defaultValue LLList = LVal [] +defaultValue LLInteger = IVal 0 +defaultValue LLVector = VVal 0.0 0.0 0.0 +defaultValue LLRot = RVal 0.0 0.0 0.0 1.0 +defaultValue LLString = SVal "" +defaultValue LLKey = KVal nullKey +defaultValue LLFloat = FVal 0.0 +defaultValue LLVoid = VoidVal + +lslValueComponent X (VVal x y z) = FVal x +lslValueComponent X (RVal x y z s) = FVal x +lslValueComponent Y (VVal x y z) = FVal y +lslValueComponent Y (RVal x y z s) = FVal y +lslValueComponent Z (VVal x y z) = FVal z +lslValueComponent Z (RVal x y z s) = FVal z +lslValueComponent S (RVal x y z s) = FVal s +lslValueComponent All val = val +lslValueComponent c v = error ("illegal component " ++ (show c) ++ " of " ++ (show v)) +replaceLslValueComponent X (VVal x y z) (FVal f) = VVal f y z +replaceLslValueComponent X (RVal x y z s) (FVal f) = RVal f y z s +replaceLslValueComponent Y (VVal x y z) (FVal f) = VVal x f z +replaceLslValueComponent Y (RVal x y z s) (FVal f) = RVal x f z s +replaceLslValueComponent Z (VVal x y z) (FVal f) = VVal x y f +replaceLslValueComponent Z (RVal x y z s) (FVal f) = RVal x y f s +replaceLslValueComponent S (RVal x y z s) (FVal f) = RVal x y z f +replaceLslValueComponent All v v' = v' +replaceLslValueComponent c v v' = error ("can't replace component " ++ (show c) ++ " of value " ++ (show v) ++ " with value " ++ (show v')) + +typeOfLSLValue v = + case v of + (IVal _) -> LLInteger + (FVal _) -> LLFloat + (SVal _) -> LLString + (VVal _ _ _) -> LLVector + (RVal _ _ _ _) -> LLRot + (LVal _) -> LLList + (KVal _) -> LLKey + VoidVal -> LLVoid + +typeOfLSLComponent v All = typeOfLSLValue v +typeOfLSLComponent (VVal _ _ _) _ = LLFloat +typeOfLSLComponent (RVal _ _ _ _) _ = LLFloat +typeOfLSLComponent v c = error ("value " ++ (show v) ++ " doesn't have a subcomponents") + +-- convert a value to a string 'internally' (TODO: where SHOULD this be used? It's used in internal funcs, but +-- probably will not work completely correctly when tabs, newlines, or double quotes are involved) +lslValString (IVal i) = (show i) +lslValString (FVal f) = (printf "%.6f" f) +lslValString (SVal s) = s +lslValString (KVal k) = k +lslValString (VVal x y z) = concat ["<",comp2Str x,",",comp2Str y,",",comp2Str z,">"] +lslValString (RVal x y z s) = concat ["<",comp2Str x,",",comp2Str y,",",comp2Str z,",",comp2Str s,">"] +lslValString (LVal l) = concat ("[":(intersperse "," (map lslValString l) ++ ["]"])) +lslValString (VoidVal) = "" + +-- convert a value to a string for display +lslShowVal (SVal s) = ('\"':escape s) ++ "\"" + where escape ('\n':cs) = '\\':'n':(escape cs) + escape ('\\':cs) = '\\':'\\':(escape cs) + escape ('\"':cs) = '\\':'\"':(escape cs) + escape ('\t':cs) = '\\':'t':(escape cs) -- this one shouldn't happen (tabs should get converted to spaces) + escape (c:cs) = c:(escape cs) + escape [] = [] +lslShowVal (KVal k) = lslShowVal (SVal k) +lslShowVal (LVal l) = concat ("[":(intersperse "," (map lslShowVal l))) ++ "]" +lslShowVal VoidVal = "n/a" +lslShowVal v = lslValString v + +-- TODO: this info is duplicated elsewhere (e.g. parser) (fix) +lslTypeString LLInteger = "integer" +lslTypeString LLFloat = "float" +lslTypeString LLKey = "key" +lslTypeString LLList = "list" +lslTypeString LLVector = "vector" +lslTypeString LLRot = "rotation" +lslTypeString LLString = "string" +lslTypeString LLVoid = "void" + +isIVal (IVal _) = True +isIVal _ = False +isSVal (SVal _) = True +isSVal _ = False +isLVal (LVal _) = True +isLVal _ = False +isFVal (FVal _) = True +isFVal _ = False +isVVal (VVal _ _ _) = True +isVVal _ = False +isRVal (RVal _ _ _ _) = True +isRVal _ = False +isKVal (KVal _) = True +isKVal _ = False + +parseInt s = + case readInt s of + [] -> 0 + (i,_):_ -> i +parseFloat s = + case readFloat s of + [] -> 0.0 + (f,_):_ -> f + +parseVector s = + case [(VVal x y z,t) | ("<",t0) <- lex s, + (x,t1) <- readFloat t0, + (",",t2) <- lex t1, + (y,t3) <- readFloat t2, + (",",t4) <- lex t3, + (z,t5) <- readFloat t4, + (">",t) <- lex t5] of + [] -> VVal 0.0 0.0 0.0 + (v,_):_ -> v +parseRotation s = + case [(RVal x y z w,t) | ("<",t0) <- lex s, + (x,t1) <- readFloat t0, + (",",t2) <- lex t1, + (y,t3) <- readFloat t2, + (",",t4) <- lex t3, + (z,t5) <- readFloat t4, + (",",t6) <- lex t5, + (w,t7) <- readFloat t6, + (">",t) <- lex t7] of + [] -> RVal 0.0 0.0 0.0 0.0 + (v,_):_ -> v + +readFloat s = + case readHexFloat s of + [] -> reads s + v -> v + +toSVal :: LSLValue -> LSLValue +toSVal (SVal s) = SVal s +toSVal (FVal f) = SVal (printf "%.6f" f) +toSVal (IVal i) = SVal (show i) +toSVal (KVal k) = SVal k +toSVal (VVal x y z) = SVal $ concat ["<",comp2Str x,",",comp2Str y,",",comp2Str z,">"] +toSVal (RVal x y z s) = SVal $ concat ["<",comp2Str x,",",comp2Str y,",",comp2Str z,",",comp2Str s,">"] +toSVal VoidVal = SVal "" -- perhaps should be error +toSVal (LVal l) = + SVal $ concatMap toS l + where toS v = let (SVal s) = toSVal v in s + +comp2Str :: Float -> String +comp2Str f = printf "%.5f" f + +lslValueElement :: MonadError String m => ElemAcceptor m LSLValue +lslValueElement = + let f e@(Elem _ attrs contents) = do + valType <- lookupM "class" attrs + case attrString valType of + "string" -> simple e >>= return . SVal + "key" -> simple e >>= return . KVal + "int" -> simple e >>= readM >>= return . IVal + "float" -> simple e >>= readM >>= return . FVal + "vector" -> acceptVector e >>= return + "rotation" -> acceptRotation e >>= return + "list" -> acceptLslList e >>= return + _ -> fail "unrecognized value element" + in ElemAcceptor "value" f + +acceptVector (Elem _ _ contents) = do + (x,c1) <- findValue "x" (elementsOnly contents) + (y,c2) <- findValue "y" (elementsOnly c1) + (z,[]) <- findValue "z" (elementsOnly c2) + return $ VVal x y z + +acceptRotation (Elem _ _ contents) = do + (x,c1) <- findValue "x" (elementsOnly contents) + (y,c2) <- findValue "y" (elementsOnly c1) + (z,c3) <- findValue "z" (elementsOnly c2) + (s,[]) <- findValue "s" (elementsOnly c3) + return $ RVal x y z s + +acceptLslList e = do + l <- acceptList lslValueElement e + return $ LVal l + +-- vector and rotation operations +vecMulScalar (VVal x y z) f = (VVal (x*f) (y*f) (z*f)) +rotMul (RVal x1 y1 z1 s1) (RVal x2 y2 z2 s2) = + let (x,y,z,s) = (x1,y1,z1,s1) `quaternionMultiply` (x2,y2,z2,s2) + in RVal x y z s +rot2Mat (RVal x y z s) = quaternionToMatrix (x,y,z,s) +matMul ((a1,b1,c1),(a2,b2,c2),(a3,b3,c3)) (VVal a b c) = + VVal (a1*a + a2 * b + a3 * c) (b1 * a + b2 * b + b3 * c) (c1 * a + c2 * b + c3 * c) +rotMulVec rot vec = matMul (rot2Mat rot) vec +invRot (RVal x y z s) = (RVal (-x) (-y) (-z) s) + +vcross (VVal x1 y1 z1) (VVal x2 y2 z2) = + let (x,y,z) = (x1,y1,z1) `cross` (x2,y2,z2) in VVal x y z + +toFloat (FVal f) = f +toFloat (IVal i) = fromInt i + +vVal2Vec (VVal x y z) = (x,y,z) +vec2VVal (x,y,z) = VVal x y z +liftV1 f = vec2VVal . f . vVal2Vec +liftV2 f = \ x y -> vec2VVal $ f (vVal2Vec x) (vVal2Vec y) + +rot2RVal (x,y,z,s) = RVal x y z s +rVal2Rot (RVal x y z s) = (x,y,z,s) diff --git a/Language/Lsl/Internal/UnitTester.hs b/Language/Lsl/Internal/UnitTester.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/UnitTester.hs @@ -0,0 +1,72 @@ +{-# OPTIONS_GHC -XFlexibleContexts #-} +module Language.Lsl.Internal.UnitTester(main2) where + +import Control.Monad(MonadPlus(..)) +import Control.Monad.Error(MonadError(..)) +import Language.Lsl.Internal.BreakpointsDeserialize(breakpointsElement) +import Language.Lsl.Internal.Compiler(compile) +import Language.Lsl.Internal.DOMProcessing(ElemAcceptor(..),findElement,findOptionalElement,match) +import Language.Lsl.Internal.DOMSourceDescriptor(sourceFilesElement) +import Language.Lsl.Internal.DOMUnitTestDescriptor(testsElement) +import Language.Lsl.Internal.ExecInfo(emitExecutionInfo) +import Language.Lsl.Syntax(libFromAugLib) +import Language.Lsl.Internal.TestResult(emitTestResult) +import Language.Lsl.UnitTest(LSLUnitTest(..)) +import Language.Lsl.UnitTestEnv(ExecCommand(..),TestEvent(..),simStep) +import Language.Lsl.Internal.Util(unescape,processLinesS) +import Language.Lsl.Internal.XmlCreate(emit) +import Text.XML.HaXml(Element(..),Content(..),Document(..),xmlParse) +-- import Debug.Trace + +-- trace1 x = trace (show x) x + +testExecutionElement :: MonadError String m => ElemAcceptor m (([(String,String)],[(String,String)]),[LSLUnitTest]) +testExecutionElement = + let f (Elem _ _ contents) = + do (sources,contents1) <- findElement sourceFilesElement [ e | e@(CElem _ _) <- contents] + (tests,[]) <- findElement testsElement contents1 + return (sources,tests) + in ElemAcceptor "test-descriptor" f + +testExecutionDescriptionFromXML input = let doc = xmlParse "" input in parseTestExecutionDescription doc + +parseTestExecutionDescription (Document _ _ root _) = match testExecutionElement root + +main2 :: IO () +main2 = + do input <- getLine + --hPutStrLn stderr input + --(src,unitTests) <- + case testExecutionDescriptionFromXML (unescape input) of + Left s -> error s + Right (src,unitTests) -> do + (augLib,scripts) <- compile src + let runStep state s = + let command = execCommandFromXML s + (e,state') = simStep scripts (libFromAugLib augLib) state command + in (state',testEventToXML e) + processLinesS (unitTests,Nothing) "quit" runStep + +execCommandFromXML xml = + let (Document _ _ root _) = xmlParse "" xml in + case execCommand root of + Left s -> error s + Right command -> command + +testEventToXML e = emitTestEvent e "" + +execCommand e = (execContinue e) `mplus` (execStep e) `mplus` (execStepOver e) `mplus` (execStepOut e) + +execContinue e = match (ElemAcceptor "exec-continue" commandContent) e >>= return . ExecContinue +execStep e = match (ElemAcceptor "exec-step" commandContent) e >>= return . ExecStep +execStepOver e = execCmd "exec-step-over" ExecStepOver e +execStepOut e = execCmd "exec-step-out" ExecStepOut e + +execCmd s f e = match (ElemAcceptor s commandContent) e >>= return . f +commandContent (Elem _ _ contents) = do + (breakpoints,[]) <- findOptionalElement breakpointsElement [ e | e@(CElem _ _) <- contents] + return $ maybe [] id breakpoints + +emitTestEvent (TestComplete testResult) = emit "test-complete" [] [emitTestResult testResult] +emitTestEvent (AllComplete) = emit "all-complete" [] [] +emitTestEvent (TestSuspended info) = emit "test-suspended" [] [emitExecutionInfo info] diff --git a/Language/Lsl/Internal/Util.hs b/Language/Lsl/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/Util.hs @@ -0,0 +1,161 @@ +{-# OPTIONS_GHC -fwarn-unused-binds -XNoMonomorphismRestriction #-} +module Language.Lsl.Internal.Util ( + mlookup, + ilookup, + throwStrError, + ctx, + readM, + filtMap, + filtMapM, + lookupByIndex, + lookupM, + removeLookup, + findM, + elemAtM, + indexOf, + fromInt, + tuplify, + cut, + unescape, + processLines, + processLinesS, + generatePermutation, + fac, + module Language.Lsl.Internal.Math + ) where + +import Control.Monad(liftM,when) +import Control.Monad.Error(MonadError(..),Error(..)) +import Data.List(find,elemIndex,isPrefixOf,tails) +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap + +-- import Debug.Trace + +import Language.Lsl.Internal.Math + +import IO(hFlush,stdout) +import Network.URI(escapeURIString,isUnescapedInURI,unEscapeString) + +-- lifting lookups for Map (if key is instance of Show) and IntMap + +mlookup k m = + maybe (throwError $ "key " ++ show k ++ " not found") return (Map.lookup k m) +ilookup i m = + maybe (throwError $ "key " ++ show i ++ " not found") return (IntMap.lookup i m) + +throwStrError :: (Error e, MonadError e m) => String -> m a +throwStrError = throwError . strMsg + +tuplify [] = [] +tuplify (_:[]) = [] +tuplify (a:b:rest) = (a,b) : tuplify rest + +readM s = case reads s of + [] -> fail ("unable to parse " ++ s) + ((v,_):_) -> return v + +ctx s (Left s') = fail (s ++ ": " ++ s' ) +ctx _ (Right v) = return v + +-- monadified lookup +lookupM :: (Monad m, Eq a, Show a) => a -> [(a,b)] -> m b +lookupM x l = + case lookup x l of + Nothing -> fail ((show x) ++ " not found") + Just y -> return y + +-- monadified find +findM :: Monad m => (a -> Bool) -> [a] -> m a +findM p l = + case find p l of + Nothing -> fail "not found!" + Just v -> return v + +-- filter a list while mapping +filtMap :: (a -> Maybe b) -> [a] -> [b] +filtMap _ [] = [] +filtMap f (x:xs) = case f x of + Nothing -> filtMap f xs + Just y -> y : filtMap f xs + +filtMapM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] +filtMapM _ [] = return [] +filtMapM f (x:xs) = + do r <- f x + case r of + Nothing -> filtMapM f xs + Just y -> liftM (y:) (filtMapM f xs) + +lookupByIndex :: Monad m => Int -> [a] -> m a +lookupByIndex i l = lookupM i $ zip [0..] l + +removeLookup :: Eq a => a -> [(a,b)] -> [(a,b)] +removeLookup k l = let (xs,ys) = break ((k==).fst) l in + case ys of + (_:zs) -> xs ++ zs + _ -> l + +indexOf :: Eq a => [a] -> [a] -> Maybe Int +indexOf sub list = elemIndex True $ map (isPrefixOf sub) (tails list) + +fromInt :: Num a => Int -> a +fromInt = fromInteger . toInteger + +cut :: Int -> Int -> [a] -> ([a],[a]) +cut start end src = (take start src, drop end src) + +elemAtM :: (Monad m) => Int -> [a] -> m a +elemAtM index list = + if index >= 0 && index < length list then return (list !! index) + else fail ("index " ++ (show index) ++ " out of range") + + +unescape = unEscapeString + +-- interactively process lines, stopping when a terminator value is read +-- each line is assumed to be URI encoded. It is decoded and passed to +-- some string handling function (String -> String). The result is +-- reencoded and output. +processLines term f = + do s <- getLine + when (term /= s) $ do + putStr (escape $ f (unescape s)) + putStr "\n" + processLines term f + where escape = escapeURIString isUnescapedInURI + +processLinesS state term f = + do s <- getLine + --hPutStrLn stderr s + when (term /= s) $ do + let (newState,s') = f state (unescape s) + putStrLn (escape s') + hFlush stdout + processLinesS newState term f + where escape = escapeURIString isUnescapedInURI + +-- TODO: fix this definition! +fac :: Integer -> Integer +fac 0 = 1 +fac 1 = 1 +fac n = n * fac (n - 1) + +-- generate the nth permutation of a list... +-- permutations are numbered such that if you gave each element in the original ordering +-- a number (e.g., for a 3 element list [0,1,2]), and then generated all the permutations, +-- and then treated each permutation as a base N number, (e.g. 012, or 12 base 3), and +-- then sorted the permutation, the number of the permutation equals its index in the +-- list of sorted permutations... simple! +generatePermutation [] _ = [] +generatePermutation l i = + let n :: Integer + n = toInteger (length l) in + if i < fac n then + let modulus = fac (n - 1) + ix :: Int + ix = fromInteger $ (i `div` modulus) in + case splitAt ix l of + (xs,y:ys) -> y : (generatePermutation (xs ++ ys) (i `mod` modulus)) + _ -> error "" + else error "no such permutation!!!" diff --git a/Language/Lsl/Internal/WorldState.hs b/Language/Lsl/Internal/WorldState.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/WorldState.hs @@ -0,0 +1,651 @@ +{-# OPTIONS_GHC -XFlexibleInstances #-} +module Language.Lsl.Internal.WorldState( + DeferredScriptEventTarget(..), + Listener(..), + PredefFunc(..), + SimEvent(..), + SimEventArg(..), + Touch(..), + WorldEventType(..), + World(..), + WorldM, + XMLRequestSourceType(..), + durationToTicks, + evalErrorT, + findAsset, + findTextureAsset, + fromErrorT, + getActualPrimScripts, + getListeners, + getNextListenerId, + getNextPause, + getObjects, + getPredefFuncs, + getPrim, + getPrimAnimations, + getPrimAttachment, + getPrimBodyParts, + getPrimClothing, + getPrimCreator, + getPrimDescription, + getPrimFaceAlpha, + getPrimFaceColor, + getPrimFaceTextureInfo, + getPrimFaces, + getPrimFlexibility, + getPrimGestures, + getPrimGroup, + getPrimInventory, + getPrimLandmarks, + getPrimLight, + getPrimLinkNum, + getPrimName, + getPrimNotecards, + getPrimMaterial, + getPrimObjects, + getPrimOwner, + getPrimParent, + getPrimPassCollisions, + getPrimPermissions, + getPrimRegion, + getPrimPassTouches, + getPrimPendingEmails, + getPrimPosition, + getPrimRotation, + getPrimScale, + getPrimScripts, + getPrimSitTarget, + getPrimSittingAvatar, + getPrimSounds, + getPrimStatus, + getPrimTempOnRez, + getPrimTextures, + getPrimTypeInfo, + getPrimVehicleFlags, + getPrims, + getRegion, + getRootPrim, + getSliceSize, + getTick, + getWLibrary, + getWQueue, + getWScripts, + getWorldAvatar, + getWorldAvatars, + getWorldBreakpointManager, + getWorldCollisions, + getWorldEventHandler, + getWorldLandCollisions, + getWorldLastPositions, + getWorldOutputQueue, + getWorldPendingHTTPRequests, + getWorldPhysicsTime, + getWorldRegions, + getWorldScripts, + getWorldSuspended, + getWorldTouchCheckTime, + getWorldTouches, + getWorldTargetCheckTime, + getWorldWebHandling, + getWorldXMLRequestRegistry, + getWorldZeroTime, + insertScriptChannelPair, + isSensorEvent, + isSoundAsset, + logAMessage, + logTrace, + lookupDataChannel, + lookupScriptFromChan, + newKey, + primHasActiveHandler, + putManyWQ, + putWQ, + queryWorld, + runAndLogIfErr, + runErrFace, + runErrPrim, + scriptHasActiveHandler, + setListeners, + setNextListenerId, + setObjects, + setPrim, + setPrimAttachment, + setPrimDescription, + setPrimFaceAlpha, + setPrimFaceColor, + setPrimFaces, + setPrimFlexibility, + setPrimInventory, + setPrimLight, + setPrimMaterial, + setPrimName, + setPrimOwner, + setPrimParent, + setPrimPassCollisions, + setPrimPassTouches, + setPrimPayInfo, + setPrimPendingEmails, + setPrimPosition, + setPrimRemoteScriptAccessPin, + setPrimRotation, + setPrimScale, + setPrimSitTarget, + setPrimSittingAvatar, + setPrimStatus, + setPrimTempOnRez, + setPrimVehicleFlags, + setPrims, + setRegion, + setTick, + setWQueue, + setWorldAvatar, + setWorldAvatars, + setWorldBreakpointManager, + setWorldCollisions, + setWorldEventHandler, + setWorldLandCollisions, + setWorldLastPositions, + setWorldOutputQueue, + setWorldPendingHTTPRequests, + setWorldPhysicsTime, + setWorldScripts, + setWorldSuspended, + setWorldTouchCheckTime, + setWorldTouches, + setWorldXMLRequestRegistry, + takeWQ, + ticksToDuration, + updatePrimFace, + wrand) where + +import Control.Monad(MonadPlus(..)) +import Control.Monad.State(StateT(..))-- hiding (State) +import Control.Monad.Error(lift,ErrorT(..),MonadError(..)) +import Data.List(elemIndex) +import Data.Map(Map) +import Data.Maybe(fromMaybe) +import qualified Data.IntMap as IM +import qualified Data.Map as M +import qualified Data.Set as S + +import qualified Language.Lsl.Internal.AvEvents as AvEvent +import Language.Lsl.Internal.Breakpoint(BreakpointManager(..)) +import Language.Lsl.Internal.Evaluation(Event(..),ScriptInfo(..),EvalResult(..)) +import Language.Lsl.Internal.Exec(hasActiveHandler) +import Language.Lsl.Internal.Key(mkKey) +import Language.Lsl.Internal.Log(LogMessage(..),LogLevel(..)) +import Language.Lsl.Syntax(Validity,LModule(..),CompiledLSLScript(..)) +import Language.Lsl.Internal.Type(LSLValue(..),LSLType(..)) +import Language.Lsl.Internal.Util(mlookup,lookupByIndex) +import Language.Lsl.WorldDef(Prim(..),PrimFace(..),InventoryItem(..),InventoryItemIdentification(..), + LSLObject(..),Script(..),Avatar(..),Region(..), + WebHandling(..),isInvNotecardItem,isInvLandmarkItem,isInvClothingItem, + isInvBodyPartItem,isInvGestureItem,isInvSoundItem,isInvAnimationItem, + isInvTextureItem,isInvScriptItem,isInvObjectItem) + +import System.Random(StdGen(..),Random(..)) + +-- a data type that defines the state of the 'world' +data World m = World { + sliceSize :: !Int, + maxTick :: !Int, + nextPause :: !Int, + wqueue :: !WorldEventQueue, + wlisteners :: !(IM.IntMap (Listener,Bool)), -- ![(Int,(Listener,Bool))], + nextListenerId :: !Int, + wobjects :: !(Map String LSLObject), + wprims :: !(Map String Prim), + worldScripts :: !(Map (String,String) Script), + inventory :: ![(String,LSLObject)], + tick :: !Int, + msglog :: ![LogMessage], + predefs :: !(Map String (PredefFunc m)), + randGen :: !StdGen, + wlibrary :: ![(String,Validity LModule)], + wscripts :: ![(String,Validity CompiledLSLScript)], + worldEventHandler :: !(Maybe (String, [(String,LSLValue)])), + worldAvatars :: !(Map String Avatar), + worldBreakpointManager :: !BreakpointManager, + worldSuspended :: !(Maybe (String,String)), -- prim-key, script-name, image + worldRegions :: !(Map (Int,Int) Region), + worldZeroTime :: !Int, + worldKeyIndex :: !Integer, + worldWebHandling :: !WebHandling, + worldOutputQueue :: ![SimEvent], + worldPendingHTTPRequests :: ![String], + worldOpenDataChannels :: !(Map String (String,String),Map (String,String) String), + worldXMLRequestRegistry :: !(Map String XMLRequestSourceType), + worldPhysicsTime :: !Int, + worldTargetCheckTime :: !Int, + worldLastPositions :: !(Map String (Bool,(Float,Float,Float))), + worldCollisions :: !(S.Set (String,String)), + worldLandCollisions :: !(S.Set String), + worldTouches :: !(Map String [Touch]), + worldTouchCheckTime :: !Int + } deriving (Show) + +-- a state monad for the World +type WorldM m = StateT (World m) m + +worldM f = StateT (\ s -> return (f s)) + +-- extracting/updating the world state ----------------------------------------------------- +queryWorld q = worldM (\w -> (q w, w)) +updateWorld u = worldM (\w -> ((), u w)) + +getSliceSize :: Monad m => WorldM m Int +getSliceSize = queryWorld sliceSize +getListeners :: Monad m => WorldM m (IM.IntMap (Listener,Bool)) +getListeners = queryWorld wlisteners +getMaxTick :: Monad m => WorldM m Int +getMaxTick = queryWorld maxTick +getNextPause :: Monad m => WorldM m Int +getNextPause = queryWorld nextPause +getTick :: Monad m => WorldM m Int +getTick = queryWorld tick +getNextListenerId :: Monad m => WorldM m Int +getNextListenerId = queryWorld nextListenerId +getObjects :: Monad m => WorldM m (Map String LSLObject) +getObjects = (queryWorld wobjects) +getPrims :: Monad m => WorldM m (Map String Prim) +getPrims = queryWorld wprims +getWorldScripts :: Monad m => WorldM m (Map (String,String) Script) +getWorldScripts = queryWorld worldScripts +getInventory :: Monad m => WorldM m [(String,LSLObject)] +getInventory = queryWorld inventory +getMsgLog :: Monad m => WorldM m [LogMessage] +getMsgLog = queryWorld msglog +getWQueue :: Monad m => WorldM m WorldEventQueue +getWQueue = queryWorld wqueue +getPredefFuncs :: Monad m => WorldM m (Map String (PredefFunc m)) +getPredefFuncs = queryWorld predefs +getRandGen :: Monad m => WorldM m StdGen +getRandGen = queryWorld randGen +getWScripts :: Monad m => WorldM m [(String,Validity CompiledLSLScript)] +getWScripts = queryWorld wscripts +getWLibrary :: Monad m => WorldM m [(String,Validity LModule)] +getWLibrary = queryWorld wlibrary +getWorldAvatars :: Monad m => WorldM m (Map String Avatar) +getWorldAvatars = queryWorld worldAvatars +getWorldBreakpointManager :: Monad m => WorldM m BreakpointManager +getWorldBreakpointManager = queryWorld worldBreakpointManager +getWorldSuspended :: Monad m => WorldM m (Maybe (String,String)) +getWorldSuspended = queryWorld worldSuspended +getWorldRegions :: Monad m => WorldM m (Map (Int,Int) Region) +getWorldRegions = queryWorld worldRegions +getWorldZeroTime :: Monad m => WorldM m Int +getWorldZeroTime = queryWorld worldZeroTime +getWorldKeyIndex :: Monad m => WorldM m Integer +getWorldKeyIndex = queryWorld worldKeyIndex +getWorldWebHandling :: Monad m => WorldM m WebHandling +getWorldWebHandling = queryWorld worldWebHandling +getWorldOutputQueue :: Monad m => WorldM m [SimEvent] +getWorldOutputQueue = queryWorld worldOutputQueue +getWorldPendingHTTPRequests :: Monad m => WorldM m [String] +getWorldPendingHTTPRequests = queryWorld worldPendingHTTPRequests +getWorldOpenDataChannels :: Monad m => WorldM m (Map String (String,String), Map (String,String) String) +getWorldOpenDataChannels = queryWorld worldOpenDataChannels +getWorldEventHandler :: Monad m => WorldM m (Maybe (String,[(String,LSLValue)])) +getWorldEventHandler = queryWorld worldEventHandler +getWorldXMLRequestRegistry :: Monad m => WorldM m (Map String XMLRequestSourceType) +getWorldXMLRequestRegistry = queryWorld worldXMLRequestRegistry +getWorldPhysicsTime :: Monad m => WorldM m Int +getWorldPhysicsTime = queryWorld worldPhysicsTime +getWorldTargetCheckTime :: Monad m => WorldM m Int +getWorldTargetCheckTime = queryWorld worldTargetCheckTime +getWorldLastPositions :: Monad m => WorldM m (Map String (Bool,(Float,Float,Float))) +getWorldLastPositions = queryWorld worldLastPositions +getWorldCollisions :: Monad m => WorldM m (S.Set (String,String)) +getWorldCollisions = queryWorld worldCollisions +getWorldLandCollisions :: Monad m => WorldM m (S.Set (String)) +getWorldLandCollisions = queryWorld worldLandCollisions +getWorldTouches :: Monad m => WorldM m (Map String [Touch]) +getWorldTouches = queryWorld worldTouches +getWorldTouchCheckTime :: Monad m => WorldM m Int +getWorldTouchCheckTime = queryWorld worldTouchCheckTime + +getWorldAvatar k = lift getWorldAvatars >>= (\ m -> case M.lookup k m of + Nothing -> throwError ("no such avatar/agent: " ++ k) + Just av -> return av) + +getRegion index = (lift getWorldRegions >>= mlookup index) + +getPrim k = (lift getPrims >>= (\ m -> case M.lookup k m of + Nothing -> throwError ("no such prim: " ++ k) + Just prim -> return prim)) + +--getPrimVal k f = (lift getPrims >>= M.lookup k >>= return . f) +getPrimVal k f = getPrim k >>= return . f +getPrimName k = getPrimVal k primName +getPrimPosition k = getPrimVal k primPosition +getPrimParent k = getPrimVal k primParent +getRootPrim k = getPrimVal k primParent >>= \ val -> return $ fromMaybe k val +getPrimDescription k = getPrimVal k primDescription +getPrimOwner k = getPrimVal k primOwner +getPrimGroup k = getPrimVal k primGroup +getPrimCreator k = getPrimVal k primCreator +getPrimRotation k = getPrimVal k primRotation +getPrimScale k = getPrimVal k primScale +getPrimFaces k = getPrimVal k primFaces +getPrimFlexibility k = getPrimVal k primFlexibility +getPrimMaterial k = getPrimVal k primMaterial +getPrimStatus k = getPrimVal k primStatus +getPrimVehicleFlags k = getPrimVal k primVehicleFlags +getPrimLight k = getPrimVal k primLight +getPrimTempOnRez k = getPrimVal k primTempOnRez +getPrimTypeInfo k = getPrimVal k primTypeInfo +getPrimPermissions k = getPrimVal k primPermissions +getPrimSitTarget k = getPrimVal k primSitTarget +getPrimSittingAvatar k = getPrimVal k primSittingAvatar +getPrimAttachment k = getPrimVal k primAttachment +getPrimPassTouches k = getPrimVal k primPassTouches +getPrimPassCollisions k = getPrimVal k primPassCollisions +getPrimPayInfo k = getPrimVal k primPayInfo +getPrimPendingEmails k = getPrimVal k primPendingEmails +getPrimRemoteScriptAccessPin k = getPrimVal k primRemoteScriptAccessPin + +getPrimInventory k = getPrimVal k primInventory + +getPrimNotecards k = getPrimInventory k >>= return . filter isInvNotecardItem +getPrimLandmarks k =getPrimInventory k >>= return . filter isInvLandmarkItem +getPrimClothing k = getPrimInventory k >>= return . filter isInvClothingItem +getPrimBodyParts k = getPrimInventory k >>= return . filter isInvBodyPartItem +getPrimObjects k = getPrimInventory k >>= return . filter isInvObjectItem +getPrimGestures k = getPrimInventory k >>= return . filter isInvGestureItem +getPrimSounds k = getPrimInventory k >>= return . filter isInvSoundItem +getPrimAnimations k = getPrimInventory k >>= return . filter isInvAnimationItem +getPrimTextures k = getPrimInventory k >>= return . filter isInvTextureItem +getPrimScripts k = getPrimInventory k >>= return . filter isInvScriptItem + +getActualPrimScripts k = do + scriptNames <- getPrimScripts k >>= return . map (fst . inventoryItemNameKey . inventoryItemIdentification) + allScripts <- (lift $ getWorldScripts) >>= return . M.toList + return [ s | s@((pk,sn),_) <- allScripts, pk == k && sn `elem` scriptNames ] + +getPrimLinkNum pk = do + mp <- getPrimParent pk + case mp of + Nothing -> do -- this is the root prim + links <- lift getObjects >>= mlookup pk >>= return . primKeys + return (if null links then 0 else 1) + Just ok -> do + links <- lift getObjects >>= mlookup ok >>= return . primKeys + case elemIndex pk links of + Nothing -> throwError "internal error, can't find prim in link list of parent object" + Just i -> return (i + 1) +-- TODO: temp until introduce region into Prim definition +getPrimRegion _ = (lift (return (0 :: Int, 0 :: Int))) +getObjectRegion _ = (lift (return (0 :: Int,0 :: Int))) +objectRegion :: a -> (Int,Int) +objectRegion _ = (0,0) + +runErrFace k i defaultVal = runAndLogIfErr + ("face " ++ (show i) ++ " or prim " ++ k ++ " not found") defaultVal + +getPrimFace k i = getPrimFaces k >>= (lookupByIndex i) +getPrimFaceAlpha k i = getPrimFace k i >>= return . faceAlpha +getPrimFaceColor k i = getPrimFace k i >>= return . faceColor +getPrimFaceTextureInfo k i = getPrimFace k i >>= return . faceTextureInfo + +setListeners l = updateWorld (\w -> w { wlisteners = l }) +setNextListenerId i = updateWorld (\w -> w { nextListenerId = i }) +setObjects os = updateWorld (\w -> w { wobjects = os }) +setPrims ps = updateWorld (\w -> w { wprims = ps }) +setInventory i = updateWorld (\w -> w { inventory = i }) +setTick t = t `seq` updateWorld (\w -> w { tick = t }) +setMsgLog l = updateWorld (\w -> w { msglog = l }) +setWQueue q = updateWorld (\w -> w { wqueue = q }) +setRandGen g = updateWorld (\w -> w { randGen = g }) +setWorldAvatars l = updateWorld (\w -> w { worldAvatars = l }) +setWorldScripts s = updateWorld (\w -> w { worldScripts = s }) +setWorldBreakpointManager m = updateWorld (\w -> w { worldBreakpointManager = m }) +setWorldSuspended v = updateWorld (\w -> w { worldSuspended = v }) +setWorldRegions r = updateWorld (\ w -> w { worldRegions = r }) +setWorldKeyIndex i = updateWorld (\ w -> w { worldKeyIndex = i }) +setWorldOutputQueue i = updateWorld (\ w -> w { worldOutputQueue = i }) +setWorldPendingHTTPRequests p = updateWorld (\ w -> w { worldPendingHTTPRequests = p }) +setWorldOpenDataChannels o = updateWorld (\ w -> w { worldOpenDataChannels = o }) +setWorldEventHandler e = updateWorld (\ w -> w { worldEventHandler = e }) +setWorldXMLRequestRegistry r = updateWorld (\ w -> w { worldXMLRequestRegistry = r }) +setWorldPhysicsTime t = updateWorld (\ w -> w { worldPhysicsTime = t }) +setWorldTargetCheckTime t = updateWorld (\ w -> w { worldTargetCheckTime = t }) +setWorldLastPositions p = updateWorld (\ w -> w { worldLastPositions = p }) +setWorldCollisions s = updateWorld (\ w -> w { worldCollisions = s }) +setWorldLandCollisions s = updateWorld (\ w -> w { worldLandCollisions = s }) +setWorldTouches ts = updateWorld (\ w -> w { worldTouches = ts }) +setWorldTouchCheckTime t = updateWorld (\ w -> w { worldTouchCheckTime = t }) + +setWorldAvatar k av = getWorldAvatars >>= return . M.insert k av >>= setWorldAvatars + +setPrim k p = (getPrims >>= return . (M.insert k p) >>= setPrims) + +updatePrimVal k f = runErrPrim k () $ (lift getPrims >>= mlookup k >>= return . f >>= lift . (setPrim k)) + +runErrPrim k defaultVal = runAndLogIfErr ("prim " ++ k ++ " not found") defaultVal + +setPrimPosition k v = updatePrimVal k (\ p -> p { primPosition = v } ) +setPrimRotation k v = updatePrimVal k (\ p -> p { primRotation = v } ) +setPrimScale k v = updatePrimVal k (\ p -> p { primScale = v } ) +setPrimDescription k v = updatePrimVal k (\ p -> p { primDescription = v } ) +setPrimName k v = updatePrimVal k (\ p -> p { primName = v } ) +setPrimParent k v = updatePrimVal k (\ p -> p { primParent = v } ) +setPrimFaces k v = updatePrimVal k (\ p -> p { primFaces = v } ) +setPrimFlexibility k v = updatePrimVal k (\ p -> p { primFlexibility = v } ) +setPrimMaterial k v = updatePrimVal k (\ p -> p { primMaterial = v } ) +setPrimOwner k v = updatePrimVal k (\ p -> p { primOwner = v } ) +setPrimGroup k v = updatePrimVal k (\ p -> p { primGroup = v } ) +setPrimStatus k v = updatePrimVal k (\ p -> p { primStatus = v } ) +setPrimVehicleFlags k v = updatePrimVal k (\ p -> p { primVehicleFlags = v } ) +setPrimLight k v = updatePrimVal k (\ p -> p { primLight = v } ) +setPrimTempOnRez k v = updatePrimVal k (\ p -> p { primTempOnRez = v } ) +setPrimTypeInfo k v = updatePrimVal k (\ p -> p { primTypeInfo = v } ) +setPrimPermissions k v = updatePrimVal k (\ p -> p { primPermissions = v } ) +setPrimSitTarget k v = updatePrimVal k (\ p -> p { primSitTarget = v }) +setPrimSittingAvatar k v = updatePrimVal k (\ p -> p { primSittingAvatar = v } ) +setPrimPassTouches k v = updatePrimVal k (\ p -> p { primPassTouches = v } ) +setPrimPassCollisions k v = updatePrimVal k (\ p -> p { primPassCollisions = v } ) +setPrimPayInfo k v = updatePrimVal k (\ p -> p { primPayInfo = v } ) +setPrimAttachment k v = updatePrimVal k (\ p -> p { primAttachment = v } ) +setPrimInventory k v = updatePrimVal k (\ p -> p { primInventory = v } ) +setPrimPendingEmails k v = updatePrimVal k (\ p -> p { primPendingEmails = v }) +setPrimRemoteScriptAccessPin k v = updatePrimVal k (\ p -> p { primRemoteScriptAccessPin = v }) + +setRegion regionIndex region = getWorldRegions >>= return . (M.insert regionIndex region) >>= setWorldRegions + +updatePrimFace k i f = do + faces <- getPrimFaces k + let faces' = zipWith (\ face index -> if (index == i) then f face else face) faces [0..] + lift $ setPrimFaces k faces' + +setPrimFaceAlpha k i v = runErrFace k i () $ updatePrimFace k i (\ f -> f { faceAlpha = v }) +setPrimFaceColor k i v = runErrFace k i () $ updatePrimFace k i (\ f -> f { faceColor = v }) + +data WorldEventType = CreatePrim { wePrimName :: String, wePrimKey :: String } + | AddScript (String,String) String Bool -- script, prim key, activate + | ResetScript String String -- prim key, script name + | ResetScripts String -- object name + | WorldSimEvent { worldSimEventName :: String, worldSimEventArgs :: [SimEventArg] } + | DeferredScriptEvent { deferredScriptEvent :: Event, deferredScriptEventTarget :: DeferredScriptEventTarget } + | Chat { chatChannel :: Int, chatterName :: String, chatterKey :: String, chatMessage :: String, + chatLocation :: ((Int,Int),(Float,Float,Float)), + chatRange :: Maybe Float } + | TimerEvent { timerEventInterval :: Float, + timerAddress :: (String,String) } + | PermissionRequestEvent { permissionRequestPrim :: String, + permissionRequestScript :: String, + permissionRequestAgent :: String, + permissionRequestMask :: Int } + | SensorEvent { sensorAddress :: (String,String), + sensorSenseName :: String, + sensorSenseKey :: String, + sensorSenseType :: Int, + sensorSenseRange :: Float, + sensorSenseArc :: Float, + sensorRepeat :: Maybe Float } + | XMLRequestEvent { xmlRequestSource :: XMLRequestSourceType, + xmlRequestChannel :: String, + xmlRequestIData :: Int, + xmlRequestSData :: String } + | HTTPRequestEvent { httpRequestSource :: (String,String), + httpRequestKey :: String, + httpRequestURL :: String, + httpRequestMethod :: String, + httpRequestMimetype :: String, + httpRequestBodyMaxlength :: Int, + httpRequestVerifyCert :: Int, + httpRequestBody :: String } + | XMLReplyEvent { xmlRequestKey :: String, + xmlRequestChannel :: String, + xmlRequestMessageId :: String, + xmlRequestSData :: String, + xmlRequestIData :: Int } + | DialogEvent { dialogAgent :: String, + dialogMessage :: String, + dialogButtons :: [String], + dialogChannel :: Int, + dialogSourceObject :: String } + | RezObjectEvent { rezObjectLinkSet :: [Prim], + rezObjectPos :: (Float,Float,Float), + rezObjectVel :: (Float,Float,Float), + rezObjectRot :: (Float,Float,Float,Float), + rezObjectStartParam :: Int, + rezObjectRezzer :: String, + rezObjectCopy :: Bool, + rezObjectAtRoot :: Bool } + | ResetScriptEvent { resetScriptPrimKey :: String, + resetScriptScriptName :: String } + | DetachCompleteEvent { detachObject :: String, detachAvatar :: String } + | GiveAvatarInventoryEvent { giveAvatarInventoryKey :: String, giveAvatarInventoryItem :: InventoryItem } + | AvatarOutputEvent { avatarOutputEventKey :: String, avatarOutputEventVal :: AvEvent.AvatarOutputEvent } + | AvatarInputEvent { avatarInputEventKey :: String, avatarInputEventVal :: AvEvent.AvatarInputEvent } + deriving (Show) + +data XMLRequestSourceType = XMLRequestInternal { xmlRequestTag :: String } + | XMLRequestExternal { xmlRequestTag :: String } + deriving (Show) + +data DeferredScriptEventTarget = DeferredScriptEventScriptTarget (String,String) + | DeferredScriptEventPrimTarget String -- pushes to all scripts in prim + | DeferredScriptEventObjectTarget String -- pushes to all scripts in all prims in object + deriving (Show) + + +data Touch = Touch { touchAvatarKey :: String , touchPrimKey :: String, touchStartTick :: Int, touchEndTick :: Int } + deriving (Show) + +isSensorEvent (SensorEvent {}) = True +isSensorEvent _ = False + +type WorldEvent = (Int,WorldEventType) -- time, event + +type WorldEventQueue = [WorldEvent] + +takeWQ :: Int -> WorldEventQueue -> (Maybe WorldEventType,WorldEventQueue) +takeWQ i [] = (Nothing,[]) +takeWQ i ((j,we):wes) | i >= j = (Just we,wes) + | otherwise = (Nothing,wes) + +putWQ tick we wes = before ++ ((tick,we):after) + where (before,after) = break ((>tick).fst) wes + +putManyWQ [] wq = wq +putManyWQ ((tick,we):wes) wq = putWQ tick we (putManyWQ wes wq) + +data SimEvent = SimEvent { simEventName :: String, simEventArgs :: [SimEventArg], simEventDelay :: Int } + deriving (Show) +data SimEventArg = SimEventArg { simEventArgName :: String, simEventArgValue :: String } + deriving (Show) + +data Listener = Listener { + listenerPrimKey :: String, + listenerScriptName :: String, + listenerChannel :: Int, + listenerName :: String, + listenerKey :: String, + listenerMsg :: String } + deriving (Show) + +data PredefFunc m = PredefFunc { predefFuncName :: String, + predefFuncResultType :: LSLType, + predef :: ScriptInfo -> [LSLValue] -> ErrorT String (WorldM m) (EvalResult,LSLValue) } + deriving (Show) + +instance Monad m => Show (ScriptInfo -> [LSLValue] -> WorldM m (EvalResult,LSLValue)) where + showsPrec _ _ = showString "(function :: ScriptInfo -> [LSLValue] -> WorldM m (EvalResult,LSLValue))" +instance Monad m => Show (ScriptInfo -> [LSLValue] -> ErrorT String (WorldM m) (EvalResult,LSLValue)) where + showsPrec _ _ = showString "(function :: ScriptInfo -> [LSLValue] -> ErrorT String (WorldM m) (EvalResult,LSLValue))" + +evalErrorT :: ErrorT String m v -> m (Either String v) +evalErrorT = runErrorT + +fromErrorT def val = evalErrorT val >>= (return . either (const def) id) + +runAndLogIfErr msg def val = do + result <- evalErrorT val + case result of + Left s -> logAMessage LogWarn "sim" (msg ++ " (" ++ s ++ ")") >> return def + Right v -> return v + +logAMessage logLevel source s = + do log <- getMsgLog + tick <- getTick + let message = LogMessage tick logLevel source s + setMsgLog (message:log) + +logTrace source s = + do log <- getMsgLog + tick <- getTick + let message = LogMessage tick LogTrace source s + setMsgLog (message:log) + +newKey :: Monad m => WorldM m String +newKey = do + i <- getWorldKeyIndex + setWorldKeyIndex (i + 1) + return $ mkKey i + +findAsset _ = return Nothing + +isSoundAsset _ = False +isTextureAsset _ = False +isAnimationAsset _ = False + +findTextureAsset "" = mzero +findTextureAsset _ = return $ InventoryItem (InventoryItemIdentification ("","")) undefined undefined + +primHasActiveHandler pk handler = + do scripts <- getPrimScripts pk + images <- lift $ imagesForScripts scripts + return $ foldl (\ x y -> x || hasActiveHandler y handler) False images + where imagesForScripts scriptItems = do + scripts <- runErrPrim pk [] $ getActualPrimScripts pk + return [ image | (Script { scriptImage = image } ) <- map snd scripts ] + +scriptHasActiveHandler pk sn handler = + do script <- lift getWorldScripts >>= mlookup (pk,sn) + return $ hasActiveHandler (scriptImage script) handler + +lookupDataChannel scriptAddr = lift getWorldOpenDataChannels >>= mlookup scriptAddr . snd +lookupScriptFromChan chan = lift getWorldOpenDataChannels >>= mlookup chan . fst + +insertScriptChannelPair script chan = lift $ do + (c2s,s2c) <- getWorldOpenDataChannels + setWorldOpenDataChannels (M.insert chan script c2s,M.insert script chan s2c) + + +----- MISC ---- +durationToTicks dur = floor (1000.0 * dur) +ticksToDuration ticks = fromIntegral ticks / 1000.0 + +nextTick :: Monad m => WorldM m Int +nextTick = do + t <- getTick + let t' = t + 1 + setTick t' + return t' + +wrand :: (Monad m, Random a) => WorldM m a +wrand = do g <- getRandGen + let (v,g') = random g + setRandGen g' + return v diff --git a/Language/Lsl/Internal/XmlCreate.hs b/Language/Lsl/Internal/XmlCreate.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Internal/XmlCreate.hs @@ -0,0 +1,26 @@ +module Language.Lsl.Internal.XmlCreate(emit,emitSimple,xmlEscape,emitList) where + +emit :: String -> [(String,String)] -> [(String -> String)] -> String -> String +emit name attrs body = + showString "<" . showString name . + foldl (.) (id) (map (\ (n,v) -> showString " " . showString n . showString "=" . shows v) attrs) . + showString ">" . (foldl (.) id body) . showString "" + +x = emit "root" [("id","one")] [ + emit "child" [] [showString "hello"], + emit "child" [] [showString "world"] + ] + +emitSimple :: String -> [(String,String)] -> String -> String -> String +emitSimple name attrs body = + emit name attrs [showString (xmlEscape body)] + +emitList tag f list = emit tag [] (map f list) + +xmlEscape [] = [] +xmlEscape ('<':cs) = ('&':'l':'t':';':(xmlEscape cs)) +xmlEscape ('>':cs) = ('&':'g':'t':';':(xmlEscape cs)) +xmlEscape ('\"':cs) = ('&':'q':'u':'o':'t':';':(xmlEscape cs)) +xmlEscape ('&':cs) = ('&':'a':'m':'p':';':(xmlEscape cs)) +xmlEscape ('\'':cs) = ('&':'a':'p':'o':'s':';':(xmlEscape cs)) +xmlEscape (c:cs) = c:(xmlEscape cs) diff --git a/LslPlus.cabal b/LslPlus.cabal --- a/LslPlus.cabal +++ b/LslPlus.cabal @@ -1,5 +1,5 @@ Name: LslPlus -version: 0.1.0 +version: 0.1.1 Synopsis: An execution and testing framework for the Linden Scripting Language (LSL) Description: Provides a framework for executing Linden Scripting Language scripts offline, @@ -27,6 +27,41 @@ pureMD5 >= 0.2 && < 3, bytestring >= 0.9 && < 0.10, template-haskell >= 2.3.0.0 && < 2.4, syb >= 0.1.0.0 && < 0.2.0.0 Exposed-Modules: Language.Lsl.Syntax, Language.Lsl.Parse, Language.Lsl.QQ, Language.Lsl.Sim Language.Lsl.WorldDef, Language.Lsl.UnitTest, Language.Lsl.UnitTestEnv, Language.Lsl.Render + Other-modules: + Language.Lsl.Internal.Animation + Language.Lsl.Internal.AvEvents + Language.Lsl.Internal.Breakpoint + Language.Lsl.Internal.BreakpointsDeserialize + Language.Lsl.Internal.BuiltInModules + Language.Lsl.Internal.CodeHelper + Language.Lsl.Internal.Compiler + Language.Lsl.Internal.Constants + Language.Lsl.Internal.DOMProcessing + Language.Lsl.Internal.DOMSourceDescriptor + Language.Lsl.Internal.DOMUnitTestDescriptor + Language.Lsl.Internal.Evaluation + Language.Lsl.Internal.EventSigs + Language.Lsl.Internal.Exec + Language.Lsl.Internal.ExecInfo + Language.Lsl.Internal.ExpressionHandler + Language.Lsl.Internal.FuncSigs + Language.Lsl.Internal.InternalLLFuncs + Language.Lsl.Internal.Key + Language.Lsl.Internal.Load + Language.Lsl.Internal.Log + Language.Lsl.Internal.Math + Language.Lsl.Internal.MetaData + Language.Lsl.Internal.NumberParsing + Language.Lsl.Internal.Optimize + Language.Lsl.Internal.Physics + Language.Lsl.Internal.SimMetaData + Language.Lsl.Internal.SystemTester + Language.Lsl.Internal.TestResult + Language.Lsl.Internal.Type + Language.Lsl.Internal.UnitTester + Language.Lsl.Internal.Util + Language.Lsl.Internal.WorldState + Language.Lsl.Internal.XmlCreate Executable LslPlus Build-Depends: ghc >= 6.10, base >= 4.0 && < 4.1, haskell98, filepath >= 1.1.0.0 && < 1.2, parsec >= 2.1.0.0 && < 3, HaXml >= 1.19 && < 1.20, directory > 1 && < 1.1, mtl >= 1.1 && < 1.2, diff --git a/LslPlus.hs b/LslPlus.hs --- a/LslPlus.hs +++ b/LslPlus.hs @@ -12,7 +12,7 @@ import System import System.Exit -version="0.1.0" +version="0.1.1" usage progName = "Usage: " ++ progName ++ " [Version|MetaData|Compiler|ExpressionHandler|SimMetaData|SystemTester|UnitTester]" main = do progName <- getProgName