LslPlus 0.1.1 → 0.1.2
raw patch · 90 files changed
+13063/−13013 lines, 90 filessetup-changed
Files
- Language/Lsl/Internal/Animation.hs +0/−137
- Language/Lsl/Internal/AvEvents.hs +0/−19
- Language/Lsl/Internal/Breakpoint.hs +0/−90
- Language/Lsl/Internal/BreakpointsDeserialize.hs +0/−18
- Language/Lsl/Internal/BuiltInModules.hs +0/−28
- Language/Lsl/Internal/CodeHelper.hs +0/−8
- Language/Lsl/Internal/Compiler.hs +0/−140
- Language/Lsl/Internal/Constants.hs +0/−574
- Language/Lsl/Internal/DOMProcessing.hs +0/−132
- Language/Lsl/Internal/DOMSourceDescriptor.hs +0/−34
- Language/Lsl/Internal/DOMUnitTestDescriptor.hs +0/−201
- Language/Lsl/Internal/Evaluation.hs +0/−24
- Language/Lsl/Internal/EventSigs.hs +0/−90
- Language/Lsl/Internal/Exec.hs +0/−1105
- Language/Lsl/Internal/ExecInfo.hs +0/−51
- Language/Lsl/Internal/ExpressionHandler.hs +0/−350
- Language/Lsl/Internal/FuncSigs.hs +0/−686
- Language/Lsl/Internal/InternalLLFuncs.hs +0/−650
- Language/Lsl/Internal/Key.hs +0/−21
- Language/Lsl/Internal/Load.hs +0/−39
- Language/Lsl/Internal/Log.hs +0/−15
- Language/Lsl/Internal/Math.hs +0/−129
- Language/Lsl/Internal/MetaData.hs +0/−59
- Language/Lsl/Internal/NumberParsing.hs +0/−59
- Language/Lsl/Internal/Optimize.hs +0/−73
- Language/Lsl/Internal/Physics.hs +0/−133
- Language/Lsl/Internal/SimMetaData.hs +0/−32
- Language/Lsl/Internal/SystemTester.hs +0/−118
- Language/Lsl/Internal/TestResult.hs +0/−40
- Language/Lsl/Internal/Type.hs +0/−259
- Language/Lsl/Internal/UnitTester.hs +0/−72
- Language/Lsl/Internal/Util.hs +0/−161
- Language/Lsl/Internal/WorldState.hs +0/−651
- Language/Lsl/Internal/XmlCreate.hs +0/−26
- Language/Lsl/Parse.hs +0/−629
- Language/Lsl/QQ.hs +0/−71
- Language/Lsl/Render.hs +0/−198
- Language/Lsl/Sim.hs +0/−3697
- Language/Lsl/Syntax.hs +0/−961
- Language/Lsl/UnitTest.hs +0/−72
- Language/Lsl/UnitTestEnv.hs +0/−268
- Language/Lsl/WorldDef.hs +0/−817
- LslPlus.cabal +42/−40
- LslPlus.hs +0/−35
- NOTICE +11/−0
- Setup.hs +5/−1
- noqqsrc/Language/Lsl/Internal/BuiltInModules.hs +6/−0
- qqsrc/Language/Lsl/Internal/BuiltInModules.hs +28/−0
- src/Language/Lsl/Internal/Animation.hs +137/−0
- src/Language/Lsl/Internal/AvEvents.hs +19/−0
- src/Language/Lsl/Internal/Breakpoint.hs +90/−0
- src/Language/Lsl/Internal/BreakpointsDeserialize.hs +18/−0
- src/Language/Lsl/Internal/CodeHelper.hs +8/−0
- src/Language/Lsl/Internal/Compiler.hs +140/−0
- src/Language/Lsl/Internal/Constants.hs +574/−0
- src/Language/Lsl/Internal/DOMProcessing.hs +132/−0
- src/Language/Lsl/Internal/DOMSourceDescriptor.hs +34/−0
- src/Language/Lsl/Internal/DOMUnitTestDescriptor.hs +201/−0
- src/Language/Lsl/Internal/Evaluation.hs +24/−0
- src/Language/Lsl/Internal/EventSigs.hs +90/−0
- src/Language/Lsl/Internal/Exec.hs +1105/−0
- src/Language/Lsl/Internal/ExecInfo.hs +51/−0
- src/Language/Lsl/Internal/ExpressionHandler.hs +350/−0
- src/Language/Lsl/Internal/FuncSigs.hs +686/−0
- src/Language/Lsl/Internal/InternalLLFuncs.hs +650/−0
- src/Language/Lsl/Internal/Key.hs +21/−0
- src/Language/Lsl/Internal/Load.hs +39/−0
- src/Language/Lsl/Internal/Log.hs +15/−0
- src/Language/Lsl/Internal/Math.hs +129/−0
- src/Language/Lsl/Internal/MetaData.hs +59/−0
- src/Language/Lsl/Internal/NumberParsing.hs +59/−0
- src/Language/Lsl/Internal/Optimize.hs +73/−0
- src/Language/Lsl/Internal/Physics.hs +133/−0
- src/Language/Lsl/Internal/SimMetaData.hs +32/−0
- src/Language/Lsl/Internal/SystemTester.hs +118/−0
- src/Language/Lsl/Internal/TestResult.hs +40/−0
- src/Language/Lsl/Internal/Type.hs +259/−0
- src/Language/Lsl/Internal/UnitTester.hs +72/−0
- src/Language/Lsl/Internal/Util.hs +161/−0
- src/Language/Lsl/Internal/WorldState.hs +651/−0
- src/Language/Lsl/Internal/XmlCreate.hs +26/−0
- src/Language/Lsl/Parse.hs +629/−0
- src/Language/Lsl/QQ.hs +71/−0
- src/Language/Lsl/Render.hs +198/−0
- src/Language/Lsl/Sim.hs +3712/−0
- src/Language/Lsl/Syntax.hs +966/−0
- src/Language/Lsl/UnitTest.hs +73/−0
- src/Language/Lsl/UnitTestEnv.hs +270/−0
- src/Language/Lsl/WorldDef.hs +821/−0
- src/LslPlus.hs +35/−0
− Language/Lsl/Internal/Animation.hs
@@ -1,137 +0,0 @@-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)]
− Language/Lsl/Internal/AvEvents.hs
@@ -1,19 +0,0 @@-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)
− Language/Lsl/Internal/Breakpoint.hs
@@ -1,90 +0,0 @@-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 - [] -> []
− Language/Lsl/Internal/BreakpointsDeserialize.hs
@@ -1,18 +0,0 @@-{-# 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
− Language/Lsl/Internal/BuiltInModules.hs
@@ -1,28 +0,0 @@-{-# 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)
− Language/Lsl/Internal/CodeHelper.hs
@@ -1,8 +0,0 @@--- 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) ++ [")"])
− Language/Lsl/Internal/Compiler.hs
@@ -1,140 +0,0 @@--- 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" -
− Language/Lsl/Internal/Constants.hs
@@ -1,574 +0,0 @@-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
− Language/Lsl/Internal/DOMProcessing.hs
@@ -1,132 +0,0 @@-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++";"
− Language/Lsl/Internal/DOMSourceDescriptor.hs
@@ -1,34 +0,0 @@-{-# 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
− Language/Lsl/Internal/DOMUnitTestDescriptor.hs
@@ -1,201 +0,0 @@-{-# 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''
− Language/Lsl/Internal/Evaluation.hs
@@ -1,24 +0,0 @@-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) -
− Language/Lsl/Internal/EventSigs.hs
@@ -1,90 +0,0 @@-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
− Language/Lsl/Internal/Exec.hs
@@ -1,1105 +0,0 @@-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
− Language/Lsl/Internal/ExecInfo.hs
@@ -1,51 +0,0 @@-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)]
− Language/Lsl/Internal/ExpressionHandler.hs
@@ -1,350 +0,0 @@-{-# 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) - -
− Language/Lsl/Internal/FuncSigs.hs
@@ -1,686 +0,0 @@-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"))]
− Language/Lsl/Internal/InternalLLFuncs.hs
@@ -1,650 +0,0 @@-{- - 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,'=','=']
− Language/Lsl/Internal/Key.hs
@@ -1,21 +0,0 @@-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)
− Language/Lsl/Internal/Load.hs
@@ -1,39 +0,0 @@-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)
− Language/Lsl/Internal/Log.hs
@@ -1,15 +0,0 @@-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"
− Language/Lsl/Internal/Math.hs
@@ -1,129 +0,0 @@-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)
− Language/Lsl/Internal/MetaData.hs
@@ -1,59 +0,0 @@-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"]
− Language/Lsl/Internal/NumberParsing.hs
@@ -1,59 +0,0 @@-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]
− Language/Lsl/Internal/Optimize.hs
@@ -1,73 +0,0 @@-{-# 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
− Language/Lsl/Internal/Physics.hs
@@ -1,133 +0,0 @@-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) -
− Language/Lsl/Internal/SimMetaData.hs
@@ -1,32 +0,0 @@-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")] []
− Language/Lsl/Internal/SystemTester.hs
@@ -1,118 +0,0 @@-{-# 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
− Language/Lsl/Internal/TestResult.hs
@@ -1,40 +0,0 @@-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
− Language/Lsl/Internal/Type.hs
@@ -1,259 +0,0 @@-{-# 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)
− Language/Lsl/Internal/UnitTester.hs
@@ -1,72 +0,0 @@-{-# 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]
− Language/Lsl/Internal/Util.hs
@@ -1,161 +0,0 @@-{-# 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!!!"
− Language/Lsl/Internal/WorldState.hs
@@ -1,651 +0,0 @@-{-# 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
− Language/Lsl/Internal/XmlCreate.hs
@@ -1,26 +0,0 @@-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 "</" . showString name . 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)
− Language/Lsl/Parse.hs
@@ -1,629 +0,0 @@-module Language.Lsl.Parse( - parseScript, - parseModule, - exprParser, - parseType, - parseScriptFromString, - parseModuleFromString, - parseScriptFromStringAQ, - parseModuleFromStringAQ - ) where - -import Data.Char(digitToInt) -import Data.List(intersperse) -import Language.Lsl.Syntax(Expr(..),Statement(..),Func(..),FuncDec(..),Handler(..),State(..),Ctx(..),SourceContext(..),LSLType(..), - Component(..),Var(..),LModule(..),LSLScript(..),GlobDef(..),goodHandlers) -import Text.ParserCombinators.Parsec hiding (State) -import qualified Text.ParserCombinators.Parsec.Token as P -import Text.ParserCombinators.Parsec.Language( javaStyle ) -import Text.ParserCombinators.Parsec.Error -import Control.Monad.Error(liftIO) -import Control.Monad.Trans(MonadIO) - --- define basic rules for lexical analysis -lslStyle = javaStyle - { P.reservedOpNames= ["*","/","+","++","-","--","^","&","&&", - "|","||","==","=","!=","<","<=",">=",">", - "<<",">>","!","%","~","@","+=","-=","*=","/=","%="], - P.reservedNames = ["state","default","string","integer","list","vector","rotation","key","float","if","else", - "while","for","do","jump","return","default", "$import", "$module","quaternion"], - P.caseSensitive = True, - P.identStart = letter <|> char '_', - P.opLetter = oneOf "*/+:!#$%&*+./=?@\\^|-~", - P.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~" } -lexer :: P.TokenParser Bool -lexer = P.makeTokenParser lslStyle - -identLetter = P.identLetter lslStyle - -identifier = P.identifier lexer -reserved = P.reserved lexer -operator = P.operator lexer -reservedOp = P.reservedOp lexer - -charLiteral = P.charLiteral lexer --- stringLiteral = P.stringLiteral lexer -natural = P.natural lexer -integer = P.integer lexer -float = P.float lexer ---naturalOrFloat = P.naturalOrFloat lexer -decimal = P.decimal lexer -hexadecimal = P.hexadecimal lexer -octal = P.octal lexer - -symbol = P.symbol lexer -lexeme = P.lexeme lexer -whiteSpace = P.whiteSpace lexer - -parens = P.parens lexer -braces = P.braces lexer -angles = P.angles lexer -brackets = P.brackets lexer -semi = P.semi lexer -comma = P.comma lexer -colon = P.colon lexer -dot = P.dot lexer -semiSep = P.semiSep lexer -semiSep1 = P.semiSep1 lexer -commaSep = P.commaSep lexer -commaSep1 = P.commaSep1 lexer - -decimalFraction w = do char '.' - fracPart True w - -fracPart reqDigit w = do digits <- (if reqDigit then many1 else many) digit <?> "fractional part of decimal" - p <- option 1.0 expon - return $ p * (w + (foldr (\ b d -> (b + d) / 10.0) 0 $ map (fromIntegral.digitToInt) digits)) - -expon = do oneOf "eE" - s <- option '+' (oneOf "+-") - let k x = if s == '+' then x else 1/x - digits <- many1 digit <?> "exponent" - let p = foldl (\ b d -> b * 10 + d) 0 $ map digitToInt digits - return ((k (10^p))::Float) - -hex = do oneOf "xX" - digits <- many1 hexDigit <?> "hex digit" - return (foldl (\ b d -> b * 16 + d) 0 $ map digitToInt digits) --- lsl doesn't support octal! --- oct = do oneOf "oO" --- digits <- many1 octDigit <?> "octal digit" --- return (foldl (\ b d -> b * 8 + d) 0 $ map digitToInt digits) - --- Like Parsec 'naturalOrFloat', but accept <digits>. and .<digits><exp> as valid floating point numbers -naturalOrFloat = do v <- natOrFloat <?> "number" - whiteSpace - return v -natOrFloat = (decimalFraction 0.0 >>= return . Right) - <|> do char '0' - option (Left 0) prefZeroNum - <|> decimalOrFloat - -prefZeroNum = (hex >>= return . Left) - <|> (decimalFraction 0.0 >>= return . Right) - <|> decimalOrFloat -decimalOrFloat = - do wholeDigits <- many1 digit <?> "number" - let w = foldl (\ b d -> b * 10 + d) 0 $ map digitToInt wholeDigits - mf <- option Nothing (char '.' >> option (fromIntegral w) (fracPart False (fromIntegral w)) >>= return . Just) - return $ case mf of - Nothing -> Left w - Just f -> Right f - -stringLiteral = lexeme ( - do{ str <- between (char '"') - (char '"' <?> "end of string") - (many stringChar) - ; return (foldr (maybe id (:)) "" str) - } - <?> "literal string") - -stringChar :: CharParser st (Maybe Char) -stringChar = do{ c <- stringLetter; return (Just c) } - <|> try stringEscape - <|> (char '\\' >> return (Just '\\')) - <?> "string character" - -stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) - -stringEscape = do - char '\\' - choice [char 't' >> return (Just '\t'), - char 'n' >> return (Just '\n'), - char '\"' >> return (Just '\"'), - char '\\' >> return (Just '\\')] - ---- EXPRESSION PARSING ------------------------------------------------------- ---mtrace s v = return v -- trace (s ++ show v) (return v) -mtrace s v = - -- trace (s ++ show v) - (return v) - -combineExprs e [] = e -combineExprs e0 ((p0,p1,op,e1):rest) = combineExprs (op p0 p1 e0 e1) rest - -opmatch s f = (reservedOp s >> return f) -op0 = ((opmatch "*" mulop) <|> (opmatch "/" divop) <|> (opmatch "%" modop)) <?> "operator" -op1 = ((opmatch "+" addop) <|> (opmatch "-" subop)) <?> "operator" -op2 = ((opmatch "<<" shiftlop) <|> (opmatch ">>" shiftrop)) <?> "operator" -op3 = (choice [opmatch "<" ltop, opmatch "<=" leop, opmatch ">" gtop, opmatch ">=" geop]) <?> "operator" -op4 = ((opmatch "==" eqop) <|> (opmatch "!=" neop)) <?> "operator" - -opAndExpr opf ef = do pos0 <- getPosition - op <- opf - pos1 <- getPosition - e <- ef - return (pos0,pos1,op,e) - -exprChain opf ef = do e0 <- ef - rest <- many (opAndExpr opf ef) - return $ combineExprs e0 rest - -mulExpr = exprChain op0 expr2 -addExpr = exprChain op1 mulExpr -shiftExpr = exprChain op2 addExpr -relExpr = do e0 <- shiftExpr - rest <- (try (many (try (opAndExpr op3 shiftExpr))) <|> return []) - return $ combineExprs e0 rest -eqExpr = exprChain op4 relExpr -bandExpr = exprChain (opmatch "&" bandop <?> "operator") eqExpr -xorExpr = exprChain (opmatch "^" xorop <?> "operator") bandExpr -borExpr = exprChain (opmatch "|" borop <?> "operator") xorExpr -andExpr = exprChain (opmatch "&&" andop <?> "operator") borExpr -orExpr = exprChain (opmatch "||" orop <?> "operator") andExpr - -bop op pos0 pos1 e0 e1 = - let ctx = combineContexts (srcCtx e0, pos0, pos1, srcCtx e1) in Ctx ctx $ op e0 e1 - -mulop pos0 pos1 = bop Mul pos0 pos1 -divop pos0 pos1 = bop Div pos0 pos1 -modop pos0 pos1 = bop Mod pos0 pos1 -addop pos0 pos1 = bop Add pos0 pos1 -subop pos0 pos1 = bop Sub pos0 pos1 -shiftlop pos0 pos1 = bop ShiftL pos0 pos1 -shiftrop pos0 pos1 = bop ShiftR pos0 pos1 -ltop pos0 pos1 = bop Lt pos0 pos1 -leop pos0 pos1 = bop Le pos0 pos1 -gtop pos0 pos1 = bop Gt pos0 pos1 -geop pos0 pos1 = bop Ge pos0 pos1 -eqop pos0 pos1 = bop Equal pos0 pos1 -neop pos0 pos1 = bop NotEqual pos0 pos1 -bandop pos0 pos1 = bop BAnd pos0 pos1 -xorop pos0 pos1 = bop Xor pos0 pos1 -borop pos0 pos1 = bop BOr pos0 pos1 -andop pos0 pos1 = bop And pos0 pos1 -orop pos0 pos1 = bop Or pos0 pos1 - -structAccess = do id <- ctxify identifier - whiteSpace - dot - whiteSpace - c <- oneOf "xyzs" - whiteSpace - return (id,stringToComponent [c]) -var = try structAccess - <|> do id <- ctxify identifier - return (id,All) - -assignment = ctxify $ - do v <- var - op <- choice [reservedOp "+=" >> (return $ IncBy), - reservedOp "-=" >> (return $ DecBy), - reservedOp "*=" >> (return $ MulBy), - reservedOp "/=" >> (return $ DivBy), - reservedOp "%=" >> (return $ ModBy), - reservedOp "=" >> (return $ Set)] <?> "assignment operator" - e <- expr - return $ op v e - -stringToComponent "" = All -stringToComponent "x" = X -stringToComponent "y" = Y -stringToComponent "z" = Z -stringToComponent "s" = S - -listExpr = do whiteSpace - exprs <- (brackets $ commaSep expr) <?> "list expression" - return $ ListExpr exprs - --- structExpr = do whiteSpace --- char '<' <?> "vector/rotation expression" --- whiteSpace --- e1 <- expr --- mtrace "structExpr:1 " e1 --- char ',' --- whiteSpace --- e2 <- expr --- mtrace "structExpr:2 " e2 --- char ',' --- whiteSpace --- e3 <- expr --- mtrace "structExpr:3 " e3 --- return (e1,e2,e3) --- vecRotExpr = do (x,y,z) <- structExpr --- mtrace "vec/rot" "hi" --- (do char '>' --- whiteSpace --- return $ VecExpr x y z) <|> --- (do char ',' --- whiteSpace --- e <- expr --- char '>' --- whiteSpace --- return $ RotExpr x y z e) - --- there's a conflict between a relational expression embedded in the last component of a vector/rotation and the --- the normal end of the expression... in particular: --- v = <1,1,1 > -<1,2,3>>; --- is not a syntax error (but is a type error), but you can't tell the difference between that and --- v = <1,1,1 > -<1,2,3>; --- which is the difference between two vectors (which is both syntactically correct and type correct) until you --- parse the ';'. So the complexity of the grammar here exists to disambiguate these cases (which requires a --- bit of lookahead...) -structStart = do whiteSpace - char '<' <?> "vector/rotation expression" - whiteSpace - e1 <- expr - mtrace "structExpr:1 " e1 - char ',' - whiteSpace - e2 <- expr - mtrace "structExpr:2 " e2 - char ',' >> whiteSpace - return (e1,e2) - -vecRotExpr = do (x,y) <- structStart - ((try (do z <- expr - char ',' >> whiteSpace - s <- tailStruct - return $ RotExpr x y z s)) <|> - (do z <- tailStruct - return $ VecExpr x y z)) - -tailStruct = (try (do e <- expr - char '>' >> whiteSpace - return e)) - <|> (do e <- shiftExpr - char '>' >> whiteSpace - return e) -callExpr = do - name <- ctxify identifier - exprs <- parens $ commaSep expr - return $ Call name exprs - -castExpr = ctxify $ - do t <- parens typeName - e <- choice [try postfixExpr, atomicExpr] - return $ Cast t e - -ctxify f = do - pos0 <- getPosition - v <- f - pos1 <- getPosition - return $ Ctx (pos2Loc (pos0,pos1)) v - -notExpr = ctxify ((char '!' <?> "prefix operator") >> whiteSpace >> expr2 >>= return.Not) -invExpr = ctxify ((char '~' <?> "prefix operator") >> whiteSpace >> expr2 >>= return.Inv) -negExpr = ctxify ((char '-' <?> "prefix operator") >> whiteSpace >> expr2 >>= return.Neg) - -atomicExpr = do - aq <- getState - (ctxify $ - try ( do m <- option 1 (reservedOp "-" >> return (-1)) - n <- naturalOrFloat - return $ case n of - Left nat -> (IntLit $ m * fromIntegral nat) - Right flt -> (FloatLit $ fromRational $ toRational m * toRational flt))) - <|> (ctxify (stringLiteral >>= return.StringLit)) - <|> (if aq then (ctxify (reservedOp "$string:" >> identifier >>= return . AQString)) else fail "") - <|> (if aq then (ctxify (reservedOp "$integer:" >> identifier >>= return . AQInteger)) else fail "") - <|> (if aq then (ctxify (reservedOp "$key:" >> identifier >>= return . AQKey)) else fail "") - <|> (if aq then (ctxify (reservedOp "$float:" >> identifier >>= return . AQFloat)) else fail "") - <|> (ctxify listExpr) - <|> (ctxify vecRotExpr) - <|> (ctxify $ try callExpr) - <|> (ctxify $ do v <- var - return $ Get v) - <|> parens expr - -postfixExpr = ctxify $ - do v <- var - f <- choice [reservedOp "++" >> return PostInc, - reservedOp "--" >> return PostDec] <?> "postfix operator" - return $ f v -prefixExpr = ctxify $ - do f <- choice [reservedOp "--" >> return (PreDec), - reservedOp "++" >> return PreInc] <?> "prefix operator" - v <- var - return $ f v - -unaryExpr = choice [try prefixExpr,notExpr,invExpr, negExpr,try castExpr,atomicExpr] - -expr2 :: GenParser Char Bool (Ctx Expr) -expr2 = choice [try assignment, try postfixExpr, unaryExpr] - -expr1 = orExpr - -expr :: GenParser Char Bool (Ctx Expr) -expr = - do r <- choice [try assignment, expr1] - mtrace "expr: " r - -exprParser :: String -> Either ParseError (Ctx Expr) -exprParser text = runParser expr False "" text - ------------------------------------------------------------------------------- --- STATEMENT PARSING - -statements = do whiteSpace - many (ctxify statement) - -statement = declStatement - <|> returnStatement - <|> jumpStatement - <|> labelStatement - <|> exprStatement - <|> blockStatement - <|> nullStatement - <|> whileStatement - <|> ifElseStatement - <|> stateStatement - <|> doWhileStatement - <|> forStatement - -declStatement = do t <- typeName - id <- identifier - rest <- (option Nothing (reservedOp "=" >> expr >>= return . Just)) - semi - return $ Decl (Var id t) rest - -integerType = (reserved "integer" >> return LLInteger) -floatType = (reserved "float" >> return LLFloat) -keyType = (reserved "key" >> return LLKey) -vectorType = (reserved "vector" >> return LLVector) -stringType = (reserved "string" >> return LLString) -rotationType = ((reserved "rotation"<|>reserved "quaternion") >> return LLRot) -listType = (reserved "list" >> return LLList) - -typeName = choice [integerType,floatType,keyType,vectorType,stringType,rotationType,listType] - -returnStatement = do reserved "return" - e <- (option Nothing (expr >>= return . Just)) - semi - return $ Return e -jumpStatement = do reserved "jump" - id <- identifier - semi - return $ Jump id -labelStatement = do reservedOp "@" - id <- identifier - semi - return $ Label id -exprStatement = do e <- expr - semi - return $ Do e - -blockStatement = do stmts <- braces statements - return $ Compound stmts - -nullStatement = (semi >> return NullStmt) - -whileStatement = do reserved "while" - e <- parens expr - stmt <- statement - return $ While e stmt -ifElseStatement = do reserved "if" - e <- parens expr - stmt1 <- statement - stmt2 <- (option NullStmt (reserved "else" >> statement)) - return $ If e stmt1 stmt2 - -stateStatement = do reserved "state" - id <- (identifier <|> (reserved "default" >> return "default")) - semi - return $ StateChange id - -forStatement = do reserved "for" - char '(' - whiteSpace - mexpr1 <- commaSep expr - semi - mexpr2 <- option Nothing (expr >>= return . Just) - semi - mexpr3 <- commaSep expr - char ')' - whiteSpace - stmt <- statement - return $ For mexpr1 mexpr2 mexpr3 stmt - -doWhileStatement = do reserved "do" - stmt <- statement - reserved "while" - e <- parens expr - return $ DoWhile stmt e - -parseType text = runParser typeName False "" text ------------------------------------------------------------- --- HANDLER Parsing - -hparam theType = ctxify $ - do t <- (typeParser theType) - id <- identifier - return $ Var id t - -typeParser LLInteger = integerType -typeParser LLFloat = floatType -typeParser LLList = listType -typeParser LLString = stringType -typeParser LLVector = vectorType -typeParser LLKey = keyType -typeParser LLRot = rotationType - -hparams [] = return [] -hparams (theType:[]) = (hparam theType >>= return . (:[])) -hparams (theType:ts) = do p <- hparam theType - comma - ps <- hparams ts - return (p:ps) - -handlerName name = try (do id <- symbol name; notFollowedBy identLetter; return id) - -handler' name types = do ctxname <- ctxify $ handlerName name - parms <- parens (hparams types) - stmts <- braces statements - return $ Handler ctxname parms stmts - -handler = choice $ map (\ (n,ts) -> handler' n ts) goodHandlers - -------------------------------------------------------------- --- STATE parsing - -stateName = choice [reserved "default" >> return "default" , reserved "state" >> identifier >>= return] - -stateDecl = do name <- ctxify stateName - handlers <- braces $ many handler - return $ State name handlers - -stateDecls = many stateDecl - --------------------------------------------------------------- -varOrFunc = do (Ctx ctx (t,id)) <- ctxify $ do - t <- try typeName - id <- ctxify identifier <?> "identifier" - return (t,id) - choice [func t id, gvar ctx t id] - <|> do id <- ctxify identifier <?> "identifier" - func LLVoid id -func t id = do ps <- parens params - stmts <- braces statements - return $ GF $ Func (FuncDec id t ps) stmts -gvar ctx t (Ctx _ id) = do mexpr <- option Nothing (reservedOp "=" >> expr >>= return . Just) - semi - return $ GV (Ctx ctx (Var id t)) mexpr --------------------------------------------------------------- --- FUNCTION parsing - -param = ctxify $ - do t <- typeName - id <- identifier - return $ Var id t -params = commaSep param - --- function = do (t,id,ps) <- try $ do t <- option LLVoid typeName <?> "type name" --- id <- ctxify identifier <?> "function name" --- ps <- parens params --- return (t,id,ps) --- stmts <- braces statements --- return $ GF $ Func (FuncDec id t ps) stmts ---------------------------------------------------------------- --- GLOBAL VARIABLES parsing - --- globals allow no initialization or initialization by 'constant' expressions... --- we can allow any expressions though and have semantic analysis catch problems - --- globvar = do var <- ctxify $ do --- t <- typeName <?> "type name" --- id <- identifier --- return (Var id t) --- mexpr <- option Nothing (reservedOp "=" >> expr >>= return.Just) --- semi --- return $ GV var mexpr ----------------------------------------------------------------- --- IMPORT (meta-lsl directive) parsing - -gimport = do reserved "$import" <?> "$import keyword" - ids <- (ctxify $ (char '$' >> identifier >>= return . (:[]) . ("$"++))) - <|>(ctxify $ sepBy identifier dot) - let id = fmap (concat . intersperse ".") ids - let binding = do id0 <- identifier - reservedOp "=" - id1 <- identifier - return (id0,id1) - bindings <- option [] $ parens $ commaSep binding - prefix <- option "" identifier - semi - return $ GI id bindings prefix ----------------------------------------------------------------- --- all globals parsing - -globals = many $ choice [gimport,varOrFunc] - -lslParser = do whiteSpace - globs <- globals - ss <- stateDecls - eof - return $ LSLScript globs ss - -moduleParser = do whiteSpace - reserved "$module" - freevars <- option [] $ parens params - globs <- globals - eof - return $ LModule globs freevars - -parseFromString parser string = - case runParser parser False "" string of - Left err -> Left (snd (fromParseError err)) - Right x -> Right x - --- | Parse an LSL script into its syntax tree.-parseScriptFromString :: String -> Either String LSLScript -parseScriptFromString s = parseFromString lslParser s --- | Parse an LSL (Plus) module into its syntax tree.-parseModuleFromString :: String -> Either String LModule -parseModuleFromString s = parseFromString moduleParser s - --- | Parse an LSL script, with possible antiquotations, into its syntax tree.-parseScriptFromStringAQ :: String -> Either ParseError LSLScript -parseScriptFromStringAQ s = runParser lslParser True "" s --- | Parse an LSL (Plus) module, with possible antiquotations, into its syntax tree.-parseModuleFromStringAQ :: String -> Either ParseError LModule -parseModuleFromStringAQ s = runParser moduleParser True "" s - -parseModule :: (MonadIO m) => SourceName -> m (Either (SourceContext,String) LModule)-parseModule file = parseFile moduleParser file -parseScript file = parseFile lslParser file - -fromParseError :: ParseError -> (SourceContext,String) -fromParseError err = - let pos = errorPos err - msg = showErrorMessages "or" "unknown parse error" - "expecting" "unexpected" "end of input" (errorMessages err) - in (TextLocation { textLine0 = sourceLine pos, textColumn0 = sourceColumn pos, - textLine1 = sourceLine pos, textColumn1 = sourceColumn pos, - textName = sourceName pos }, - msg) - -parseFile p file = - do s <- liftIO $ readFile file - case parser s of - Left err -> return $ Left (fromParseError err) - Right x -> return $ Right x - where parser = runParser p False file - -txtLoc pos len = - TextLocation { textName = sourceName pos, - textColumn0 = sourceColumn pos, - textLine0 = sourceLine pos, - textColumn1 = sourceColumn pos + (len-1), - textLine1 = sourceLine pos } - -idLoc pos id = txtLoc pos $ length id - -pos2Loc (pos0,pos1) = - TextLocation { - textName = sourceName pos0, - textColumn0 = sourceColumn pos0, - textLine0 = sourceLine pos0, - textColumn1 = sourceColumn pos1, - textLine1 = sourceLine pos1 - } - -combineContexts (UnknownSourceContext,pos0,pos1,UnknownSourceContext) = pos2Loc (pos0,pos1) -combineContexts (TextLocation l0 c0 l1 c1 n,_,_,TextLocation l0' c0' l1' c1' n') = - TextLocation l0 c0 l1' c1' n -combineContexts (TextLocation l0 c0 l1 c1 n,_,pos,_) = - TextLocation l0 c0 (sourceLine pos) (sourceColumn pos) n -combineContexts (_,pos,_,TextLocation l0 c0 l1 c1 n) = - TextLocation (sourceLine pos) (sourceColumn pos) l1 c1 n -
− Language/Lsl/QQ.hs
@@ -1,71 +0,0 @@-{-# LANGUAGE TemplateHaskell #-} -module Language.Lsl.QQ(lslm,lsl) where - -import Data.Generics.Aliases(extQ) -import qualified Language.Haskell.TH as TH -import Language.Haskell.TH.Quote(QuasiQuoter(..),dataToPatQ,dataToExpQ) -import Language.Lsl.Syntax(Expr(..)) -import Language.Lsl.Parse(parseModuleFromStringAQ,parseScriptFromStringAQ) -import Text.ParserCombinators.Parsec.Error(errorPos,errorMessages,showErrorMessages) -import Text.ParserCombinators.Parsec.Pos - -aqe (AQString v) = Just $ TH.appE (TH.conE 'StringLit) $ TH.varE $ TH.mkName v -aqe (AQInteger v) = Just $ TH.appE (TH.conE 'IntLit) $ TH.varE $ TH.mkName v -aqe (AQKey v) = Just $ TH.appE (TH.conE 'KeyLit) $ TH.varE $ TH.mkName v -aqe (AQFloat v) = Just $ TH.appE (TH.conE 'FloatLit) $ TH.varE $ TH.mkName v -aqe _ = Nothing -aqp (AQString v) = Just $ TH.conP 'StringLit [TH.varP $ TH.mkName v] -aqp (AQInteger v) = Just $ TH.conP 'IntLit [TH.varP $ TH.mkName v] -aqp (AQKey v) = Just $ TH.conP 'KeyLit [TH.varP $ TH.mkName v] -aqp (AQFloat v) = Just $ TH.conP 'FloatLit [TH.varP $ TH.mkName v] -aqp _ = Nothing - -lslModulePat :: String -> TH.Q TH.Pat -lslModulePat s = - case parseModuleFromStringAQ s of - Left err -> let (pos,msgs) = (errorPos err, errorMessages err) in do - l <- TH.location - let (line,col) = TH.loc_start l - let (line1, col1) = (sourceLine pos, sourceColumn pos) - fail $ "at " ++ show (line + line1 - 1) ++ ":" ++ show (col1) ++ ": " ++ - showErrorMessages "or" "unknown" "expecting" "unexpected" "end of input" msgs - Right x -> dataToPatQ (const Nothing `extQ` aqp) x -lslModuleExp :: String -> TH.Q TH.Exp -lslModuleExp s = - case parseModuleFromStringAQ s of - Left err -> let (pos,msgs) = (errorPos err, errorMessages err) in do - l <- TH.location - let (line,col) = TH.loc_start l - let (line1, col1) = (sourceLine pos, sourceColumn pos) - fail $ "at " ++ show (line + line1 - 1) ++ ":" ++ show (col1) ++ ": " ++ - showErrorMessages "or" "unknown" "expecting" "unexpected" "end of input" msgs - Right x -> dataToExpQ (const Nothing `extQ` aqe) x - --- | A quasi-quoter for an LSL (Plus) module. -lslm :: QuasiQuoter-lslm = QuasiQuoter lslModuleExp lslModulePat - -lslScriptPat :: String -> TH.Q TH.Pat -lslScriptPat s = - case parseScriptFromStringAQ s of - Left err -> let (pos,msgs) = (errorPos err, errorMessages err) in do - l <- TH.location - let (line,col) = TH.loc_start l - let (line1, col1) = (sourceLine pos, sourceColumn pos) - fail $ "at " ++ show (line + line1 - 1) ++ ":" ++ show (col1) ++ ": " ++ - showErrorMessages "or" "unknown" "expecting" "unexpected" "end of input" msgs - Right x -> dataToPatQ (const Nothing `extQ` aqp) x -lslScriptExp :: String -> TH.Q TH.Exp -lslScriptExp s = - case parseScriptFromStringAQ s of - Left err -> let (pos,msgs) = (errorPos err, errorMessages err) in do - l <- TH.location - let (line,col) = TH.loc_start l - let (line1, col1) = (sourceLine pos, sourceColumn pos) - fail $ "at " ++ show (line + line1 - 1) ++ ":" ++ show (col1) ++ ": " ++ - showErrorMessages "or" "unknown" "expecting" "unexpected" "end of input" msgs - Right x -> dataToExpQ (const Nothing `extQ` aqe) x - --- | A quasi-quoter for an LSL script. -lsl :: QuasiQuoter-lsl = QuasiQuoter lslScriptExp lslScriptPat
− Language/Lsl/Render.hs
@@ -1,198 +0,0 @@-module Language.Lsl.Render(renderCompiledScript) where - -import Data.List(foldl',intersperse) -import Language.Lsl.Syntax(Expr(..),Func(..),FuncDec(..),Global(..),Handler(..),State(..),Statement(..), - Ctx(..),Var(..),LSLType(..),Component(..),ctxItems,validLSLScript,CompiledLSLScript(..)) - --- | Generate a string representing an LSL script from a timestamp (string) --- and a compiled (i.e. validated, with referenced modules included) LSL script.-renderCompiledScript :: String -> CompiledLSLScript -> String-renderCompiledScript stamp (CompiledLSLScript globals funcs states) = - (renderString "// LSL script generated: " . renderString stamp . renderString "\n" . - renderGlobals globals . renderFuncs funcs . renderStates states) "" - -renderSequence r = (foldl' (.) blank) . (map r) - -renderGlobals = renderSequence renderGlobal - -renderGlobal (GDecl var val) = renderVar var . - case val of - Nothing -> renderString ";\n" - Just expr -> renderString " = " . renderSimple expr . renderString ";\n" - -renderCtxSimple (Ctx _ expr) = renderSimple expr -renderSimple (Neg expr) = renderChar '-' . renderCtxExpr expr -renderSimple (ListExpr l) = - renderChar '[' . - (foldl' (.) id $ intersperse (renderChar ',') $ map renderCtxSimple l) . - renderChar ']' -renderSimple (VecExpr x y z) = renderChar '<' . renderCtxSimple x . - renderChar ',' . renderCtxSimple y . - renderChar ',' . renderCtxSimple z . - renderChar '>' -renderSimple (RotExpr x y z s) = renderChar '<' . renderCtxSimple x . - renderChar ',' . renderCtxSimple y . - renderChar ',' . renderCtxSimple z . - renderChar ',' . renderCtxSimple s . - renderChar '>' -renderSimple e = renderExpression e - -renderStates = renderSequence renderState - -renderState (State (Ctx _ "default") handlers) = - renderString "default {\n" . renderHandlers handlers . renderString "}\n" -renderState (State (Ctx _ name) handlers) = - renderString "state " . renderString name . renderString " {\n" . renderHandlers handlers . renderString "}\n" - -renderHandlers = renderSequence renderHandler - -renderHandler (Handler (Ctx _ name) vars stmts) = renderHandler' name vars stmts - -renderHandler' name vars stmts = - renderIndent 0 . renderString name . renderChar '(' . renderVarList (ctxItems vars) . renderString ") {\n" . - renderStatements 1 stmts . renderIndent 0 . renderString "}\n" - -renderChar = showChar -renderVar (Var nm t) = (renderType t) . renderChar ' ' . (renderString nm) -renderFuncDec (FuncDec name t vars) = - let sp = if t == LLVoid then "" else " " in - renderType t . renderString sp . renderString (ctxItem name) . renderChar '(' . - renderVarList (ctxItems vars) . renderChar ')' - -renderVarList [] = blank -renderVarList (v:vars) = - (renderVar v) . - let render' [] = blank - render' (v:vars) = renderChar ',' . renderVar v . render' vars in render' vars - -renderFuncs = renderSequence renderFunc - -renderFunc (Func dec stmts) = - renderFuncDec dec . renderString "{\n" . renderStatements 0 stmts . renderString "}\n" - -renderIndent 0 = renderString " " -renderIndent n = renderString " " . renderIndent (n - 1) - -renderCtxStatement hang n (Ctx _ s) = renderStatement hang n s - -renderStatements n = renderSequence (renderCtxStatement False n) - -doHang True n = renderString " " -doHang False n = renderIndent n - -renderOptionalExpression Nothing = blank -renderOptionalExpression (Just expr) = renderCtxExpr expr - -renderStatement hang n stmt = doHang hang n . renderStatement' n stmt -renderStatement' n (Compound stmts) = - renderString "{\n" . renderStatements (n+1) stmts . renderIndent n . renderString "}\n" -renderStatement' n (While expr stmt) = - renderString "while (" . renderCtxExpr expr . renderChar ')' . renderStatement True n stmt -renderStatement' n (DoWhile stmt expr) = - renderString "do " . renderStatement True n stmt . doHang False n . renderString "while (" . renderCtxExpr expr . renderString ");\n" -renderStatement' n (For mexpr1 mexpr2 mexpr3 stmt) = - renderString "for (" . renderCtxExprs "" mexpr1 . renderString "; " . renderOptionalExpression mexpr2 . - renderString "; " . renderCtxExprs "" mexpr3 . renderString ")" . renderStatement True n stmt -renderStatement' n (If expr stmt1 stmt2) = - renderString "if (" . renderCtxExpr expr . renderChar ')' . renderStatement True n stmt1 . - case stmt2 of - NullStmt -> blank - _ -> renderIndent n . renderString "else " . (renderStatement True n stmt2) -renderStatement' n (Decl var val) = - renderVar var . - case val of - Nothing -> renderString ";\n" - Just expr -> renderString " = " . renderCtxExpr expr . renderString ";\n" -renderStatement' n (NullStmt) = blank -renderStatement' n (Return Nothing) = renderString "return;\n" -renderStatement' n (Return (Just expr)) = renderString "return " . renderCtxExpr expr . renderString ";\n"; -renderStatement' n (StateChange name) = renderString "state " . renderString name . renderString ";\n"; -renderStatement' n (Do expr) = renderCtxExpr expr . renderString ";\n"; -renderStatement' n (Label s) = renderChar '@' . renderString s . renderString ";\n"; -renderStatement' n (Jump s) = renderString "jump " . renderString s . renderString ";\n"; - -renderExpressions prefix [] = blank -renderExpressions prefix (e:es) = renderString prefix . renderExpression e . renderExpressions "," es - -renderCtxName (Ctx _ n) = renderString n -renderCtxExpr (Ctx _ e) = renderExpression e - -renderCtxExprs prefix [] = blank -renderCtxExprs prefix (e:es) = renderString prefix . renderCtxExpr e . renderCtxExprs "," es - -renderExpression (IntLit i) = shows i -renderExpression (FloatLit f) = shows f -renderExpression (StringLit s) = shows s -renderExpression (KeyLit k) = shows k -renderExpression (VecExpr x y z) = - renderChar '<' . renderCtxExpr x . renderChar ',' . - renderCtxExpr y . renderChar ',' . - renderCtxExpr z . renderChar '>' -renderExpression (RotExpr x y z s) = - renderChar '<' . renderCtxExpr x . renderChar ',' . - renderCtxExpr y . renderChar ',' . - renderCtxExpr z . renderChar ',' . - renderCtxExpr s . renderChar '>' -renderExpression (ListExpr l) = - let r prefix [] = blank - r prefix (i:is) = renderString prefix . renderCtxExpr i . r "," is - in renderChar '[' . r "" l . renderChar ']' -renderExpression (Add expr1 expr2) = renderBinExpr "+" expr1 expr2 -renderExpression (Sub expr1 expr2) = renderBinExpr "-" expr1 expr2 -renderExpression (Mul expr1 expr2) = renderBinExpr "*" expr1 expr2 -renderExpression (Div expr1 expr2) = renderBinExpr "/" expr1 expr2 -renderExpression (Mod expr1 expr2) = renderBinExpr "%" expr1 expr2 -renderExpression (BAnd expr1 expr2) = renderBinExpr "&" expr1 expr2 -renderExpression (Xor expr1 expr2) = renderBinExpr "^" expr1 expr2 -renderExpression (BOr expr1 expr2) = renderBinExpr "|" expr1 expr2 -renderExpression (Lt expr1 expr2) = renderBinExpr "<" expr1 expr2 -renderExpression (Gt expr1 expr2) = renderBinExpr ">" expr1 expr2 -renderExpression (Le expr1 expr2) = renderBinExpr "<=" expr1 expr2 -renderExpression (Ge expr1 expr2) = renderBinExpr ">=" expr1 expr2 -renderExpression (And expr1 expr2) = renderBinExpr "&&" expr1 expr2 -renderExpression (Or expr1 expr2) = renderBinExpr "||" expr1 expr2 -renderExpression (ShiftL expr1 expr2) = renderBinExpr "<<" expr1 expr2 -renderExpression (ShiftR expr1 expr2) = renderBinExpr ">>" expr1 expr2 -renderExpression (Inv expr) = renderChar '(' . renderChar '~' . renderCtxExpr expr . renderChar ')' -renderExpression (Not expr) = renderChar '(' . renderChar '!' . renderCtxExpr expr . renderChar ')' -renderExpression (Neg expr) = renderChar '(' . renderChar '-' . renderCtxExpr expr . renderChar ')' -renderExpression (Call name exprs) = renderCtxName name . renderChar '(' . renderCtxExprs "" exprs . renderChar ')' -renderExpression (Cast t expr) = renderString "((" . renderType t . renderChar ')' . renderCtxExpr expr . renderChar ')' -renderExpression (Get var) = renderVarAccess var ---renderExpression (Const var) = renderVarAccess var -renderExpression (Set var expr) = renderVarAccess var . renderString " = " . renderCtxExpr expr -renderExpression (IncBy va expr) = renderAssignment va "+=" expr -renderExpression (DecBy va expr) = renderAssignment va "-=" expr -renderExpression (MulBy va expr) = renderAssignment va "*=" expr -renderExpression (DivBy va expr) = renderAssignment va "/=" expr -renderExpression (ModBy va expr) = renderAssignment va "%=" expr -renderExpression (Equal expr1 expr2) = renderBinExpr "==" expr1 expr2 -renderExpression (NotEqual expr1 expr2) = renderBinExpr "!=" expr1 expr2 -renderExpression (PostInc va) = renderVarAccess va . renderString "++" -renderExpression (PostDec va) = renderVarAccess va . renderString "--" -renderExpression (PreInc va) = renderString "++" . renderVarAccess va -renderExpression (PreDec va) = renderString "--" . renderVarAccess va - -renderBinExpr op expr1 expr2 = renderChar '(' . renderCtxExpr expr1 . renderChar ' ' . - renderString op . renderChar ' ' . renderCtxExpr expr2 . renderChar ')' -renderAssignment va op expr = renderVarAccess va . renderChar ' ' . renderString op . renderChar ' ' . renderCtxExpr expr -renderComponent All = blank -renderComponent X = renderString ".x" -renderComponent Y = renderString ".y" -renderComponent Z = renderString ".z" -renderComponent S = renderString ".s" - -renderVarAccess (v,c) = renderCtxName v . renderComponent c - -renderString s s' = s ++ s' -renderType LLList = renderString "list" -renderType LLInteger = renderString "integer" -renderType LLVector = renderString "vector" -renderType LLFloat = renderString "float" -renderType LLString = renderString "string" -renderType LLRot = renderString "rotation" -renderType LLKey = renderString "key" -renderType LLVoid = blank - -blank :: String -> String -blank = id
− Language/Lsl/Sim.hs
@@ -1,3697 +0,0 @@-{-# OPTIONS_GHC -XFlexibleContexts -fwarn-unused-binds #-} -module Language.Lsl.Sim(SimStatus(..), - SimStateInfo(..), - SimCommand(..), - SimInputEventDefinition(..), - SimParam(..), - SimParamType(..), - eventDescriptors, - simStep, - unimplementedFuncs, - module Language.Lsl.Internal.WorldState) where - -import Control.Monad(MonadPlus(..),(>=>),filterM,foldM,forM_,liftM,liftM2,unless,when) -import Control.Monad.State(StateT(..),lift) -import Control.Monad.Identity(Identity(..)) -import Control.Monad.Error(MonadError(..),ErrorT(..)) -import Data.List(elemIndex,find,foldl',isSuffixOf,nub,sortBy) -import Data.Bits((.&.),(.|.),bit,clearBit,complement,xor,setBit,shiftL,testBit) -import Data.Int() -import Data.Map(Map) -import Data.Maybe(fromMaybe,isJust,isNothing) -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.IntMap as IM - -import Language.Lsl.Internal.Animation(builtInAnimations) -import Language.Lsl.Internal.AvEvents(AvatarOutputEvent(..),AvatarInputEvent(..)) -import Language.Lsl.Internal.Breakpoint(Breakpoint,emptyBreakpointManager,setStepOverBreakpoint,setStepOutBreakpoint,replaceBreakpoints, - setStepBreakpoint,breakpointFile,breakpointLine,checkBreakpoint) -import Language.Lsl.Internal.CodeHelper(renderCall) -import Language.Lsl.Internal.Constants -import Language.Lsl.Internal.Evaluation(ScriptInfo(..),Event(..),EvalResult(..)) -import Language.Lsl.Internal.EventSigs(EventAdditionalData(..),EventDelivery(..),lslEventDescriptors) -import Language.Lsl.Internal.Exec(ExecutionState(..),ExecutionInfo(ExecutionInfo),ScriptImage(..),executeLsl,frameInfo,hardReset,hasActiveHandler,initLSLScript) -import Language.Lsl.Internal.ExpressionHandler(evaluateExpression) -import Language.Lsl.Internal.FuncSigs(funcSigs) -import Language.Lsl.Internal.InternalLLFuncs(internalLLFuncs) -import Language.Lsl.Internal.Key(nullKey) -import Language.Lsl.Internal.Log(LogLevel(..),LogMessage(..)) -import Language.Lsl.Internal.Physics(calcAccel,checkIntersections,dampForce,dampTorque,dampZForce,gravC,kin,primMassApprox,rotDyn,totalTorque) -import Language.Lsl.Syntax(Ctx(..),FuncDec(..),predefFuncs) -import Language.Lsl.Internal.Type(LSLValue(..),LSLType(..),defaultValue,isIVal,isLVal,isSVal, - lslShowVal,lslTypeString,lslValString,rVal2Rot,rot2RVal,typeOfLSLValue,vVal2Vec,vec2VVal) -import Language.Lsl.UnitTestEnv(simFunc,hasFunc) -import Language.Lsl.Internal.Util(add3d,angleBetween,diff3d,dist3d2,fac,findM,fromInt,generatePermutation,ilookup,lookupByIndex, - mag3d,mlookup,neg3d,norm3d,quaternionMultiply,quaternionToMatrix,rot3d,rotationBetween,scale3d,tuplify) -import Language.Lsl.WorldDef(Attachment(..),Avatar(..),AvatarControlListener(..),Email(..),Flexibility(..),InventoryInfo(..), - InventoryItem(..),InventoryItemData(..),InventoryItemIdentification(..),LightInfo(..),LSLObject(..), - ObjectDynamics(..),Parcel(..),Prim(..),PrimFace(..),PrimType(..),PositionTarget(..),Region(..),RotationTarget(..), - Script(..),TextureInfo(..),WebHandling(..), - defaultCamera,defaultDynamics,emptyPrim,findByInvKey,findByInvName, - inventoryInfoPermValue,inventoryItemName,mkScript, - isInvAnimationItem,isInvBodyPartItem,isInvClothingItem,isInvGestureItem,isInvNotecardItem, - isInvObjectItem,isInvScriptItem,isInvSoundItem,isInvTextureItem, - primPhantomBit,primPhysicsBit,scriptInventoryItem,worldFromFullWorldDef) -import Language.Lsl.Internal.WorldState - -import System.Random(mkStdGen) -import System.Time(ClockTime(..),CalendarTime(..),TimeDiff(..),addToClockTime,toUTCTime) -import Text.Printf(PrintfType(..),printf) - --- execute a predefined ('ll') function -doPredef :: Monad m => String -> ScriptInfo -> [LSLValue] -> WorldM m (EvalResult,LSLValue) -doPredef name info@(ScriptInfo oid pid sid pkey event) args = - do predefs <- getPredefFuncs - -- find the correct function to execute - case tryPredefs name predefs of - Just (t,f) -> runErrFunc info name (defaultValue t) args f - Nothing -> do - (_,rettype,argtypes) <- findM (\ (x,y,z) -> x == name) funcSigs - logAMessage LogDebug (pkey ++ ":" ++ sid) ("unimplemented predefined function called: " ++ renderCall name args) - continueWith $ defaultValue rettype - - -getParcelByPosition regionIndex (x,y,_) = - do region <- getRegion regionIndex - findParcel 0 (regionParcels region) - where findParcel _ [] = throwError "parcel not found" -- mzero - findParcel i (p:ps) = - let (south,north,west,east) = parcelBoundaries p - (xc,yc) = (floor x, floor y) in - if xc < east && xc >= west && yc < north && yc >= south - then return (i,p) else findParcel (i + 1) ps - -getPrimParcel pk = do - regionIndex <- getPrimRegion pk - pos <- getRootPrim pk >>= getObject >>= return . objectPosition . objectDynamics - (index,parcel) <- getParcelByPosition regionIndex pos - return (regionIndex,index,parcel) - -putParcel regionIndex index parcel = do - region <- getRegion regionIndex - let (before,after) = splitAt index (regionParcels region) - let parcels' = if null after then parcel : before else before ++ (parcel : tail after) - lift $ setRegion regionIndex $ region { regionParcels = parcels' } - -tryPredefs name predefs = - case M.lookup name predefs of - Just (PredefFunc _ t predef) -> Just (t,predef) - Nothing -> Nothing - -defaultPredef name predef = - case lookup name $ map (\ (FuncDec n t ps) -> (ctxItem n,t)) predefFuncs of - Nothing -> error ("undefined predef " ++ name) - Just t -> PredefFunc name t predef - -runErrFunc info fname defval args f = - do v <- evalErrorT (f info args) - case v of - Left s -> logFromScript info (fname ++ ": " ++ s) >> return (EvalIncomplete,defval) - Right result -> return result - -runFace k i action = action <||> throwError ("face " ++ (show i) ++ " or prim " ++ k ++ " not found") - -(<||>) a b = a `catchError` (\ _ -> b) - -infixl 0 <||> - -primErr k = (\ s -> throwError ("problem - can't find prim " ++ k)) - ---- Web related functions ---------------------------------------------------- - -llHTTPRequest info@(ScriptInfo _ _ sn pk _) [SVal url, LVal params, SVal body] = - do t <- lift getTick - -- verify the parameters - when (length params `mod` 2 /= 0) (throwError "invalid parameter list") - when (length params > 8) (throwError "invalid parameter list") - let params' = tuplify params - when (not $ all (\ (x,_) -> x `elem` [llcHTTPMethod,llcHTTPMimetype,llcHTTPBodyMaxlength,llcHTTPVerifyCert]) params') - (throwError "invalid parameter list") - method <- maybe (return "GET") - (\ v -> if not $ v `elem` (map SVal ["GET","POST","PUT","DELETE"]) - then throwError ("invalid HTTP method " ++ lslValString v) - else let SVal s = v in return s) - (lookup llcHTTPMethod params') - mimetype <- maybe (return "text/plain;charset=utf-8") - (\ v -> if LLString /= typeOfLSLValue v then throwError "invalid mimtype" else let SVal s = v in return s) - (lookup llcHTTPMimetype params') - maxlength <- maybe (return 2048) - (\ v -> if LLInteger /= typeOfLSLValue v then throwError "invalid body length" else return (let IVal i = v in i)) - (lookup llcHTTPBodyMaxlength params') - verify <- maybe (return 1) - (\ v -> if LLInteger /= typeOfLSLValue v then throwError "invalid verify cert value" else return (let IVal i = v in i)) - (lookup llcHTTPVerifyCert params') - -- parameters ok - key <- lift newKey - lift $ putWorldEvent 0 (HTTPRequestEvent (pk,sn) key url method mimetype maxlength verify body) - continueWith $ KVal key - ---- Sensor related functions ------------------------------------------------- - -llSensor info@(ScriptInfo _ _ sn pk _) [SVal name, KVal key, IVal etype, FVal range, FVal arc] = - lift $ putWorldEvent 0 (SensorEvent (pk,sn) name key etype range arc Nothing) >> continueWith VoidVal -llSensorRepeat info@(ScriptInfo _ _ sn pk _) [SVal name, KVal key, IVal etype, FVal range, FVal arc, FVal interval] = - let interval' = if interval < 0 then 0 else interval in - lift $ putWorldEvent 0 (SensorEvent (pk,sn) name key etype range arc (Just interval')) >> continueWith VoidVal -llSensorRemove info@(ScriptInfo _ _ sn pk _) [] = - do q <- lift getWQueue - lift $ setWQueue [ qentry | qentry@(_,event) <- q, not (isSensorEvent event) || sensorAddress event /= (pk,sn)] - continueWith VoidVal ------------------------------------------------------------------------------- - -llRequestAgentData info@(ScriptInfo _ _ sn pk _) [KVal ak, IVal d] = - do key <- lift newKey - av <- (lift getWorldAvatars >>= mlookup ak) <||> (throwError ("no such avatar" ++ ak)) - dataVal <- case d of - d | d == cDataBorn -> return "1981-01-01" - | d == cDataOnline -> return "1" - | d == cDataRating -> return "0,0,0,0,0" - | d == cDataName -> return $ avatarName av - | d == cDataPayinfo -> return "3" - | otherwise -> throwError ("invalid data requested: " ++ show d) - lift $ pushDataserverEvent pk sn key dataVal - continueWith (KVal key) - -llRequestSimulatorData info@(ScriptInfo _ _ sn pk _) [SVal simName, IVal d] = - do key <- lift newKey - regions <- lift getWorldRegions - let findRegion = findM ((==simName) . regionName . snd) (M.toList regions) - let simErr = throwError ("unknown simulator " ++ simName) - val <- case d of - d | d == cDataSimStatus -> (findRegion >> return "up") <||> return "unknown" - | d == cDataSimRating -> (findRegion >> return "PG") <||> simErr - | d == cDataSimPos -> (do ((x,y),_) <- findRegion - return $ lslValString $ vec2VVal (256 * fromIntegral x, 256 * fromIntegral y, 0)) - <||> simErr - | otherwise -> throwError ("invalid data requested: " ++ show d) - lift $ pushDataserverEvent pk sn key val - continueWith (KVal key) ---- INVENTORY related functions ---------------------------------------------- - -sortByInvName l = sortBy (\ i i' -> compare (invName i) (invName i')) l - -invName = inventoryItemName - -getPrimInventoryInfo info@(ScriptInfo _ _ _ pk _) invType = - case invType of - i | i == llcInventoryAll -> getPrimInventory pk >>= return . sortByInvName - | i == llcInventoryAnimation -> getPrimAnimations pk >>= return . sortByInvName - | i == llcInventoryBodyPart -> getPrimBodyParts pk >>= return . sortByInvName - | i == llcInventoryClothing -> getPrimClothing pk >>= return . sortByInvName - | i == llcInventoryGesture -> getPrimGestures pk >>= return . sortByInvName - | i == llcInventoryNotecard -> getPrimNotecards pk >>= return . sortByInvName - | i == llcInventoryObject -> getPrimObjects pk >>= return . sortByInvName - | i == llcInventoryScript -> getPrimScripts pk >>= return . sortByInvName - | i == llcInventorySound -> getPrimSounds pk >>= return . sortByInvName - | i == llcInventoryTexture -> getPrimTextures pk >>= return . sortByInvName - | otherwise -> do lift $ logFromScript info ("invalid inventory type: " ++ lslValString invType) - return [] - -llGetInventoryNumber info@(ScriptInfo _ _ _ pk _) [invType@(IVal _)] = do - getPrimInventoryInfo info invType >>= continueWith . IVal . length - -llGetInventoryCreator info@(ScriptInfo _ _ _ pk _) [SVal name] = - do all <- getPrimInventory pk - result <- case findByInvName name all of - Nothing -> (lift $ putChat (Just 20.0) pk 0 ("no item named '" ++ name ++ "'")) >> return nullKey - Just item -> return $ inventoryInfoCreator $ inventoryItemInfo item - continueWith $ KVal result - -llGetInventoryPermMask info@(ScriptInfo _ _ _ pk _) [SVal name, IVal mask] = - do all <- getPrimInventory pk - mask <- case findByInvName name all of - Nothing -> (lift $ putChat (Just 20.0) pk 0 ("No item named '" ++ name ++ "'")) >> throwError ("No item named '" ++ name ++ "'") - Just item -> inventoryInfoPermValue mask (inventoryInfoPerms $ inventoryItemInfo item) - continueWith (IVal mask) - -llGetInventoryKey info@(ScriptInfo _ _ _ pk _) [SVal name] = - do all <- getPrimInventory pk - result <- case findByInvName name all of - Nothing -> return nullKey - Just (InventoryItem id invInfo _) -> - let Right perms = inventoryInfoPermValue cMaskOwner (inventoryInfoPerms invInfo) in - if perms .&. cFullPerm == cFullPerm then - return $ snd (inventoryItemNameKey id) - else return nullKey - continueWith $ KVal result - -llGetInventoryName info@(ScriptInfo _ _ _ pk _) [invType@(IVal _), IVal index] = - getPrimInventoryInfo info invType >>= return . map (\ item -> invName item) >>= continueWith . SVal . fromMaybe "" . lookupByIndex index - -llGetInventoryType info@(ScriptInfo _ _ _ pk _) [SVal name] = do - getPrimInventory pk >>= continueWith . classify . findByInvName name - where classifications = [(isInvAnimationItem,llcInventoryAnimation),(isInvBodyPartItem,llcInventoryBodyPart), - (isInvClothingItem,llcInventoryClothing),(isInvGestureItem,llcInventoryGesture), - (isInvNotecardItem,llcInventoryNotecard),(isInvObjectItem,llcInventoryObject), - (isInvSoundItem,llcInventorySound),(isInvTextureItem,llcInventoryTexture), - (isInvScriptItem,llcInventoryScript)] - classify Nothing = IVal (-1) - classify (Just item) = foldl' (\ (IVal cur) (f,i) -> if (cur >= 0) || not (f item) then IVal cur else i) (IVal (-1)) classifications - -llRemoveInventory info@(ScriptInfo _ _ _ pk _) [SVal name] = - do inv <- getPrimInventory pk - maybe (lift $ putChat (Just 20) pk cDebugChannel ("Missing inventory item '" ++ name ++ "'")) - (\ _ -> let inv' = [ item | item <- inv, name /= (inventoryItemName item)] in - lift $ setPrimInventory pk inv') - (findByInvName name inv) - continueWith VoidVal - -copyInventoryItem newOwner newGroup item = - case item of - item | isInvObjectItem item -> do - let copyLink prim = do - k <- lift newKey - inventory <- mapM (copyInventoryItem newOwner newGroup) (primInventory prim) - return (prim { primKey = k, primInventory = inventory, primOwner = newOwner, primGroup = newGroup }) - InvObject links <- return $ inventoryItemData item - links' <- mapM copyLink links - when (null links') $ throwError "empty linkset!" - let info = inventoryItemInfo item - return (InventoryItem (InventoryItemIdentification (inventoryItemName item,primKey $ head links')) - info (InvObject links')) - | otherwise -> do - k <- lift newKey - let info = inventoryItemInfo item - let dat = inventoryItemData item - return (InventoryItem (InventoryItemIdentification (inventoryItemName item, k)) info dat) -changeName (InventoryItem (InventoryItemIdentification (name,key)) info dat) newName = - (InventoryItem (InventoryItemIdentification (newName,key)) info dat) - -llGiveInventory info@(ScriptInfo _ _ _ pk _) [KVal k, SVal inv] = - do inventory <- getPrimInventory pk <||> throwError "cant find prim!" - item <- maybe (throwError ("inventory item " ++ inv ++ "not found")) (return . id) (findByInvName inv inventory) - prims <- lift getPrims - case M.lookup k prims of - Just p -> do - owner <- getPrimOwner pk - group <- getPrimGroup pk - let (_,ownerP,groupP,everybodyP,_) = let [p1,p2,p3,p4,p5] = take 5 (primPermissions p) ++ repeat 0 in (p1,p2,p3,p4,p5) - let hasModifyPerm = (cPermModify .&. everybodyP /= 0) || - (cPermModify .&. groupP /= 0 && not (isNothing group) && group == primGroup p) || - (cPermModify .&. ownerP /= 0 && owner == primOwner p) - if hasModifyPerm || primAllowInventoryDrop p - then do - let newOwner = primOwner p - let newGroup = primGroup p - item' <- copyInventoryItem newOwner newGroup item - let inventory' = primInventory p - let findAName i base = let name = base ++ " " ++ show i in - if isNothing (findByInvName name inventory') then name - else findAName (i + 1) base - let inventory'' = case findByInvName inv inventory' of - Nothing -> item' : inventory' - Just _ -> let newName = findAName 1 inv in (changeName item' newName) : inventory' - lift $ setPrimInventory k inventory'' - -- TODO: are scripts handled right? - lift $ pushDeferredScriptEventToPrim - (Event "changed" [if hasModifyPerm then llcChangedInventory else llcChangedAllowedDrop] M.empty) k 0 - else throwError ("can't modify/drop inventory on target") - Nothing -> do - avatars <- lift getWorldAvatars - case M.lookup k avatars of - Nothing -> throwError ("no object or avatar found with key " ++ k) - Just av -> lift (putWorldEvent 0 (GiveAvatarInventoryEvent k item)) >> - (lift $ logFromScript info $ "llGiveInventory: avatar " ++ k ++ " given option of accepting inventory") - continueWith VoidVal - -llSetRemoteScriptAccessPin info@(ScriptInfo _ _ _ pk _) [IVal pin] = - lift $ setPrimRemoteScriptAccessPin pk pin >> continueWith VoidVal -llRemoteLoadScript info@(ScriptInfo _ _ _ pk _) [KVal _,SVal _, IVal _, IVal _] = - lift $ putChat (Just 20.0) pk cDebugChannel "Deprecated. Please use llRemoteLoadScriptPin instead." >> continueWith VoidVal - -llRezObject info params = rezObject False info params -llRezAtRoot info params = rezObject True info params - -rezObject atRoot info@(ScriptInfo _ _ _ pk _) [SVal inventory, VVal px py pz, VVal vx vy vz, RVal rx ry rz rs, IVal param] = - do objects <- getPrimObjects pk - maybe (do lift $ putChat (Just 20) pk 0 ("Couldn't find object '" ++ inventory ++ "'") - throwError ("no such inventory item - " ++ inventory)) - (\ item -> do - let copy = isCopyable item - let InvObject linkSet = inventoryItemData item - lift $ putWorldEvent 0 (RezObjectEvent linkSet (px,py,pz) (vz,vy,vz) (rz,ry,rz,rs) param pk copy atRoot) - when (not copy) $ do -- delete! - wholeInventory <- getPrimInventory pk - lift $ setPrimInventory pk - [ item | item <- wholeInventory, inventory /= inventoryItemName item] - ) - (findByInvName inventory objects) - continueWith VoidVal - -isCopyable item = - let (_,perm,_,_,_) = inventoryInfoPerms $ inventoryItemInfo item in - if cPermCopy .&. perm == 0 - then False - else - (if isInvObjectItem item - then let InvObject links = inventoryItemData item - primCopyable prim = all isCopyable (primInventory prim) - in all primCopyable links - else True) - -llResetScript info@(ScriptInfo _ _ sn pk _) [] = - do lift $ putWorldEvent 0 (ResetScriptEvent pk sn) - return (EvalComplete Nothing,VoidVal) - -llResetOtherScript info@(ScriptInfo _ _ sn pk _) [SVal sn'] = - do when (sn == sn') $ throwError ("trying to reset the current script - must use llResetScript for this") - lift getWorldScripts >>= mlookup (pk,sn) >>= return . scriptActive >>= flip when (throwError "can't reset a stopped script") . not - resetScript pk sn' - continueWith VoidVal - -resetScript pk sn = do - lift $ logAMessage LogDebug "sim" "resetting a script" - scripts <- lift getWorldScripts - script <- mlookup (pk,sn) scripts - t <- lift getTick - let img = scriptImage script - let doReset execState = - let script' = script { - scriptImage = (hardReset img) {executionState = execState}, - scriptActive = True, - scriptPermissions = M.empty, - scriptLastPerm = Nothing, - scriptLastResetTick = t, - scriptEventQueue = [Event "state_entry" [] M.empty] - } in lift $ setWorldScripts (M.insert (pk,sn) script' scripts) - in case executionState img of - Executing -> doReset Waiting - Waiting -> doReset Waiting - SleepingTil i -> doReset (WaitingTil i) - WaitingTil i -> doReset (WaitingTil i) - _ -> throwError ("can't reset script that is crashed or suspended") - -llGetScriptState info@(ScriptInfo _ _ _ pk _) [SVal sn] = - do script <- (lift getWorldScripts >>= mlookup (pk,sn)) <||> throwError "no such script/invalid script" - (continueWith . IVal) $ if not $ scriptActive script then 0 - else case executionState (scriptImage script) of - Halted -> 0 - Erroneous _ -> 0 - Crashed _ -> 0 - _ -> 1 - -llSetScriptState info@(ScriptInfo _ _ sn pk _) [SVal sn', IVal state] = - do when (sn == sn') $ throwError ("can't change your own state") - scripts <- lift getWorldScripts - script <- mlookup (pk,sn') scripts <||> throwError "no such script (could be invalid script)" - if state == 0 - then - if (scriptActive script) - then lift $ setWorldScripts (M.insert (pk,sn') (script { scriptActive = False }) scripts) - else return () - else case executionState (scriptImage script) of - Crashed _ -> throwError "can't change state of crashed script" - Erroneous _ -> throwError "can't change state of erroneous script" - _ -> if scriptActive script - then throwError "script is already running" - else resetScript pk sn' - continueWith VoidVal ------------------------------------------------------------------------------- -llSetPayPrice info@(ScriptInfo _ _ sn pk _) [IVal price, LVal l] = - let toI (IVal i) = if (i < (-2)) then (-1) else i - toI _ = (-1) - [i1,i2,i3,i4] = take 4 $ (map toI l) ++ replicate 4 (-1) in - do hasMoney <- scriptHasActiveHandler pk sn "money" - when (not hasMoney) $ throwError ("no money handler, pay price info ignored") - lift $ setPrimPayInfo pk (price,i1,i2,i3,i4) - continueWith VoidVal - -llGetStartParameter info@(ScriptInfo _ _ sn pk _) [] = - (lift getWorldScripts >>= mlookup (pk,sn) >>= continueWith . IVal . scriptStartParameter) ------------------------------------------------------------------------------- -llCloud info [v@(VVal x y z)] = - do lift $ logFromScript info "llCloud: returning default density" - continueWith $ FVal 0 - -llWind info [v@(VVal x y z)] = - lift $ logFromScript info "llWind: returning default density" >> continueWith (VVal 0 0 0) - -llWater info [v@(VVal x y z)] = - do lift $ logFromScript info "llWater: returning default water elevation" - continueWith $ FVal 0 - -llSitTarget (ScriptInfo _ _ _ pk _) [v@(VVal _ _ _),r@(RVal _ _ _ _)] = - lift $ setPrimSitTarget pk (Just (vVal2Vec v, rVal2Rot r)) >> continueWith VoidVal - -llAvatarOnSitTarget info@(ScriptInfo _ _ _ pk _) [] = - do sitTarget <- getPrimSitTarget pk - when (sitTarget == Nothing) (throwError ("no sit target")) - k <- getPrimSittingAvatar pk >>= return . fromMaybe nullKey - continueWith (KVal k) - -llUnSit info@(ScriptInfo _ _ _ pk _) [KVal k] = - do val <- getPrimSittingAvatar pk - maybe (throwError "no avatar sitting on prim (land unsit not implemented") - (\ ak -> if ak == k then lift $ setPrimSittingAvatar pk Nothing - else throwError "unsit of avatar not sitting on prim attempted (land unsit not implemented)") - val - continueWith VoidVal - -llMessageLinked info@(ScriptInfo oid pid sid pkey _) [IVal link,IVal val,SVal msg,KVal key] = - do LSLObject { primKeys = links } <- (getObject oid) <||> throwError ("object not found!") - when (null links) $ throwError ("object is has no links!") - let targetLinkIndices = targetLinks (length links) link pid - let targetLinks = map (links !!) targetLinkIndices - let event = (Event "link_message" [IVal pid, IVal val, SVal msg, KVal key] M.empty) - lift $ mapM_ (\ pk -> pushDeferredScriptEventToPrim event pk 0) targetLinks - continueWith VoidVal - -targetLinks n link pid = - case link of - l | l == linkSet -> [0 .. (n - 1)] - | l == linkAllOthers -> [0..(pid - 1)] ++ [(pid + 1).. (n - 1)] - | l == linkAllChildren -> [1..(n - 1)] - | l == linkThis -> [pid] - | otherwise -> [link - 1] - --- the key to 'sleep' is that instead of returning 'EvalIncomplete' as its EvalResult, it returns --- 'YieldTil <some-tick>', which puts the script into a sleep state. --- other functions which have a built in delay should use this mechanism as well. -llSleep info@(ScriptInfo oid pid sid pkey event) [FVal f] = - do tick <- lift $ getTick - return $ (YieldTil (tick + durationToTicks f),VoidVal) - - -llInstantMessage info@(ScriptInfo _ _ _ pk _) [KVal ak, SVal message] = - do tick <- lift getTick - name <- getPrimName pk - av <- (lift getWorldAvatars >>= mlookup ak) <||> throwError ("no such user: " ++ ak) - let avname = avatarName av - lift $ logAMessage LogInfo "sim" ("IM to " ++ avname ++ " from " ++ name ++ ": " ++ message) - return (YieldTil (tick + durationToTicks 2),VoidVal) - -llSay info params= lift $ chat (Just 20.0) info params -llWhisper info params = lift $ chat (Just 10.0) info params -llShout info params = lift $ chat (Just 100.0) info params -llRegionSay info params@[IVal chan, SVal message] = - if (chan == 0) - then do lift $ logAMessage LogWarn (scriptInfoPrimKey info ++ ": " ++ scriptInfoScriptName info) "attempt to llRegionSay on channel 0" - return (EvalIncomplete,VoidVal) - else lift $ chat Nothing info params - -chat range info@(ScriptInfo oid pid sid pkey event) [IVal chan, SVal message] = - do logFromScript info $ concat ["chan = ", show chan, ", message = ", message] - putChat range pkey chan message - return (EvalIncomplete,VoidVal) - -putChat range k chan message = do - prims <- getPrims - case M.lookup k prims of - Just prim -> runErrPrim k () $ do - region <- (getPrimRegion k) - pos <- getRootPrim k >>= getObject >>= return . objectPosition . objectDynamics - lift $ putWorldEvent 0 $ Chat chan (primName prim) k message (region, pos) (range) - Nothing -> do - avatars <- getWorldAvatars - case M.lookup k avatars of - Just avatar -> putWorldEvent 0 $ Chat chan (avatarName avatar) k message (avatarRegion avatar, avatarPosition avatar) (range) - Nothing -> logAMessage LogWarn "sim" ("Trying to chat from unknown object/avatar with key " ++ k) - -llListen (ScriptInfo oid pid sid pkey event) [IVal chan, SVal sender, KVal key, SVal msg] = - (lift $ registerListener $ Listener pkey sid chan sender key msg) >>= continueWith . IVal - -llListenRemove (ScriptInfo _ _ sid pk _) [IVal id] = - (unregisterListener pk sid id) >> continueWith VoidVal - -llListenControl (ScriptInfo _ _ sid pk _) [IVal id, IVal active] = - (updateListener pk sid id $ active /= 0) >> continueWith VoidVal - -llFrand _ [FVal maxval] = - lift $ do r <- wrand - continueWith $ FVal (maxval * r) - -llTeleportAgentHome info@(ScriptInfo _ _ _ pk _) [KVal ak] = - do owner <- getPrimOwner pk - regionIndex <- getPrimRegion pk - (_,_,parcel) <- getPrimParcel pk - if parcelOwner parcel == owner - then lift $ logFromScript info ("llTeleportAgentHome: user " ++ ak ++ " teleported home (in theory)") - else lift $ logFromScript info ("llTeleportAgentHome: not permitted to teleport agents from this parcel") - continueWith VoidVal - -llEjectFromLand info@(ScriptInfo oid _ _ pk _) [KVal user] = - do owner <- getPrimOwner pk - regionIndex <- getPrimRegion pk - (_,parcel) <- getObjectPosition oid >>= getParcelByPosition regionIndex - if parcelOwner parcel == owner - then lift $ logFromScript info ("llEjectFromLand: user " ++ user ++ " ejected (in theory)") - else lift $ logFromScript info ("llEjectFromLand: not permitted to eject from this parcel") - continueWith VoidVal - -llBreakLink info@(ScriptInfo oid _ sid pk _) [IVal link] = - do perm <- getPermissions pk sid - if perm .&. cPermissionChangeLinks /= 0 - then do - objects <- lift getObjects - LSLObject { primKeys = links, objectDynamics = dynamics } <- mlookup oid objects - attachment <- getPrimAttachment oid - case attachment of - Nothing -> - if link < 1 || link > length links then lift $ logFromScript info ("llBreakLink: invalid link id") - else do - let (dyn1,dyn2) = if link == 1 then (defaultDynamics,dynamics) else (dynamics,defaultDynamics) - let (xs,y:ys) = splitAt (link - 1) links - let (linkSet1,linkSet2) = (xs ++ ys, [y]) - let objects' = if null linkSet1 then objects else M.insert (head linkSet1) (LSLObject linkSet1 dyn1) objects - lift $ setObjects (M.insert (head linkSet2) (LSLObject linkSet2 dyn2) objects') - when (not (null linkSet1)) $ do - lift $ pushChangedEventToObject (head linkSet1) cChangedLink - lift $ setPrimParent (head linkSet1) Nothing - lift $ pushChangedEventToObject (head linkSet2) cChangedLink - lift $ setPrimParent (head linkSet2) Nothing - _ -> lift $ logFromScript info ("llBreakLink: can't change links of attached object") - else lift $ logFromScript info ("llBreakLink: no permission") - continueWith VoidVal - -llBreakAllLinks info@(ScriptInfo oid _ sid pk _) [] = - do perm <- getPermissions pk sid - if perm .&. cPermissionChangeLinks /= 0 - then do - objects <- lift getObjects - LSLObject links dynamics <- mlookup oid objects - attachment <- getPrimAttachment oid - case attachment of - Nothing -> - if length links > 1 - then do - -- order of parameters to union is vital: union is left biased, so we want the - -- new objects (in the left argument) to replace the old (in the right) where - -- both exist (the root key of the old object is found in both) - let objects' = M.union - (M.fromList $ map (\ k -> (k, LSLObject [k] (if k == oid then dynamics else defaultDynamics))) links) objects - lift $ setObjects objects' - lift $ mapM_ (\ link -> pushChangedEventToObject link cChangedLink >> - setPrimParent link Nothing) links - else return () - _ -> lift $ logFromScript info ("llBreakAllLinks: can't change links of attached object") - else lift $ logFromScript info ("llBreakAllLinks: no permission") - continueWith VoidVal - --- TODO: verify link order -llCreateLink info@(ScriptInfo oid _ sid pk _) [KVal target, IVal iparent] = - do perm <- getPermissions pk sid - if perm .&. cPermissionChangeLinks /= 0 - then do - objects <- lift getObjects - LSLObject (link:links) dynamics <- mlookup oid objects - case M.lookup target objects of - Nothing -> lift $ logFromScript info "llCreateLink: target not found" - Just (LSLObject (link':links') dynamics') -> do - attachment0 <- getPrimAttachment oid - attachment1 <- getPrimAttachment target - case (attachment0,attachment1) of - (Nothing,Nothing) -> do - mask <- getObjectPermMask target cMaskOwner - ownerTarget <- getPrimOwner target - owner <- getPrimOwner oid - if mask .&. cPermModify /= 0 && owner == ownerTarget - then do - let (newLinkset,deleteKey,newDynamics) = if parent - then ((link:link':links') ++ links, link',dynamics) - else ((link':link:links) ++ links', link,dynamics') - lift $ setObjects (M.insert (head newLinkset) (LSLObject newLinkset newDynamics) $ M.delete deleteKey objects) - lift $ pushChangedEventToObject (head newLinkset) cChangedLink - else lift $ logFromScript info "llCreateLink: no modify permission on target" - _ -> lift $ logFromScript info ("llCreateLink: can't change links of attached object") - else lift $ logFromScript info ("llCreateLink: no permission to change links") - continueWith VoidVal - where parent = iparent /= 0 - -llDie info@(ScriptInfo oid _ _ pk _) [] = - do attachment <- getPrimAttachment oid - case attachment of - Nothing -> do - objects <- lift getObjects - LSLObject { primKeys = (links) } <- mlookup oid objects - allScripts <- mapM getPrimScripts links - let primsWithScriptNames = zip links (map (map (invName)) allScripts) - let skeys = concat $ map ( \ (k,list) -> map ((,)k) list) primsWithScriptNames - lift $ mapM_ delScript skeys - lift $ mapM_ (\ link -> (getPrims >>= return . M.delete link >>= setPrims)) links - lift $ setObjects (M.delete oid objects) - lift $ logFromScript info ("object, and therefore this script, is dying") - return (EvalComplete Nothing,VoidVal) - where delScript (k,s) = getWorldScripts >>= return . M.delete (k,s) >>= setWorldScripts - _ -> do lift $ logFromScript info ("attachment cannot die") - return (EvalIncomplete,VoidVal) - -llAttachToAvatar info@(ScriptInfo oid _ sid pk _) [IVal attachPoint] = - if attachPoint `elem` validAttachmentPoints then - do script <- (lift getWorldScripts >>= mlookup (pk,sid)) - attachment <- getPrimAttachment oid - case attachment of - Just _ -> lift $ logFromScript info "llAttachToAvatar: already attached" - Nothing -> - case scriptLastPerm script of - Nothing -> throwError "no permission to attach" - Just k -> do - perm <- mlookup k (scriptPermissions script) - when (perm .&. cPermissionAttach == 0) $ throwError "no permission to attach" - owner <- getPrimOwner pk - if (k /= owner) - then lift $ putChat (Just 20.0) pk 0 ("Script trying to attach to someone other than owner!") - else do - avatars <- lift getWorldAvatars - let av = M.lookup k avatars - case av of - Nothing -> throwError "avatar not present in sim" - Just av -> - let attachments = avatarAttachments av in - case IM.lookup attachPoint attachments of - Nothing -> let av' = av { avatarAttachments = IM.insert attachPoint oid attachments } in - do lift $ setWorldAvatars (M.insert k av' avatars) - lift $ setPrimAttachment oid (Just $ Attachment k attachPoint) - lift $ pushAttachEvent pk k - Just _ -> throwError "attachment point already occupied" - continueWith VoidVal - else throwError ("invalid attachment point: " ++ show attachPoint) - -llDetachFromAvatar info@(ScriptInfo oid _ sid pk _) [] = - do when (oid /= pk) $ throwError "can't detach from within child prim" - script <- (lift getWorldScripts >>= mlookup (pk,sid)) <||> throwError "can't find current script!" - attachment <- getPrimAttachment oid - when (isNothing attachment) $ throwError "not attached!" - Just (Attachment k attachPoint) <- return attachment - perm <- (mlookup k $ scriptPermissions script) <||> throwError "no permission to detach" - when (perm .&. cPermissionAttach == 0) $ throwError "no permission to attach" - avatars <- lift getWorldAvatars - avatar <- mlookup k avatars <||> throwError "can't find avatar!" - let attachments = avatarAttachments avatar - lift $ setWorldAvatars (M.insert k (avatar { avatarAttachments = IM.delete attachPoint attachments }) avatars) - lift $ setPrimAttachment oid Nothing - lift $ pushAttachEvent oid nullKey - lift $ putWorldEvent 1 (DetachCompleteEvent oid k) - continueWith VoidVal - -llGetAttached info@(ScriptInfo oid _ _ _ _) [] = - getPrimAttachment oid >>= return . maybe 0 attachmentPoint >>= continueWith . IVal - -llGiveMoney info@(ScriptInfo _ _ sn pk _) [KVal ak, IVal amount] = - do script <- (lift getWorldScripts >>= mlookup (pk,sn)) <||> (throwError "can't find script!") - permKey <- maybe (throwError "no permission") (return . id) (scriptLastPerm script) - perm <- mlookup permKey (scriptPermissions script) - when (perm .&. cPermissionAttach == 0) $ throwError "no permission" - lift $ logFromScript info ("llGiveMoney: pretending to give " ++ show amount ++ " to avatar with key " ++ ak) - continueWith (IVal 0) - -llGetPermissionsKey (ScriptInfo _ _ sid pk _) [] = - lift getWorldScripts >>= mlookup (pk,sid) >>= continueWith . KVal . fromMaybe nullKey . scriptLastPerm - -llGetPermissions (ScriptInfo _ _ sid pk _) [] = getPermissions pk sid >>= continueWith . IVal - -getPermissions pk s = do - script <- (lift getWorldScripts >>= mlookup (pk,s)) - case scriptLastPerm script of - Nothing -> return 0 - Just k -> mlookup k (scriptPermissions script) - -getPermittedAvKey info@(ScriptInfo _ _ s pk _) fname perm = do - script <- (lift getWorldScripts >>= mlookup (pk,s)) - case scriptLastPerm script of - Nothing -> lift $ logFromScript info (fname ++ ": not permitted") >> return Nothing - Just k -> case M.lookup k (scriptPermissions script) of - Nothing -> lift $ logFromScript info (fname ++ ": internal error getting permissions") >> return Nothing - Just i | i .&. perm /= 0 -> return (Just k) - | otherwise -> return Nothing - -llRequestPermissions (ScriptInfo _ _ sid pk _) [KVal k, IVal mask] = - do avatars <- lift $ getWorldAvatars - case M.lookup k avatars of - Nothing -> lift $ logAMessage LogInfo (pk ++ ":" ++ sid) ("Invalid permissions request: no such avatar: " ++ k) - _ -> lift $ putWorldEvent 0 (PermissionRequestEvent pk sid k mask) - continueWith VoidVal - -llClearCameraParams info@(ScriptInfo _ _ sid pk _) [] = - do avKey <- getPermittedAvKey info "llClearCameraParams" cPermissionControlCamera - case avKey of - Nothing -> return () - Just k -> do - avatars <- lift getWorldAvatars - av <- mlookup k avatars - lift $ setWorldAvatars (M.insert k (av { avatarCameraControlParams = defaultCamera }) avatars) - continueWith VoidVal - -llGetCameraPos info@(ScriptInfo _ _ sid pk _) [] = - do avKey <- getPermittedAvKey info "llGetCameraPos" cPermissionTrackCamera - maybe (return (0,0,0)) (\ k -> lift getWorldAvatars >>= mlookup k >>= return . avatarCameraPosition) avKey >>= - continueWith . vec2VVal - -llGetCameraRot info@(ScriptInfo _ _ sid pk _) [] = - do avKey <- getPermittedAvKey info "llGetCameraRot" cPermissionTrackCamera - maybe (return (0,0,0,1)) (\ k -> lift getWorldAvatars >>= mlookup k >>= return . avatarCameraRotation) avKey - >>= continueWith . rot2RVal - -llTakeCamera info _ = lift $ logFromScript info "llTakeCamera: deprecated!" >> continueWith VoidVal -llReleaseCamera info _ = lift $ logFromScript info "llRelaaseCamera: deprecated!" >> continueWith VoidVal -llPointAt info _ = lift $ logFromScript info "llPointAt: deprecated!" >> continueWith VoidVal -llStopPointAt info _ = lift $ logFromScript info "llStopPointAt: deprecated!" >> continueWith VoidVal - -llSetPrimURL info _ = lift $ logFromScript info "llSetPrimURL: unimplemented!" >> continueWith VoidVal -llRefreshPrimURL info _ = lift $ logFromScript info "llRefreshPrimURL: unimplemted!" >> continueWith VoidVal - -llGetRot info@(ScriptInfo oid _ _ pk _) [] = - getGlobalRot pk >>= continueWith . rot2RVal - -llGetLocalRot info@(ScriptInfo oid _ _ pk _) [] = - (if oid == pk - then getObjectRotation oid - else getPrimRotation pk) >>= continueWith . rot2RVal - -llGetRootRotation info@(ScriptInfo oid _ _ pk _) [] = getObjectRotation oid >>= continueWith . rot2RVal - ---TODO: handle attachments... ---TODO: confirm order of rotations in both of these -llSetRot info@(ScriptInfo oid _ _ pk _) [r@(RVal _ _ _ _)] = - (if oid == pk then setRootRotation oid rot else setChildRotation oid pk rot) >> continueWith VoidVal - where rot = rVal2Rot r - --- TODO: fix this!! -setChildRotation rk pk rot = do - rootRot <- getPrimRotation rk - lift $ setPrimRotation pk (rot `quaternionMultiply` rootRot `quaternionMultiply` rootRot) - -setRootRotation rk rot = do - obj <- getObject rk - lift $ setObject rk (obj { objectDynamics = (objectDynamics obj) { objectRotation = rot }}) - -llSetLocalRot info@(ScriptInfo oid _ _ pk _) [r@(RVal _ _ _ _)] = - (if oid == pk then setRootRotation oid rot else lift $ setPrimRotation pk rot) >> continueWith VoidVal - where rot = rVal2Rot r - -llSetPos info@(ScriptInfo oid pid sid pk event) [val] = - (if oid == pk then setRootPos oid v else setChildPos pk v) >> continueWith VoidVal - where v = vVal2Vec val - -setChildPos pk val = lift $ setPrimPosition pk val - --- updates the world coordinates of object --- does NOT consider region boundaries (TODO: fix!) -setRootPos oid v = - do v0 <- getObjectPosition oid - let vec = diff3d v v0 - let dist = mag3d vec - let vec' = if dist <= 10.0 - then vec - else scale3d 10.0 $ norm3d vec - --objects <- lift getObjects - obj <- getObject oid - lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectPosition = v0 `add3d` vec' } }) - -llGetOwner info [] = - let k = scriptInfoPrimKey info in getPrimOwner k >>= continueWith . KVal -llGetCreator info [] = - let k = scriptInfoPrimKey info in getPrimCreator k >>= continueWith . KVal -llSameGroup info@(ScriptInfo _ _ _ pk _) [KVal k] = - do group <- avGroup <||> getPrimGroup k <||> throwError ("no such object or avatar: " ++ k) - myGroup <- getPrimGroup pk <||> throwError ("can't find " ++ pk) - continueWith (IVal (if group == myGroup then 1 else 0)) - where avGroup = lift getWorldAvatars >>= mlookup k >>= return . avatarActiveGroup - -llGetLinkKey (ScriptInfo oid _ _ _ _) [IVal link] = do - do LSLObject { primKeys = pkeys } <- getObject oid - pk <- lookupByIndex (link - 1) pkeys - continueWith (KVal pk) - --- TODO: should check for av/prim in same region --- TODO: no concept of online/offline for av -llKey2Name info [KVal k] = lift $ - do avs <- getWorldAvatars - case M.lookup k avs of - Just av -> continueWith $ SVal (avatarName av) - _ -> do - prims <- getPrims - case M.lookup k prims of - Just prim -> continueWith $ SVal (primName prim) - Nothing -> continueWith (SVal "") -llOwnerSay info [SVal s] = - do lift $ logAMessage LogInfo (infoToLogSource info) ("Owner Say: " ++ s) - owner <- getPrimOwner (scriptInfoObjectKey info) - lift $ putWorldEvent 0 (AvatarInputEvent owner (AvatarOwnerSay (scriptInfoPrimKey info) s)) - continueWith VoidVal - -llGetGeometricCenter info@(ScriptInfo oid _ _ _ _) [] = - do LSLObject { primKeys = links } <- getObject oid - when (null links) $ throwError "error: empty linkset!" - rootPos <- getObjectPosition oid - foldM (\ v k -> getGlobalPos k >>= return . add3d v) (0,0,0) links - >>= continueWith . vec2VVal . scale3d (1 / fromIntegral (length links)) - -llGetMass info@(ScriptInfo oid _ _ _ _) [] = - objectMass oid >>= continueWith . FVal - -objectMass oid = do - LSLObject { primKeys = links } <- getObject oid - foldM (\ v k -> getPrim k >>= ( \ prim -> return $ v + primMassApprox prim)) 0.0 links - -llGetObjectMass info [KVal k] = - do avatars <- lift getWorldAvatars - val <- case M.lookup k avatars of - Just _ -> return 80.0 - Nothing -> objectMass k - continueWith (FVal val) - -llGetVel info@(ScriptInfo oid _ _ _ _) [] = - getObject oid >>= continueWith . vec2VVal . objectVelocity . objectDynamics - -llGetForce info@(ScriptInfo oid _ _ _ _) [] = - getObject oid >>= return . objectForce . objectDynamics >>= continueWith . vec2VVal . fst - -llSetForce info@(ScriptInfo oid _ _ _ _) [v@(VVal x y z), IVal local] = - do obj <- getObject oid - lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectForce = ((x,y,z), local /= 0) }}) - continueWith VoidVal - -llSetBuoyancy info@(ScriptInfo { scriptInfoObjectKey = oid }) [FVal buoy] = - do obj <- getObject oid - lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectBuoyancy = buoy }}) - continueWith VoidVal - -llApplyImpulse info@(ScriptInfo oid _ _ _ _) [v@(VVal x y z), IVal local] = - do t <- lift getTick - obj <- getObject oid - lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectImpulse = (((x,y,z), local /= 0), t + durationToTicks 1) } }) - continueWith VoidVal - -llGetAccel info@(ScriptInfo oid _ _ _ _) [] = - do prim <- getPrim oid - obj <- getObject oid - let dyn = objectDynamics obj - let force = fst (objectForce dyn) `rot3d` rotation - where rotation = if snd $ objectForce dyn then objectRotation dyn else (0,0,0,1) - let impulse = ((fst . fst . objectImpulse) dyn `rot3d` rotation, (snd . objectImpulse) dyn) - where rotation = if (snd . fst . objectImpulse) dyn then objectRotation dyn else (0,0,0,1) - t <- lift getTick - mass <- objectMass oid - pos <- getObjectPosition oid - continueWith $ vec2VVal $ calcAccel t 0 mass pos force impulse - -llSetTorque info@(ScriptInfo { scriptInfoObjectKey = oid }) [VVal x y z, IVal local] = - do obj <- getObject oid - lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectTorque = ((x,y,z),local /= 0) } }) - continueWith VoidVal - -llSetForceAndTorque info@(ScriptInfo { scriptInfoObjectKey = oid}) [VVal fx fy fz, VVal tx ty tz, IVal local] = - do obj <- getObject oid - let loc = local /= 0 - lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { - objectForce = ((fx,fy,fz),loc), objectTorque = ((tx,ty,tz),loc) } }) - continueWith VoidVal - -llGetTorque info@(ScriptInfo { scriptInfoObjectKey = oid }) [] = - getObject oid >>= continueWith . vec2VVal . fst . objectTorque . objectDynamics - -llGetOmega info@(ScriptInfo { scriptInfoObjectKey = oid }) [] = - getObject oid >>= continueWith . vec2VVal . objectOmega . objectDynamics - -llApplyRotationalImpulse info@(ScriptInfo { scriptInfoObjectKey = oid }) [VVal x y z, IVal local] = - do obj <- getObject oid - t <- lift getTick - lift $ setObject oid (obj { - objectDynamics = (objectDynamics obj) { objectRotationalImpulse = (((x,y,z),local /= 0), t + durationToTicks 1) } }) - continueWith VoidVal - -llGetPos info@(ScriptInfo _ _ _ pk _) [] = getGlobalPos pk >>= continueWith . vec2VVal -llGetRootPosition info@(ScriptInfo oid _ _ _ _) [] = getObjectPosition oid >>= continueWith . vec2VVal - -getGlobalPos pk = do - oid <- getRootPrim pk - root <- getObjectPosition oid - rel <- getPrimPosition pk - rot <- getObjectRotation oid - return (root `add3d` (rot3d rel rot)) - -getGlobalRot pk = do - oid <- getRootPrim pk - rot0 <- getObjectRotation oid - rot <- getPrimRotation pk - return (rot `quaternionMultiply` rot0) - -llRotLookAt info@(ScriptInfo oid _ _ _ _) [RVal x y z s, FVal strength, FVal tau] = - rotLookAt oid (x,y,z,s) strength tau >> continueWith VoidVal - -llLookAt info@(ScriptInfo oid _ _ _ _) [VVal x y z, FVal strength, FVal tau] = - do pos <- getObjectPosition oid - rot <- getGlobalRot oid - let v = diff3d (x,y,z) pos - let rot1 = rot `quaternionMultiply` (rotationBetween (rot3d (0,0,1) rot) v) - rotLookAt oid rot1 strength tau - continueWith VoidVal - -rotLookAt oid (x,y,z,s) strength tau = do - obj <- getObject oid - lift $ setObject oid $ obj { objectDynamics = (objectDynamics obj) { objectRotationTarget = - Just (RotationTarget { - rotationTarget = (x,y,z,s), - rotationTargetStrength = strength, - rotationTargetTau = tau } ) }} - -llStopLookAt info@(ScriptInfo oid _ _ _ _) [] = - do obj <- getObject oid - lift $ setObject oid $ obj { objectDynamics = (objectDynamics obj) { objectRotationTarget = Nothing }} - continueWith VoidVal - -llGetLocalPos info@(ScriptInfo oid _ _ pk _) [] = - getLocalPos pk >>= continueWith . vec2VVal - -getLocalPos k = getPrimPosition k - -llMoveToTarget info@(ScriptInfo { scriptInfoObjectKey = oid, scriptInfoScriptName = sn, scriptInfoPrimKey = pk }) [VVal x y z, FVal tau] = - do obj <- getObject oid - let action = setTarg obj - case objectPositionTarget (objectDynamics obj) of - Nothing -> action - Just (PositionTarget { positionTargetSetBy = scriptId }) - | scriptId == (pk,sn) -> action - | otherwise -> lift $ logAMessage LogInfo "llMoveToTarget" ("target already set by another script: " ++ show scriptId) - Just _ -> action - continueWith VoidVal - where setTarg obj = lift $ setObject oid obj' - where targ = PositionTarget { positionTargetTau = tau, - positionTargetLocation = (x,y,z), - positionTargetSetBy = (pk,sn) } - obj' = obj { objectDynamics = (objectDynamics obj) { objectPositionTarget = Just targ } } - -llStopMoveToTarget info@(ScriptInfo { scriptInfoObjectKey = oid, scriptInfoScriptName = sn, scriptInfoPrimKey = pk }) [] = - do obj <- getObject oid - case objectPositionTarget $ objectDynamics obj of - Just (PositionTarget {}) -> lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectPositionTarget = Nothing }}) - _ -> return () - continueWith VoidVal - -llGroundRepel info@(ScriptInfo { scriptInfoObjectKey = oid }) [FVal height, IVal water, FVal tau] = - do obj <- getObject oid - lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { - objectPositionTarget = Just $ Repel { - positionTargetTau = tau, - positionTargetOverWater = water /= 0, - positionTargetHeight = height } } }) - continueWith VoidVal - -llSetHoverHeight info@(ScriptInfo { scriptInfoObjectKey = oid }) [FVal height, IVal water, FVal tau] = - do obj <- getObject oid - lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { - objectPositionTarget = Just $ Hover { - positionTargetTau = tau, - positionTargetOverWater = water /= 0, - positionTargetHeight = height } } }) - continueWith VoidVal - -llStopHover info@(ScriptInfo { scriptInfoObjectKey = oid }) [] = - do obj <- getObject oid - case objectPositionTarget $ objectDynamics obj of - Just (Hover {}) -> lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectPositionTarget = Nothing }}) - _ -> lift $ logAMessage LogWarn "llStopHover" "not hovering" - continueWith VoidVal - -llGetAlpha (ScriptInfo _ _ _ pkey _) [IVal side] = - computeAlpha >>= continueWith - where computeAlpha = if (side /= -1) - then runFace pkey side $ (getPrimFaceAlpha pkey side >>= return . FVal) - else runFace pkey side $ do - faces <- getPrimFaces pkey - let n = length faces - let alpha = if n > 0 then sum (map faceAlpha faces) / (fromInt $ length faces) - else 1.0 - return $ FVal alpha - -llSetAlpha (ScriptInfo _ _ _ pkey _) [FVal alpha, IVal face] = lift $ setAlpha alpha face pkey - -setAlpha alpha face pkey = - if face == -1 - then runErrFace pkey face (EvalIncomplete,VoidVal) $ do - faces <- getPrimFaces pkey - let faces' = map (\ face -> face { faceAlpha = alpha }) faces - lift $ setPrimFaces pkey faces' - continueWith VoidVal - else setPrimFaceAlpha pkey face alpha >> continueWith VoidVal - -llSetLinkAlpha (ScriptInfo oid pid _ _ _) [IVal link, FVal alpha, IVal face] = do - pks <- lift $ getTargetPrimKeys oid link pid - lift $ mapM_ (setAlpha alpha face) pks - continueWith VoidVal - -getTargetPrimKeys oid link pid = do - LSLObject { primKeys = prims } <- runAndLogIfErr ("can't find object " ++ oid) (LSLObject [] defaultDynamics) $ getObject oid - let targetList = targetLinks (length prims) link pid - mapM (flip lookupByIndex prims) targetList - -llGetColor (ScriptInfo _ _ _ pkey _) [IVal side] = - computeColor >>= continueWith - where computeColor = if (side /= -1) - then runFace pkey side $ (getPrimFaceColor pkey side >>= return . vec2VVal) - else runFace pkey side $ do - faces <- getPrimFaces pkey - let n = length faces - let color = if n > 0 then scale3d (1.0/ (fromInt $ length faces) ) - (foldr add3d (0.0,0.0,0.0) (map faceColor faces)) - else (1.0,1.0,1.0) - return $ vec2VVal color - -llSetColor (ScriptInfo _ _ _ pkey _) [color, IVal face] = setColor color face pkey - -setColor color face pkey = - if face == -1 - then runFace pkey face $ do - faces <- getPrimFaces pkey - let colorVal = vVal2Vec color - let faces' = map (\ face -> face { faceColor = colorVal }) faces - lift $ setPrimFaces pkey faces' - continueWith VoidVal - else lift $ setPrimFaceColor pkey face (vVal2Vec color) >> continueWith VoidVal - -llSetLinkColor (ScriptInfo oid pid _ _ _) [IVal link, color, IVal face] = do - pks <- lift $ getTargetPrimKeys oid link pid - mapM (setColor color face) pks - continueWith VoidVal - -llGetTextureOffset (ScriptInfo _ _ _ pkey _) [IVal face] = - let face' = if face == -1 then 0 else face in - runFace pkey face (getPrimFaceTextureInfo pkey face' >>= return . textureOffsets) >>= continueWith . vec2VVal -llGetTextureScale (ScriptInfo _ _ _ pkey _) [IVal face] = - let face' = if face == -1 then 0 else face in - runFace pkey face (getPrimFaceTextureInfo pkey face' >>= return . textureRepeats) >>= continueWith . vec2VVal -llGetTextureRot (ScriptInfo _ _ _ pkey _) [IVal face] = - let face' = if face == -1 then 0 else face in - runFace pkey face (getPrimFaceTextureInfo pkey face' >>= return . textureRotation) >>= continueWith . FVal - -llSetTexture info@(ScriptInfo _ _ _ pk _) [SVal texture,IVal face] = - do tk <- findTexture pk texture - setTexture tk face pk - continueWith VoidVal - --- TODO: worry about texture permissions -llGetTexture (ScriptInfo _ _ _ pkey _) [IVal face] = - let face' = if face == -1 then 0 else face in - runFace pkey face (do - info <- getPrimFaceTextureInfo pkey face' - invTextures <- getPrimTextures pkey - let tKey = textureKey info - case findByInvKey tKey invTextures of - Nothing -> return tKey - Just item -> return $ invName item) >>= continueWith . SVal - -llSetLinkTexture info@(ScriptInfo oid pid _ pk _) [IVal link, SVal texture,IVal face] = do - pks <- lift $ getTargetPrimKeys oid link pid - tk <- findTexture pk texture - mapM_ (setTexture tk face) pks - continueWith VoidVal - -findTexture pk id = - do textures <- getPrimTextures pk - case findByInvName id textures of - Just item -> return $ snd $ inventoryItemNameKey $ inventoryItemIdentification item - Nothing -> do - result <- return $ findTextureAsset id - case result of - Nothing -> throwError ("cannot find texture " ++ id) - Just item -> return $ snd $ inventoryItemNameKey $ inventoryItemIdentification item - -setTexture tk face pkey = do - if face == -1 - then do faces <- getPrimFaces pkey - let faces' = map (\ face -> - let info = faceTextureInfo face in - face { faceTextureInfo = info { textureKey = tk } }) faces - lift $ setPrimFaces pkey faces' - else do faces <- getPrimFaces pkey - f <- lookupByIndex face faces - let tInfo = faceTextureInfo f - updatePrimFace pkey face (\ f -> f { faceTextureInfo = tInfo { textureKey = tk } }) - -updateTextureInfo update pk faceIndex = - runFace pk faceIndex ( - if faceIndex == -1 - then do - faces <- getPrimFaces pk - let faces' = map (\ face -> - let info = faceTextureInfo face in - face { faceTextureInfo = update info }) faces - lift $ setPrimFaces pk faces' - else do - f <- getPrimFaces pk >>= lookupByIndex faceIndex - let tInfo = update $ faceTextureInfo f - updatePrimFace pk faceIndex (\ f -> f { faceTextureInfo = tInfo }) - ) >> continueWith VoidVal - -llScaleTexture info@(ScriptInfo _ _ _ pk _) [FVal h,FVal v,IVal faceIndex] = - updateTextureInfo update pk faceIndex where update info = info { textureRepeats = (h,v,0) } -llOffsetTexture (ScriptInfo _ _ _ pk _) [FVal h, FVal v, IVal faceIndex] = - updateTextureInfo update pk faceIndex where update info = info { textureOffsets = (h,v,0) } -llRotateTexture (ScriptInfo _ _ _ pk _) [FVal rot, IVal faceIndex] = - updateTextureInfo update pk faceIndex where update info = info { textureRotation = rot } - -getPos pkey = runErrPrim pkey - (VVal 0.0 0.0 0.0) - (getRootPrim pkey >>= getObjectPosition >>= return . vec2VVal) - -getRegionIndex pkey = return (0,0) - -groupList _ [] = [] -groupList n l | n > 0 = take n l : groupList n (drop n l) - | otherwise = groupList 1 l - -genNum :: [Int] -> Integer -> Integer -genNum rands maxval = - let rands' :: [Integer] - rands' = map ((0x80000000-).toInteger) rands - topval :: Rational - topval = fromInteger $ - foldl' (.|.) 0 $ zipWith (shiftL) (replicate (length rands') 0xffffffff) [0,32..] - randval :: Rational - randval = fromInteger $ foldl' (.|.) 0 $ zipWith (shiftL) rands' [0,32] - in floor ((randval / topval) * (fromInteger maxval)) - - -llListRandomize _ [LVal list, IVal stride] = - let l1 = groupList stride list - n = fac (toInteger $ length l1) - randsNeeded = ceiling $ (logBase 2 (fromInteger n)) / 32 - wrands = replicate randsNeeded wrand - in lift $ do - rands <- sequence wrands - let permutation = genNum rands n - let list' = generatePermutation list permutation - continueWith $ LVal list' - -llGetNumberOfPrims (ScriptInfo oid _ _ pkey _) [] = - do (LSLObject { primKeys = prims }) <- getObject oid - continueWith $ IVal (length prims) - -llGetObjectPrimCount info@(ScriptInfo oid _ _ pkey _) [KVal k] = - do - region <- getPrimRegion oid - p <- getPrim k - region' <- getPrimRegion k - if region /= region' - then continueWith (IVal 0) - else getRootPrim k >>= primCount >>= continueWith . IVal - where primCount oid = do - (LSLObject { primKeys = l}) <- getObject oid - return $ length l - -llGetNumberOfSides (ScriptInfo _ _ _ pkey _) [] = - getPrimFaces pkey >>= continueWith . IVal . length - -llGetObjectDesc (ScriptInfo _ _ _ pkey _) [] = - getPrimDescription pkey >>= continueWith . SVal -llGetObjectName (ScriptInfo _ _ _ pkey _) [] = - getPrimName pkey >>= continueWith . SVal - -llSetObjectName (ScriptInfo _ _ _ pkey _) [SVal name] = - lift $ setPrimName pkey (take 255 name) >> continueWith VoidVal - -llSetObjectDesc (ScriptInfo _ _ _ pkey _) [SVal desc] = - lift $ setPrimDescription pkey (take 127 desc) >> continueWith VoidVal - -llGetObjectPermMask (ScriptInfo oid _ _ _ _) [IVal maskId] = - getObjectPermMask oid maskId >>= continueWith . IVal - -getObjectPermMask oid maskId = do - masks <- getPrimPermissions oid - let base = if null masks then 0x0008e000 else masks !! 0 - let n = length masks - return (if maskId `elem` [0..(n-1)] then masks !! maskId else - if maskId == 3 then 0 else base) - -llGetScale (ScriptInfo _ _ _ pkey _) [] = getPrimScale pkey >>= continueWith . vec2VVal - -llSetScale (ScriptInfo _ _ _ pk _) [scale] = - if tooSmall then continueWith VoidVal else lift $ setPrimScale pk clippedVec >> continueWith VoidVal - where (x,y,z) = vVal2Vec scale - tooSmall = (x < 0.01 || y < 0.01 || z < 0.01) - clippedVec = (min x 10.0, min y 10.0, min z 10.0) - -llGetBoundingBox info [KVal k] = - do lift $ logAMessage LogInfo "sim" "note: llGetBoundingBox does not return accurate results (yet)" - avatars <- lift getWorldAvatars - case M.lookup k avatars of - Just avatar -> let pos = avatarPosition avatar in - continueWith (LVal $ map (vec2VVal . (add3d pos)) [(-1.0,-1.0,-1.0),(1.0,1.0,1.0)]) - Nothing -> getRootPrim k >>= getPrimBox >>= continueWith . LVal . map vec2VVal . tup2l - where tup2l (x,y) = [x,y] - -getPrimBox pk = do - pos <- getGlobalPos pk - scale <- getPrimScale pk - let (xs,ys,zs) = scale3d 0.5 scale - return (add3d pos (-xs, -ys, -zs),add3d pos (xs,ys,zs)) - --- this is extremely approximate.... -objRadius oid = do - LSLObject { primKeys = keys } <- getObject oid - foldM f 0 keys - where f r k = do - (x,y,z) <- getPrimPosition k - (sx,sy,sz) <- getPrimScale k - let (rx,ry,rz) = (sx / 2 + abs x, sy / 2 + abs y, sz / 2 + abs z) - return $ maximum [r,rx,ry,rz] - -llSetTimerEvent (ScriptInfo _ _ sn pk _) [FVal interval] = - -- TODO: this may not accurately reflect buggy behavior in SL - do lift $ removePendingTimerEvent pk sn - when (interval > 0) $ lift $ putWorldEvent interval (TimerEvent interval (pk,sn)) - continueWith VoidVal - where removePendingTimerEvent pk sn = do - wq <- getWQueue - let wq' = flip filter wq $ \ e -> case e of - (_,TimerEvent _ (pk',sn')) -> pk /= pk' || sn /= sn' - _ -> True - setWQueue wq' - -llSetVehicleFlags info@(ScriptInfo _ _ _ pk _) [IVal flagsToSet] = - do flags <- getPrimVehicleFlags pk `catchError` primErr pk - lift $ setPrimVehicleFlags pk (flags .|. flagsToSet) - continueWith VoidVal - -llRemoveVehicleFlags info@(ScriptInfo _ _ _ pk _) [IVal flagsToClear] = - do flags <- getPrimVehicleFlags pk `catchError` primErr pk - lift $ setPrimVehicleFlags pk (flags .&. complement flagsToClear) - continueWith VoidVal - ----------------------------------------------------------------------- --- get/set prim parameters -llGetPrimitiveParams (ScriptInfo _ _ _ pk _) [LVal l] = getPrimParameters pk l >>= continueWith . LVal -llSetPrimitiveParams (ScriptInfo _ _ _ pk _) [LVal l] = setPrimParameters pk l >> continueWith VoidVal - -llSetLinkPrimitiveParams (ScriptInfo oid pid _ _ _) [IVal link,LVal l] = do - do LSLObject { primKeys = pks } <- getObject oid - let targetList = targetLinks (length pks) link pid - pkList <- mapM (flip lookupByIndex pks) targetList - mapM_ (flip setPrimParameters l) pkList - continueWith VoidVal - -getPrimParameters pk params = - case params of - [] -> return [] - (x:xs) | x `elem` [llcPrimBumpShiny,llcPrimFullbright,llcPrimColor,llcPrimTexture,llcPrimTexgen] && null xs -> return [] - | x == llcPrimBumpShiny -> queryAndDoRest (queryPrimBumpShiny $ head xs) (tail xs) - | x == llcPrimColor -> queryAndDoRest (queryPrimColor $ head xs) (tail xs) - | x == llcPrimTexture -> queryAndDoRest (queryPrimTexture $ head xs) (tail xs) - | x == llcPrimTexgen -> queryAndDoRest (queryPrimTexgen $ head xs) (tail xs) - | x == llcPrimFullbright -> queryAndDoRest (queryPrimFullbright $ head xs) (tail xs) - | x == llcPrimMaterial -> queryAndDoRest queryPrimMaterial xs - | x == llcPrimPhantom -> queryAndDoRest (queryPrimStatus primPhantomBit) xs - | x == llcPrimPhysics -> queryAndDoRest (queryPrimStatus primPhysicsBit) xs - | x == llcPrimFlexible -> queryAndDoRest queryPrimFlexible xs - | x == llcPrimPointLight -> queryAndDoRest queryPrimLight xs - | x == llcPrimPosition -> queryAndDoRest queryPrimPosition xs - | x == llcPrimRotation -> queryAndDoRest queryPrimRotation xs - | x == llcPrimSize -> queryAndDoRest queryPrimScale xs - | x == llcPrimTempOnRez -> queryAndDoRest queryPrimTempOnRez xs - | x == llcPrimType -> queryAndDoRest queryPrimType xs - | x == IVal 1 -> queryAndDoRest queryPrimTypeOldSkool xs - | otherwise -> getPrimParameters pk xs - where queryAndDoRest q rest = liftM2 (++) (q pk) (getPrimParameters pk rest) - -queryPrimTempOnRez k = getPrimTempOnRez k >>= return . return . IVal . (\ b -> if b then 1 else 0) -queryPrimRotation k = getGlobalRot k >>= return . return . rot2RVal -queryPrimPosition k = getGlobalPos k >>= return . return . vec2VVal -queryPrimScale k = getPrimScale k >>= return . return . vec2VVal -queryPrimFlexible k = - getPrimFlexibility k >>= (\ flex -> case flex of - Nothing -> return [IVal 0, IVal 0, FVal 0, FVal 0, FVal 0, FVal 0, VVal 0.0 0.0 0.0] - Just flex' -> return $ map ($ flex') [const (IVal 1),IVal . flexSoftness, FVal . flexGravity, FVal . flexFriction, - FVal . flexWind, FVal . flexTension, vec2VVal . flexForce]) -queryPrimLight k = - getPrimLight k >>= (\ light -> case light of - Nothing -> return [IVal 0, VVal 0 0 0, FVal 0, FVal 0, FVal 0] - Just light' -> return $ map ($ light') [const (IVal 1), vec2VVal . lightColor, FVal . lightIntensity, FVal . lightRadius, FVal . lightFalloff]) - -queryPrimMaterial k = getPrimMaterial k >>= return . return . IVal -queryPrimStatus bit k = getPrimStatus k >>= return . return . IVal . (\ i -> if testBit i bit then 1 else 0) -queryPrimBumpShiny side = queryFaceVals bumpShiny side - where bumpShiny face = [IVal $ faceShininess face, IVal $ faceBumpiness face] -queryPrimColor side = queryFaceVals colorAlpha side - where colorAlpha face = [vec2VVal $ faceColor face, FVal $ faceAlpha face] -queryPrimTexture side = queryFaceVals textureInfo side - where textureInfo face = let tinfo = faceTextureInfo face in map ($ tinfo) - [SVal .textureKey,vec2VVal . textureRepeats,vec2VVal . textureOffsets,FVal . textureRotation] -queryPrimTexgen side = queryFaceVals (return . IVal . faceTextureMode) side -queryPrimFullbright side = queryFaceVals (\ face -> if faceFullbright face then [IVal 1] else [IVal 0]) side - -queryFaceVals f (IVal side) k = - if side == -1 - then getPrimFaces k >>= return . concat . (map f) - else getPrimFaces k >>= fromErrorT [] . (\ faces -> (lookupByIndex side faces >>= return . f)) - --- TODO: get these out of here -Just (Constant _ llcObjectUnknownDetail) = findConstant "OBJECT_UNKNOWN_DETAIL" -Just (Constant _ llcObjectName) = findConstant "OBJECT_NAME" -Just (Constant _ llcObjectDesc) = findConstant "OBJECT_DESC" -Just (Constant _ llcObjectPos) = findConstant "OBJECT_POS" -Just (Constant _ llcObjectRot) = findConstant "OBJECT_ROT" -Just (Constant _ llcObjectVelocity) = findConstant "OBJECT_VELOCITY" -Just (Constant _ llcObjectOwner) = findConstant "OBJECT_OWNER" -Just (Constant _ llcObjectGroup) = findConstant "OBJECT_GROUP" -Just (Constant _ llcObjectCreator) = findConstant "OBJECT_CREATOR" - -queryPrimType k = do - (PrimType version typecode holeshape cut twist holesize topshear hollow taper advancedcut roffset revs skew sculpt sculptType) <- - getPrimTypeInfo k - case typecode of - i | (IVal i) `elem` [llcPrimTypeBox,llcPrimTypeCylinder,llcPrimTypePrism] -> - return [IVal i,IVal holeshape, vec2VVal cut, FVal hollow, vec2VVal twist, vec2VVal taper, vec2VVal topshear] - | (IVal i) == llcPrimTypeSphere -> return [IVal i,IVal holeshape, vec2VVal cut, FVal hollow, vec2VVal twist, vec2VVal advancedcut] - | (IVal i) `elem` [llcPrimTypeRing,llcPrimTypeTorus,llcPrimTypeTube] -> - return [IVal i,IVal holeshape, vec2VVal cut, FVal hollow, vec2VVal twist, vec2VVal holesize, vec2VVal topshear, - vec2VVal advancedcut, vec2VVal taper, FVal revs, FVal roffset, FVal skew] - | (IVal i) == llcPrimTypeSculpt -> return [IVal i,SVal $ fromMaybe "" sculpt, IVal sculptType] - | otherwise -> return [] - -queryPrimTypeOldSkool k = do - (PrimType version typecode holeshape cut twist holesize topshear hollow taper advancedcut roffset revs skew sculpt sculptType) <- - getPrimTypeInfo k - case typecode of - i | (IVal i) `elem` [llcPrimTypeBox,llcPrimTypeCylinder,llcPrimTypePrism] -> - return [IVal i, vec2VVal cut, FVal hollow, FVal $ yOf twist, vec2VVal taper, vec2VVal topshear] - | (IVal i) == llcPrimTypeSphere -> return [IVal i,vec2VVal cut, FVal hollow,vec2VVal advancedcut] - | (IVal i) == llcPrimTypeTorus -> - return [IVal i, vec2VVal cut, FVal hollow, FVal $ yOf twist, FVal $ yOf taper, vec2VVal topshear, vec2VVal advancedcut] - | (IVal i) == llcPrimTypeTube -> - return [IVal i, vec2VVal cut, FVal hollow, FVal $ yOf twist, FVal $ xOf topshear] - | otherwise -> return [] - where xOf (x,y,z) = x - yOf (x,y,z) = y - -setPrimParameters pk params = updatePrimParameters pk params >> return () - -updatePrimParameters pk [] = return [] -updatePrimParameters pk (code:rest) = do - result <- case code of - i | i == llcPrimTempOnRez -> updatePrimTempOnRez pk rest - | i == llcPrimMaterial -> updatePrimMaterial pk rest - | i == llcPrimPhantom -> updatePrimPhantom pk rest - | i == llcPrimPhysics -> updatePrimPhysics pk rest - | i == llcPrimPosition -> updatePrimPosition pk rest - | i == llcPrimRotation -> updatePrimRotation pk rest - | i == llcPrimSize -> updatePrimScale pk rest - | i == llcPrimFlexible -> updatePrimFlexible pk rest - | i == llcPrimPointLight -> updatePrimLight pk rest - | i == llcPrimBumpShiny -> updatePrimBumpShiny pk rest - | i == llcPrimColor -> updatePrimColor pk rest - | i == llcPrimTexture -> updatePrimTexture pk rest - | i == llcPrimTexgen -> updatePrimTexgen pk rest - | i == llcPrimFullbright -> updatePrimFullbright pk rest - | i == llcPrimType -> updatePrimType pk rest - | i == IVal 1 -> updatePrimTypeOldSkool pk rest - | otherwise -> fail "incorrect parameter" - updatePrimParameters pk result - -updatePrimType pk vals = getPrim pk >>= flip updatePrimType' vals >>= (\ (prim,rest) -> (lift $ setPrim pk prim) >> return rest) -updatePrimType' prim (primCode@(IVal i):rest) | primCode == llcPrimTypeSphere = updatePrimTypeSphere prim rest - | primCode `elem` [llcPrimTypeBox,llcPrimTypeCylinder,llcPrimTypePrism] = - updatePrimTypeBoxCylPrism i prim rest - | primCode `elem` [llcPrimTypeTorus,llcPrimTypeTube,llcPrimTypeRing] = - updatePrimTypeRingTorusTube i prim rest - | primCode == llcPrimTypeSculpt = updatePrimTypeSculpt prim rest - | otherwise = fail "incorrect parameters for PRIM_TYPE" -updatePrimType' _ _ = fail "insufficient or incorrect parameters for PRIM_TYPE" - -updatePrimTypeOldSkool pk vals = getPrim pk >>= flip updatePrimTypeOldSkool' vals >>= (\ (prim,rest) -> (lift $ setPrim pk prim) >> return rest) -updatePrimTypeOldSkool' prim (primCode@(IVal i):rest) | primCode == llcPrimTypeSphere = updatePrimTypeSphereOld prim rest - | primCode `elem` [llcPrimTypeBox,llcPrimTypeCylinder,llcPrimTypePrism] = - updatePrimTypeBoxCylPrismOld i prim rest - | primCode == llcPrimTypeTorus = updatePrimTypeTorusOld prim rest - | primCode == llcPrimTypeTube = updatePrimTypeTubeOld prim rest - | otherwise = fail "incorrect parameters for deprecated prim type" -updatePrimTypeOldSkool' _ _ = fail "insufficient or incorrect parameters for deprecated prim type" - ---updatePrimTempOnRez prim (IVal tempOnRez:rest) = return (prim { primTempOnRez = if tempOnRez /= 0 then True else False }, rest) -updatePrimTempOnRez pk (IVal tempOnRez:rest) = lift (setPrimTempOnRez pk (tempOnRez /= 0)) >> return rest -updatePrimTempOnRez _ _ = fail "insufficient or incorrect parameters for PRIM_TEMP_ON_REZ" - ---updatePrimMaterial prim (IVal material:rest) = return (prim { primMaterial = material }, rest) -updatePrimMaterial pk (IVal material:rest) = lift (setPrimMaterial pk material) >> return rest -updatePrimMaterial _ _ = fail "insufficient or incorrect parameters for PRIM_MATERIAL" - -updatePrimPhantom pk params = updatePrimStatus "insufficient or incorrect parameters for PRIM_PHANTOM" primPhantomBit pk params -updatePrimPhysics pk params = updatePrimStatus "insufficient or incorrect parameters for PRIM_PHYSICS" primPhysicsBit pk params - --- updatePrimStatus _ bit prim (IVal i:rest) = return (prim { primStatus = if i == 0 then clearBit (primStatus prim) bit --- else setBit (primStatus prim) bit }, rest) -updatePrimStatus _ bit pk (IVal i:rest) = (getPrimStatus pk) >>= lift . (setPrimStatus pk) . (if i == 0 then flip clearBit bit - else flip setBit bit) >> return rest -updatePrimStatus fMsg _ _ _ = fail fMsg - -updatePrimPosition pk (pos@(VVal _ _ _):rest) = - do getPrimParent pk >>= \ mok -> case mok of - Nothing -> setRootPos pk v - Just ok -> setChildPos pk v - return rest - where v = vVal2Vec pos -updatePrimPosition _ _ = fail "insufficient or incorrect parameters for PRIM_POSITION" - -updatePrimRotation pk (rot@(RVal _ _ _ _):rest) = - do getPrimParent pk >>= \ mok -> case mok of - Nothing -> setRootRotation pk r - Just rk -> setChildRotation rk pk r - return rest - where r = rVal2Rot rot -updatePrimRotation _ _ = fail "insufficient or incorrect parameters for PRIM_ROTATION" -updatePrimScale pk (scale@(VVal _ _ _):rest) = (lift $ setPrimScale pk (vVal2Vec scale)) >> return rest -updatePrimScale _ _ = fail "insufficient or incorrect parameters for PRIM_SIZE" - -updatePrimFlexible pk (IVal flex:IVal soft:FVal gravity:FVal friction:FVal wind:FVal tension:VVal fx fy fz:rest) = - lift (setPrimFlexibility pk (if flex == 0 then Nothing else Just (Flexibility soft gravity friction wind tension (fx,fy,fz)))) >> return rest -updatePrimFlexible _ _ = fail "insufficient or incorrect parameters for PRIM_FLEXIBLE" - -updatePrimLight pk (IVal light:VVal r g b:FVal intensity:FVal radius:FVal falloff:rest) = - lift (setPrimLight pk (if light == 0 then Nothing else Just (LightInfo (r,g,b) intensity radius falloff))) >> return rest -updatePrimLight _ _ = fail "insufficient or incorrect parameters for PRIM_POINT_LIGHT" - -updatePrimBumpShiny pk params = - let extract (IVal face:IVal bump:IVal shiny:rest) = return (face, [IVal bump, IVal shiny], rest) - extract _ = fail ("insufficient or incorrect parameters for PRIM_BUMP_SHINY") - update [IVal bump, IVal shiny] face = face { faceBumpiness = bump, faceShininess = shiny } - in updatePrimFaceParams pk params extract update -updatePrimColor pk params = - let extract (IVal face:VVal r g b:FVal alpha:rest) = return (face,[VVal r g b, FVal alpha], rest) - extract _ = fail ("insufficient or incorrect parameters for PRIM_COLOR") - update [color, FVal alpha] face = face { faceColor = vVal2Vec color, faceAlpha = alpha } - in updatePrimFaceParams pk params extract update -updatePrimTexture pk params = - let extract (IVal face:name@(SVal _):repeats@(VVal _ _ _):offsets@(VVal _ _ _):rotation@(FVal _):rest) = - return (face,[name,repeats,offsets,rotation],rest) - extract _ = fail ("insufficient or incorrect parameters for PRIM_TEXTURE") - update [SVal name,repeats,offsets,FVal rotation] face = - face { faceTextureInfo = TextureInfo name (vVal2Vec repeats) (vVal2Vec offsets) rotation } - in updatePrimFaceParams pk params extract update -updatePrimTexgen pk params = - let extract (IVal face:IVal mode:rest) = return (face,[IVal mode],rest) - extract _ = fail "insufficient or incorrect parameters for PRIM_TEXGEN" - update [IVal mode] face = face { faceTextureMode = mode } - in updatePrimFaceParams pk params extract update -updatePrimFullbright pk params = - let extract (IVal face:IVal fullbright:rest) = return (face,[IVal fullbright],rest) - extract _ = fail "insufficient or incorrect parameters for PRIM_FULLBRIGHT" - update [IVal fullbright] face = face { faceFullbright = if fullbright == 0 then False else True } - in updatePrimFaceParams pk params extract update - -updatePrimFaceParams pk params extract update = do - (face, faceParams, rest) <- extract params -- this can fail - prim <- getPrim pk - let prim' = if face == -1 - then prim { primFaces = map (update faceParams) $ primFaces prim } - else let (xs,ys) = splitAt face (primFaces prim) in - if null ys then prim else prim { primFaces = xs ++ [(update faceParams $ head ys)] ++ (tail ys) } - lift $ setPrim pk prim' - return rest - -updatePrimTypeBoxCylPrism ptype prim (IVal holeshape:VVal cx cy cz:FVal hollow:VVal twx twy twz:VVal tx ty tz:VVal sx sy sz:rest) = - return (prim { primTypeInfo = (primTypeInfo prim) { primTypeCode = ptype, primHoleshape = holeshape, primCut = (cx,cy,cz), - primHollow = hollow, primTwist = (twx,twy,twz), primTaper = (tx,ty,tz), - primTopshear = (sx,sy,sz) }}, rest) -updatePrimTypeBoxCylPrism _ _ _ = fail "insufficient or incorret parameters for PRIM_TYPE (PRIM_TYPE_PRISM, PRIM_TYPE_CYLINDER, or PRIM_TYPE_BOX)" -updatePrimTypeSphere prim (IVal holeshape:VVal cx cy cz:FVal hollow:VVal tx ty tz:VVal ax ay az:rest) = - return (prim { primTypeInfo = (primTypeInfo prim) { primTypeCode = cPrimTypeSphere, primHoleshape = holeshape, primCut = (cx,cy,cz), - primHollow = hollow, primTwist = (tx,ty,tz), primAdvancedCut = (ax,ay,az) } }, rest) -updatePrimTypeSphere _ _ = fail "insufficient or incorrect parameters for PRIM_TYPE (PRIM_TYPE_SPHERE)" -updatePrimTypeRingTorusTube ptype prim (IVal holeshape:VVal cx cy cz:FVal hollow:VVal twx twy twz:VVal hx hy hz:VVal sx sy sz: - VVal ax ay az:VVal tx ty tz:FVal revs:FVal roffset:FVal skew:rest) = - return (prim { primTypeInfo = (primTypeInfo prim) { primTypeCode = ptype, primHoleshape = holeshape, primCut = (cx,cy,cz), - primHollow = hollow, primTwist = (twx,twy,twz), primHolesize = (hx,hy,hz), - primTopshear = (sx,sy,sz), primAdvancedCut = (ax,ay,az), primTaper = (tx,ty,tz), - primRevolutions = revs, primRadiusOffset = roffset, primSkew = skew } }, rest) -updatePrimTypeRingTorusTube _ _ _ = fail "insufficient or incorrect parameters for PRIM_TYPE (PRIM_TYPE_RING, PRIM_TYPE_TORUS, or PRIM_TYPE_TUBE)" -updatePrimTypeSculpt prim (SVal name:IVal sculptType:rest) = - return (prim { primTypeInfo = (primTypeInfo prim) { primTypeCode = cPrimTypeSculpt, primSculptTexture = Just name, primSculptType = sculptType } }, rest) -updatePrimTypeSculpt _ _ = fail "insufficient or incorrect parameters for PRIM_TYPE (PRIM_TYPE_SCULPT)" - -updatePrimTypeBoxCylPrismOld ptype prim (VVal cx cy cz:FVal hollow:FVal twisty:VVal tx ty tz:VVal sx sy sz:rest) = - let info = primTypeInfo prim in - return (prim { primTypeInfo = info { primTypeCode = ptype, primCut = (cx,cy,cz), primHollow = hollow, - primTwist = let (x,_,z) = primTwist info in (x,twisty,z), primTaper = (tx,ty,tz), - primTopshear = (sx,sy,sz) } }, rest) -updatePrimTypeBoxCylPrismOld _ _ _ = fail "insufficient or inccorrect parameters for deprecated prim type (PRIM_TYPE_BOX, PRIM_TYPE_CYLINDER, or PRIM_TYPE_PRISM)" - -updatePrimTypeSphereOld prim (VVal cx cy cz:FVal hollow:VVal ax ay az:rest) = - return (prim { primTypeInfo = (primTypeInfo prim) { primTypeCode = cPrimTypeSphere, primCut = (cx,cy,cz), primHollow = hollow, - primAdvancedCut = (ax,ay,az) }}, rest) -updatePrimTypeSphereOld _ _ = fail "insufficient or incorrect parameters for deprecated prim type (PRIM_TYPE_SPHERE)" - -updatePrimTypeTorusOld prim (VVal cx cy cz:FVal hollow:FVal twisty:FVal tapery:VVal sx sy sz:VVal ax ay az:rest) = - let info = primTypeInfo prim in - return (prim { primTypeInfo = info { primTypeCode = cPrimTypeTorus, primCut = (cx,cy,cz), primHollow = hollow, - primTwist = let (x,_,z) = primTwist info in (x,twisty,z), - primTaper = let (x,_,z) = primTaper info in (x,tapery,z), - primTopshear = (sx,sy,sz), primAdvancedCut = (ax,ay,az) } }, rest) -updatePrimTypeTorusOld _ _ = fail "insufficient or incorrect parameters for deprecated prim type (PRIM_TYPE_TORUS)" - -updatePrimTypeTubeOld prim (VVal cx cy cz:FVal hollow:FVal twisty:FVal shearx:rest) = - let info = primTypeInfo prim in - return (prim { primTypeInfo = info { primTypeCode = cPrimTypeTube, primCut = (cx,cy,cz), primHollow = hollow, - primTwist = let (x,_,z) = primTwist info in (x,twisty,z), - primTopshear = let (_,y,z) = primTopshear info in (shearx,y,z) } }, rest) -updatePrimTypeTubeOld _ _ = fail "insufficient or incorrect parameters for deprecated prim type (PRIM_TYPE_TUBE)" - -llGetObjectDetails _ [KVal k, LVal params] = - -- TODO: this doesn't take into account multiple regions - do (getAvatarDetails k params <||> getPrimDetails k params) >>= continueWith . LVal - where getAvatarDetails k params = - do avs <- lift getWorldAvatars - av <- mlookup k avs - return $ map (avq av) params - where avq av i | i == llcObjectName = SVal $ avatarName av - | i == llcObjectDesc = SVal "" - | i == llcObjectPos = vec2VVal $ avatarPosition av - | i == llcObjectRot = rot2RVal $ avatarRotation av - | i == llcObjectVelocity = VVal 0.0 0.0 0.0 -- TODO: avatar velocities - | i == llcObjectOwner = KVal k - | i == llcObjectGroup = KVal nullKey - | i == llcObjectCreator = KVal nullKey - | otherwise = llcObjectUnknownDetail - getPrimDetails k params = - do prim <- getPrim k - pos <- getObjectPosition k - rot <- getObjectRotation k - vel <- getObject k >>= return . objectVelocity . objectDynamics - return $ map (primq prim pos rot vel) params - where primq prim pos rot vel i | i == llcObjectName = SVal $ primName prim - | i == llcObjectDesc = SVal $ primDescription prim - | i == llcObjectPos = vec2VVal $ pos - | i == llcObjectRot = rot2RVal $ rot - | i == llcObjectVelocity = vec2VVal $ vel - | i == llcObjectOwner = KVal $ primOwner prim - | i == llcObjectGroup = KVal nullKey -- TODO: prim groups - | i == llcObjectCreator = KVal $ primOwner prim -- TODO: prim creators - | otherwise = llcObjectUnknownDetail - --------------------------------------------------------------------------------------------------------------- -llAllowInventoryDrop info@(ScriptInfo _ _ _ k _) [IVal add] = - (getPrim k >>= return . (\ p -> p { primAllowInventoryDrop = add /= 0 }) >>= lift . setPrim k >> - lift (logFromScript info ("drop is now " ++ (if add == 0 then "not " else "") ++ "allowed"))) >> - continueWith VoidVal - -llAdjustSoundVolume info [FVal f] = lift $ do - do if (f < 0.0 || f > 1.0) then logFromScript info ("llAdjustSoundVolume: volume " ++ show f ++ " out of range.") - else logFromScript info ("llAdjustSoundVolume: volume adjusted to " ++ show f) - continueWith VoidVal ------------------------------------------------------------------------------------------------------------------ --- Parcel related functions - -llSetParcelMusicURL info@(ScriptInfo _ _ _ pk _) [SVal url] = - -- parcel music URL is a write-only value, so we won't worry about setting anything.... - do -- make sure object owner == parcel owner - (_,_,parcel) <- getPrimParcel pk - owner <- getPrimOwner pk - when (parcelOwner parcel /= owner) $ throwError ("prim doesn't have permission to modify parcel") - lift $ logFromScript info ("setting music url for parcel " ++ parcelName parcel ++ " to " ++ url) - continueWith VoidVal - -llGetParcelFlags info@(ScriptInfo _ _ _ pk _) [VVal x y z] = - do regionIndex <- getPrimRegion pk - (_,parcel) <- getParcelByPosition regionIndex (x,y,z) - continueWith $ IVal $ parcelFlags parcel - -llGetParcelDetails info@(ScriptInfo _ _ _ pk _) [VVal x y z, LVal details] = - do regionIndex <- getPrimRegion pk - (_,parcel) <- getParcelByPosition regionIndex (x,y,z) - detailList <- mapM (getDetail parcel) details - continueWith $ LVal [ d | Just d <- detailList] - where getDetail parcel (IVal detail) | detail == cParcelDetailsName = return $ Just $ SVal $ parcelName parcel - | detail == cParcelDetailsDesc = return $ Just $ SVal $ parcelDescription parcel - | detail == cParcelDetailsOwner = return $ Just $ KVal $ parcelOwner parcel - | detail == cParcelDetailsGroup = return $ Just $ KVal nullKey - | detail == cParcelDetailsArea = return $ Just $ FVal $ fromIntegral $ - let (bot,top,left,right) = parcelBoundaries parcel in (top - bot) * (right - left) - | otherwise = lift $ logFromScript info ("llGetParcelDetails: invalid detail flag: " ++ show detail) >> return Nothing - getDetail _ v = lift $ logFromScript info ("llGetParcelDetails: invalid detail: " ++ lslValString v) >> return Nothing - -whenParcelPermitted info pk action= do - (regionIndex,parcelIndex,parcel) <- getPrimParcel pk - prim <- getPrim pk - if parcelOwner parcel /= primOwner prim then lift $ logFromScript info "prim not permitted to change parcel" - else action regionIndex parcelIndex parcel >>= putParcel regionIndex parcelIndex - -addToLandACLList aclType aclFromParcel aclIntoParcel info@(ScriptInfo _ _ _ pk _) [KVal ak,FVal duration] = do - do - whenParcelPermitted info pk $ \ regionIndex parcelIndex parcel -> do - lift $ runAndLogIfErr ("attempt to change " ++ aclType ++ " unknown avatar " ++ ak) parcel $ do - avs <- lift getWorldAvatars - _ <- mlookup ak avs - when (duration < 0.0) $ lift $ logFromScript info (aclType ++ " change attempted with invalid duration: " ++ show duration) - t <- lift getTick - let acl = (ak, if duration == 0 then Nothing else Just $ t + durationToTicks duration) - let acllist = acl : ([ b | b@(k,Just expire) <- aclFromParcel parcel,expire < t, k /= ak] ++ - [ b | b@(k,Nothing) <- aclFromParcel parcel, k /= ak]) - let parcel' = aclIntoParcel parcel acllist - lift $ logFromScript info ("added " ++ ak ++ " to " ++ aclType ++ " list for parcel in " ++ (show regionIndex)) - return parcel' - continueWith VoidVal - -removeFromLandACLList aclFromParcel aclIntoParcel info@(ScriptInfo _ _ _ pk _) ak = do - whenParcelPermitted info pk $ \ regionIndex parcelIndex parcel -> do - avs <- lift getWorldAvatars - mlookup ak avs `catchError` (\ _ -> throwError ("unkown avatar " ++ ak)) - let acl = aclFromParcel parcel - return $ aclIntoParcel parcel [ ac | ac@(k,_) <- acl, k /= ak ] - - -llResetLandBanList info@(ScriptInfo _ _ _ pk _) [] = - do whenParcelPermitted info pk (\ regionIndex parcelIndex parcel -> return $ parcel { parcelBanList = [] }) - continueWith VoidVal -llResetLandPassList info@(ScriptInfo _ _ _ pk _) [] = - do whenParcelPermitted info pk (\ regionIndex parcelIndex parcel -> return $ parcel { parcelPassList = [] }) - continueWith VoidVal - -llRemoveFromLandPassList info [KVal ak] = - let aclFromParcel = parcelPassList - aclIntoParcel = (\ parcel list -> parcel { parcelPassList = list}) - in do removeFromLandACLList aclFromParcel aclIntoParcel info ak - lift $ logFromScript info ("llRemovFromLandPassList: removed " ++ ak) - continueWith VoidVal - -llRemoveFromLandBanList info [KVal ak] = - let aclFromParcel = parcelBanList - aclIntoParcel = (\ parcel list -> parcel { parcelBanList = list}) - in do removeFromLandACLList aclFromParcel aclIntoParcel info ak - lift $ logFromScript info ("llRemovFromLandBanList: removed " ++ ak) - continueWith VoidVal - -llAddToLandPassList info args = - let aclFromParcel = parcelPassList - aclIntoParcel = (\ parcel list -> parcel { parcelPassList = list }) - in addToLandACLList "pass" aclFromParcel aclIntoParcel info args -llAddToLandBanList info args = - let aclFromParcel = parcelBanList - aclIntoParcel = (\ parcel list -> parcel { parcelBanList = list }) - in addToLandACLList "ban" aclFromParcel aclIntoParcel info args - -llGetLandOwnerAt info@(ScriptInfo _ _ _ pk _) [VVal x y z] = - do regionIndex <- getPrimRegion pk - getParcelByPosition regionIndex (x,y,z) >>= continueWith . KVal . parcelOwner . snd - -llOverMyLand info@(ScriptInfo _ _ _ pk _) [KVal ak] = - do regionIndex <- getPrimRegion pk - owner <- getPrimOwner pk - avatars <- lift getWorldAvatars - i <- case M.lookup ak avatars of - Nothing -> lift $ logFromScript info "llOverMyLand: no such avatar" >> return 0 - Just av | avatarRegion av /= regionIndex -> lift $ logFromScript info "llOverMyLand: avatar not in sim" >> return 0 - | otherwise -> do - parcel <- getParcelByPosition regionIndex (avatarPosition av) - return $ if owner == (parcelOwner . snd) parcel then 1 else 0 - continueWith (IVal i) -------------------------------------------------------------------------------- --- EMAIL -llGetNextEmail info@(ScriptInfo _ _ sn pk _) [SVal addr, SVal subj] = - do emails <- getPrimPendingEmails pk - case find match emails of - Nothing -> return () - Just email -> do - lift $ pushDeferredScriptEvent (Event "email" [SVal $ show $ emailTime email, SVal $ emailAddress email, SVal $ emailSubject email, - SVal $ emailMessage email, IVal (length emails - 1)] M.empty) pk sn 0 - lift $ setPrimPendingEmails pk (filter (not . match) emails) - continueWith VoidVal - where match email = (addr == "" || addr == emailAddress email) && - (subj == "" || subj == emailSubject email) - -llEmail info@(ScriptInfo _ _ _ pk _) [SVal address, SVal subject, SVal message] = - do let suffix = "@lsl.secondlife.com" - let logit = lift $ logFromScript info ("llEmail: sending email to " ++ address) - if suffix `isSuffixOf` address - then let potentialKey = take (length address - length suffix) address in - do pending <- (getPrimPendingEmails potentialKey) <||> throwError ("LSL destination addresses unknown prim") - time <- lift $ getUnixTime - lift $ setPrimPendingEmails pk (pending ++ [Email subject address message time]) - logit - else logit - continueWith VoidVal -- should do a yield til... (20 second delay!) -------------------------------------------------------------------------------- -soundExists pk sound = do - sounds <- getPrimSounds pk - case findByInvName sound sounds of - Nothing -> do - result <- lift $ findAsset sound - case result of - Nothing -> return False - Just v -> return $ if isSoundAsset v then True else False - Just _ -> return True - -llTriggerSound info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal volume] = - do found <- soundExists pk sound - let message = if found then "llTriggerSound: triggering sound " ++ sound else "llTriggerSound: sound not found - " ++ sound - lift $ logFromScript info message - continueWith VoidVal - -llTriggerSoundLimited info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal volume, VVal t n e, VVal b s w] = - do when (t <= b || n <= s || e <= w) $ lift $ logFromScript info ("llTriggerSoundLimited: bounding box has zero or negative volume") - found <- soundExists pk sound - let message = if found then "llTriggerSoundLimited: triggering sound " ++ sound else "llTriggerSoundLimited: sound no found - " ++ sound - lift $ logFromScript info message - continueWith VoidVal - -llSound info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol, IVal q, IVal loop] = - do found <- soundExists pk sound - let message = if found then "llSound (deprecated): playing sound " ++ sound else "llSound (deprecated): sound not found - " ++ sound - lift $ logFromScript info message - continueWith VoidVal - -llPlaySound info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol] = - do - found <- soundExists pk sound - let message = if found then "llPlaySound: playing sound " ++ sound else "llPlaySound: sound not found - " ++ sound - lift $ logFromScript info message - continueWith VoidVal - -llCollisionSound info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol] = - do found <- soundExists pk sound - let message = if found then "llCollisionSound: setting collision sound to " ++ sound else "llCollisionSound: sound not found - " ++ sound - lift $ logFromScript info message - continueWith VoidVal - -llPreloadSound info@(ScriptInfo _ _ _ pk _) [SVal sound] = - do found <- soundExists pk sound - let message = if found then "llPreloadSound: loading sound " ++ sound else "llPreloadSound: sound not found - " ++ sound - lift $ logFromScript info message - continueWith VoidVal - -llSoundPreload info@(ScriptInfo _ _ _ pk _) [SVal sound] = - do found <- soundExists pk sound - let message = if found then "llSoundPreload: loading sound " ++ sound else "llSoundPreload: sound not found - " ++ sound - lift $ logFromScript info message - continueWith VoidVal - -llPlaySoundSlave info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol] = - do found <- soundExists pk sound - let message = if found then "llPlaySoundSlave: playing sound " ++ sound else "llPlaySoundSlave: sound not found - " ++ sound - lift $ logFromScript info message - continueWith VoidVal - -llLoopSoundSlave info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol] = - do found <- soundExists pk sound - let message = if found then "llLoopSoundSlave: playing sound " ++ sound else "llLoopSoundSlave: sound not found - " ++ sound - lift $ logFromScript info message - continueWith VoidVal - -llLoopSound info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol] = - do found <- soundExists pk sound - let message = if found then "llLoopSound: playing sound " ++ sound else "llLoopSound: sound not found - " ++ sound - lift $ logFromScript info message - continueWith VoidVal - -llLoopSoundMaster info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol] = - do found <- soundExists pk sound - let message = if found then "llLoopSoundMaster: playing sound " ++ sound else "llLoopSoundMaster: sound not found - " ++ sound - lift $ logFromScript info message - continueWith VoidVal - -llStopSound info [] = lift $ logFromScript info "llStopSound: stopping sound" >> continueWith VoidVal -llSetSoundRadius info [FVal radius] = - lift $ logFromScript info "llSetSoundRadius: called. In real sim, this function has no effect." >> continueWith VoidVal -llSetSoundQueueing info [IVal bool] = - lift $ logFromScript info ("llSetSoundQueuiing: set to " ++ (if bool /= 0 then "TRUE" else "FALSE")) >> continueWith VoidVal - ------------------------------------------------------------------------------- -llCollisionSprite info@(ScriptInfo _ _ _ pk _) [SVal impactSprite] = - do tk <- findTexture pk impactSprite - lift $ logFromScript info ("llCollisionSprite: set sprite to " ++ tk) - continueWith VoidVal --- - -llGetKey (ScriptInfo _ _ _ pk _) [] = continueWith $ KVal pk - -llGetOwnerKey info@(ScriptInfo _ _ _ pk _) [KVal k] = - do regionIndex <- getPrimRegion pk - mRegionIndex <- fromErrorT Nothing (getPrimRegion k >>= return . Just) - key <- case mRegionIndex of - Nothing -> (lift $ logFromScript info "llGetOwnerKey: object key not found") >> return k - Just regionIndex' | regionIndex /= regionIndex' -> (lift $ logFromScript info "llGetOwnerKey: object in different simulator") >> return k - | otherwise -> getPrimOwner k - continueWith (KVal key) - -llGetLinkNumber (ScriptInfo oid pid _ pk _) [] = - if pid /= 0 then continueWith (IVal $ pid + 1) else - do LSLObject { primKeys = links } <- getObject oid - continueWith $ IVal (if length links == 1 then 0 else 1) - -llGetUnixTime (ScriptInfo _ _ _ _ _) [] = - lift (getUnixTime >>= continueWith . IVal) - -llGetTimestamp (ScriptInfo _ _ _ _ _) [] = lift $ do - cal <- getTimeOfDay >>= return . toUTCTime - continueWith $ SVal $ printf "%04d-%02d-%02dT%02d:%02d:%02.6f" - (ctYear cal) (1 + (fromEnum $ ctMonth cal)) (ctDay cal) (ctHour cal) (ctMin cal) - (((fromIntegral $ ctSec cal) / (10.0^12 * (fromIntegral $ ctPicosec cal))) :: Float) - -llGetDate (ScriptInfo _ _ _ _ _) [] = lift (getUTCDate >>= continueWith . SVal) -llGetGMTclock (ScriptInfo _ _ _ _ _) [] = lift $ do - cal <- getTimeOfDay >>= return . toUTCTime - continueWith $ IVal $ (24 * ctHour cal) + (60 * ctMin cal) + (ctSec cal) - -llGetWallclock (ScriptInfo _ _ _ _ _) [] = lift $ do - cal <- getLocalTimeOfDay (-8) >>= return . toUTCTime - continueWith $ IVal $ (24 * ctHour cal) + (60 * ctMin cal) + (ctSec cal) -llGetTimeOfDay (ScriptInfo _ _ _ _ _) [] = lift $ do - t <- getTick - continueWith $ FVal $ (ticksToDuration (t `mod` durationToTicks 4.0)) -getUnixTime :: (Monad (StateT (World a) a), Monad a) => StateT (World a) a Int -getUnixTime = (liftM2 (+) getWorldZeroTime (getTick >>= return . floor . ticksToDuration)) >>= return . fromIntegral -getTimeOfDay :: (Monad (StateT (World a) a), Monad a) => StateT (World a) a ClockTime -getTimeOfDay = getUnixTime >>= return . (flip TOD 0) . fromIntegral - -getLocalTimeOfDay offset = getTimeOfDay >>= return . (addToClockTime (TimeDiff 0 0 0 offset 0 0 0)) - -getUTCDate :: (Monad (StateT (World a) a), Monad a, PrintfType (Int -> Int -> Int -> b)) => StateT (World a) a b -getUTCDate = do - cal <- getTimeOfDay >>= return . toUTCTime - return $ printf "%04d-%02d-%02d" (ctYear cal) (1 + fromEnum (ctMonth cal)) (ctDay cal) - -llGetRegionFPS _ _ = continueWith $ FVal 45.0 -llGetRegionTimeDilation _ _ = continueWith $ FVal 1.0 - -llGetTime (ScriptInfo _ _ sid pk _) [] = - do t <- lift getTick - script <- lift getWorldScripts >>= mlookup (pk,sid) - continueWith $ FVal $ ticksToDuration (t - scriptLastResetTick script) - -getAndResetTick pk sid = - do - scripts <- lift getWorldScripts - script <- mlookup (pk,sid) scripts - let t = scriptLastResetTick script - t' <- lift getTick - lift $ setWorldScripts (M.insert (pk,sid) (script { scriptLastResetTick = t' } ) scripts) - return $ t' - t - -llGetAndResetTime (ScriptInfo _ _ sid pk _) [] = - getAndResetTick pk sid >>= continueWith . FVal . ticksToDuration - -llResetTime (ScriptInfo _ _ sid pk _) [] = - getAndResetTick pk sid >> continueWith VoidVal - -llSetText info [SVal text, VVal r g b, FVal alpha] = lift $ setText "llSetText" 254 info text -llSetSitText info [SVal text] = lift $ setText "llSetSitText" 9 info text -llSetTouchText info [SVal text] = lift $ setText "llSetTouchText" 9 info text - -setText func lim info text = - do logFromScript info (func ++ ": setting text to " ++ text) - when (length text > lim) $ logFromScript info (func ++ ": text exceeds " ++ show lim ++ " character limit") - continueWith VoidVal - -llGetScriptName (ScriptInfo _ _ sid _ _) [] = continueWith (SVal sid) - -llGetNumberOfNotecardLines (ScriptInfo _ _ sn pk _) [SVal name] = - do notecards <- getPrimNotecards pk - key <- case find ((name==) . inventoryItemName) notecards of - Nothing -> (lift $ putChat (Just 20.0) pk 0 ("Couldn't find notecard " ++ name)) >> return nullKey - Just notecard -> do - key <- lift newKey - lift $ pushDataserverEvent pk sn key (show $ length $ invNotecardLines $ inventoryItemData notecard) - return key - continueWith (KVal key) - -llGetNotecardLine (ScriptInfo _ _ sn pk _) [SVal name, IVal lineNumber] = - do notecards <- getPrimNotecards pk - key <- case find ((name==) . inventoryItemName) notecards of - Nothing -> (lift $ putChat (Just 20.0) pk cDebugChannel ("Couldn't find notecard " ++ name)) >> return nullKey - Just notecard -> do - key <- lift newKey - let line = case lookupByIndex lineNumber $ invNotecardLines $ inventoryItemData notecard of - Nothing -> cEOF - Just v -> take 255 v - lift $ pushDataserverEvent pk sn key line - return key - continueWith (KVal key) - -llRequestInventoryData info@(ScriptInfo _ _ sn pk _) [SVal name] = do - do t <- lift getTick - landmarks <- getPrimLandmarks pk - landmark <- maybe (throwError ("no landmark named " ++ name)) (\ l -> return l) (findByInvName name landmarks) - let (_,v) = invLandmarkLocation $ inventoryItemData landmark - key <- lift newKey - lift $ pushDataserverEvent pk sn key (lslValString (vec2VVal v)) - return (YieldTil $ t + durationToTicks 1,KVal key) - -llGetLinkName (ScriptInfo oid _ _ _ _) [IVal linkNumber] = - do LSLObject { primKeys = links } <- getObject oid - name <- if length links == 0 - then if linkNumber == 0 - then getPrimName oid - else return nullKey - else case lookupByIndex (linkNumber - 1) links of - Nothing -> return nullKey - Just k -> getPrimName k - continueWith (SVal name) - -llGetStatus (ScriptInfo _ _ _ pk _) [IVal check] = - do status <- getPrimStatus pk - continueWith $ IVal $ case mssb check of - Nothing -> 0 - Just b -> if bit b .&. status /= 0 then 1 else 0 - where mssb i = foldl' (\ x y -> x `mplus` (if testBit i y then Just y else Nothing)) Nothing [31,30..0] - -llSetStatus info@(ScriptInfo _ _ _ pk _) [IVal mask, IVal val] = - do status <- getPrimStatus pk - let status' = if val == 0 - then status .&. (complement mask) - else status .|. mask - lift $ setPrimStatus pk status' - continueWith VoidVal - -llPassTouches info@(ScriptInfo _ _ _ pk _) [IVal val] = - lift $ setPrimPassTouches pk (if val /= 0 then True else False) >> continueWith VoidVal - -llPassCollisions info@(ScriptInfo _ _ _ pk _) [IVal val] = - lift $ setPrimPassCollisions pk (if val /= 0 then True else False) >> continueWith VoidVal - -llGetRegionCorner (ScriptInfo _ _ _ pk _) [] = - do (x,y) <- getPrimRegion pk - continueWith $ vec2VVal (256 * fromIntegral x, 256 * fromIntegral y, 0) - -llGetRegionFlags info@(ScriptInfo _ _ _ pk _) [] = - getPrimRegion pk >>= getRegion >>= return . regionFlags >>= continueWith . IVal - -llGetSimulatorHostname (ScriptInfo _ _ _ pk _) [] = - do (i,j) <- getPrimRegion pk - (continueWith . SVal) (show i ++ "x" ++ show j ++ ".example.com") - -llGetRegionName (ScriptInfo _ _ _ pk _) [] = - do regionIndex <- getPrimRegion pk - regions <- lift getWorldRegions - region <- mlookup regionIndex regions - continueWith $ SVal $ regionName region - -llGetAgentSize info@(ScriptInfo _ _ _ pk _) [KVal ak] = - do region <- getPrimRegion pk - avatars <- lift getWorldAvatars - size <- case M.lookup ak avatars of - Nothing -> lift $ logFromScript info ("llGetAgentSize: no such agent - " ++ ak) >> return (0,0,0) - Just av -> if avatarRegion av == region - then return $ (0.45,0.6,avatarHeight av) - else lift $ logFromScript info ("llGetAgentSize: agent not in sim") >> return (0,0,0) - continueWith (vec2VVal size) - -llGetAgentInfo info@(ScriptInfo _ _ _ pk _) [KVal ak] = - do region <- getPrimRegion pk - avatars <- lift getWorldAvatars - i <- case M.lookup ak avatars of - Nothing -> lift $ logFromScript info ("llGetAgentInfo: no such agent - " ++ ak) >> return 0 - Just av -> if avatarRegion av == region then return $ avatarState av - else lift $ logFromScript info ("llGetAgentInfo: agent not in sim") >> return 0 - continueWith (IVal i) - --- llDetected* functions ------------------------------------------------------ --- TODO: only setup for 1 detected thing at a time... --- This is a problem especially for sensor testing - -llDetectedKey (ScriptInfo _ _ _ pk mevent) [IVal i] = - continueWith $ maybe (KVal nullKey) id $ do - event <- mevent - M.lookup ("key_" ++ show i) (eventInfo event) - -llDetectedLinkNumber (ScriptInfo _ _ _ pk mevent) [IVal i] = - continueWith $ maybe (IVal 0) id (mevent >>= M.lookup ("integer_" ++ (show i)) . eventInfo) - -llDetectedGrab (ScriptInfo _ _ _ _ mevent) [IVal i] = - continueWith $ maybe (VVal 0 0 0) id (mevent >>= M.lookup ("vector_" ++ show i) . eventInfo) - -llDetectedPos (ScriptInfo _ _ _ _ mevent) [IVal i] = - do avatars <- lift getWorldAvatars - Just event <- return mevent - KVal key <- mlookup ("key_" ++ show i) (eventInfo event) - v <- case M.lookup key avatars of - Just av -> return $ avatarPosition av - Nothing -> getRootPrim key >>= getObjectPosition - continueWith (vec2VVal v) - -llDetectedRot (ScriptInfo _ _ _ _ mevent) [IVal i] = - do - avatars <- lift getWorldAvatars - Just event <- return mevent - KVal key <- mlookup ("key_" ++ show i) (eventInfo event) - r <- case M.lookup key avatars of - Just av -> return $ avatarRotation av - Nothing -> getRootPrim key >>= getObjectRotation - continueWith (rot2RVal r) - -llDetectedName (ScriptInfo _ _ _ _ mevent) [IVal i] = - do avatars <- lift getWorldAvatars - Just event <- return mevent - KVal key <- mlookup ("key_" ++ show i) (eventInfo event) - name <- case M.lookup key avatars of - Just av -> return $ avatarName av - Nothing -> getPrimName key - continueWith (SVal name) - -llDetectedOwner (ScriptInfo _ _ _ _ mevent) [IVal i] = - do avatars <- lift getWorldAvatars - Just event <- return mevent - KVal key <- mlookup ("key_" ++ show i) (eventInfo event) - k <- case M.lookup key avatars of - Just av -> return key - Nothing -> getPrimOwner key - continueWith (KVal k) - -llDetectedGroup info@(ScriptInfo _ _ _ _ mevent) [IVal i] = - do Just event <- return mevent - KVal key <- mlookup ("key_" ++ show i) (eventInfo event) <||> throwError ("index " ++ show i ++ " out of range") - avatars <- lift getWorldAvatars - prims <- lift getPrims - k <- (mlookup key avatars >>= return . fromMaybe nullKey . avatarActiveGroup) <||> - (mlookup key prims >>= return . fromMaybe nullKey . primGroup) <||> throwError ("error: key not an avatar or an object!") - continueWith (KVal k) - -llDetectedVel _ [IVal i] = continueWith $ VVal 0 0 0 -- TODO: physics!!! - -llDetectedType (ScriptInfo _ _ _ _ mevent) [IVal i] = - do Just event <- return mevent - KVal key <- mlookup ("key_" ++ show i) (eventInfo event) - avatars <- lift getWorldAvatars - t <- case M.lookup key avatars of - Just _ -> return cAgent - Nothing -> determineActivePassiveScripted key - continueWith (IVal t) - -determineActivePassiveScripted key = do - status <- getPrimStatus key - case status of - st | st .&. cStatusPhysics /= 0 -> return cActive - | otherwise -> do - scripts <- getPrimScripts key - return (if length scripts > 0 then cScripted else cPassive) - -------------------------------------------------------------------------------- --- animation functions - -llGetAnimationList info@(ScriptInfo _ _ _ pk _) [KVal ak] = - do rp <- getPrimRegion pk - avatars <- lift getWorldAvatars - list <- case M.lookup ak avatars of - Nothing -> lift $ logFromScript info ("llGetAnimationList: no such avatar: " ++ ak) >> return [] - Just av | avatarRegion av /= rp -> lift $ logFromScript info ("llGetAnimationList: avatar not in sim") >> return [] - | otherwise -> do - now <- lift getTick - return [ KVal anim | (t,anim) <- avatarActiveAnimations av, maybe True (<now) t] - continueWith (LVal list) - -llGetAnimation info@(ScriptInfo _ _ _ pk _) [KVal ak] = - do rp <- getPrimRegion pk - avatars <- lift getWorldAvatars - nm <- case M.lookup ak avatars of - Nothing -> lift $ logFromScript info ("llGetAnimation: no such avatar: " ++ ak) >> return "" - Just av | avatarRegion av /= rp -> lift $ logFromScript info ("llGetAnimationList: avatar no in sim") >> return "" - | otherwise -> return "Standing" -- TODO: real animation state - continueWith (SVal nm) - -llStartAnimation info@(ScriptInfo _ _ sid pk _) [SVal anim] = - do avKey <- getPermittedAvKey info "llStartAnimation" cPermissionTriggerAnimation - case avKey of - Nothing -> return () - Just ak -> do - avatars <- lift getWorldAvatars - av <- mlookup ak avatars - let anims = avatarActiveAnimations av - now <- lift getTick - result <- findAnimation pk anim - case result of - Just (key,mduration) -> do - let anims' = updateAnims anims now mduration key - lift $ setWorldAvatars (M.insert ak (av { avatarActiveAnimations = anims' }) avatars) - Nothing -> lift $ logFromScript info ("llStartAnimation: animation not found - " ++ anim) - where updateAnims anims now mduration key = - (expire,key):[(t,k) | (t,k) <- anims, (maybe True (<now) t) && key /= k] - where expire = fmap ((now+) . durationToTicks) mduration - continueWith VoidVal - -findAnimation pk anim = - do primAnims <- getPrimAnimations pk - case find (\ item -> invName item == anim) primAnims of - Just item -> do - return $ Just (snd $ inventoryItemNameKey $ inventoryItemIdentification item, invAnimationDuration $ inventoryItemData item) - Nothing -> - case find (\ (name,_,_) -> name == anim) builtInAnimations of - Just (_,key,mduration) -> return $ Just (key,mduration) - Nothing -> return Nothing - -llStopAnimation info@(ScriptInfo _ _ sid pk _) [SVal anim] = - do avKey <- getPermittedAvKey info "llStartAnimation" cPermissionTriggerAnimation - case avKey of - Nothing -> return () - Just ak -> do - avatars <- lift getWorldAvatars - av <- mlookup ak avatars - let anims = avatarActiveAnimations av - result <- findAnimation pk anim - case result of - Just (key,_) -> do - case find (\ (_,k) -> k == key) anims of - Nothing -> lift $ logFromScript info "llStopAnimation: animation not active" - Just _ -> do - let anims' = [(expire,k) | (expire,k) <- anims, k /= key] - lift $ setWorldAvatars $ M.insert ak (av { avatarActiveAnimations = anims' }) avatars - Nothing -> lift $ logFromScript info ("llStopAnimation: animation not found - " ++ anim) - continueWith VoidVal - -llSetClickAction info [IVal action] = - lift $ (if action `elem` cClickActions then logFromScript info "llSetClickAction: setting click action" - else logFromScript info "llSetClickAction: invalid click action") >> continueWith VoidVal -------------------------------------------------------------------------------- --- XML RPC related functions -llCloseRemoteDataChannel info@(ScriptInfo _ _ sn pk _) [KVal key] = - do -- according to LSL wiki this function has no effect, - -- so we'll just log a message indicating whether or not the passed in key is valid - (lookupScriptFromChan key) <||> throwError "key not an open channel" - return () - continueWith VoidVal - -llOpenRemoteDataChannel info@(ScriptInfo _ _ sn pk _) [] = - do key <- lookupDataChannel (pk,sn) <||> lift newKey - insertScriptChannelPair (pk,sn) key - lift $ logFromScript info ("pushing remote data channel to script") - lift $ pushDeferredScriptEvent (Event "remote_data" [llcRemoteDataChannel, KVal key, KVal nullKey, SVal "", IVal 0, SVal ""] M.empty) pk sn 0 - continueWith VoidVal - -llSendRemoteData info [KVal channel, SVal dest, IVal idata, SVal sdata] = - do -- according to LSL Wiki, this function doesn't do anything... but we'll check - -- for a valid channel and log a message. - lookupScriptFromChan channel <||> throwError "key not an open channel" - lift newKey >>= continueWith . KVal - -llRemoteDataReply info@(ScriptInfo _ _ _ _ mevent) [KVal channel, KVal messageId, SVal sdata, IVal idata] = - do Just event <- return mevent - when (eventName event /= "remote_data") $ throwError "no effect unless called within remote_data handler" - let m = eventInfo event - (KVal k) <- mlookup "requestKey" m <||> throwError ("problem: invalid or mistyped request key in event") - lift $ putWorldEvent 0 (XMLReplyEvent k channel messageId sdata idata) - lift $ logFromScript info ("llRemoteDataReply: (" ++ show channel ++ "," ++ show messageId ++ "," ++ show sdata ++ "," ++ - show idata ++ ")") - continueWith VoidVal - -llRemoteDataSetRegion info [] = lift $ logFromScript info "llRemoteDataSetRegion: this function has no effect" >> continueWith VoidVal -------------------------------------------------------------------------------- - -llDialog info@(ScriptInfo _ _ _ pk _) [KVal ak, SVal message, LVal buttons, IVal channel] = - do when (length message > 512) $ doErr "message too long, must be less than 512 characters" - when (null message) $ doErr "must supply a message" - when (not $ all (==LLString) $ map typeOfLSLValue buttons) $ doErr "button list must contain only strings" - let buttons' = take 12 $ map ( \ (SVal s) -> s) buttons - when (any ((24 <) . length) buttons') $ doErr "Button Labels cannot have more that 24 characters" - when (any null buttons') $ doErr "all buttons must have label strings" - (lift getWorldAvatars >>= mlookup ak) <||> throwError ("no such agent/avatar - " ++ ak) - lift $ putWorldEvent 0 (DialogEvent ak message buttons' channel pk) -- deprecated! - lift $ putWorldEvent 0 (AvatarInputEvent ak (AvatarDialog message buttons' channel pk)) - continueWith VoidVal - where doErr msg = (lift $ putChat (Just 20) pk cDebugChannel ("llDialog: " ++ msg)) >> throwError msg -------------------------------------------------------------------------------- --- old (deprecated) functions for visual effects - -llMakeExplosion info _ = lift $ logFromScript info "llMakeExplosion: deprecated" >> continueWith VoidVal -llMakeSmoke info _ = lift $ logFromScript info "llMakeSmoke: deprecated" >> continueWith VoidVal -llMakeFire info _ = lift $ logFromScript info "llMakeFire: deprecated" >> continueWith VoidVal -llMakeFountain info _ = lift $ logFromScript info "llMakeFountain: deprecated" >> continueWith VoidVal - --------------------------------------------------------------------------------- -llTakeControls info@(ScriptInfo {scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [IVal controls, IVal accept, IVal pass] = - do allScripts <- lift getWorldScripts - script <- mlookup (pk,sn) allScripts - case scriptLastPerm script of - Nothing -> lift $ logFromScript info "no persmission to take controls from any agent" - Just ak -> do - av <- getWorldAvatar ak - maybe (throwError $ "no permission to take controls from " ++ avatarName av) - (\ perms -> if perms .&. cPermissionTakeControls /= 0 - then when (accept /= 0) $ lift $ setWorldAvatar ak (av { avatarControlListener = Just acl }) - else (throwError $ "no permission to take controls from " ++ avatarName av)) - (M.lookup ak $ scriptPermissions script) - where acl = AvatarControlListener { avatarControlListenerMask = controls, avatarControlListenerScript = (pk,sn) } - continueWith VoidVal --------------------------------------------------------------------------------- - -llVolumeDetect info@(ScriptInfo { scriptInfoObjectKey = oid }) [IVal i] = - do obj <- getObject oid - lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectVolumeDetect = i /= 0 }}) - continueWith VoidVal - -llCollisionFilter info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn }) [SVal name, KVal k, IVal i] = - do allScripts <- lift getWorldScripts - script <- mlookup (pk,sn) allScripts - lift $ setWorldScripts (M.insert (pk,sn) (script { scriptCollisionFilter = (name,k, i /= 0) }) allScripts) - continueWith VoidVal - -llTarget info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [VVal x y z, FVal range] = - do allScripts <- lift getWorldScripts - script <- mlookup (pk,sn) allScripts - let index = scriptTargetIndex script - let script' = script {scriptTargetIndex = index + 1, - scriptPositionTargets = IM.insert index ((x,y,z),range) (scriptPositionTargets script) - } - lift $ setWorldScripts (M.insert (pk,sn) script' allScripts) - continueWith $ IVal index - -llTargetRemove info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [IVal tnumber] = - do allScripts <- lift getWorldScripts - script <- mlookup (pk,sn) allScripts - let script' = script { scriptPositionTargets = IM.delete tnumber (scriptPositionTargets script) } - lift $ setWorldScripts (M.insert (pk,sn) script' allScripts) - continueWith VoidVal - -llRotTarget info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [RVal x y z s, FVal err] = - do allScripts <- lift getWorldScripts - script <- mlookup (pk,sn) allScripts - let index = scriptTargetIndex script - let script' = script { scriptTargetIndex = index + 1, - scriptRotationTargets = IM.insert index ((x,y,z,s),err) (scriptRotationTargets script) - } - lift $ setWorldScripts (M.insert (pk,sn) script' allScripts) - continueWith VoidVal - -llRotTargetRemove info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [IVal tnumber] = - do allScripts <- lift getWorldScripts - script <- mlookup (pk,sn) allScripts - let script' = script { scriptRotationTargets = IM.delete tnumber (scriptRotationTargets script) } - lift $ setWorldScripts (M.insert (pk,sn) script' allScripts) - continueWith VoidVal - --------------------------------------------------------------------------------- -llGround info [VVal _ _ _] = continueWith (FVal 0) -- the world is flat! -llGroundContour info [VVal _ _ _] = continueWith (VVal 1 0 0) -- could be any vector -llGroundNormal info [VVal _ _ _] = continueWith (VVal 0 0 1) -- straight up! -llGroundSlope info [VVal _ _ _] = continueWith (VVal 0 1 0) --------------------------------------------------------------------------------- -llGetSunDirection info [] = lift $ do - az <- getTick >>= return . (*(pi/7200)) . ticksToDuration - let el = 80 * pi - continueWith $ vec2VVal (sin az * cos el, sin el, cos az * cos el) - --------------------------------------------------------------------------------- -llLoadURL info [KVal ak, SVal msg, SVal url] = do - getWorldAvatar ak - lift $ putWorldEvent 0 (AvatarInputEvent ak (AvatarLoadURL msg url)) - continueWith VoidVal - -llMapDestination info [SVal simName, (VVal x y z), (VVal _ _ _)] = do - case mevent of - Nothing -> do - attachment <- getPrimAttachment oid - case attachment of - Nothing -> lift $ logFromScript info ("prim neither attached nor touched, so call to llMapDestination is not valid") - Just (Attachment { attachmentKey = ak }) -> putIt ak - Just (Event "touch" _ m) -> - case M.lookup "key_0" m of - Just (SVal ak) -> putIt ak - _ -> throwError "invalid touch event!" - continueWith VoidVal - where oid = scriptInfoObjectKey info - mevent = scriptInfoCurrentEvent info - putIt ak = lift $ putWorldEvent 0 (AvatarInputEvent ak (AvatarMapDestination simName (x,y,z))) --------------------------------------------------------------------------------- -continueWith val = return (EvalIncomplete,val) - -defaultPredefs :: Monad m => M.Map String (PredefFunc m) -defaultPredefs = M.fromList $ map (\(x,y) -> (x, defaultPredef x y)) [ - ("llAddToLandBanList",llAddToLandBanList), - ("llAddToLandPassList",llAddToLandPassList), - ("llAdjustSoundVolume",llAdjustSoundVolume), - ("llAllowInventoryDrop",llAllowInventoryDrop), - ("llApplyImpulse",llApplyImpulse), - ("llApplyRotationalImpulse", llApplyRotationalImpulse), - ("llAttachToAvatar",llAttachToAvatar), - ("llAvatarOnSitTarget",llAvatarOnSitTarget), - ("llBreakAllLinks",llBreakAllLinks), - ("llBreakLink",llBreakLink), - ("llClearCameraParams",llClearCameraParams), - ("llCloseRemoteDataChannel",llCloseRemoteDataChannel), - ("llCloud",llCloud), - ("llCollisionFilter", llCollisionFilter), - ("llCollisionSound",llCollisionSound), - ("llCollisionSprite",llCollisionSprite), - ("llCreateLink",llCreateLink), - ("llDetachFromAvatar", llDetachFromAvatar), - ("llDetectedGrab",llDetectedGrab), - ("llDetectedGroup",llDetectedGroup), - ("llDetectedKey", llDetectedKey), - ("llDetectedLinkNumber", llDetectedLinkNumber), - ("llDetectedName", llDetectedName), - ("llDetectedOwner", llDetectedOwner), - ("llDetectedPos", llDetectedPos), - ("llDetectedRot", llDetectedRot), - ("llDetectedType", llDetectedType), - ("llDetectedVel", llDetectedVel), - ("llDialog", llDialog), - ("llDie",llDie), - ("llEjectFromLand",llEjectFromLand), - ("llEmail",llEmail), - ("llFrand",llFrand), - ("llGetAccel",llGetAccel), - ("llGetAgentInfo",llGetAgentInfo), - ("llGetAgentSize",llGetAgentSize), - ("llGetAlpha",llGetAlpha), - ("llGetAndResetTime", llGetAndResetTime), - ("llGetAnimation", llGetAnimation), - ("llGetAnimationList",llGetAnimationList), - ("llGetAttached",llGetAttached), - ("llGetBoundingBox",llGetBoundingBox), - ("llGetCameraPos",llGetCameraPos), - ("llGetCameraRot",llGetCameraRot), - ("llGetColor",llGetColor), - ("llGetCreator",llGetCreator), - ("llGetDate",llGetDate), - ("llGetForce", llGetForce), - ("llGetGeometricCenter",llGetGeometricCenter), - ("llGetGMTclock",llGetGMTclock), - ("llGetInventoryCreator",llGetInventoryCreator), - ("llGetInventoryKey",llGetInventoryKey), - ("llGetInventoryName",llGetInventoryName), - ("llGetInventoryNumber",llGetInventoryNumber), - ("llGetInventoryPermMask", llGetInventoryPermMask), - ("llGetInventoryType",llGetInventoryType), - ("llGetKey",llGetKey), - ("llGetLocalPos",llGetLocalPos), - ("llGetNextEmail",llGetNextEmail), - ("llGetNumberOfPrims",llGetNumberOfPrims), - ("llGetNumberOfSides",llGetNumberOfSides), - ("llGetLinkKey",llGetLinkKey), - ("llGetLinkName",llGetLinkName), - ("llGetLinkNumber", llGetLinkNumber), - ("llGetLocalRot", llGetLocalRot), - ("llGetLandOwnerAt", llGetLandOwnerAt), - ("llGetMass",llGetMass), - ("llGetNotecardLine", llGetNotecardLine), - ("llGetNumberOfNotecardLines",llGetNumberOfNotecardLines), - ("llGetObjectDesc", llGetObjectDesc), - ("llGetObjectDetails", llGetObjectDetails), - ("llGetObjectMass", llGetObjectMass), - ("llGetObjectName", llGetObjectName), - ("llGetObjectPermMask", llGetObjectPermMask), - ("llGetObjectPrimCount",llGetObjectPrimCount), - ("llGetOmega",llGetOmega), - ("llGetOwner", llGetOwner), - ("llGetOwnerKey",llGetOwnerKey), - ("llGetParcelFlags", llGetParcelFlags), - ("llGetParcelDetails", llGetParcelDetails), - ("llGetPermissions",llGetPermissions), - ("llGetPermissionsKey",llGetPermissionsKey), - ("llGetPos", llGetPos), - ("llGetPrimitiveParams", llGetPrimitiveParams), - ("llGetRegionCorner", llGetRegionCorner), - ("llGetRegionFlags", llGetRegionFlags), - ("llGetRegionFPS", llGetRegionFPS), - ("llGetRegionName", llGetRegionName), - ("llGetRegionTimeDilation", llGetRegionTimeDilation), - ("llGetRot",llGetRot), - ("llGetRootPosition",llGetRootPosition), - ("llGetRootRotation",llGetRootRotation), - ("llGetScale", llGetScale), - ("llGetScriptName", llGetScriptName), - ("llGetScriptState", llGetScriptState), - ("llGetSimulatorHostname", llGetSimulatorHostname), - ("llGetStartParameter",llGetStartParameter), - ("llGetStatus",llGetStatus), - ("llGetSunDirection",llGetSunDirection), - ("llGetTexture", llGetTexture), - ("llGetTextureOffset", llGetTextureOffset), - ("llGetTextureRot", llGetTextureRot), - ("llGetTextureScale", llGetTextureScale), - ("llGetTime",llGetTime), - ("llGetTimeOfDay",llGetTimeOfDay), - ("llGetTimestamp",llGetTimestamp), - ("llGetTorque",llGetTorque), - ("llGetUnixTime",llGetUnixTime), - ("llGetWallclock",llGetWallclock), - ("llGetVel",llGetVel), - ("llGiveInventory", llGiveInventory), - ("llGiveMoney",llGiveMoney), - ("llGround", llGround), - ("llGroundContour", llGroundContour), - ("llGroundNormal", llGroundNormal), - ("llGroundRepel",llGroundRepel), - ("llGroundSlope",llGroundSlope), - ("llHTTPRequest",llHTTPRequest), - ("llInstantMessage",llInstantMessage), - ("llKey2Name", llKey2Name), - ("llListRandomize",llListRandomize), - ("llListen", llListen), - ("llListenControl",llListenControl), - ("llListenRemove",llListenRemove), - ("llLoadURL",llLoadURL), - ("llLookAt", llLookAt), - ("llLoopSound",llLoopSound), - ("llLoopSoundSlave",llLoopSoundSlave), - ("llLoopSoundMaster", llLoopSoundMaster), - ("llMakeExplosion",llMakeExplosion), - ("llMakeFire",llMakeFire), - ("llMakeFountain",llMakeFountain), - ("llMakeSmoke",llMakeSmoke), - ("llMapDestination", llMapDestination), - ("llMessageLinked", llMessageLinked), - ("llMoveToTarget", llMoveToTarget), - ("llOffsetTexture", llOffsetTexture), - ("llOpenRemoteDataChannel", llOpenRemoteDataChannel), - ("llOverMyLand", llOverMyLand), - ("llOwnerSay", llOwnerSay), - ("llPassCollisions", llPassCollisions), - ("llPassTouches", llPassTouches), - ("llPlaySound", llPlaySound), - ("llPlaySoundSlave", llPlaySoundSlave), - ("llPointAt",llPointAt), - ("llPreloadSound", llPreloadSound), - ("llRefreshPrimURL", llRefreshPrimURL), - ("llRegionSay", llRegionSay), - ("llReleaseCamera", llReleaseCamera), - ("llRemoteDataReply", llRemoteDataReply), - ("llRemoteDataSetRegion", llRemoteDataSetRegion), - ("llRemoteLoadScript", llRemoteLoadScript), - ("llRemoveFromLandPassList",llRemoveFromLandPassList), - ("llRemoveFromLandBanList",llRemoveFromLandBanList), - ("llRemoveInventory",llRemoveInventory), - ("llRemoveVehicleFlags",llRemoveVehicleFlags), - ("llRequestAgentData", llRequestAgentData), - ("llRequestInventoryData",llRequestInventoryData), - ("llRequestPermissions",llRequestPermissions), - ("llRequestSimulatorData",llRequestSimulatorData), - ("llResetLandPassList",llResetLandPassList), - ("llResetLandBanList",llResetLandBanList), - ("llResetOtherScript",llResetOtherScript), - ("llResetScript",llResetScript), - ("llResetTime",llResetTime), - ("llRezAtRoot",llRezAtRoot), - ("llRezObject",llRezObject), - ("llRotLookAt",llRotLookAt), - ("llRotTarget",llRotTarget), - ("llRotTargetRemove",llRotTargetRemove), - ("llRotateTexture", llRotateTexture), - ("llSameGroup", llSameGroup), - ("llSay",llSay), - ("llScaleTexture", llScaleTexture), - ("llSensor",llSensor), - ("llSensorRemove",llSensorRemove), - ("llSensorRepeat",llSensorRepeat), - ("llSendRemoteData",llSendRemoteData), - ("llSetAlpha", llSetAlpha), - ("llSetBuoyancy", llSetBuoyancy), - ("llSetClickAction", llSetClickAction), - ("llSetColor", llSetColor), - ("llSetForce", llSetForce), - ("llSetForceAndTorque", llSetForceAndTorque), - ("llSetHoverHeight", llSetHoverHeight), - ("llSetLinkAlpha",llSetLinkAlpha), - ("llSetLinkColor",llSetLinkColor), - ("llSetLinkPrimitiveParams",llSetLinkPrimitiveParams), - ("llSetLinkTexture",llSetLinkTexture), - ("llSetLocalRot",llSetLocalRot), - ("llSetObjectName",llSetObjectName), - ("llSetObjectDesc",llSetObjectDesc), - ("llSetParcelMusicURL",llSetParcelMusicURL), - ("llSetPayPrice",llSetPayPrice), - ("llSetPos",llSetPos), - ("llSetPrimitiveParams",llSetPrimitiveParams), - ("llSetPrimURL",llSetPrimURL), - ("llSetRemoteScriptAccessPin", llSetRemoteScriptAccessPin), - ("llSetRot",llSetRot), - ("llSetScale",llSetScale), - ("llSetScriptState",llSetScriptState), - ("llSetSoundQueueing",llSetSoundQueueing), - ("llSetSoundRadius",llSetSoundRadius), - ("llSetSitText",llSetSitText), - ("llSetStatus",llSetStatus), - ("llSetText",llSetText), - ("llSetTexture",llSetTexture), - ("llSetTorque",llSetTorque), - ("llSetTouchText",llSetTouchText), - ("llSetVehicleFlags",llSetVehicleFlags), - ("llSitTarget",llSitTarget), - ("llShout",llShout), - ("llSleep", llSleep), - ("llSetTimerEvent",llSetTimerEvent), - ("llSound",llSound), - ("llSoundPreload", llSoundPreload), - ("llStartAnimation", llStartAnimation), - ("llStopAnimation", llStopAnimation), - ("llStopHover",llStopHover), - ("llStopLookAt",llStopLookAt), - ("llStopMoveToTarget", llStopMoveToTarget), - ("llStopPointAt", llStopPointAt), - ("llStopSound",llStopSound), - ("llTakeCamera",llTakeCamera), - ("llTakeControls",llTakeControls), - ("llTarget",llTarget), - ("llTargetRemove",llTargetRemove), - ("llTeleportAgentHome",llTeleportAgentHome), - ("llTriggerSound",llTriggerSound), - ("llTriggerSoundLimited",llTriggerSoundLimited), - ("llUnSit",llUnSit), - ("llVolumeDetect", llVolumeDetect), - ("llWhisper",llWhisper), - ("llWind",llWind), - ("llWater",llWater) - ] ++ map (\ (n,f) -> (n, defaultPredef n (\ i args -> lift $ f i args))) internalLLFuncs - -allFuncs = (map (\ (name,_,_) -> name) funcSigs) -implementedFuncs = (map fst $ M.toList (defaultPredefs::(M.Map String (PredefFunc Maybe)))) -unimplementedFuncs = S.toList (S.difference (S.fromList allFuncs) (S.fromList implementedFuncs)) - ---------------------------------------------------------------------------------------------------- -logFromScript :: Monad m => ScriptInfo -> String -> WorldM m () -logFromScript scriptInfo msg = logAMessage LogInfo (infoToLogSource scriptInfo) msg - -infoToLogSource info = (scriptInfoPrimKey info ++ ": " ++ scriptInfoScriptName info) - -addScript prim invScript = prim { primInventory = (invScript:(primInventory prim)) } - --- should monadify further... -getPrimInfo pkey = - do prims <- getPrims - case M.lookup pkey prims of - Nothing -> return Nothing - Just p -> - case primParent p of - Nothing -> return $ Just (pkey, 0, primName p) - Just p1Key -> do - objects <- getObjects - case M.lookup p1Key objects of - Nothing -> return Nothing - Just (LSLObject { primKeys = plist }) -> - case elemIndex pkey plist of - Nothing -> return Nothing - Just i -> return $ Just (p1Key, i, primName p) - -pushEvent e key sid = - do scripts <- getWorldScripts - case M.lookup (key,sid) scripts of - Nothing -> logAMessage LogWarn "sim" ("no such script: " ++ (show (key, sid)) ++ ", event: " ++ show e) - Just script -> setWorldScripts (M.insert (key,sid) (script { scriptEventQueue = (scriptEventQueue script) ++ [e] } ) scripts) - -pushEventToPrim e key = - runErrPrim key () (getPrimScripts key >>= mapM_ (lift . pushEvent e key) . (map invName)) - -pushEventToObject e key = - do objects <- getObjects - case M.lookup key objects of - Nothing -> logAMessage LogWarn "sim" ("no such object: " ++ key) - Just o -> mapM_ (pushEventToPrim e) (primKeys o) - -pushDataserverEvent pk sn key val = pushDeferredScriptEvent (Event "dataserver" [KVal key, SVal val] M.empty) pk sn 0 -pushChangedEventToObject oid val = pushDeferredScriptEventToObject (Event "changed" [IVal val] M.empty) oid 0 -pushAttachEvent pk k = pushDeferredScriptEventToPrim (Event "attach" [KVal k] M.empty) pk 0 - -pushDeferredScriptEvent event pk sn delay = - putWorldEvent delay (DeferredScriptEvent event (DeferredScriptEventScriptTarget (pk,sn))) -pushDeferredScriptEventToPrim event pk delay = - putWorldEvent delay (DeferredScriptEvent event (DeferredScriptEventPrimTarget pk)) -pushDeferredScriptEventToObject event oid delay = - putWorldEvent delay (DeferredScriptEvent event (DeferredScriptEventObjectTarget oid)) - -putHTTPTimeoutEvent pk sn key delay = - pushDeferredScriptEvent (Event "http_response" [KVal key, IVal 499, LVal [], SVal ""] M.empty) pk sn delay -putHTTPResponseEvent pk sn key status metadata body delay = - pushDeferredScriptEvent (Event "http_response" [KVal key, IVal status, LVal metadata, body] M.empty) pk sn delay - -getObject name = lift getObjects >>= mlookup name -setObject oid obj = getObjects >>= setObjects . M.insert oid obj -getObjectDynamics k = getObject k >>= return . objectDynamics -getObjectPosition k = getObjectDynamics k >>= return . objectPosition -getObjectRotation k = getObjectDynamics k >>= return . objectRotation - -newWorld slice maxt iq lib scripts avatars objs prims activeScripts regions keyIndex webHandling eventHandler log = World { - sliceSize = slice, - maxTick = maxt, - nextPause = slice, - wqueue = iq, - wlisteners = IM.empty, - nextListenerId = 0, - wobjects = objs, - wprims = prims, - worldScripts = activeScripts, - inventory = [], - tick = 0, - msglog = [LogMessage 0 LogWarn "init" s | s <- log ], - predefs = defaultPredefs, - randGen = mkStdGen 1, - wlibrary = lib, - wscripts = scripts, - worldEventHandler = fmap (flip (,) []) eventHandler, - worldAvatars = avatars, - worldBreakpointManager = emptyBreakpointManager, - worldSuspended = Nothing, - worldRegions = regions, - worldZeroTime = 0, - worldKeyIndex = keyIndex, - worldWebHandling = webHandling, - worldOutputQueue = [], - worldPendingHTTPRequests = [], - worldOpenDataChannels = (M.empty,M.empty), - worldXMLRequestRegistry = M.empty, - worldPhysicsTime = 0, - worldTargetCheckTime = 0, - worldLastPositions = M.empty, - worldCollisions = S.empty, - worldLandCollisions = S.empty, - worldTouches = M.empty, - worldTouchCheckTime = 0 - } - -putWorldEvent delay we = - do weq <- getWQueue - t <- getTick - setWQueue $ putWQ (t + max (durationToTicks delay) 1) we weq - -checkBp bp sm = - do bpm <- getWorldBreakpointManager - let (result,bpm',sm') = checkBreakpoint bp bpm sm - setWorldBreakpointManager bpm' - return (result,sm') - -updatePrim f key = - do prims <- getPrims - case M.lookup key prims of - Nothing -> logAMessage LogWarn "sim" ("prim " ++ key ++ " not found") - Just p -> do p' <- f p - setPrims (M.insert key p' prims) - -registerListener listener = - do listeners <- getListeners - id <- getNextListenerId - let id' = id + 1 - setNextListenerId id' - setListeners $ IM.insert id (listener,True) listeners - return id -unregisterListener pk sname id = - do listeners <- lift getListeners - (listener,_) <- ilookup id listeners - when (listenerScriptName listener /= sname && listenerPrimKey listener /= pk) - (throwError ("listener " ++ show id ++ " not registered for calling script")) - lift $ setListeners $ IM.delete id listeners -updateListener pk sname id active = - do listeners <- lift getListeners - (listener,_) <- ilookup id listeners - when (listenerScriptName listener /= sname && listenerPrimKey listener /= pk) - (throwError ("listener " ++ show id ++ " not registered for calling script")) - lift $ setListeners $ IM.insert id (listener,active) listeners - -processEvents :: (Monad m) => WorldM m () -processEvents = - do suspenseInfo <- getWorldSuspended - when (isNothing suspenseInfo) $ do - tick <- getTick - weq <- getWQueue - case takeWQ tick weq of - (Nothing,_) -> return () - (Just we,weq') -> - do setWQueue weq' - w <- queryWorld id - processEvent we - processEvents - where isNothing = maybe True (const False) - -processEvent (DeferredScriptEvent event (DeferredScriptEventScriptTarget (pk,sn))) = pushEvent event pk sn -processEvent (DeferredScriptEvent event (DeferredScriptEventPrimTarget pk)) = pushEventToPrim event pk -processEvent (DeferredScriptEvent event (DeferredScriptEventObjectTarget oid)) = pushEventToObject event oid -processEvent (CreatePrim name key) = - do worldPrims <- getPrims - objects <- getObjects - let prim = emptyPrim name key - setPrims (M.insert key prim worldPrims) - setObjects (M.insert key (LSLObject [key] defaultDynamics) objects) -processEvent (AddScript (name,script) key active) = - do scripts <- getWScripts - t <- getTick - case lookup script scripts of - Nothing -> logAMessage LogWarn "sim" ("no such script: " ++ script) - Just (Left s) -> do - scriptKey <- newKey - updatePrim (\ p -> return $ addScript p (scriptInventoryItem name scriptKey script)) key --- scripts <- getWorldScripts --- setWorldScripts (M.insert (key,name) ((mkScript (Invalid s)) { scriptActive = False, scriptStartTick = t, scriptLastResetTick = t, scriptEventQueue = []}) scripts) - Just (Right code) -> do - scriptKey <- newKey - updatePrim (\ p -> return $ addScript p (scriptInventoryItem name scriptKey script)) key - let sstate = initLSLScript code - scripts <- getWorldScripts - setWorldScripts (M.insert (key,name) ((mkScript sstate) { scriptStartTick = t, scriptLastResetTick = t }) scripts) -processEvent chat@(Chat chan name key msg location range) = - do listeners <- getListeners - locatedListeners <- mapM locateListener (IM.elems listeners) - let listeners'= [ l | (l,_,_) <- filter (matchListener chat) locatedListeners] - -- event goes to all UNIQUE addresses in list - let addresses = nub $ map listenAddress listeners' - mapM_ (\ (key',sid) -> pushEvent (Event "listen" [IVal chan, SVal name, KVal key, SVal msg] M.empty) key' sid) addresses - when (chan == 0) $ case range of - Nothing -> return () - Just dist -> pushChatToAvatars location dist - where locateListener (listener,active) = do - (VVal x y z) <- getPos (listenerPrimKey listener) - region <- getRegionIndex (listenerPrimKey listener) - return (listener,active,(region,(x,y,z))) - pushChatToAvatars location range = do - avatars <- getWorldAvatars >>= return . M.elems - mapM_ (pushChatToAvatar location range) avatars - pushChatToAvatar (region,pos) range avatar = - when (region == avatarRegion avatar && dist3d2 pos (avatarPosition avatar) <= range^2) $ do - putWorldEvent 0 $ (AvatarInputEvent (avatarKey avatar) (AvatarHearsChat name key msg)) -processEvent (WorldSimEvent name args) = - case M.lookup name eventDescriptors of - Nothing -> logAMessage LogWarn "sim" ("event " ++ name ++ " not understood") - Just def -> handleSimInputEvent def args -processEvent (PermissionRequestEvent pk sname ak mask) = - runAndLogIfErr ("can't find prim/script: " ++ pk ++ "/" ++ sname) () $ do - scripts <- lift getWorldScripts - script <- mlookup (pk,sname) scripts - let script' = script { scriptPermissions = M.insert ak mask (scriptPermissions script), scriptLastPerm = Just ak } - lift $ setWorldScripts (M.insert (pk,sname) script' scripts) - lift $ pushEvent (Event "run_time_permissions" [IVal mask] M.empty) pk sname -processEvent evt@(TimerEvent interval (primKey,scriptName)) = - do pushEvent (Event "timer" [] M.empty) primKey scriptName - putWorldEvent interval evt -processEvent evt@(SensorEvent (pk,sn) name key stype range arc rpt) = - runAndLogIfErr "problem processing sensor even" () $ do - t <- lift getTick - maybe (return ()) (\ interval -> lift $ putWorldEvent interval evt) rpt - sensedObjects <- senseObjects - sensedAvatars <- senseAvatars - let list = take 16 (sensedObjects ++ sensedAvatars) - if null list - then lift $ pushEvent (Event "no_sensor" [] M.empty) pk sn - else lift $ pushEvent (Event "sensor" [(IVal $ length list)] (M.fromList (zipWith (\ i k -> ("key_" ++ show i,KVal k)) [0..] list))) pk sn - where senseObjects = do - pos <- getGlobalPos pk - rot <- getGlobalRot pk - root <- getRootPrim pk - let fwd = fwdFromRot rot - prims <- rootPrims root - poss <- mapM getGlobalPos (map primKey prims) - let pprims = zip poss prims - statuses <- mapM objectStatus (map primKey prims) - return [ primKey p | ((pos,p),stat) <- zip pprims statuses, withinSensorArea pos fwd range arc pos, stat .&. stype /= 0] - senseAvatars = - if stype .&. cAgent /= 0 then do - pos <- getGlobalPos pk - rot <- getGlobalRot pk - attachKey <- getPrimAttachment pk >>= return . liftM attachmentKey - let fwd = fwdFromRot rot - avs <- allAvs attachKey - return [ avatarKey av | av <- avs, withinSensorArea pos fwd range arc (avatarPosition av)] - else return [] - fwdFromRot rot = let ((x,_,_),(y,_,_),(z,_,_)) = quaternionToMatrix rot in (x,y,z) - angleBetweenV (x0,y0,z0) (x1,y1,z1) = acos (x0*x1 + y0*y1 + z0*z1) - withinSensorArea origin direction range arc pos = - let v = diff3d pos origin - m = mag3d v - v' = norm3d v - in if m == 0 - then True - else m <= range && (angleBetweenV v' direction) <= arc - rootPrims exclude = do - objs <- lift getObjects - mapM getPrim [ k | LSLObject { primKeys = (k:_) } <- M.elems objs, exclude /= k] - objectStatus root = do - LSLObject { primKeys = pks } <- getObject root - stat <- foldM (\ x k -> determineActivePassiveScripted k >>= return . (x .|.)) 0 pks - if (stat .&. cActive /= 0 && stat .&. cPassive /= 0) - then return (stat .&. complement cPassive) - else return stat - allAvs exclude = do - avs <- lift getWorldAvatars - return [ av | av <- M.elems avs, exclude /= Just (avatarKey av)] -processEvent (HTTPRequestEvent (pk,sn) key url method mimetype maxlength verify body) = do - logAMessage LogDebug "sim" "processing an HTTP request event" - handling <- getWorldWebHandling - case handling of - WebHandlingByDoingNothing -> putHTTPTimeoutEvent pk sn key 60 - WebHandlingByFunction -> runAndLogIfErr "problem with handler" () $ do - (moduleName, state) <- lift getWorldEventHandler >>= maybe (throwError "no handler defined") return - lib <- lift getWLibrary - -- invoke the function to get the results - case simFunc lib (moduleName,"httpRequest") state [SVal url, SVal method, SVal mimetype, IVal maxlength, IVal verify, SVal body] of - Left s -> throwError s - Right (SVal msg,results) | not (null msg) -> do - lift $ setWorldEventHandler (Just (moduleName, results)) - throwError msg - | otherwise -> - let IVal status = maybe (IVal 200) id (lookup "outHttpStatus" results >>= ( \ val -> if isIVal val then Just val else Nothing)) - LVal metadata = maybe (LVal []) id (lookup "outHttpMetadata" results >>= ( \ val -> if isLVal val then Just val else Nothing)) - body = maybe (SVal "") id (lookup "outHttpBody" results >>= ( \ val -> if isSVal val then Just val else Nothing)) - events = maybe (LVal []) id (lookup "outEvents" results) - in do lift $ putHTTPResponseEvent pk sn key status metadata body 2 - lift $ processEventsList events - lift $ setWorldEventHandler (Just (moduleName, results)) - Right _ -> throwError ("invalid web handling function, must return a string") - WebHandlingByInternet timeout -> do - let event = SimEvent "http_request" [ - SimEventArg "url" url, - SimEventArg "prim" pk, - SimEventArg "script" sn, - SimEventArg "requestKey" key, - SimEventArg "HTTP_METHOD" method, - SimEventArg "HTTP_MIMETYPE" mimetype, - SimEventArg "HTTP_BODY_MAXLENGTH" (show maxlength), - SimEventArg "HTTP_VERIFY_CERT" (show verify), - SimEventArg "body" body] 0 - (getWorldOutputQueue >>= return . (event:) >>= setWorldOutputQueue) - (getWorldPendingHTTPRequests >>= return . (key:) >>= setWorldPendingHTTPRequests) - -- put a timeout event on the queue. 'real' time and sim time are much different, so the - -- 'real' world timeout is much different - putHTTPTimeoutEvent pk sn key timeout -processEvent (XMLRequestEvent source channel idata sdata) = - runAndLogIfErr "invalid xml request" () $ do - lift $ logAMessage LogInfo "sim" "processing XMLRequestEvent" - (pk,sn) <- lookupScriptFromChan channel <||> throwError ("no such channel" ++ channel) - key <- lift newKey - lift getWorldXMLRequestRegistry >>= return . (M.insert key source) >>= lift . setWorldXMLRequestRegistry - lift $ pushEvent (Event "remote_data" [llcRemoteDataRequest, KVal channel, KVal nullKey, SVal "", IVal idata, SVal sdata] - (M.fromList [("requestKey",KVal key)])) pk sn -processEvent (XMLReplyEvent key channel messageId sdata idata) = do - runAndLogIfErr "invalid xml reply" () $ do - source <- (lift getWorldXMLRequestRegistry >>= mlookup key) <||> throwError "missing source for XML request" - lift (getWorldXMLRequestRegistry >>= return . M.delete key >>= setWorldXMLRequestRegistry) - case source of - XMLRequestInternal tag -> do - (moduleName, state) <- lift getWorldEventHandler >>= maybe (throwError "no handler defined") return - lib <- lift getWLibrary - case simFunc lib (moduleName, "xmlReply") state [SVal tag, SVal channel, SVal sdata, IVal idata] of - Left s -> throwError s - Right (SVal msg, results) | not (null msg) -> do - lift $ setWorldEventHandler (Just (moduleName, results)) - throwError msg - | otherwise -> - let events = maybe (LVal []) id (lookup "outEvents" results) in do - lift $ processEventsList events - lift $ setWorldEventHandler (Just (moduleName, results)) - XMLRequestExternal tag -> do - let event = SimEvent "xml_reply" [ - SimEventArg "tag" tag, - SimEventArg "channel" channel, - SimEventArg "sdata" sdata, - SimEventArg "idata" (show idata)] 0 - lift $ (getWorldOutputQueue >>= return . (event:) >>= setWorldOutputQueue) -processEvent (DialogEvent agent message buttons channel source) = - runAndLogIfErr "invalid dialog event" () $ do - lift getWorldEventHandler >>= (\ mhandler -> case mhandler of - Nothing -> return () - Just (moduleName,state) -> do - lib <- lift getWLibrary - avName <- (lift getWorldAvatars >>= mlookup agent >>= return . avatarName) <||> throwError "problem finding avatar" - objName <- getPrimName source <||> throwError "problem finding object" - case hasFunc lib (moduleName,"dialog") of - Left s -> throwError s - Right False -> return () - Right True -> - case simFunc lib (moduleName, "dialog") state - [SVal avName, SVal message, LVal (map SVal buttons), IVal channel, SVal objName] of - Left s -> throwError s - Right (SVal msg, results) | not (null msg) -> do - warn - lift $ setWorldEventHandler (Just (moduleName, results)) - throwError msg - | otherwise -> - let (IVal selection) = maybe (IVal (-1)) id (lookup "outDialogButtonSelected" results) - events = maybe (LVal []) id (lookup "outEvents" results) - in do - warn - when (selection >= 0 && selection < length buttons) $ - lift $ putChat (Just 20.0) agent channel (buttons !! selection) - lift $ processEventsList events - lift $ setWorldEventHandler (Just (moduleName, results))) - where warn = lift $ logAMessage LogWarn "sim" - "the 'dialog' entry point for the world event handler is deprecated, use the avatar event handler instead" - -processEvent (RezObjectEvent links pos vel rot start pk copy atRoot) = - runAndLogIfErr "invalid rez object event" () $ do - when (null links) $ throwError "empty link set!" - -- reset positions relative to root - let geomCenter = scale3d ( 1 / fromIntegral (length links)) - (foldl' add3d (0,0,0) (map ((flip diff3d (0,0,0)) . primPosition) links)) - let pos' = if atRoot then pos else (pos `add3d` (neg3d geomCenter)) - let update = if copy then (\ p -> updateKeys p) else return - -- TODO: rotation and velocity - links' <- mapM update links - mapM activateScripts links' - let rootKey = primKey (head links') - lift (getObjects >>= return . M.insert rootKey (LSLObject (map primKey links') defaultDynamics { objectPosition = pos' }) >>= setObjects) - lift $ (getPrims >>= (\ m -> return (foldl' (\ m l -> M.insert (primKey l) l m) m links')) >>= setPrims) - lift $ pushEventToObject (Event "on_rez" [IVal start] M.empty) rootKey - lift $ pushEventToPrim (Event "object_rez" [KVal rootKey] M.empty) pk - where activateScripts prim = do - let scripts = [ item | item <- primInventory prim, isInvScriptItem item ] - let activateScriptItem item = - let InvScript id state = inventoryItemData item - name = inventoryItemName item in - activateScript (primKey prim) name id state start - mapM activateScriptItem scripts - updateKeys prim = do - key <- lift newKey - newInventory <- mapM updateItemKeys (primInventory prim) - return $ prim { primKey = key, primInventory = newInventory } - updateItemKeys item = do - key <- lift newKey - let name = inventoryItemName item - newData <- if isInvObjectItem item - then mapM updateKeys (invObjectPrims $ inventoryItemData item) >>= return . InvObject - else return (inventoryItemData item) - return $ item { inventoryItemIdentification = InventoryItemIdentification (name,key), inventoryItemData = newData } -processEvent (ResetScriptEvent pk sn) = - runAndLogIfErr "invalid reset script event" () (resetScript pk sn) -processEvent (DetachCompleteEvent oid ak) = - runAndLogIfErr "invalid detach complete event" () $ do - -- need to remove the object and it's prims and its active scripts from the live lists, but - -- save the script states - avatars <- lift getWorldAvatars - avatar <- mlookup ak avatars - LSLObject { primKeys = links } <- getObject oid - prims <- mapM passivatePrim links - when (null prims) $ throwError "object has no prims!" - let root = head prims - let object = InventoryItem (InventoryItemIdentification (primName root,primKey root)) - (InventoryInfo (primCreator root) (0x0008e000,0x0008e000,0x0008e000,0x0008e000,0x0008e000)) - (InvObject prims) - let avInv = avatarInventory avatar - lift $ setWorldAvatars (M.insert ak (avatar { avatarInventory = object:avInv }) avatars) - objects <- lift getObjects - lift $ setObjects (M.delete oid objects) - where passivatePrim pk = do - scriptItems <- getPrimScripts pk - mapM_ (moveScriptStateToPrim pk) (map inventoryItemName scriptItems) - prims <- lift getPrims - prim <- mlookup pk prims - lift $ setPrims $ M.delete pk prims - return prim - moveScriptStateToPrim pk sn = do - scripts <- lift getWorldScripts - script <- mlookup (pk,sn) scripts - let img = scriptImage script - primInv <- getPrimInventory pk - let (xs,ys) = break (\ item -> sn == inventoryItemName item) primInv - when (null ys) $ throwError ("script inexplicably not in inventory") - (y:ys') <- return ys - let scriptData = inventoryItemData y - lift $ setPrimInventory pk (((y { inventoryItemData = scriptData { invScriptState = Just img } }) : xs) ++ ys) - lift $ setWorldScripts (M.delete (pk,sn) scripts) -processEvent (GiveAvatarInventoryEvent ak item) = logAMessage LogInfo "sim" "giving avatar inventory: not implemented" -processEvent (AvatarOutputEvent ak avEv) = processAvatarOutputEvent ak avEv -processEvent (AvatarInputEvent ak avEv) = processAvatarInputEvent ak avEv -processEvent _ = error "not implemented" - -processEventsList (LVal []) = return () -processEventsList (LVal ((IVal i):l)) = do - processEventList (take i l) - processEventsList (LVal (drop i l)) -processEventsList _ = logAMessage LogWarn "sim" ("user supplied event handler has invalid type for 'outEvents' variable") - -processEventList [SVal "xml_request", SVal sourceId, KVal channel, IVal idata, SVal sdata, FVal delay] = do - putWorldEvent delay (XMLRequestEvent (XMLRequestInternal sourceId) channel idata sdata) -processEventList l = logAMessage LogWarn "sim" ("Invalid event from event handler: " ++ lslShowVal (LVal l)) - -processAvatarOutputEvent k (AvatarTouch {avatarTouchPrimKey = pk, avatarTouchDuration = secs}) = do - touches <- getWorldTouches - now <- getTick - setWorldTouches (M.alter (alt now) pk touches) - where alt start Nothing = Just [newTouch start] - alt start (Just ts) = Just (newTouch start:ts) - newTouch start = Touch {touchAvatarKey = k, touchPrimKey = pk, touchStartTick = start, touchEndTick = start + durationToTicks secs} -processAvatarOutputEvent k (AvatarWhisper {avatarChatChannel = chan, avatarChatMessage = msg}) = avChat 10 msg k chan -processAvatarOutputEvent k (AvatarSay {avatarChatChannel = chan, avatarChatMessage = msg}) = avChat 20 msg k chan -processAvatarOutputEvent k (AvatarShout {avatarChatChannel = chan, avatarChatMessage = msg}) = avChat 100 msg k chan -processAvatarOutputEvent k (AvatarPay {avatarPayPrimKey = pk, avatarPayAmount = val}) = runAndLogIfErr "problem handling avatar payment" () $ - primHasActiveHandler k "money" >>= flip when (lift $ pushEventToPrim (Event "money" [KVal pk, IVal val] M.empty) pk) -processAvatarOutputEvent k (AvatarControl { avatarNewControlBits = newBits }) = runAndLogIfErr "problem processing control change" () $ do - av <- getWorldAvatar k - let prev = avatarControls av - lift $ setWorldAvatar k (av { avatarControls = newBits }) - flip (maybe (return ())) (avatarControlListener av) $ - \ (AvatarControlListener {avatarControlListenerMask = mask, avatarControlListenerScript = (pk,sn)}) -> - lift $ pushEvent (Event "control" [KVal k, IVal newBits, IVal (newBits `xor` prev)] M.empty) pk sn ---processAvatarOutputEvent _ _ = error "not yet implemented(1)" - -avChat range msg key chan = runAndLogIfErr "problem processing chat" () $ do - av <- getWorldAvatar key - lift $ putWorldEvent 0 $ Chat chan (avatarName av) key msg (avatarRegion av,avatarPosition av) (Just range) - -processAvatarInputEvent k inputEvent = runAndLogIfErr "problem processing event for avatar" () $ do - av <- getWorldAvatar k - flip (maybe (return ())) (avatarEventHandler av) $ (\ (moduleName,state) -> do - lib <- lift getWLibrary - case callAvatarEventProcessor k moduleName inputEvent lib state of - Nothing -> return () - Just (Left s) -> throwError s - Just (Right (LVal events,result)) -> do - mapM_ (putAvatarOutputEvent k) events - lift $ setWorldAvatar k (av { avatarEventHandler = Just (moduleName,result) })) - -avEventProcCallInfo (AvatarOwnerSay key msg) = ("onOwnerSay",[SVal key, SVal msg]) -avEventProcCallInfo (AvatarHearsChat name key msg) = ("onChat",[SVal name, SVal key, SVal msg]) -avEventProcCallInfo (AvatarDialog msg buttons chan source) = ("onDialog",[SVal msg, LVal $ map SVal buttons, IVal chan, SVal source]) -avEventProcCallInfo (AvatarLoadURL msg url) = ("onLoadURL",[SVal msg, SVal url]) -avEventProcCallInfo (AvatarMapDestination simName position) = ("onMapDestination",[SVal simName, vec2VVal position]) -callAvatarEventProcessor k moduleName avEvent lib state = - case hasFunc lib (moduleName,funcName) of - Left s -> Just (Left s) - Right True -> Just $ simFunc lib (moduleName, funcName) state args - Right False -> Nothing - where (funcName,args) = avEventProcCallInfo avEvent - -putAvatarOutputEvent k (SVal s) = - case reads s of - ((ev,_):_) -> lift $ putWorldEvent 0 (AvatarOutputEvent k ev) - [] -> lift $ logAMessage LogWarn "sim" ("avatar event handler for " ++ k ++ " returned invalid event: " ++ show s) -putAvatarOutputEvent k v = lift $ logAMessage LogWarn "sim" ("avatar event handler for " ++ k ++ " returned invalid event: " ++ lslShowVal v) - -activateScript pk sn scriptId Nothing startParam = - do wscripts <- lift getWScripts - worldScripts <- lift getWorldScripts - case lookup scriptId wscripts of - Nothing -> lift $ logAMessage LogWarn "sim" ("script " ++ scriptId ++ " not found") - Just (Left s) -> lift $ logAMessage LogWarn "sim" ("script " ++ scriptId ++ " not valid") - Just (Right code) -> - lift $ setWorldScripts - (M.insert (pk,sn) (mkScript (initLSLScript code)) worldScripts) -activateScript pk sn _ (Just image) startParam = do - worldScripts <- lift getWorldScripts - lift $ setWorldScripts - (M.insert (pk,sn) ((mkScript image) { scriptStartParameter = startParam }) worldScripts) - -matchListener (Chat chan' sender' key' msg' (region,position) range) ((Listener pkey sid chan sender key msg),active,(region',position')) = - active && - region == region' && - chan == chan' && - key' /= pkey && - (sender == "" || sender == sender') && - (key == "" || key == nullKey || key == key') && - (msg == "" || msg == msg') && - (case range of - Nothing -> True - Just dist -> dist3d2 position position' <= dist^2) - -listenAddress l = (listenerPrimKey l, listenerScriptName l) - -nextActivity :: (Monad (StateT (World a) a), Monad a) => StateT (World a) a (Maybe Int) -nextActivity = - do scripts <- getWorldScripts - t <- getTick >>= return . (+1) - let ns = foldl' (calcNxt t) Nothing $ M.elems scripts - wq <- getWQueue - let ne = case wq of - [] -> Nothing - ((i,x):_) -> Just $ max t i - return $ mmin ne ns - where calcNxt t n (Script { scriptActive = False }) = n - calcNxt t n (Script { scriptImage = img , scriptEventQueue = q }) = - case executionState img of - Executing -> (Just t) - Suspended _ -> (Just t) - Waiting -> if null q then n else (Just t) - WaitingTil i -> if isNothing n then Just (max t i) else fmap (max t . min i) n - SleepingTil i -> if isNothing n then Just (max t i) else fmap (max t . min i) n - _ -> n - mmin Nothing Nothing = Nothing - mmin Nothing (Just i) = (Just i) - mmin (Just i) Nothing = (Just i) - mmin (Just i) (Just j) = Just (min i j) - -runScripts :: Monad m => WorldM m () -runScripts = - do scripts <- getWorldScripts - mapM_ findAndRunScript (M.keys scripts) - -findAndRunScript scriptKey = - do scripts <- getWorldScripts - case M.lookup scriptKey scripts of - Nothing -> return () - Just script -> checkAndRunScript scriptKey script -checkAndRunScript _ (Script { scriptActive = False }) = return () -checkAndRunScript k@(pkey,sname) (Script {scriptImage = img, scriptEventQueue = q}) = - do pInfo <- getPrimInfo pkey - suspenseInfo <- getWorldSuspended - case suspenseInfo of - Nothing -> run pInfo - Just (suspKey,suspName) | pkey == suspKey && suspName == sname -> run pInfo - | otherwise -> return () - where run pInfo = - case pInfo of - Nothing -> logAMessage LogWarn "sim" ("script " ++ (show k) ++ ": prim not found!") - Just (parent, index, primName) -> runScript parent index pkey sname primName img q -runScript parent index pkey sname primName img q = - do slice <- getSliceSize - tick <- getTick - let img' = img { scriptImageName = sname ++ "/" ++ primName ++ "/" ++ pkey } - let log = logTrace (pkey ++ ":" ++ sname) - --let checkBp _ sm = return (False,sm) - result <- executeLsl img' parent index sname pkey doPredef log getTick setTick checkBp q (tick + slice) - case result of - Left s -> logAMessage LogWarn "sim" ("execution error in script " ++ "(" ++ pkey ++ "," ++ sname ++ ") ->" ++ s) - Right (img'',q') -> do - scripts <- getWorldScripts - let result = M.lookup (pkey,sname) scripts - case result of - Nothing -> do logAMessage LogInfo "sim" ("script seems to have disappeared while executing (result of llDie?)") - Just script -> do - let script' = script { scriptImage = img'', scriptEventQueue = q' } - setWorldScripts (M.insert (pkey,sname) script' scripts) - case executionState img'' of - Suspended bp -> setWorldSuspended (Just (pkey,sname)) - _ -> setWorldSuspended Nothing - - -handleTouches :: Monad m => WorldM m () -handleTouches = do - now <- getTick - before <- getWorldTouchCheckTime - when (now - before > durationToTicks 0.05) $ do - touchLists <- getWorldTouches >>= return . M.toList - runAndLogIfErr "problem handling touches" () $ do - starts <- collectTouches "touch_start" M.empty $ - concatMap (\ (_,tl) -> [ touch | touch@(Touch { touchStartTick = t }) <- tl, t > before]) touchLists - ongoings <- collectTouches "touch" M.empty $ - concatMap - (\ (_,tl) -> [ touch | touch@(Touch { touchStartTick = ts, touchEndTick = te }) <- tl, te >= now && ts <= before]) touchLists - ends <- collectTouches "touch_end" M.empty $ - concatMap (\ (_,tl) -> [ touch | touch@(Touch { touchEndTick = te }) <- tl, te <= now]) touchLists - lift $ mapM_ (uncurry (sendTouch "touch_start")) $ M.toList starts - lift $ mapM_ (uncurry (sendTouch "touch")) $ M.toList ongoings - lift $ mapM_ (uncurry (sendTouch "touch_end")) $ M.toList ends - let nonends = [ (pk,[ t | t@(Touch { touchEndTick = te }) <- list, te > now]) | (pk,list) <- touchLists ] - setWorldTouchCheckTime now - setWorldTouches (M.fromList nonends) - return () - -sendTouch ttype k tl = - pushEventToPrim (Event ttype [IVal $ length tl] payload) k - where payload = foldl' ins M.empty (zip [0..] tl) - ins m (i,(Touch { touchAvatarKey = ak },link)) = - (M.insert ("vector_" ++ show i) (VVal 0 0 0)) . - (M.insert ("key_" ++ show i) (KVal ak)) . - (M.insert ("integer_" ++ show i) (IVal link)) $ m - -collectTouches touchType acc [] = return acc -collectTouches touchType acc (t@(Touch { touchPrimKey = pk }):ts) = do - lneeds <- primHasActiveHandler pk touchType - linkNum <- getPrimLinkNum pk - rk <- getRootPrim pk - if pk == rk && lneeds then collectTouches touchType (M.alter (alt (t,linkNum)) pk acc) ts - else do - pass <- getPrimPassTouches pk - rneeds <- primHasActiveHandler rk touchType - let r = if rneeds && pass then [(rk,(t { touchPrimKey = rk }, linkNum))] else [] - let p = if lneeds then [(pk,(t, linkNum))] else [] - collectTouches touchType (foldl' ( \ m (k,d) -> M.alter (alt d) k m) acc (r ++ p)) ts - where alt i Nothing = Just [i] - alt i (Just l) = Just (i:l) -runPhysics :: Monad m => WorldM m () -runPhysics = do - t0 <- getWorldPhysicsTime - t1 <- getTick - os <- getObjects - let tlist = [t0,(t0+10)..t1] ++ if (t1 - t0) `mod` 10 > 0 then [t1] else [] - let intervals = zip tlist $ tail tlist - forM_ intervals $ \ (t0,t1) -> do - forM_ (M.toList os) $ \ (pk,obj) -> runErrPrim pk () $ do - prim <- getPrim pk - obj <- getObject pk - when ((flip testBit) primPhysicsBit $ primStatus prim) $ do - mass <- objectMass pk - let dyn = objectDynamics obj - let pos0@(_,_,z0) = objectPosition dyn - let vel0@(_,_,vz0) = objectVelocity dyn - let force = (fst (objectForce dyn) `rot3d` rotation) `add3d` (0,0,mass * (objectBuoyancy dyn) * (-gravC)) - where rotation = if snd $ objectForce dyn then objectRotation dyn else (0,0,0,1) - let impulse = ((fst . fst . objectImpulse) dyn `rot3d` rotation, (snd . objectImpulse) dyn) - where rotation = if (snd . fst . objectImpulse) dyn then objectRotation dyn else (0,0,0,1) - let impulseFNow = if snd impulse >= t1 then fst impulse else (0,0,0) - let heightDampF tau z = (0,0, dampZForce tau z z0 mass vz0 fz0) - where (_,_,fz0) = force `add3d` impulseFNow - let dampF = case objectPositionTarget dyn of - Nothing -> (0,0,0) - Just (PositionTarget { positionTargetTau = tau, positionTargetLocation = l }) -> - dampForce tau l pos0 mass vel0 (force `add3d` impulseFNow) - Just (Repel { positionTargetTau = tau, positionTargetHeight = z }) -> - if z0 <= 0.5 * z then heightDampF tau z else (0,0,0) - Just (Hover { positionTargetTau = tau, positionTargetHeight = z}) -> heightDampF tau z - let (pos,vel) = kin t0 t1 ticksToDuration 0 mass pos0 vel0 (force `add3d` dampF) impulse - -- TODO: local vs global rotations in torque - -- TODO: rotational impulses - radius <- objRadius pk - let torque = totalTorque t0 t1 ticksToDuration - [(fst $ objectTorque dyn,t1),(fst $ fst $ objectRotationalImpulse dyn, snd $ objectRotationalImpulse dyn)] - let dampingTorque = case objectRotationTarget dyn of - Nothing -> (0,0,0) - Just rt@(RotationTarget {rotationTargetTau = tau, - rotationTargetStrength = strength, - rotationTarget = target}) -> - dampTorque tau strength target - (objectRotation dyn) mass radius (objectOmega dyn) torque - let (rot,omega) = rotDyn (ticksToDuration (t1 - t0)) radius mass (objectRotation dyn) (objectOmega dyn) - (torque `add3d` dampingTorque) - lift $ setObject pk $! (obj { objectDynamics = (objectDynamics obj) - { objectVelocity = vel, - objectPosition = pos, - objectRotation = rot, - objectOmega = omega }}) - return () - handleCollisions - handleMovers - handleTargets - setWorldPhysicsTime $! t1 - -handleMovers :: Monad m => WorldM m () -handleMovers = runAndLogIfErr "problem determining which objects moved" () $ - do lastPositions <- lift $ getWorldLastPositions - let lastKeys = S.fromList $ M.keys lastPositions - curPositions <- lift getObjects >>= return . M.keys >>= mapM (\ k -> getObjectPosition k >>= return . ((,)k)) - let curKeys = S.fromList $ map fst curPositions - let newKeys = curKeys `S.difference` lastKeys - let keysFromBefore = curKeys `S.difference` newKeys - m <- return . M.fromList =<< mapM ( \ (k,pos) -> if k `S.member` keysFromBefore - then do (moving,lpos) <- mlookup k lastPositions - let moving' = lpos /= pos - when (moving' && not moving) $ - lift $ pushEventToPrim (Event "moving_start" [] M.empty) k - when (moving && not moving') $ - lift $ pushEventToPrim (Event "moving_end" [] M.empty) k - return (k,(moving', pos)) - else return (k,(False,pos))) curPositions - lift $ setWorldLastPositions m - -handleObjectCollisions prims = do - -- look at all non-phantom prims - primBoxes <- mapM (\ (k,p) -> getPrimBox k >>= return . ((,) k ) . ((,)p) ) prims - --let voldtct = map fst $ filter (primVolumeDetect . snd) prims - voldtct <- flip filterM prims (\ (_,prim) -> - let f k = (getObject k >>= return . objectVolumeDetect . objectDynamics) in - case primParent prim of - Nothing -> f (primKey prim) - Just k -> f k - ) >>= return . map fst - let cmp x y = compare (fst x) (fst y) - let curCollisions = S.fromList [ (k0,k1) | ((k0,(p0,_)),(k1,(p1,_))) <- checkIntersections (snd . snd) cmp primBoxes, - primParent p0 /= Just k1 && - primParent p1 /= Just k0 && - not (primParent p0 == primParent p1 && isJust (primParent p0))] - oldCollisions <- lift getWorldCollisions - let formerCollisions = oldCollisions `S.difference` curCollisions - let newCollisions = curCollisions `S.difference` oldCollisions - toObjCollisions newCollisions "collision_start" >>= mapM_ (send "collision_start") - (do - objCollisions <- toObjCollisions curCollisions "collision" - -- filter out volume detect objects, except for those objects that are attatched - let attachment k = do - parent <- getPrimParent k - case parent of - Nothing -> getPrimAttachment k - Just ok -> getPrimAttachment ok - objCollisions' <- (mapM (\ v@(k,_) -> (attachment k >>= return . ((,) v))) objCollisions) - >>= return . (filter (\ ((k,_),mv) -> (k `notElem` voldtct) || isJust mv)) - >>= return . (map fst) - mapM_ (send "collision") objCollisions') - toObjCollisions formerCollisions "collision_end" >>= mapM_ (send "collision_end") - lift $ setWorldCollisions curCollisions - where send :: Monad m => String -> (String,[(Int,String)]) -> ErrorT String (WorldM m) () - send hn (pk,oinfo) = collisionScripts >>= mapM_ (sendScript hn pk oinfo) - where collisionScripts = do - scripts <- getPrimScripts pk >>= return . (map invName) - filterM (\ sn -> scriptHasActiveHandler pk sn hn) scripts - sendScript :: Monad m => String -> String -> [(Int,String)] -> String -> ErrorT String (WorldM m) () - sendScript hn pk oinfo sn = do - scripts <- lift $ getWorldScripts - return () - case M.lookup (pk,sn) scripts of - Nothing -> throwError "can't find script" - Just (Script { scriptCollisionFilter = (name,key,accept) }) - | null name && (null key || nullKey == key) && accept -> pushit oinfo - | null name && (null key || nullKey == key) && not accept -> return () - | accept -> filterM (matchesIn name key) oinfo >>= pushit - | otherwise -> filterM (matchesOut name key) oinfo >>= pushit - where matchesIn name key (_,k) = if k == key - then return True - else (if null key || key == nullKey - then (getPrimName k >>= return . (name==)) - else return False) - matchesOut name key (_,k) = if k == key - then return False - else (if null key || key == nullKey - then (getPrimName k >>= return . not . (name==)) - else return True) - pushit oinfo = unless (null oinfo) $ lift (pushEvent ev pk sn) - where ev = Event hn [IVal $ length oinfo] - (M.fromList $ - (zipWith (\ i (_,k) -> ("key_" ++ show i, KVal k)) [0..] oinfo) ++ - (zipWith (\ i (n,_) -> ("integer_" ++ show i, IVal n)) [0..] oinfo)) - toObjCollisions collisionsS hn = do - passed <- passes primColliders - colliders' <- mapM (\ (k,cs) -> (getPrimLinkNum k >>= \ i -> return (k,i,cs))) primColliders - colliders'' <- mapM pk2ok (colliders' ++ passed) - colliders''' <- mapM (\ (k,i,cs) -> filterM (objectHasVolDetect >=> (return . not)) cs >>= return . ((,,) k i)) colliders'' - return $ M.toList (foldl' combine M.empty (map dist colliders''')) - where collisions = S.toList collisionsS - dist (pk,i,cs) = (pk, zip (repeat i) cs) - combine m (k,lv) = case M.lookup k m of - Nothing -> M.insert k lv m - Just lv' -> M.insert k (lv ++ lv') m - --prims = fromListOfPairs collisions - primColliders = map (\ k -> (k, collectColliders collisions k)) (S.toList $ fromListOfPairs collisions) - passes [] = return [] - passes ((pk,cs):pcs) = do - passed <- pass hn pk - if passed - then do - parent <- getPrimParent pk >>= maybe (throwError "can't get parent") return - rest <- passes pcs - num <- getPrimLinkNum pk - return ((parent,num,cs):rest) - else passes pcs - pk2ok (pk,i,cs) = primsToObjects cs >>= return . ((,,) pk i) - primsToObjects ks = mapM getPrimParent ks >>= (\ parents -> (return (nub $ zipWith fromMaybe ks parents))) - pass hn k = do - parent <- getPrimParent k - case parent of - Nothing -> return False - Just pk -> do - passOverride <- getPrimPassTouches k - pass <- (k `primHasActiveHandler` hn) >>= return . not - return (pass || passOverride) - fromListOfPairs [] = S.empty - fromListOfPairs ((x,y):ps) = (S.insert x . S.insert y) (fromListOfPairs ps) - collectColliders intsns pk = [ j | (Just j) <- map (other pk) intsns] - objectHasVolDetect ok = do - attach <- getPrimAttachment ok - if isJust attach - then return False - else getObject ok >>= return . objectVolumeDetect . objectDynamics - other k (x,y) | k == x = Just y - | k == y = Just x - | otherwise = Nothing - -handleLandCollisions prims = do - primBoxes <- mapM (\ (k,p) -> getPrimBox k >>= return . ((,) k )) prims - let curCollisions = S.fromList [ k | (k,((_,_,z),_)) <- primBoxes, z <= 0] - oldCollisions <- lift getWorldLandCollisions - let formerCollisions = oldCollisions `S.difference` curCollisions - let newCollisions = curCollisions `S.difference` oldCollisions - mapM_ (send "land_collision_end") $ S.toList formerCollisions - mapM_ (send "land_collision") $ S.toList curCollisions - mapM_ (send "land_collision_start") $ S.toList newCollisions - lift $ setWorldLandCollisions curCollisions - where send hn pk = do - pass <- getPrimPassCollisions pk - pos <- getGlobalPos pk >>= ( \ (x,y,_) -> return (x,y,0)) - liveScripts <- getActualPrimScripts pk >>= - (\ ss -> return [ s | s@(_,Script { scriptActive = True }) <- ss]) - when (not $ null liveScripts) $ send' pos pk - when (null liveScripts || pass) $ getRootPrim pk >>= send' pos - where send' pos k = do - scripts <- getPrimScripts k >>= return . (map invName) >>= - filterM (\ sn -> scriptHasActiveHandler k sn hn) - forM_ scripts $ (lift . pushEvent (Event hn [vec2VVal pos] M.empty) k) - -handleCollisions :: (Monad m) => WorldM m () -handleCollisions = runAndLogIfErr "can't handle collisions" () $ do - prims <- getNonPhantomPrims - handleObjectCollisions prims - handleLandCollisions prims - -getNonPhantomPrims :: (Monad m) => ErrorT String (WorldM m) [(String,Prim)] -getNonPhantomPrims = lift getPrims >>= return . M.assocs >>= (return . filter ((==0) . (.&. cStatusPhantom) . primStatus . snd)) - -handleTargets :: Monad m => WorldM m () -handleTargets = do - t <- getTick - t0 <- getWorldTargetCheckTime - when (t - t0 > durationToTicks 0.1) $ do - getObjects >>= return . M.keys >>= mapM_ (\ k -> do - runErrPrim k () $ do - pos <- getGlobalPos k - rot <- getGlobalRot k - scripts <- getActualPrimScripts k - forM_ scripts (\ ((_,sn),script) -> do - forM_ (IM.toList $ scriptPositionTargets script) $ (\ (i,(target,range)) -> - let image = scriptImage script - inRange = (dist3d2 target pos <= range^2) in - if hasActiveHandler image "at_target" && inRange - then lift $ pushEvent (Event "at_target" [IVal i, vec2VVal target, vec2VVal pos] M.empty) k sn - else if hasActiveHandler image "not_at_target" && not inRange - then lift $ pushEvent (Event "not_at_target" [] M.empty) k sn - else return () - ) - forM_ (IM.toList $ scriptRotationTargets script) $ (\ (i,(target,range)) -> - let image = scriptImage script - inRange = (angleBetween target rot <= range) in - if hasActiveHandler image "at_rot_target" && inRange - then lift $ pushEvent (Event "at_rot_target" [IVal i, rot2RVal target, rot2RVal rot] M.empty) k sn - else if hasActiveHandler image "not_at_rot_target" && not inRange - then lift $ pushEvent (Event "not_at_rot_target" [] M.empty) k sn - else return () - ) - ) - - ) - -simulate :: Monad m => WorldM m () -simulate = - do processEvents - runScripts - runPhysics - handleTouches - mn <- nextActivity - t <- getTick - let t' = case mn of - Nothing -> t + 10 - Just n -> min (t + 10) n - setTick t' - --setTick (t + 1) - pauseTime <- getNextPause - suspendInfo <- getWorldSuspended - if t' >= pauseTime || isSuspended suspendInfo then return () else simulate - where isSuspended Nothing = False - isSuspended _ = True - -linkSet = -1::Int -linkAllOthers = -2::Int -linkAllChildren = -3::Int -linkThis = -4::Int - --- etrace :: Monad m => String -> m () --- etrace val = trace val $ return () --- trace1 s val = trace (s ++ ": " ++ show val) val - --- -------------------------------------------------------------------------------------------- - -data SimCommand = SimContinue { simCmdBreakpoints :: [Breakpoint], simCmdEvents :: [SimEvent] } - | SimStep { simCmdBreakpoints :: [Breakpoint], simCmdEvents :: [SimEvent] } - | SimStepOver { simCmdBreakpoints :: [Breakpoint], simCmdEvents :: [SimEvent] } - | SimStepOut { simCmdBreakpoints :: [Breakpoint], simCmdEvents :: [SimEvent] } deriving (Show) - -data SimStatus = SimEnded { simStatusMessage :: String, simStatusLog :: [LogMessage], simStatusState :: SimStateInfo } | - SimInfo { simStatusEvents :: [SimEvent], simStatusLog :: [LogMessage], simStatusState :: SimStateInfo } | - SimSuspended { simStatusEvents :: [SimEvent], - simStatusSuspendInfo :: ExecutionInfo, - simStatusLog :: [LogMessage], - simStatusState :: SimStateInfo } deriving (Show) - -data SimStateInfo = SimStateInfo { - simStateInfoTime :: Int, - simStateInfoPrims :: [(String,String)], - simStateInfoAvatars :: [(String,String)], - simStateInfoScripts :: [(String,String)] - } deriving (Show) - -nullSimState = SimStateInfo 0 [] [] [] - -stateInfoFromWorld world = - SimStateInfo { - simStateInfoTime = tick world, - simStateInfoPrims = map (\ p -> (primKey p, primName p)) (M.elems $ wprims world), - simStateInfoAvatars = map (\ (_,a) -> (avatarKey a, avatarName a)) (M.toList $ worldAvatars world), - simStateInfoScripts = M.keys (worldScripts world) - } - -data SimInputEventDefinition m = SimInputEventDefinition { - simInputEventName :: String, - simInputEventDescription :: String, - simInputEventParameters :: [SimParam], - simInputEventHandler :: String -> [LSLValue] -> WorldM m () } - -data SimParam = SimParam { simParamName :: String, simParamDescription :: String, - simParamType :: SimParamType } - deriving (Show) -data SimParamType = SimParamPrim | SimParamAvatar | SimParamLSLValue LSLType | SimParamRootPrim | SimParamKey | - SimParamScript - deriving (Show) - -initWorld def scripts lib = worldFromFullWorldDef newWorld def lib scripts - -simStep init@(Left (worldDef, scripts, lib)) command = --- let world = initWorld worldDef scripts lib in simStep (Right world) command - case initWorld worldDef scripts lib of - Left s -> -- initialization failed - (SimEnded ("Error initializing: " ++ s) [LogMessage 0 LogError "sim" ("Error initializing: " ++ s)] nullSimState, init) - Right world -> simStep (Right world) command -simStep (Right world) command = - let t = tick world - events = simCmdEvents command - newBreakpointManager = replaceBreakpoints (simCmdBreakpoints command) (worldBreakpointManager world) - slice = sliceSize world - newScripts = case worldSuspended world of - Nothing -> worldScripts world - Just (k,s) -> - let Just script = M.lookup (k,s) (worldScripts world) - img = scriptImage script - stepMgr = stepManager img - img' = case command of - SimStep _ _ -> img { stepManager = setStepBreakpoint stepMgr } - SimStepOver _ _ -> img { stepManager = setStepOverBreakpoint stepMgr } - SimStepOut _ _ -> img { stepManager = setStepOutBreakpoint stepMgr } - _ -> img - in M.insert (k,s) (script { scriptImage = img' }) (worldScripts world) - simEventToWorldEvent (SimEvent name args delay) = (t + delay, WorldSimEvent name args) - wq' = putManyWQ (map simEventToWorldEvent events) (wqueue world) - world' = world { wqueue = wq', - nextPause = t + slice, - worldBreakpointManager = newBreakpointManager, - worldScripts = newScripts } - (_,world'') = runIdentity $ runStateT simulate world' - log = msglog world'' - outputEvents = reverse $ worldOutputQueue world'' - world''' = world'' { msglog = [], worldOutputQueue = [] } in - if (tick world''') < (maxTick world''') - then case worldSuspended world''' of - Nothing -> - (SimInfo { simStatusEvents = outputEvents, - simStatusLog = log, - simStatusState = stateInfoFromWorld world''' }, Right world''') - Just (k,s) -> - let Just script = M.lookup (k,s) (worldScripts world''') -- TODO: non-exhaustive but MUST succeed - img = scriptImage script - (Suspended bp) = executionState img -- TODO: non-exhaustive but MUST succeed - executionInfo = ExecutionInfo (breakpointFile bp) (breakpointLine bp) (frameInfo img) - in - (SimSuspended { simStatusEvents = outputEvents, - simStatusSuspendInfo = executionInfo, - simStatusLog = reverse log, - simStatusState = stateInfoFromWorld world''' }, Right world''') - else (SimEnded { simStatusMessage = "ended", - simStatusLog = reverse log, - simStatusState = stateInfoFromWorld world''' }, Right world''') - --- Event Descriptions and Handlers ------------------------------------------- ------------------------------------------------------------------------------- ---checkArgs def args = do -checkEventArgs def args = - do - when (length params /= length args) $ fail "wrong number of parameters" - mapM (uncurry checkEventArg) argList - where params = simInputEventParameters def - argList = map (\ p -> ( p , find (\ a -> simParamName p == simEventArgName a) args)) params - -checkEventArg (SimParam _ _ SimParamPrim) (Just arg) = return $ KVal (simEventArgValue arg) -checkEventArg (SimParam _ _ SimParamRootPrim) (Just arg) = return $ KVal (simEventArgValue arg) -checkEventArg (SimParam _ _ SimParamScript) (Just arg) = return $ SVal (simEventArgValue arg) -checkEventArg (SimParam name _ SimParamAvatar) (Just arg) = return $ KVal (simEventArgValue arg) -checkEventArg (SimParam name _ SimParamKey) (Just arg) = return $ KVal (simEventArgValue arg) -checkEventArg (SimParam name _ (SimParamLSLValue t)) (Just arg) = - case evaluateExpression t (simEventArgValue arg) of - Nothing -> fail $ ("invalid " ++ (lslTypeString t) ++ " expression" ) - Just v -> return v -checkEventArg (SimParam name _ _) Nothing = fail ("event argument " ++ name ++ " not found") - -handleSimInputEvent def args = - case checkEventArgs def args of - Left s -> logAMessage LogWarn "sim" s - Right argValues -> (simInputEventHandler def) (simInputEventName def) argValues - -mkTouchStartEvent pk nd ak ln = - WorldSimEvent "touch_start" [SimEventArg "Prim Key" pk, SimEventArg "num_detected" nd, - SimEventArg "Avatar key" ak, SimEventArg "Link Number" (show ln)] -mkTouchEvent pk nd ak ln = - WorldSimEvent "touch" [SimEventArg "Prim Key" pk, SimEventArg "num_detected" nd, - SimEventArg "Avatar key" ak, SimEventArg "Grab vector" "<0.0,0.0,0.0>", - SimEventArg "Link Number" (show ln)] -mkTouchEndEvent pk nd ak ln = - WorldSimEvent "touch_end" [SimEventArg "Prim Key" pk, SimEventArg "num_detected" nd, - SimEventArg "Avatar key" ak, SimEventArg "Link Number" (show ln)] - -userTouchEventDef :: Monad m => SimInputEventDefinition m -userTouchEventDef = - SimInputEventDefinition { - simInputEventName = "Touch Prim", - simInputEventDescription = "Avatar touches a prim for a duration", - simInputEventParameters = [ - SimParam "Prim" "The prim the avatar should touch" SimParamPrim, - SimParam "Avatar" "The avatar that should do the touching" SimParamAvatar, - SimParam "Duration" "The duration of the touch (in seconds)" (SimParamLSLValue LLFloat)], - simInputEventHandler = - let f _ [KVal pk, KVal ak, FVal duration] = runAndLogIfErr "can't find prim? " () $ do - -- should we pass touches? - prim <- getPrim pk - linkNum <- getPrimLinkNum pk --- linkNum <- (case primParent prim of --- Nothing -> return 0 --- Just parent -> do --- LSLObject { primKeys = links } <- getObject parent --- Just i <- return $ elemIndex pk links --- return (i + 1)) <||> --- (do lift $ logAMessage LogWarn "sim" ("can't figure out link number of prim: " ++ pk) --- return 0) - needstouches <- liftM or $ mapM (primHasActiveHandler pk) ["touch","touch_start","touch_end"] - let touchList = (if needstouches then [pk] else []) ++ - (if (primPassTouches prim || not needstouches) then maybe [] return (primParent prim) else []) - lift $ mapM_ (doTouch linkNum) touchList - where doTouch linkNum k = do - putWorldEvent 0 (mkTouchStartEvent k "1" ak linkNum) - let tdur = floor (1000 * duration) - let tTimes = map ((/1000.0) . fromIntegral) [1,(1 + 500) .. tdur] - mapM_ ((flip putWorldEvent) (mkTouchEvent pk "1" ak linkNum)) tTimes - putWorldEvent duration (mkTouchEndEvent pk "1" ak linkNum) - f name _ = logAMessage LogWarn "sim" ("invalid event activation: " ++ name) - in f - } - -userChatEventDef :: Monad m => SimInputEventDefinition m -userChatEventDef = - SimInputEventDefinition { - simInputEventName = "Chat", - simInputEventDescription = "Avatar chats", - simInputEventParameters = [ - SimParam "Avatar" "The avatar that should do the chatting" SimParamAvatar, - SimParam "Message" "What the avatar should say" (SimParamLSLValue LLString), - SimParam "Channel" "The channel to chat on" (SimParamLSLValue LLInteger)], - simInputEventHandler = - let f _ [KVal ak, SVal message, IVal chan] = do - avatars <- getWorldAvatars - case M.lookup ak avatars of - Nothing -> logAMessage LogWarn "sim" ("avatar with key " ++ ak ++ " not found") - Just av -> do - putWorldEvent 0 $ Chat chan (avatarName av) ak message (avatarRegion av,avatarPosition av) (Just 20.0) - f name _ = logAMessage LogWarn "sim" ("invalid event activation: " ++ name) - in f - } - -eventDescriptors :: Monad m => Map [Char] (SimInputEventDefinition m) -eventDescriptors = M.fromList $ mkEventDefList ([userTouchEventDef,userChatEventDef] ++ rawLslEventDescriptors) - -mkEventDefList eventDefs = map (\ e -> (simInputEventName e, e)) eventDefs - -rawLslEventDescriptors :: Monad m => [SimInputEventDefinition m] -rawLslEventDescriptors = map lslEventDescriptorToSimInputDef lslEventDescriptors - -lslEventDescriptorToSimInputDef (name, params, delivery, additionalData, description) = - SimInputEventDefinition { - simInputEventName = name, - simInputEventDescription = "This is a raw LSL event: " ++ description, - simInputEventParameters = - (case delivery of - EventDeliveryScript -> [SimParam "Script" "name of script to deliver to" SimParamScript, - SimParam "Prim Key" "key of prim to deliver to" SimParamPrim] - EventDeliveryObject -> [SimParam "Object Key" "key of object to deliver to" SimParamRootPrim] - EventDeliveryRoot -> [SimParam "Object Key" "key of object to deliver to" SimParamRootPrim] - EventDeliveryPrim -> [SimParam "Prim Key" "key of prim to deliver to" SimParamPrim] - ) ++ - (flip map additionalData (\ d -> case d of - EventAdditionalInts name description -> SimParam name description (SimParamLSLValue LLInteger) - EventAdditionalKeys name description -> SimParam name description SimParamKey - EventAdditionalAvatarKeys name description -> SimParam name description SimParamAvatar - EventAdditionalVectors name description -> SimParam name description (SimParamLSLValue LLVector))) ++ - map ( \ (t,name) -> SimParam name "" (SimParamLSLValue t)) params, - simInputEventHandler = - let f _ list = - let lenAddl = length additionalData - (df,rest) = case (delivery,list) of - (EventDeliveryScript,SVal sn:KVal pk:vals) -> (\ e -> pushEvent e pk sn,vals) - (EventDeliveryObject,KVal key:vals) -> (\ e -> pushEventToObject e key,vals) - (EventDeliveryRoot, KVal key:vals) -> ((\ e -> pushEventToPrim e key), vals) - (EventDeliveryPrim, KVal key:vals) -> ((\ e -> pushEventToPrim e key), vals) - _ -> (\ _ -> logAMessage LogWarn "sim" "invalid user event - bad script address",[]) - in df (Event name (drop lenAddl rest) (M.fromList (zipWith mkInfo additionalData (take lenAddl rest))) ) - where mkInfo (EventAdditionalVectors _ _) val = ("vector_0",val) - mkInfo (EventAdditionalInts _ _) val = ("integer_0",val) - mkInfo _ val = ("key_0",val) - in f - }
− Language/Lsl/Syntax.hs
@@ -1,961 +0,0 @@-{-# OPTIONS_GHC -XDeriveDataTypeable -XTypeSynonymInstances -XFlexibleContexts #-} --- | Defines the abstract syntax tree for LSL (and LSL Plus extensions). -module Language.Lsl.Syntax ( - -- Types - Expr(..), - Var(..), - FuncDec (..), - Func(..), - LModule(..), - Component(..), - Statement(..), - LSLType(..), - Handler(..), - State(..), - GlobDef(..), - LSLScript(..), - Validity, - Global(..), - SourceContext(..), - Ctx(..), - CompiledLSLScript(..), - Library, - AugmentedLibrary, - CodeErr, - -- Values - fromMCtx, - ctxItems, - nullCtx, - ctxVr2Vr, - findFunc, - validLSLScript, - validLibrary, - findState, - predefFuncs, - findFuncDec, - goodHandlers, - libFromAugLib, - isTextLocation) where - -import Language.Lsl.Internal.Type(Component(..),LSLType(..),lslTypeString) -import Language.Lsl.Internal.Constants(isConstant,findConstType) -import Language.Lsl.Internal.EventSigs(simpleLslEventDescriptors) -import Language.Lsl.Internal.FuncSigs(funcSigs) -import Data.Data(Data,Typeable) -import Data.List(find,sort,sortBy,nub) -import Language.Lsl.Internal.Util(ctx,findM,lookupM,filtMap,throwStrError) -import Control.Monad(when,foldM,MonadPlus(..)) -import Control.Monad.Error(MonadError(..),Error(..)) ---trace1 s v = trace (s ++ show v) v - -type CtxVar = Ctx Var - --- | An LSL variable (a name, and a type).-data Var = Var { varName :: String, varType :: LSLType } deriving (Show,Typeable,Data) - -type CtxName = Ctx String - --- | An LSL function declaration (the function name and type information, without associated --- statements. -data FuncDec = FuncDec { funcName :: CtxName, funcType :: LSLType, funcParms :: [CtxVar] } - deriving (Show,Typeable,Data) - -type CtxStmt = Ctx Statement --- | An LSL function definition (return type, parameters and statements. -data Func = Func FuncDec [CtxStmt] deriving (Show,Typeable,Data) - --- | An LSL Plus module, which is a separately 'compiled' unit that can contain --- both global variables and functions, but not states or handlers. -data LModule = LModule [GlobDef] [CtxVar] - deriving (Show,Typeable,Data) - -type CtxExpr = Ctx Expr --- | An LSL expression. -data Expr = IntLit Int - | FloatLit Float - | StringLit String - | ListExpr [CtxExpr] - | VecExpr CtxExpr CtxExpr CtxExpr - | RotExpr CtxExpr CtxExpr CtxExpr CtxExpr - | KeyLit String - | Call CtxName [CtxExpr] - | Add CtxExpr CtxExpr - | Sub CtxExpr CtxExpr - | Mul CtxExpr CtxExpr - | Div CtxExpr CtxExpr - | Mod CtxExpr CtxExpr - | Get (CtxName,Component) - | Set (CtxName,Component) CtxExpr - | BAnd CtxExpr CtxExpr - | BOr CtxExpr CtxExpr - | Xor CtxExpr CtxExpr - | ShiftL CtxExpr CtxExpr - | ShiftR CtxExpr CtxExpr - | And CtxExpr CtxExpr - | Or CtxExpr CtxExpr - | Equal CtxExpr CtxExpr - | NotEqual CtxExpr CtxExpr - | Lt CtxExpr CtxExpr - | Le CtxExpr CtxExpr - | Gt CtxExpr CtxExpr - | Ge CtxExpr CtxExpr - | IncBy (CtxName,Component) CtxExpr - | DecBy (CtxName,Component) CtxExpr - | MulBy (CtxName,Component) CtxExpr - | DivBy (CtxName,Component) CtxExpr - | ModBy (CtxName,Component) CtxExpr - | PostInc (CtxName,Component) - | PostDec (CtxName,Component) - | PreInc (CtxName,Component) - | PreDec (CtxName,Component) - | Not CtxExpr - | Neg CtxExpr - | Inv CtxExpr - | Cast LSLType CtxExpr - | AQString String - | AQInteger String - | AQKey String - | AQFloat String - deriving (Show,Typeable,Data) - --- | An LSL statement. -data Statement = Compound [CtxStmt] - | While CtxExpr Statement - | DoWhile Statement CtxExpr - | For ([CtxExpr]) (Maybe CtxExpr) ([CtxExpr]) Statement - | If CtxExpr Statement Statement - | Decl Var (Maybe CtxExpr) - | NullStmt - | Return (Maybe CtxExpr) - | StateChange String - | Do CtxExpr - | Label String - | Jump String - deriving (Show,Typeable,Data) - -isLabel (Label _) = True -isLabel _ = False - --- | An LSL global variable (this is actually not a source level/syntactic entity -- the set of globals --- for a script is derived after analyzing all included modules. -data Global = GDecl Var (Maybe Expr) - deriving (Show,Typeable,Data) - --- | A global definition (a function, a variable, or a module import statement). -data GlobDef = GV CtxVar (Maybe CtxExpr) | GF Func | GI CtxName [(String,String)] String - deriving (Show,Typeable,Data) --- | An LSL event handler definition. -data Handler = Handler CtxName [CtxVar] [CtxStmt] - deriving (Show,Typeable,Data) - --- | The set of valid handlers supported by LSL. -goodHandlers :: [(String,[LSLType])] -goodHandlers = simpleLslEventDescriptors - --- | An LSL state definition. -data State = State CtxName [Handler] - deriving (Show,Typeable,Data) - --- | An LSL script. -data LSLScript = LSLScript [GlobDef] [State] deriving (Show,Typeable,Data) - -type ModuleInfo = ([Global],[Func]) --- | A collection of modules. -type Library = [(String,Validity LModule)] --- | A collection of mouldes, augmented with additional derived information. -type AugmentedLibrary = [(String,Validity (LModule,ModuleInfo))] - -lslFunc (name,t,ts) = - FuncDec (nullCtx name) t (zipWith (\ x y -> nullCtx $ Var [y] x) ts ['a'..]) -predefFuncs = map lslFunc funcSigs - -findVar name = find (\(Var n _ ) -> n == name) -findType name = - let f Nothing = Nothing - f (Just (Var _ t )) = Just t in f . (findVar name) -findFuncDec name = ctx ("finding function " ++ name) . findM (\ fd -> ctxItem (funcName fd) == name) -findState name = ctx ("finding state " ++ name) . findM (\ (State n _) -> ctxItem n == name) -findFunc name = ctx ("finding function " ++ name) . findM (\ (Func fd _) -> ctxItem (funcName fd) == name) - -lookupModule name lib = - case lookup name lib of - Nothing -> throwStrError "unknown module" - Just (Left (_,s)) -> throwStrError ("invalid library (" ++ s ++ ")") - Just (Right m) -> return m - --- A description of an error and where to find it in the source.-type CodeErr = (SourceContext,String) - --- | An error monad for representing validation errors with respect to LSL code.-type Validity a = Either CodeErr a - -instance Error CodeErr where - noMsg = (UnknownSourceContext,"") - strMsg s = (UnknownSourceContext,s) - -incontext (ctx,s) (Left (ctx',s')) = - case ctx' of - UnknownSourceContext -> Left (ctx,msg) - _ -> Left (ctx',msg) - where msg = if null s then s' else s ++ ": " ++ s' -incontext _ v = v - -incontext' (ctx,s) (Left (_,s')) = Left (ctx,s ++ ": " ++ s') -incontext' _ v = v - --------------------- -matchTypes LLFloat LLInteger = True -matchTypes dest src = dest == src || (all (`elem` [LLKey,LLString]) [dest,src]) - -typeGlob library prefix (vars,funcs) (GV (Ctx ctx (Var name t)) _) = return ((Var (prefix ++ name) t):vars,funcs) -typeGlob library prefix (vars,funcs) (GF (Func (FuncDec name t params) _)) = - return (vars,(FuncDec (fmap (prefix++) name) t params):funcs) -typeGlob library prefix v@(vars,funcs) (GI moduleName _ prefix') = - do (LModule globs _) <- lookupModule (ctxItem moduleName) library - foldM (typeGlob library (prefix++prefix')) (vars,funcs) globs -typeGlobs library gs = foldM (typeGlob library "") ([],[]) gs - -noDupVars :: [String] -> [CtxVar] -> Validity [String] -noDupVars used [] = return used -noDupVars used ((Ctx ctx (Var n t)):vs) = do - when (n `elem` used) $ throwError (ctx, n ++ " already defined") - noDupVars (n:used) vs - -checkName :: Maybe SourceContext -> String -> [String] -> Validity () -checkName (Just ctx) name names = - when (name `elem` names) $ throwError (ctx, name ++ " is multiply defined") - -noDupGlobs :: Maybe SourceContext -> String -> [String] -> Library -> [GlobDef] -> Validity [String] -noDupGlobs forceCtx prefix usedNames library [] = return usedNames -noDupGlobs forceCtx prefix usedNames library ((GV (Ctx ctx (Var name t)) _):gs) = do - checkName (forceCtx `mplus` Just ctx) globName usedNames - noDupGlobs forceCtx prefix (globName:usedNames) library gs - where globName = prefix ++ name -noDupGlobs forceCtx prefix usedNames library ((GF (Func (FuncDec (Ctx ctx name) t params) _)):gs) = do - checkName (forceCtx `mplus` Just ctx) globName usedNames - noDupGlobs forceCtx prefix (globName:usedNames) library gs - where globName = prefix ++ name -noDupGlobs forceCtx prefix usedNames library ((GI (Ctx ctx moduleName) _ prefix'):gs) = do - (LModule globs _) <- incontext (ctx,"") $ lookupModule moduleName library - usedNames' <- noDupGlobs (forceCtx `mplus` Just ctx) (prefix ++ prefix') usedNames library globs - noDupGlobs forceCtx prefix usedNames' library gs - -data CompiledLSLScript = CompiledLSLScript {- scriptGlobals :: ![Global],- scriptFuncs :: ![Func],- scriptStates :: ![State]} - deriving (Show) - -validLSLScript :: Library -> LSLScript -> Validity CompiledLSLScript -validLSLScript library (LSLScript globs states) = - do --noDupGlobs Nothing "" [] library globs - (typedVars,typedFuncs) <- typeGlobs library globs - let vars = reverse typedVars - let funcDecs = typedFuncs ++ predefFuncs - (globvars,funcs,_,_) <- foldM (validGlob library vars funcDecs) ([],[],[],[]) globs - validStates snames [] vars funcDecs states - return (CompiledLSLScript (reverse globvars) funcs states) - where snames = let sname (State cn _) = ctxItem cn in map sname states -validGlob _ vars funcDecs (globvars,funcs,imports,namesUsed) (GV v mexpr) = - do when (isConstant $ varName v') $ throwError (srcCtx v, varName v' ++ " is a predefined constant") - -- find the vars that are defined prior to this global variable -- only one of these - -- vars may be used to initialize the global variable. - when (varName v' `elem` namesUsed) $ throwError (srcCtx v, varName v' ++ " is already defined") - let (vars',_) = break (\ var -> varName var == varName v') vars - case mexpr of - Nothing -> return (GDecl v' Nothing:globvars,funcs,imports, (varName v'):namesUsed) - Just expr -> do - t <- validCtxSimple vars' expr - let vt = varType v' - when (not (matchTypes vt t)) $ throwError (srcCtx expr, "expression not of the correct type") - return ((GDecl v' $ Just (ctxItem expr)):globvars,funcs,imports, (varName v'):namesUsed) - where v' = ctxItem v -validGlob _ vars funcDecs (globvars,funcs,imports,namesUsed) (GF f@(Func (FuncDec name t params) statements)) = - do noDupVars [] params - when (ctxItem name `elem` namesUsed) $ throwError (srcCtx name, ctxItem name ++ " is already defined") - returns <- validStatements False [] funcDecs vars t [] [[],params'] statements - when (not returns && t /= LLVoid) $ - throwError (srcCtx name, "function " ++ (ctxItem name) ++ ": not all code paths return a value") - return (globvars,f:funcs,imports,(ctxItem name):namesUsed) - where params' = ctxItems params -validGlob library vars funcDecs vstate@(globvars,funcs,imports,namesUsed) (GI (Ctx ctx name) bindings prefix) = - let context = incontext' (ctx,"module " ++ name) in - do let imp = (name,sort bindings,prefix) - if imp `elem` imports - then return (globvars,funcs,imports,namesUsed) - else context $ do - (LModule globs freevars) <- context $ lookupModule name library - context $ validBindings vars freevars bindings - (vars',funcDecs') <- context $ typeGlobs library globs - let renames = bindings ++ (map (\ x -> (x,prefix ++ x)) ((map varName vars') ++ (funcNames funcDecs'))) - (gvs,fs,imports',namesUsed') <- foldM (rewriteGlob prefix library renames ((map ctxItem freevars) ++ vars')) vstate globs - return (gvs,fs,imp:imports',namesUsed') - -rewriteGlob _ _ renames vars (globvars,funcs,imports,namesUsed) (GF (Func (FuncDec name t params) statements)) = - do name' <- incontext (srcCtx name, "renaming function " ++ ctxItem name ++ ", " ++ show renames) $ lookupM (ctxItem name) renames - when (name' `elem` namesUsed) $ throwStrError (name' ++ " imported from module is already defined") - let rewrittenFunc = (Func (FuncDec (Ctx (srcCtx name) name') t params) $ rewriteStatements 0 renames statements) - return (globvars,rewrittenFunc:funcs,imports,name':namesUsed) -rewriteGlob _ _ renames vars (globvars,funcs,imports,namesUsed) (GV (Ctx ctx (Var name t)) mexpr) = - do name' <- incontext (ctx,"renaming variable " ++ name) $ lookupM name renames - when (name' `elem` namesUsed) $ throwStrError (name' ++ " imported from module is already defined") - let rewrittenGlobVar = GDecl (Var name' t) $ - case mexpr of - Nothing -> Nothing - Just expr -> Just $ (ctxItem (rewriteCtxExpr renames expr)) - return (rewrittenGlobVar:globvars,funcs,imports,name':namesUsed) -rewriteGlob prefix0 library renames vars vstate@(globvars,funcs,imports,namesUsed) (GI (Ctx ctx mName) bindings prefix) = - do (LModule globs freevars) <- incontext (ctx, "rewriting module " ++ mName) $ lookupModule mName library - incontext (ctx,"") $ validBindings vars freevars bindings - bindings' <- mapM rewriteBinding bindings - let imp = (mName,sort bindings',prefix0 ++ prefix) - if (imp `elem` imports) - then return (globvars,funcs,imports,namesUsed) - else do - (vars',funcDecs') <- typeGlobs library globs - let renames = bindings' ++ map (\ x -> (x,prefix0 ++ prefix ++ x)) (map varName vars' ++ map (ctxItem . funcName) funcDecs') - (gvs,fs,imports',namesUsed') <- foldM (rewriteGlob (prefix0 ++ prefix) library renames vars') vstate globs - return (gvs,fs,imp:imports',namesUsed') - where rewriteBinding (fv,rn) = lookupM rn renames >>= return . ((,) fv) - -validBindings vars freevars bindings = - if length freevars /= length bindings then - throwStrError ("wrong number of bindings in import: " ++ (show $ length freevars) ++ " required") - else let f [] = return () - f ((x,y):xys) = - case (findType x (ctxItems freevars), findType y vars) of - (Nothing,_) -> throwStrError ("free variable " ++ x ++ " not found") - (_,Nothing) -> throwStrError ("global variable " ++ y ++ " not found") - (Just t0,Just t1) | not (matchTypes t0 t1) -> throwStrError ("types of " ++ x ++ " and " ++ y ++ " don't match") - | otherwise -> f xys - in f bindings - -validState snames used vars funcs (State (Ctx ctx name) handlers) = - do when (name `elem` used) $ throwError (ctx, name ++ " already used") - incontext (ctx,"") $ validHandlers snames [] funcs vars handlers - return name - -validStates snames used vars funcs [] = return () -validStates snames used vars funcs (s:ss) = - do name <- validState snames used vars funcs s - validStates snames (name:used) vars funcs ss - -validCast t0 t1 = - let validCasts = [(LLInteger,LLFloat), (LLFloat,LLInteger), - (LLInteger,LLString),(LLString,LLInteger), - (LLFloat,LLString),(LLString,LLFloat), - (LLString,LLVector),(LLVector,LLString), - (LLString,LLKey),(LLKey,LLString), - (LLRot,LLString),(LLString,LLRot), - (LLList,LLString),(LLString,LLList)] in - do when (t0 /= t1 && (t0,t1) `notElem` validCasts) $ throwStrError ("can't cast from " ++ (lslTypeString t0) ++ " to " ++ (lslTypeString t1)) - -validCtxSimple :: [Var] -> Ctx Expr -> Validity LSLType -validCtxSimple vars (Ctx ctx expr) = incontext (ctx,"") $ validSimple vars expr - -validSimple :: [Var] -> Expr -> Validity LSLType -validSimple vars (IntLit i) = return LLInteger -validSimple vars (FloatLit f) = return LLFloat -validSimple vars (StringLit s) = return LLString -validSimple vars (KeyLit k) = return LLKey -validSimple vars (Get (Ctx ctx name,All)) = - (do (Var _ t) <- incontext (ctx, "variable " ++ name) $ findM (\ v -> varName v == name) vars - return t) - `mplus` (findConstType name) -validSimple vars (Get (Ctx ctx name,_)) = throwError (ctx,"can't access vector/rotation component in global variable initialization") -validSimple vars (ListExpr []) = return LLList -validSimple vars (ListExpr (e:es)) = - do t <- validCtxSimple vars e - when (t == LLList) $ throwError (srcCtx e,"lists cannot contain other lists") - validSimple vars (ListExpr es) -validSimple vars (VecExpr e1 e2 e3) = validSimpleStructure vars LLVector [e1,e2,e3] -validSimple vars (RotExpr e1 e2 e3 e4) = validSimpleStructure vars LLRot [e1,e2,e3,e4] -validSimple vars (Neg e) = - do t <- validCtxSimple vars e - when (t `notElem` [LLFloat, LLInteger]) $ throwError (srcCtx e,"operator only applicable to integers and floats in this context") - return t -validSimple vars e = throwStrError ("expression is not valid in a static context.") - -validSimpleStructure vars t [] = return t -validSimpleStructure vars t (e:es) = - do t' <- validCtxSimple vars e - when (t' `notElem` [LLFloat,LLInteger]) $ throwError (srcCtx e, "literal of type " ++ - (lslTypeString t') ++ " not a valid element of " ++ (lslTypeString t)) - validSimpleStructure vars t es - -validExpression :: Expr -> [FuncDec] -> [Var] -> [[Var]] -> Validity LSLType -validExpression (Cast t expr) funcs vars locals = - do t' <- validCtxExpr expr funcs vars locals - incontext (srcCtx expr, "") $ validCast t' t - return t -validExpression (Get ((Ctx ctx name),component)) funcs vars locals = - case (findType name (concat locals ++ vars) `mplus` findConstType name,component) of - (Nothing,_) -> throwError (ctx, "undefined variable or constant: " ++ name) - (Just LLRot,All) -> return LLRot - (Just LLRot,_) -> return LLFloat - (Just LLVector,All) -> return LLVector - (Just LLVector,S) -> throwError (ctx,"s is not a valid component of a vector") - (Just LLVector,_) -> return LLFloat - (Just t,All) -> return t - (Just t,_) -> throwError (ctx,"only vectors and rotations have components") -validExpression (Call name exprs) funcs vars locals = validCall funcs vars locals name exprs -validExpression (Not expr) funcs vars locals = - do t <- validCtxExpr expr funcs vars locals - when (t /= LLInteger) $ throwError (srcCtx expr, "expression is not an integer expression, which is required for applying the Not operator") - return t -validExpression (Neg expr) funcs vars locals = - do t <- validCtxExpr expr funcs vars locals - when (t == LLList) $ throwError (srcCtx expr, "operator not applicable to list type") - return t -validExpression (Inv expr) funcs vars locals = - do t <- validCtxExpr expr funcs vars locals - when (t /= LLInteger) $ throwError (srcCtx expr, "expression is not an integer expression, which is required for applying the inverse operator") - return t -validExpression plus@(Add expr1 expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLInteger,LLFloat) -> return LLFloat - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLVector) -> return LLVector - (LLRot,LLRot) -> return LLRot - (LLString,LLString) -> return LLString - (LLList,LLList) -> return LLList - (t,LLList) -> return LLList - (LLList,t) -> return LLList - (t0,t1) -> incompatibleOperands plus t0 t1 -validExpression minus@(Sub expr1 expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLInteger,LLFloat) -> return LLFloat - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLVector) -> return LLVector - (LLRot,LLRot) -> return LLRot - (t0,t1) -> incompatibleOperands minus t0 t1 -validExpression expr@(Mul expr1 expr2) funcs vars locals= - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) 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 - (LLFloat,LLVector) -> return LLVector - (LLInteger,LLVector) -> return LLVector - (LLVector,LLVector) -> return LLFloat - (LLVector,LLRot) -> return LLVector - (LLRot,LLRot) -> return LLRot - (t0,t1) -> incompatibleOperands expr t0 t1 -validExpression expr@(Div expr1 expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) 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 - (t0,t1) -> incompatibleOperands expr t0 t1 -validExpression expr@(Mod expr1 expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLVector,LLVector) -> return LLVector - _ -> incompatibleOperands expr t1 t2 -validExpression e@(Equal expr1 expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLFloat) -> return LLInteger - (LLFloat,LLInteger) -> return LLInteger - (LLString,LLKey) -> return LLInteger - (LLKey,LLString) -> return LLInteger - (t1,t2) | (t1 == t2) -> return LLInteger - | otherwise -> incompatibleOperands e t1 t2 -validExpression e@(NotEqual expr1 expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLFloat) -> return LLInteger - (LLFloat,LLInteger) -> return LLInteger - (LLString,LLKey) -> return LLInteger - (LLKey,LLString) -> return LLInteger - (t1,t2) | (t1 == t2) -> return LLInteger - | otherwise -> incompatibleOperands e t1 t2 -validExpression e@(BAnd expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals -validExpression e@(BOr expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals -validExpression e@(Xor expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals -validExpression e@(ShiftL expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals -validExpression e@(ShiftR expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals -validExpression e@(Gt expr1 expr2) funcs vars locals = validRelExpr (expr1,expr2) funcs vars locals -validExpression e@(Ge expr1 expr2) funcs vars locals = validRelExpr (expr1,expr2) funcs vars locals -validExpression e@(Le expr1 expr2) funcs vars locals = validRelExpr (expr1,expr2) funcs vars locals -validExpression e@(Lt expr1 expr2) funcs vars locals = validRelExpr (expr1, expr2) funcs vars locals -validExpression e@(And expr1 expr2) funcs vars locals = validBothInteger (expr1, expr2) funcs vars locals -validExpression e@(Or expr1 expr2) funcs vars locals = validBothInteger (expr1, expr2) funcs vars locals -validExpression e@(IncBy (name,All) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLVector) -> return LLVector - (LLRot,LLRot) -> return LLRot - (LLString,LLString) -> return LLString - (LLList,LLList) -> return LLList - (LLList,t) -> return LLList - (t0,t1) -> incompatibleOperands e t0 t1 -validExpression e@(IncBy (name,_) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat - | otherwise -> incompatibleOperands e t1 t2 -validExpression e@(DecBy (name,All) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLVector) -> return LLVector - (LLRot,LLRot) -> return LLRot - (t0,t1) -> incompatibleOperands e t0 t1 -validExpression e@(DecBy (name,_) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat - | otherwise -> incompatibleOperands e t1 t2 -validExpression e@(MulBy (name,All) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLInteger) -> return LLVector - (LLVector,LLFloat) -> return LLVector - (LLVector,LLVector) -> return LLVector -- note: LSL compiles this, but it results in runtime error! - (LLVector,LLRot) -> return LLVector - (LLRot,LLRot) -> return LLRot - (t0,t1) -> incompatibleOperands e t0 t1 -validExpression e@(MulBy (name,_) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat - | otherwise -> incompatibleOperands e t1 t2 -validExpression e@(DivBy (name,All) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLInteger) -> return LLVector - (LLVector,LLFloat) -> return LLVector - (LLVector,LLRot) -> return LLVector - (LLRot,LLRot) -> return LLRot - (t0,t1) -> incompatibleOperands e t0 t1 -validExpression e@(DivBy (name,_) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat - | otherwise -> incompatibleOperands e t1 t2 -validExpression e@(ModBy (name,All) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLVector,LLVector) -> return LLVector - (t0,t1) -> incompatibleOperands e t0 t1 -validExpression e@(ModBy (name,_) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (t1,t2) -> incompatibleOperands e t1 t2 -validExpression e@(PostInc var) funcs vars locals = validIncDecOp var vars locals "++" -validExpression e@(PostDec var) funcs vars locals = validIncDecOp var vars locals "--" -validExpression e@(PreInc var) funcs vars locals = validIncDecOp var vars locals "++" -validExpression e@(PreDec var) funcs vars locals = validIncDecOp var vars locals "++" -validExpression expr0@(Set (name,All) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLFloat,LLInteger) -> return LLFloat - (LLKey,LLString) -> return LLKey - (LLString,LLKey) -> return LLString - (t1,t2) | t1 == t2 -> return t1 - | otherwise -> incompatibleOperands expr0 t1 t2 -validExpression expr0@(Set (name,S) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLRot,LLFloat) -> return LLFloat - (LLRot,LLInteger) -> return LLFloat - (t0,t1) -> incompatibleOperands expr0 t0 t1 -validExpression expr0@(Set (name,_) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLVector,LLFloat) -> return LLFloat - (LLVector,LLInteger) -> return LLFloat - (LLRot,LLFloat) -> return LLFloat - (LLRot,LLInteger) -> return LLFloat - (t0,t1) -> incompatibleOperands expr0 t0 t1 -validExpression (IntLit i) _ _ _ = return LLInteger -validExpression (FloatLit _) _ _ _ = return LLFloat -validExpression (StringLit _) _ _ _ = return LLString -validExpression (KeyLit _) _ _ _ = return LLKey -validExpression (ListExpr es) fs vs ls = do - mapM (\ e -> validListExprElement e fs vs ls) es - return LLList -validExpression (VecExpr xExpr yExpr zExpr) funcs vars locals = - do xt <- validCtxExpr xExpr funcs vars locals - yt <- validCtxExpr yExpr funcs vars locals - zt <- validCtxExpr zExpr funcs vars locals - when (not (all (`elem` [LLInteger,LLFloat]) [xt,yt,zt])) $ throwStrError "invalid components for vector" - return LLVector -validExpression (RotExpr xExpr yExpr zExpr sExpr) funcs vars locals = - do xt <- validCtxExpr xExpr funcs vars locals - yt <- validCtxExpr yExpr funcs vars locals - zt <- validCtxExpr zExpr funcs vars locals - st <- validCtxExpr sExpr funcs vars locals - when (not (all (`elem` [LLInteger,LLFloat]) [xt,yt,zt,st])) $ throwStrError "invalid components for rotation" - return LLRot ---validExpression x funcs vars locals = error ("what to do with " ++ (show x)) - -validListExprElement (Ctx ctx e) funcs vars locals = do - t <- validExpression e funcs vars locals - when (t `elem` [LLVoid,LLList]) $ throwError (ctx,"invalid type for list element") - return () - -validMExpression Nothing funcs vars locals = return LLVoid -validMExpression (Just expr) funcs vars locals = validCtxExpr expr funcs vars locals - -validExpressions es funcs vars locals = mapM_ (\ e -> validCtxExpr e funcs vars locals) es - -validRelExpr (expr1,expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLInteger,LLFloat) -> return LLInteger - (LLFloat, LLInteger) -> return LLInteger - (LLFloat, LLFloat) -> return LLInteger - (t0,t1) -> throwStrError ("operands are of incompatible types") -validBothInteger (expr1, expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - when (t1 /= LLInteger || t2 /= LLInteger) $ throwStrError ("operands are of incompatible types") - return LLInteger -validEach (expr1, expr2) funcs vars locals = - do t1 <- validCtxExpr expr1 funcs vars locals - t2 <- validCtxExpr expr2 funcs vars locals - return (t1,t2) - -validNameExpr (Ctx ctx name, expr) funcs vars locals = - case (findType name (concat locals ++ vars), - validCtxExpr expr funcs vars locals) of - (Just t1, Right t2) -> return (t1,t2) - (Nothing, _) -> throwError (ctx, "variable " ++ name ++ " not defined") - (_,Left s) -> throwError s -validCall funcs vars locals (Ctx ctx fname) exprs = - do (FuncDec _ t params) <- findFuncDec fname funcs - let vArg _ [] [] = return () - vArg _ (p:ps) [] = throwError (ctx, "mismatch of arguments vs. formal paramters in call to function " ++ fname) - vArg _ [] (a:as) = throwError (ctx, "mismatch of arguments vs. formal paramters in call to function " ++ fname) - vArg n (Var name t:ts) (arg:args) = - do t' <- validCtxExpr arg funcs vars locals - when (not (matchTypes t t')) $ throwError (ctx, "argument " ++ (show n) ++ " in call to function (" ++ fname ++ ") is of wrong type:" ++ (lslTypeString t') ++ ", should be " ++ (lslTypeString t)) - vArg (n+1) ts args - vArg 1 (ctxItems params) exprs - return t - -validCtxExpr (Ctx ctx e) fs vs ls = incontext (ctx,"") $ validExpression e fs vs ls - -validIncDecOp (n@(Ctx ctx name),c) vars locals op = - do failIfNoModify n - case (findType name (concat locals ++ vars),c) of - (Nothing,_) -> throwError (ctx, "variable " ++ name ++ " not found") - (Just LLInteger,All) -> return LLInteger - (Just LLFloat,All) -> return LLFloat - (Just LLRot,S) -> return LLFloat - (Just LLVector,S) -> throwError (ctx, "s is not a valid component of " ++ name) - (Just t,All) -> throwError (ctx, name ++ " is not a valid operand for " ++ op) - (Just LLVector,_) -> return LLFloat - (Just LLRot,_) -> return LLFloat - _ -> throwError (ctx, name ++ " is not a valid operand for " ++ op) - -failIfNoModify (Ctx ctx name) = - when (isConstant name) $ throwError (ctx,"cannot modify " ++ name ++ " because it is a constant") - -incompatibleOperands expr t0 t1 = - throwStrError ("types of the operands aren't compatible (" ++ - (lslTypeString t0) ++ " vs. " ++ (lslTypeString t1) ++ ")") - -defined :: String -> [Var] -> Bool -defined n = any (\ (Var n' _) -> n == n') - -validStatement _ _ funcs vars rtype labels locals@(scope:scopes) returns (Decl var@(Var name t) expr) = - do when (defined name $ concat locals) $ throwStrError ("variable " ++ name ++ " already defined") -- can't hide another local, even in a surrounding scope - when (isConstant name) $ throwStrError ("variable " ++ name ++ " is a predefined constant") - case expr of - Nothing -> return ((var:scope):scopes,returns) - Just expr' -> do t' <- validCtxExpr expr' funcs vars locals - when (not $ matchTypes t t') $ throwError (srcCtx expr', "type of expression in declaration of " ++ name ++ " does not match " ++ lslTypeString t) - return ((var:scope):scopes,returns) -validStatement scallow snames funcs vars rtype labels locals returns (While expr statement) = - do t <- validCtxExpr expr funcs vars locals - --when (t /= LLInteger) $ throwError (srcCtx expr, "expression is not a valid loop condition") - validStatement scallow snames funcs vars rtype labels locals False statement - return (locals,returns) -validStatement scallow snames funcs vars rtype labels locals returns (DoWhile statement expr) = - do t <- validCtxExpr expr funcs vars locals - --when (t /= LLInteger) $ throwError (srcCtx expr, "expression is not a valid loop condition") - validStatement scallow snames funcs vars rtype labels locals False statement - return (locals,returns) -validStatement scallow snames funcs vars rtype labels locals returns (For mexpr1 mexpr2 mexpr3 statement) = - do validExpressions mexpr1 funcs vars locals - validExpressions mexpr3 funcs vars locals - t <- validMExpression mexpr2 funcs vars locals - --when (t /= LLInteger) $ throwStrError ("expression is not a valid loop condition") - validStatement scallow snames funcs vars rtype labels locals False statement - return (locals,returns) -validStatement scallow snames funcs vars rtype labels locals returns (If expr thenStmt elseStmt) = - do t <- validCtxExpr expr funcs vars locals - --when (t /= LLInteger) $ throwError (srcCtx expr, "expression is not a valid 'if' condition") - (_,ret1) <- validStatement scallow snames funcs vars rtype labels locals False thenStmt - (_,ret2) <- validStatement scallow snames funcs vars rtype labels locals False elseStmt - return (locals,returns || ret1 && ret2) -validStatement _ _ _ _ _ _ locals returns NullStmt = return (locals,returns) -validStatement _ _ funcs vars rtype labels locals _ (Return Nothing) = - do when (rtype /= LLVoid) (throwStrError "function must return a value") - return (locals,True) -validStatement _ _ funcs vars rtype labels locals _ (Return (Just expr)) = - do t <- validCtxExpr expr funcs vars locals - when (t /= rtype && not (all (`elem` [LLString,LLKey]) [t,rtype])) (throwStrError "inappropriate return type for function/handler") - return (locals,True) -validStatement scallow snames funcs vars rtype labels locals returns (StateChange name) = do - when (not scallow) $ throwStrError "state changes not allowed from this context" - when (not (name `elem` snames)) $ throwStrError (name ++ " is not a valid state") - return (locals,returns) -validStatement _ _ funcs vars rtype labels locals returns (Do expr) = validCtxExpr expr funcs vars locals>>return (locals,returns) -validStatement scallow snames funcs vars rtype labels locals returns (Compound stmts) = - do returns' <- validStatements scallow snames funcs vars rtype labels ([]:locals) stmts - return (locals,returns || returns') -validStatement _ _ funcs vars rtype labels locals _ (Label _) = return (locals,False) -validStatement _ _ funcs vars rtype labels locals returns (Jump s) = - do when (s `notElem` concat labels) $ throwStrError ("no such label to jump to: " ++ s) - return (locals,returns) - -validStatement' scallow snames funcs vars rtype labels locals returns line (Ctx ctx stmt) = - incontext (ctx, "") $ validStatement scallow snames funcs vars rtype labels locals returns stmt - -validStatements :: Bool -> [String] -> [FuncDec] -> [Var] -> LSLType -> [[String]] -> [[Var]] -> [CtxStmt] -> Validity Bool -validStatements scallow snames funcs vars rtype labels locals stmts = - do let newLabels = map (\ (Label s) -> s) $ filter isLabel (ctxItems stmts) - (_,r') <- foldM (\ (l,r) (n, s) -> - validStatement' scallow snames funcs vars rtype (newLabels:labels) l r n s) (locals,False) $ zip ([1..]::[Int]) stmts - return r' - -validHandler snames used funcs vars (Handler (Ctx ctx name) args stmts) = - do when (name `elem` used) $ throwError (ctx,name ++ " already used in state") - types <- incontext (ctx,"handler: ") $ lookupM name goodHandlers - when (types /= map varType args') $ throwError (ctx,"invalid argument types for handler " ++ name) - when (length args /= (length $ nub $ map varName args')) $ throwError (ctx,"not all argument names are unique for handler " ++ name) - validStatements True snames funcs vars LLVoid [] [[],args'] stmts - return name - where args' = ctxItems args - -validHandlers _ _ _ _ [] = return () -validHandlers snames used funcs vars (h:hs) = - do name <- validHandler snames used funcs vars h - validHandlers snames (name:used) funcs vars hs - --- Validating a library of modules - --- -validModule library m@(LModule globs freevars) = - do --used <- noDupGlobs Nothing "" [] library globs - (typedVars, typedFuncs) <- typeGlobs library globs - let used = (map varName typedVars) ++ (map (ctxItem . funcName) typedFuncs) - noDupVars used freevars - let vars = freevars' ++ reverse typedVars - let funcDecs = typedFuncs ++ predefFuncs - (vs,fs,_,_) <- foldM (validGlob library vars funcDecs) ([],[],[],[]) globs - return (vs,fs) - where freevars' = ctxItems freevars - --- this function isn't partiuclarly efficient! -moduleDependencies lib chain m = - let f (GI s _ _) = Just (ctxItem s) - f _ = Nothing - in do (LModule globs _) <- lookupM m lib - case filtMap f globs of - [] -> return [] - list -> if any (`elem` list) (m:chain) then throwStrError "circular dependency" - else - do deps <- fmap concat ( - let chain' = (m:chain) in - mapM (moduleDependencies lib chain') list) - return $ nub (list ++ deps) - --- sort modules by dependency: for each module in the list, after sorting that module --- will depend only on modules preceding it in the list. This of course implies that --- there can be no circular dependencies in the modules. -sortModules :: [(String,(LModule,[String]))] -> [(String,LModule)] -sortModules modules = - let cmp (name,(_,deplist)) (name',(_,deplist')) = compare (length deplist, name) (length deplist', name') - sort1 [] = [] - sort1 list = - let sorted = sortBy cmp list - (nodeps,deps) = span ((==0).length.snd.snd) sorted - exclude = map fst nodeps - newlist = if length nodeps == 0 then error "circular depencencies in library" - else map (\ (nm,(m,l)) -> (nm, (m,filter (`notElem` exclude) l))) deps - in nodeps ++ sort1 newlist - in map (\ (s,(m,_)) -> (s,m)) $ sort1 modules - -validLibrary modules = - let checkDep (n,m) = case moduleDependencies modules [] n of - Right deps -> (n,Right (m,deps)) - Left s -> (n,Left s) - categorize (good,bad) (n,Left s) = (good,(n,s):bad) - categorize (good,bad) (n,Right (m,deps)) = ((n,(m,deps)):good,bad) - (good,bad) = foldl categorize ([],[]) $ map checkDep modules - sorted = sortModules good - validate augLib (name,m) = - case validModule (libFromAugLib augLib) m of - Left s -> (name, Left s):augLib - Right gs -> (name,Right (m,gs)):augLib - in (foldl validate [] sorted) ++ (map (\ (n,s) -> (n,Left s)) bad) - -libFromAugLib :: AugmentedLibrary -> Library -libFromAugLib augLib = - let f (name,Left s) = (name,Left s) - f (name,Right (lm,_)) = (name, Right lm) - in map f augLib - -tstLib = [ - ("alpha", LModule [GI (nullCtx "beta") [] []] []), - ("beta", LModule [GI (nullCtx "gamma") [] []] []), - ("gamma", LModule [GI (nullCtx "alpha") [] []] []), - ("omega", LModule [GI (nullCtx "lambda") [] []] []), - ("lambda", LModule [GI (nullCtx "kappa") [] [], GI (nullCtx "sigma") [] []] []), - ("kappa", LModule [] []), - ("sigma", LModule [] [])] - -rewriteName renames (Ctx ctx name) = - case lookup name renames of - Nothing -> Ctx ctx name - Just name' -> Ctx ctx name' -rewriteStatements _ _ [] = [] -rewriteStatements n bindings (Ctx c s:ss) = - let (n',bindings',s') = rewriteStatement n bindings s in - (Ctx c s'):(rewriteStatements n' bindings' ss) - -rewriteStatement n bindings (Compound stmts) = (n, bindings, Compound $ rewriteStatements n bindings stmts) -rewriteStatement n bindings (While expr stmt) = - let (_,_,stmt') = rewriteStatement n bindings stmt in - (n, bindings, While (rewriteCtxExpr bindings expr) stmt') -rewriteStatement n bindings (DoWhile stmt expr) = - let (_,_,stmt') = rewriteStatement n bindings stmt in - (n, bindings, DoWhile stmt' (rewriteCtxExpr bindings expr)) -rewriteStatement n bindings (For mexpr1 mexpr2 mexpr3 stmt) = - let (_,_,stmt') = rewriteStatement n bindings stmt - rewriteMExpr = rewriteMExpression bindings - rewriteEs = rewriteCtxExprs bindings in - (n, bindings, For (rewriteEs mexpr1) (rewriteMExpr mexpr2) (rewriteEs mexpr3) stmt') -rewriteStatement n bindings (If expr stmt1 stmt2) = - let (_,_,stmt1') = rewriteStatement n bindings stmt1 - (_,_,stmt2') = rewriteStatement n bindings stmt2 in - (n, bindings, If (rewriteCtxExpr bindings expr) stmt1' stmt2') -rewriteStatement n bindings (Decl (Var name t) val) = - let (n',bindings', newname) = - if any (\(name',_) -> name == name') bindings then let newname = "local" ++ (show n) in (n + 1, (name,newname):bindings, newname) - else (n,bindings,name) - in (n',bindings',Decl (Var newname t) (rewriteMExpression bindings val)) -rewriteStatement n bindings (Return Nothing) = (n, bindings, Return Nothing) -rewriteStatement n bindings (Return (Just expr)) = (n, bindings, Return $ Just $ rewriteCtxExpr bindings expr) -rewriteStatement n bindings (Do expr) = (n, bindings, Do $ rewriteCtxExpr bindings expr) -rewriteStatement n bindings s = (n, bindings, s) - ---rewriteExpressions bindings es = map (rewriteExpression bindings) es - -rewriteCtxExpr bindings (Ctx ctx expr) = Ctx ctx $ rewriteExpression bindings expr -rewriteCtxExprs bindings ctxExprs = map (rewriteCtxExpr bindings) ctxExprs - -rewriteExpression _ (IntLit i) = IntLit i -rewriteExpression _ (FloatLit f) = FloatLit f -rewriteExpression _ (StringLit s) = StringLit s -rewriteExpression _ (KeyLit k) = KeyLit k -rewriteExpression bindings (ListExpr l) = ListExpr $ rewriteCtxExprs bindings l -rewriteExpression bindings (VecExpr e1 e2 e3) = VecExpr (rewriteCtxExpr bindings e1) (rewriteCtxExpr bindings e2) (rewriteCtxExpr bindings e3) -rewriteExpression bindings (RotExpr e1 e2 e3 e4) = RotExpr (rewriteCtxExpr bindings e1) (rewriteCtxExpr bindings e2) (rewriteCtxExpr bindings e3) (rewriteCtxExpr bindings e4) -rewriteExpression bindings (Add expr1 expr2) = Add (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Sub expr1 expr2) = Sub (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Mul expr1 expr2) = Mul (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Div expr1 expr2) = Div (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Mod expr1 expr2) = Mod (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (BAnd expr1 expr2) = BAnd (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Xor expr1 expr2) = Xor (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (BOr expr1 expr2) = BOr (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Lt expr1 expr2) = Lt (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Gt expr1 expr2) = Gt (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Le expr1 expr2) = Le (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Ge expr1 expr2) = Ge (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (And expr1 expr2) = And (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Or expr1 expr2) = Or (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (ShiftL expr1 expr2) = ShiftL (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (ShiftR expr1 expr2) = ShiftR (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Equal expr1 expr2) = Equal (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (NotEqual expr1 expr2) = NotEqual (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Inv expr) = Inv $ rewriteCtxExpr bindings expr -rewriteExpression bindings (Not expr) = Not $ rewriteCtxExpr bindings expr -rewriteExpression bindings (Neg expr) = Neg $ rewriteCtxExpr bindings expr -rewriteExpression bindings (Call name exprs) = Call (rewriteName bindings name) $ rewriteCtxExprs bindings exprs -rewriteExpression bindings (Cast t expr) = Cast t $ rewriteCtxExpr bindings expr -rewriteExpression bindings (Get (name,component)) = Get (rewriteName bindings name,component) ---rewriteExpression bindings c@(Const _) = c -rewriteExpression bindings (Set (name,component) expr) = Set (rewriteName bindings name,component) (rewriteCtxExpr bindings expr) -rewriteExpression bindings (IncBy (name,component) expr) = IncBy (rewriteName bindings name,component) (rewriteCtxExpr bindings expr) -rewriteExpression bindings (DecBy (name,component) expr) = DecBy (rewriteName bindings name,component) (rewriteCtxExpr bindings expr) -rewriteExpression bindings (MulBy (name,component) expr) = MulBy (rewriteName bindings name,component) (rewriteCtxExpr bindings expr) -rewriteExpression bindings (DivBy (name,component) expr) = DivBy (rewriteName bindings name,component) (rewriteCtxExpr bindings expr) -rewriteExpression bindings (ModBy (name,component) expr) = ModBy (rewriteName bindings name,component) (rewriteCtxExpr bindings expr) -rewriteExpression bindings e@(PostInc _) = e -rewriteExpression bindings e@(PostDec _) = e -rewriteExpression bindings e@(PreInc _) = e -rewriteExpression bindings e@(PreDec _) = e -rewriteMExpression bindings = fmap (rewriteCtxExpr bindings) - -data SourceContext = TextLocation { textLine0 :: Int, textColumn0 :: Int, textLine1 :: Int, textColumn1 :: Int, textName :: String } | - UnknownSourceContext - deriving (Show,Typeable,Data) - -isTextLocation (TextLocation _ _ _ _ _) = True -isTextLocation _ = False - --- | A wrapper that can associate a source code context with a value (e.g. a syntax value). -data Ctx a = Ctx { srcCtx :: SourceContext, ctxItem :: a } deriving (Show,Typeable,Data) -instance Functor Ctx where - fmap f (Ctx c v) = (Ctx c $ f v) - -ctxItems = map ctxItem - -fromMCtx :: Maybe (Ctx a) -> Maybe a -fromMCtx = fmap ctxItem- -nullCtx :: a -> Ctx a -nullCtx = Ctx UnknownSourceContext - -funcNames = map (ctxItem.funcName) - -ctxVr2Vr :: (Ctx a,b) -> (a,b) -ctxVr2Vr (Ctx _ name,c) = (name,c)
− Language/Lsl/UnitTest.hs
@@ -1,72 +0,0 @@-module Language.Lsl.UnitTest( - LSLUnitTest(..), - FuncCallExpectations(..), - ExpectationMode(..), - EntryPoint(..), - expectedReturns, - removeExpectation) where - -import Control.Monad(liftM2) -import Data.List(maximumBy) -import Language.Lsl.Internal.Type(LSLValue(..)) -import Language.Lsl.Internal.Exec(Binding(..)) -import Language.Lsl.Internal.Util(removeLookup) - -data FuncCallExpectations = FuncCallExpectations { - expectationMode :: ExpectationMode, - callList :: [((String, [Maybe LSLValue]),LSLValue)] } deriving (Show) - -data ExpectationMode = Nice | Normal | Exhaust | Strict deriving (Show,Eq) - -data EntryPoint = ModuleFunc String String | ScriptFunc String String | ScriptHandler String String String - deriving (Show) - -data LSLUnitTest = LSLUnitTest { - unitTestName :: String, - entryPoint :: EntryPoint, - initialGlobs :: [Binding], - arguments :: [LSLValue], - expectedCalls :: FuncCallExpectations, - expectedReturn :: Maybe LSLValue, - expectedGlobalVals :: [Binding], - expectedNewState :: Maybe String - } deriving (Show) - -argMatch (Just x) y | lslValuesMatch x y = Just 1 - | otherwise = Nothing -argMatch Nothing _ = Just 0 -argsMatch expectArgs args = foldl (liftM2 (+)) (Just 0) $ zipWith argMatch expectArgs args - -lslValuesMatch (FVal a) (FVal b) = a == b || - if a == 0.0 then b < 0.000001 - else if b == 0.0 then a < 0.000001 - else abs ((b - a) / a) < 0.000001 -lslValuesMatch x y = x == y - -matchFail :: Monad m => m a -matchFail = fail "no matching call" - -expectedReturns :: (Monad m) => String -> [LSLValue] -> FuncCallExpectations -> m ((String,[Maybe LSLValue]),LSLValue) -expectedReturns name args (FuncCallExpectations Strict (match@((name',expectArgs),returns):_)) = - if name /= name' || argsMatch expectArgs args == Nothing then matchFail - else return match -expectedReturns name args (FuncCallExpectations Strict _) = matchFail -expectedReturns n a (FuncCallExpectations mode callList) = - let rightNames = filter ((n==) . fst . fst) callList - argMatch (Just x) y | x == y = Just 1 - | otherwise = Nothing - argMatch Nothing _ = Just 0 - argsMatch args expectArgs = foldl (liftM2 (+)) (Just 0) $ zipWith argMatch expectArgs args - ranked = zip (map (argsMatch a) (map (snd . fst) rightNames)) rightNames - orderMatch (Nothing,_) (Nothing,_) = EQ - orderMatch _ (Nothing,_) = GT - orderMatch (Nothing,_) _ = LT - orderMatch ((Just a),_) ((Just b),_) = compare a b - in case ranked of - [] -> fail matchFail - _ -> case maximumBy orderMatch ranked of - (Nothing,_) -> matchFail - (_,e) -> return e - -removeExpectation :: (String,[Maybe LSLValue]) -> FuncCallExpectations -> FuncCallExpectations -removeExpectation m fce = fce { callList = removeLookup m (callList fce) }
− Language/Lsl/UnitTestEnv.hs
@@ -1,268 +0,0 @@-module Language.Lsl.UnitTestEnv( - simStep, - simFunc, - hasFunc, - SimpleWorld, - TestEvent(..), - ExecutionInfo(..), - ExecCommand(..)) where - -import Control.Monad(liftM2) -import Control.Monad.State(MonadState(..),State(..),StateT(..),evalState) -import Control.Monad.Error(ErrorT(..)) -import Data.List(find,intersperse) -import Data.Maybe(isJust) -import Language.Lsl.Internal.Breakpoint(Breakpoint,BreakpointManager,checkBreakpoint,emptyBreakpointManager, - replaceBreakpoints,setStepBreakpoint,setStepOverBreakpoint,setStepOutBreakpoint, - breakpointFile,breakpointLine) -import Language.Lsl.Internal.CodeHelper(renderCall) -import Language.Lsl.Internal.FuncSigs(funcSigs) -import Language.Lsl.Internal.InternalLLFuncs(internalLLFuncs) -import Language.Lsl.Syntax hiding (State) -import qualified Language.Lsl.Syntax as L -import Language.Lsl.Internal.Type(LSLValue,lslValString,lslShowVal,defaultValue) -import Language.Lsl.Internal.Evaluation(EvalResult(..)) -import Language.Lsl.Internal.Exec(- EvalState,ExecutionInfo(..),ScriptImage(..),evalSimple,runEval,scriptImage,setupSimple,initStateSimple,frameInfo) -import Language.Lsl.Internal.TestResult(TestResult(..)) -import Language.Lsl.UnitTest(EntryPoint(..),LSLUnitTest(..),ExpectationMode(..),FuncCallExpectations(..),expectedReturns,removeExpectation) -import Language.Lsl.Internal.Util(findM,ctx) - ---trace1 v = trace ("->>" ++ (show v)) v - -data SimpleWorld = SimpleWorld { - maxTick :: Int, - tick :: Int, - msgLog :: [(Int,String)], - wScripts :: [(String,Validity CompiledLSLScript)], - wLibrary :: [(String,Validity LModule)], - expectations :: FuncCallExpectations, - breakpointManager :: BreakpointManager - } - -type SimpleWorldM = ErrorT String (State SimpleWorld) -simpleWorldM = ErrorT . State -getTick :: SimpleWorldM Int -getTick = get >>= return . tick -getMaxTick :: SimpleWorldM Int -getMaxTick = get >>= return . maxTick -getMsgLog :: SimpleWorldM [(Int,String)] -getMsgLog = get >>= return . msgLog -getWScripts :: SimpleWorldM [(String, Validity CompiledLSLScript)] -getWScripts = get >>= return . wScripts -getWLibrary :: SimpleWorldM [(String, Validity LModule)] -getWLibrary = get >>= return . wLibrary -getExpectations :: SimpleWorldM FuncCallExpectations -getExpectations = get >>= return . expectations -getBreakpointManager :: SimpleWorldM BreakpointManager -getBreakpointManager = get >>= return . breakpointManager - -setTick t = do w <- get; put (w { tick = t }) -setMsgLog l = do w <- get; put (w { msgLog = l }) -setExpectations e = do w <- get; put (w { expectations = e }) -setBreakpointManager bpm = do w <- get; put (w { breakpointManager = bpm }) -modifyMsgLog f = do w <- get; put (w { msgLog = f (msgLog w) }) - -checkBp bp sm = - do bpm <- getBreakpointManager - let (result,bpm',sm') = checkBreakpoint bp bpm sm - setBreakpointManager bpm' - return (result,sm') - -logMsg s = do - tick <- getTick - modifyMsgLog ((tick,s):) - -doPredef n i a = - do logMsg $ "call: " ++ renderCall n a - case lookup n internalLLFuncs of - Just f -> do - result@(m, v) <- f i a - logMsg ("return: " ++ lslShowVal v) - return result - Nothing -> do - fce <- getExpectations - let allowed = Nice == expectationMode fce - case expectedReturns n a fce of - Nothing -> handleUnexpected allowed - Just (m, v) -> do - logMsg ("return: " ++ lslShowVal v) - setExpectations $ removeExpectation m fce - return (EvalIncomplete,v) - where handleUnexpected allowed = - if allowed then - do (_,rt,_) <- ctx ("finding predef " ++ n) $ - findM (\ (n',_,_) -> n' == n) funcSigs - return $ (EvalIncomplete, defaultValue rt) - else fail ("unexpected call: " ++ renderCall n a) - -mkScript (LModule globdefs vars) = - LSLScript (varsToGlobdefs ++ globdefs) [L.State (nullCtx "default") []] - where varsToGlobdefs = map (\ v -> GV v Nothing) vars - -getValidScript name = - do scripts <- getWScripts - case lookup name scripts of - Nothing -> return (Left $ "No such script: " ++ name) - Just (Left s) -> return $ Left $ "Invalid script: " ++ name - Just (Right script) -> return $ Right script - -convertEntryPoint (ScriptFunc scriptName funcName) = - do script <- getValidScript scriptName - return $ liftM2 (,) script (Right [funcName]) -convertEntryPoint (ScriptHandler scriptName stateName handlerName) = - do script <- getValidScript scriptName - return $ liftM2 (,) script (Right [stateName,handlerName]) -convertEntryPoint (ModuleFunc moduleName funcName) = - do lib <- getWLibrary - case lookup moduleName lib of - Nothing -> return (Left $ "No such module: " ++ moduleName) - Just (Left s) -> return (Left $ "Invalid module: " ++ moduleName) - Just (Right lmodule) -> - case validLSLScript lib (mkScript lmodule) of - Left _ -> return $ Left "Invalid entry point (internal error?)" - Right script -> return $ Right (script,[funcName]) - -checkResults (ms1, val, globs, w) unitTest = - let name = unitTestName unitTest - ms0 = expectedNewState unitTest - expectedR = expectedReturn unitTest in - if ((expectationMode $ expectations w) `elem` [Strict,Exhaust]) && - (not (null (callList $ expectations w))) then - FailureResult name ("some expected function calls not made: " ++ - concat (intersperse ", " $ map (fst.fst) $ callList $ expectations w)) - (msgLog w) - else case (ms0, ms1) of - (Nothing, Just st) -> - FailureResult name ("expected no state change, but changed to " ++ st) (msgLog w) - (Just st, Nothing) -> - FailureResult name ("expected state change to " ++ st ++ ", but no change occurred") (msgLog w) - (ms0, ms1) | ms0 /= ms1 -> let (Just s0, Just s1) = (ms0,ms1) in - FailureResult name ("expected state change to " ++ s0 ++ - ", but acutally changed to " ++ s1) (msgLog w) - | otherwise -> - if expectedR /= Nothing && expectedR /= Just val then - let (Just val') = expectedR in - FailureResult name ("expected return value was " ++ (lslValString val') ++ - ", but actually was " ++ (lslValString val)) (msgLog w) - else - case find (`notElem` globs) (expectedGlobalVals unitTest) of - Just (globname,val) -> - case lookup globname globs of - Nothing -> - FailureResult name ("expected global " ++ globname ++ " to have final value of " ++ - (lslValString val) ++ ", but no such global was found") - (msgLog w) - Just val' -> - FailureResult name ("expected global " ++ globname ++ " to have final value of " ++ - (lslValString val) ++ ", but actually had value of " ++ - (lslValString val')) (msgLog w) - Nothing -> SuccessResult name (msgLog w) - --------------------------------------------------- --- 'Interactive' testing - -data TestEvent = TestComplete TestResult | TestSuspended ExecutionInfo | AllComplete - -data ExecCommand = ExecContinue [Breakpoint] | ExecStep [Breakpoint] | ExecStepOver [Breakpoint] | - ExecStepOut [Breakpoint] - -breakpointsFromCommand (ExecContinue bps) = bps -breakpointsFromCommand (ExecStep bps) = bps -breakpointsFromCommand (ExecStepOver bps) = bps -breakpointsFromCommand (ExecStepOut bps) = bps - -hasFunc :: [(String,Validity LModule)] -> (String,String) -> Either String Bool -hasFunc lib (moduleName,functionName) = - case converted of - Left s -> Left ("no such module: " ++ moduleName) - Right (Left s) -> Left ("no such module: " ++ moduleName) - Right (Right (script,path)) -> Right $ isJust (findFunc functionName $ scriptFuncs script) - where converted = evalState (runErrorT (convertEntryPoint ep)) world - ep = ModuleFunc moduleName functionName - world = SimpleWorld { maxTick = 10000, tick = 0, msgLog = [], wScripts = [], wLibrary = lib, - expectations = FuncCallExpectations Nice [], breakpointManager = emptyBreakpointManager } - -simFunc :: [(String,Validity LModule)] -> (String,String) -> [(String,LSLValue)] -> [LSLValue] -> Either String (LSLValue,[(String,LSLValue)]) -simFunc lib (moduleName,functionName) globs args = - let world = SimpleWorld { maxTick = 10000, tick = 0, msgLog = [], wScripts = [], wLibrary = lib, - expectations = FuncCallExpectations Nice [], breakpointManager = emptyBreakpointManager } - ep = ModuleFunc moduleName functionName - init = runState (runErrorT ( - do converted <- convertEntryPoint ep - case converted of - Left s -> fail s - Right (script,path) -> - do result <- runEval (setupSimple path globs args) exec - case result of - (Left s, _) -> fail s - (Right (), exec') -> return exec' - where exec = initStateSimple script doPredef logMsg getTick setTick checkBp)) world - in case init of - (Left s, world') -> Left s - (Right exec,world') -> - case (runState $ runErrorT $ (runStateT $ runErrorT $ evalSimple 1000) exec) world of - (Left s,_) -> Left s - (Right r, _) -> - case r of - (Left s,_) -> Left s - (Right (EvalComplete newState, Just val), exec') -> Right (val,glob $ scriptImage exec') - (Right (EvalComplete newState, _),_) -> Left "execution error" - (Right (EvalIncomplete,_),_) -> Left "execution error: timeout" - (Right _,_) -> Left "execution error" - -simSome exec world = runState (runErrorT ( - do maxTick <- getMaxTick - (runStateT $ runErrorT $ evalSimple maxTick) exec)) world - --- no more tests, not currently executing -simStep _ _ ([], Nothing) _ = (AllComplete,([],Nothing)) --- not currently executing, more tests -simStep scripts lib (unitTest:tests, Nothing) command = - let world = (SimpleWorld { maxTick = 10000, tick = 0, msgLog = [], - wScripts = scripts, wLibrary = lib, expectations = (expectedCalls unitTest), - breakpointManager = emptyBreakpointManager}) - ep = entryPoint unitTest - globs = initialGlobs unitTest - args = arguments unitTest - name = unitTestName unitTest - init = runState (runErrorT ( - do converted <- convertEntryPoint ep - case converted of - Left s -> fail s - Right (script,path) -> - do result <- runEval (setupSimple path globs args) exec - case result of - (Left s, _) -> fail s - (Right (),exec') -> return exec' - where exec = initStateSimple script doPredef logMsg getTick setTick checkBp)) world - in case init of - (Left s,world') -> (TestComplete $ ErrorResult name s [],(tests, Nothing)) - (Right exec,world') -> simStep scripts lib (unitTest:tests, Just (world',exec)) command --- currently executing -simStep _ _ (unitTest:tests, Just (world,exec)) command = - let name = unitTestName unitTest - breakpoints = breakpointsFromCommand command - world' = world { breakpointManager = replaceBreakpoints breakpoints (breakpointManager world) } - updateStepManager f ex = let img = scriptImage ex - stepMgr = stepManager img in ex { scriptImage = img { stepManager = f stepMgr } } - execNew = case command of - ExecStep _ -> updateStepManager setStepBreakpoint exec - ExecStepOver _ -> updateStepManager setStepOverBreakpoint exec - ExecStepOut _ -> updateStepManager setStepOutBreakpoint exec - _ -> exec - in - case simSome execNew world' of - (Left s,world'') -> (TestComplete $ ErrorResult name s (msgLog world''),(tests,Nothing)) - (Right res,world'') -> - case res of - (Left s,_) -> (TestComplete $ ErrorResult name s (msgLog world''),(tests,Nothing)) - (Right (EvalComplete newState,Just val), exec') -> (TestComplete checkedResult, (tests,Nothing)) - where checkedResult = checkResults (newState, val, glob $ scriptImage exec', world'') unitTest - (Right (EvalIncomplete,_),_) -> (TestComplete $ Timeout name (msgLog world''),(tests,Nothing)) - (Right (BrokeAt bp,_),exec') -> - (TestSuspended (ExecutionInfo file line frames),(unitTest:tests,Just (world'',exec'))) - where file = breakpointFile bp - line = breakpointLine bp - frames = frameInfo (scriptImage exec') -
− Language/Lsl/WorldDef.hs
@@ -1,817 +0,0 @@-{-# OPTIONS_GHC -XFlexibleContexts #-} -module Language.Lsl.WorldDef(Avatar(..), - AvatarControlListener(..), - Prim(..), - PrimFace(..), - TextureInfo(..), - Flexibility(..), - LightInfo(..), - LSLObject(..), - ObjectDynamics(..), - PositionTarget(..), - RotationTarget(..), - PrimType(..), - FullWorldDef(..), - Region(..), - Parcel(..), - InventoryItemIdentification(..), - InventoryItem(..), - InventoryInfo(..), - InventoryItemData(..), - Script(..), - ScriptId, - Attachment(..), - CameraParams(..), - Email(..), - WebHandling(..), - defaultAvatar, - defaultCamera, - defaultDynamics, - isInvScriptItem, - isInvBodyPartItem, - isInvGestureItem, - isInvClothingItem, - isInvTextureItem, - isInvSoundItem, - isInvAnimationItem, - isInvLandmarkItem, - isInvNotecardItem, - isInvObjectItem, - inventoryInfoPermValue, - defaultInventoryPermissions, - inventoryItemName, - inventoryItemNames, - scriptInventoryItem, - findByInvName, - findByInvKey, - emptyPrim, - primPhantomBit, - primPhysicsBit, - worldFromFullWorldDef, - worldElement, - defaultRegions, - mkScript - ) where - -import Control.Monad(when,foldM) -import Control.Monad.Error(MonadError(..),ErrorT(..)) -import Control.Monad.Writer(tell,lift,runWriterT) - -import qualified Control.Monad.State as SM(get,put,State) -import Data.List(find) -import qualified Data.Map as M -import qualified Data.IntMap as IM -import Data.Maybe(isNothing) - -import Language.Lsl.Internal.DOMProcessing(ElemAcceptor(..),Element(..),findOrDefault,findValueOrDefault,elementList, - findOptionalElement,elementsOnly,findValue,findElement,findSimple,simpleElement, - findSimpleOrDefault,valueAcceptor,elementListWith,matchChoice) -import Language.Lsl.Internal.Evaluation(Event(..)) -import Language.Lsl.Internal.Exec(ScriptImage,initLSLScript) -import Language.Lsl.Internal.Key(mkKey,nullKey) -import Language.Lsl.Internal.Type(LSLValue(..)) -import Language.Lsl.Internal.Util(mlookup,readM,Permutation3(..),rotationsToQuaternion) - -type KeyManagerM = ErrorT String (SM.State (M.Map String String,Integer)) - -type ScriptId = (String,String) - -data FullWorldDef = FullWorldDef { - fullWorldDefMaxTime :: Int, - fullWorldDefSliceSize :: Int, - fullWorldDefWebHandling :: WebHandling, - fullWorldDefEventHandler :: Maybe String, - fullWorldDefObjects :: [LSLObject], - fullWorldDefPrims :: [Prim], - fullWorldDefAvatars :: [Avatar], - fullWorldDefRegions :: [((Int,Int),Region)], - fullWorldDefInitialKeyIndex :: Integer } deriving (Show) - -data WebHandling = WebHandlingByFunction - | WebHandlingByDoingNothing - | WebHandlingByInternet { webHandlingTimeout :: Float } deriving (Show) - -data LSLObject = LSLObject { primKeys :: [String], objectDynamics :: !ObjectDynamics } deriving (Show) - -data ObjectDynamics = ObjectDynamics { - objectPosition :: (Float,Float,Float), - objectRotation :: (Float,Float,Float,Float), - objectVelocity :: (Float,Float,Float), - objectForce :: ((Float,Float,Float),Bool), - objectBuoyancy :: Float, - objectImpulse :: (((Float,Float,Float),Bool),Int), - objectTorque :: ((Float,Float,Float),Bool), - objectRotationalImpulse :: (((Float,Float,Float),Bool),Int), - objectOmega :: (Float,Float,Float), - objectPositionTarget :: !(Maybe PositionTarget), - objectRotationTarget :: !(Maybe RotationTarget), - objectVolumeDetect :: Bool - } deriving (Show) - -defaultDynamics = ObjectDynamics { objectPosition = (0,0,0), - objectRotation = (0,0,0,1), - objectVelocity = (0,0,0), - objectForce = ((0,0,0),False), - objectBuoyancy = 0, - objectImpulse = (((0,0,0),False),0), - objectTorque = ((0,0,0),False), - objectRotationalImpulse = (((0,0,0),False),0), - objectOmega = (0,0,0), - objectPositionTarget = Nothing, - objectRotationTarget = Nothing, - objectVolumeDetect = False } -data PositionTarget = Repel { positionTargetTau :: Float, - positionTargetOverWater :: Bool, - positionTargetHeight :: Float } - | Hover { positionTargetTau :: Float, - positionTargetOverWater :: Bool, - positionTargetHeight :: Float } - | PositionTarget { positionTargetTau :: Float, - positionTargetLocation :: (Float,Float,Float), - positionTargetSetBy :: ScriptId } - deriving (Show) - -data RotationTarget = RotationTarget { rotationTarget :: (Float,Float,Float,Float), - rotationTargetStrength :: Float, - rotationTargetTau :: Float } deriving (Show) - -data Avatar = Avatar { avatarKey :: String, - avatarName :: String, - avatarActiveGroup :: Maybe String, - avatarRegion :: (Int,Int), - avatarPosition :: (Float,Float,Float), - avatarRotation :: (Float,Float,Float,Float), - avatarHeight :: Float, - avatarState :: Int, - avatarInventory :: [InventoryItem], - avatarCameraPosition :: (Float,Float,Float), - avatarCameraRotation :: (Float,Float,Float,Float), - avatarCameraControlParams :: CameraParams, - avatarActiveAnimations :: [(Maybe Int,String)], - avatarAttachments :: IM.IntMap String, - avatarEventHandler :: !(Maybe (String,[(String,LSLValue)])), - avatarControls :: !Int, - avatarControlListener :: !(Maybe AvatarControlListener) } deriving (Show) - -data AvatarControlListener = AvatarControlListener { avatarControlListenerMask :: !Int, avatarControlListenerScript :: !(String,String) } deriving (Show) - -data CameraParams = CameraParams { cameraActive :: Bool, - cameraBehindednessAngle :: Float, - cameraBehindednessLag :: Float, - cameraDistance :: Float, - cameraFocus :: Maybe (Float,Float,Float), - cameraFocusLag :: Float, - cameraFocusLocked :: Bool, - cameraFocusOffset :: (Float,Float,Float), - cameraFocusThreshold :: Float, - cameraPitch :: Float, - cameraPosition :: Maybe (Float,Float,Float), - cameraPositionLag :: Float, - cameraPositionLocked :: Bool, - cameraPositionThreshold :: Float } deriving Show -defaultCamera = CameraParams { cameraActive = False, - cameraBehindednessAngle = 10.0, - cameraBehindednessLag = 0, - cameraDistance = 3.0, - cameraFocus = Nothing, - cameraFocusLag = 0, - cameraFocusLocked = False, - cameraFocusOffset = (0,0,0), - cameraFocusThreshold = 1.0, - cameraPitch = 0.0, - cameraPosition = Nothing, - cameraPositionLag = 0.1, - cameraPositionLocked = False, - cameraPositionThreshold = 1 } - -defaultAvatar key = - Avatar { avatarKey = key, - avatarName = "Default Avatar", - avatarActiveGroup = Nothing, - avatarRegion = (0,0), - avatarPosition = (128.0,128.0,0.0), - avatarRotation = (0.0, 0.0, 0.0, 1.0), - avatarHeight = 2, - avatarState = 0, - avatarInventory = [], - avatarCameraPosition = (128.0,128.0,0.0), - avatarCameraRotation = (0,0,0,1), - avatarCameraControlParams = defaultCamera, - avatarActiveAnimations = [], - avatarAttachments = IM.empty, - avatarEventHandler = Nothing, - avatarControls = 0, - avatarControlListener = Nothing } - --- these are bit INDEXES not MASKS (0 == least significant bit) -primPhantomBit :: Int -primPhantomBit = 4 -primPhysicsBit :: Int -primPhysicsBit = 0 - -data InventoryItemData = InvScript { invScriptLibId :: String, invScriptState :: Maybe ScriptImage } - | InvBodyPart - | InvGesture - | InvClothing - | InvTexture - | InvSound { invSoundDuration :: Float } - | InvAnimation { invAnimationDuration :: Maybe Float } - | InvLandmark { invLandmarkLocation :: ((Int,Int),(Float,Float,Float)) } - | InvNotecard { invNotecardLines :: [String] } - | InvObject { invObjectPrims :: [Prim] } deriving (Show) -isInvScript (InvScript _ _) = True -isInvScript _ = False -isInvBodyPart InvBodyPart = True -isInvBodyPart _ = False -isInvGesture InvGesture = True -isInvGesture _ = False -isInvClothing InvClothing = True -isInvClothing _ = False -isInvTexture InvTexture = True -isInvTexture _ = False -isInvSound (InvSound _) = True -isInvSound _ = False -isInvAnimation (InvAnimation _) = True -isInvAnimation _ = False -isInvLandmark (InvLandmark _) = True -isInvLandmark _ = False -isInvNotecard (InvNotecard _) = True -isInvNotecard _ = False -isInvObject (InvObject _) = True -isInvObject _ = False - -isInvScriptItem = isInvScript . inventoryItemData -isInvBodyPartItem = isInvBodyPart . inventoryItemData -isInvGestureItem = isInvGesture . inventoryItemData -isInvClothingItem = isInvClothing . inventoryItemData -isInvTextureItem = isInvTexture . inventoryItemData -isInvSoundItem = isInvSound . inventoryItemData -isInvAnimationItem = isInvAnimation . inventoryItemData -isInvLandmarkItem = isInvLandmark . inventoryItemData -isInvNotecardItem = isInvNotecard . inventoryItemData -isInvObjectItem = isInvObject . inventoryItemData - -newtype InventoryItemIdentification = InventoryItemIdentification { inventoryItemNameKey :: (String,String) } deriving (Show) --- data InventoryItem a = InventoryItem { inventoryItemIdentification :: InventoryItemIdentification, --- inventoryItemInfo :: InventoryInfo, --- inventoryItemData :: a } deriving (Show) -data InventoryInfo = InventoryInfo { inventoryInfoCreator :: String, - --inventoryInfoOwner :: String, - inventoryInfoPerms :: (Int,Int,Int,Int,Int) } deriving (Show) -data InventoryItem = InventoryItem { inventoryItemIdentification :: InventoryItemIdentification, - inventoryItemInfo :: InventoryInfo, - inventoryItemData :: InventoryItemData } deriving (Show) - ---inventoryItemInfoMap = map ( \ item -> (inventoryItemIdentification item, inventoryItemInfo item)) -inventoryItemName = fst . inventoryItemNameKey . inventoryItemIdentification -inventoryItemNames = map inventoryItemName -scriptInventoryItem s k id = InventoryItem (InventoryItemIdentification (s,k)) (InventoryInfo "" defaultInventoryPermissions) (InvScript id Nothing) -inventoryItemIdentifications = map inventoryItemIdentification -findByInvName name = find ((== name) . (fst . inventoryItemNameKey . inventoryItemIdentification)) -findByInvKey key = find ((== key) . (snd . inventoryItemNameKey . inventoryItemIdentification)) - -inventoryInfoPermValue 0 (i,_,_,_,_) = return i -inventoryInfoPermValue 1 (_,i,_,_,_) = return i -inventoryInfoPermValue 2 (_,_,i,_,_) = return i -inventoryInfoPermValue 3 (_,_,_,i,_) = return i -inventoryInfoPermValue 4 (_,_,_,_,i) = return i -inventoryInfoPermValue i _ = throwError ("no such perm mask - " ++ show i) - -defaultInventoryPermissions :: (Int,Int,Int,Int,Int) -defaultInventoryPermissions = (0xffffffff,0xffffffff,0xffffffff,0xffffffff,0xffffffff) - -data Prim = Prim { - primName :: String, - primKey :: String, - primParent :: Maybe String, - primDescription :: String, - primInventory :: [InventoryItem], - primOwner :: String, - primGroup :: Maybe String, - primCreator :: String, - primPosition :: (Float, Float, Float), - primRotation :: (Float, Float, Float, Float), - primScale :: (Float, Float, Float), - primFaces :: [PrimFace], - primFlexibility :: Maybe Flexibility, - primMaterial :: Int, - primStatus :: Int, - primVehicleFlags :: Int, - primLight :: Maybe LightInfo, - primTempOnRez :: Bool, - primTypeInfo :: PrimType, - primPermissions :: [Int], - primAllowInventoryDrop :: Bool, - primSitTarget :: Maybe ((Float,Float,Float),(Float,Float,Float,Float)), - primSittingAvatar :: Maybe String, - primPendingEmails :: [Email], - primPassTouches :: Bool, - primPassCollisions :: Bool, - primPayInfo :: (Int,Int,Int,Int,Int), - primAttachment :: Maybe Attachment, - primRemoteScriptAccessPin :: Int } deriving (Show) - -data PrimType = PrimTypeUnknown - | PrimType { - primVersion :: Int, -- 1 or 9 - primTypeCode :: Int, - primHoleshape :: Int, - primCut :: (Float,Float,Float), - primTwist :: (Float,Float,Float), - primHolesize :: (Float,Float,Float), - primTopshear :: (Float, Float, Float), - primHollow :: Float, - primTaper :: (Float,Float,Float), - primAdvancedCut :: (Float,Float,Float), - primRadiusOffset :: Float, - primRevolutions :: Float, - primSkew :: Float, - primSculptTexture :: Maybe String, - primSculptType :: Int - } deriving (Show) - -basicBox = PrimType 9 0 0 (0,1,0) (0,0,0) (0,0,0) (0,0,0) 0 (0,0,0) (0,1,0) 0 0 0 Nothing 0 - -data Attachment = Attachment { attachmentKey :: String, attachmentPoint :: Int } deriving (Show) - -data LightInfo = LightInfo { - lightColor :: (Float,Float,Float), - lightIntensity :: Float, - lightRadius :: Float, - lightFalloff :: Float - } deriving (Show) - -data Flexibility = Flexibility { - flexSoftness :: Int, - flexGravity :: Float, - flexFriction :: Float, - flexWind :: Float, - flexTension :: Float, - flexForce :: (Float,Float,Float) - } deriving (Show) - -data PrimFace = PrimFace { - faceAlpha :: Float, - faceColor :: (Float,Float,Float), - faceShininess :: Int, - faceBumpiness :: Int, - faceFullbright :: Bool, - faceTextureMode :: Int, - faceTextureInfo :: TextureInfo - } deriving (Show) - -defaultFace = PrimFace 1.0 (1.0,1.0,1.0) 0 0 False 0 defaultTextureInfo - -data TextureInfo = TextureInfo { - textureKey :: String, - textureRepeats :: (Float,Float,Float), - textureOffsets :: (Float,Float,Float), - textureRotation :: Float - } deriving (Show) - -defaultTextureInfo = TextureInfo "" (1.0,1.0,0.0) (0.0,0.0,0.0) 0.0 - -data Email = Email { - emailSubject :: String, - emailAddress :: String, -- sender address - emailMessage :: String, - emailTime :: Int } deriving (Show) - -emptyPrim name key = - Prim { primName = name, - primKey = key, - primParent = Nothing, - primDescription = "", - primInventory = [], - primOwner = "", - primGroup = Nothing, - primCreator = "", - primPosition = (0.0,0.0,0.0), - primRotation = (0.0,0.0,0.0,1.0), - primScale = (1.0,1.0,1.0), - primFaces = replicate 6 defaultFace, - primFlexibility = Nothing, - primMaterial = 0, - primStatus = 0x0e, - primVehicleFlags = 0, - primLight = Nothing, - primTempOnRez = False, - primTypeInfo = basicBox, - primPermissions = [0], - primAllowInventoryDrop = False, - primSitTarget = Nothing, - primSittingAvatar = Nothing, - primPendingEmails = [], - primPassTouches = False, - primPassCollisions = False, - primPayInfo = ( -2, -2, -2, -2, -2), - primAttachment = Nothing, - primRemoteScriptAccessPin = 0 } - -data Region = Region { - regionName :: String, - regionFlags :: Int, - regionParcels :: [Parcel] - } deriving (Show) - -data Parcel = Parcel { - parcelName :: String, - parcelDescription :: String, - parcelBoundaries :: (Int,Int,Int,Int), -- bottom, top, left, right aka south,north,west,east - parcelOwner :: String, - parcelFlags :: Int, - parcelBanList :: [(String,Maybe Int)], - parcelPassList :: [(String,Maybe Int)] - } deriving (Show) - -defaultRegions :: String -> [((Int,Int),Region)] -defaultRegions owner = [ - ((0,0), Region { regionName = "Region_0_0", regionFlags = 0, - regionParcels = [Parcel "parcel_0" "default parcel" (0,256,0,256) owner 0xffffffff [] []] }) - ] - -data Script = Script { scriptImage :: !ScriptImage, - scriptActive :: Bool, - scriptPermissions :: M.Map String Int, - scriptLastPerm :: Maybe String, - scriptStartTick :: Int, - scriptLastResetTick :: Int, - scriptEventQueue :: [Event], - scriptStartParameter :: Int, - scriptCollisionFilter :: !(String,String,Bool), - scriptTargetIndex :: !Int, - scriptPositionTargets :: !(IM.IntMap ((Float,Float,Float), Float)), - scriptRotationTargets :: !(IM.IntMap ((Float,Float,Float,Float), Float)) } deriving (Show) - -mkScript img = Script { scriptImage = img, - scriptActive = True, - scriptPermissions = M.empty, - scriptLastPerm = Nothing, - scriptStartTick = 0, - scriptLastResetTick = 0, - scriptEventQueue = [Event "state_entry" [] M.empty], - scriptStartParameter = 0, - scriptCollisionFilter = ("",nullKey,True), - scriptTargetIndex = 0, - scriptPositionTargets = IM.empty, - scriptRotationTargets = IM.empty } - -worldFromFullWorldDef worldBuilder fwd lib scripts = - do let primMap = mkPrimMap (fullWorldDefPrims fwd) - primMap' <- checkObjects primMap (fullWorldDefObjects fwd) -- prove all the prims in all the objects exists - let activeScripts = - concat (map (\ prim -> map - (\ item -> ((primKey prim, fst $ inventoryItemNameKey $ inventoryItemIdentification item), - invScriptLibId $ inventoryItemData item)) (filter isInvScriptItem $ primInventory prim)) (M.elems primMap')) - (activatedScripts,log) <- runWriterT (activateScripts activeScripts scripts primMap') - return $ worldBuilder (fullWorldDefSliceSize fwd) - (fullWorldDefMaxTime fwd) - [] lib scripts - (M.fromList $ mkAvatarLookup (fullWorldDefAvatars fwd)) - (mkObjectMap (fullWorldDefObjects fwd)) - primMap' - (M.fromList activatedScripts) - (M.fromList (fullWorldDefRegions fwd)) - (fullWorldDefInitialKeyIndex fwd) - (fullWorldDefWebHandling fwd) - (fullWorldDefEventHandler fwd) - log - -fctx :: MonadError String m => String -> Either String a -> m a -fctx s (Left s') = throwError s -fctx _ (Right v) = return v - -maybe2Either Nothing = Left "failed" -maybe2Either (Just v) = Right v - -mkPrimMap prims = M.fromList [(primKey p, p) | p <- prims] - --let tuples = map (\ p -> (primKey p, p)) prims in M.fromList tuples -mkObjectMap objects = M.fromList [ (p, o) | o@(LSLObject { primKeys = (p:_) }) <- objects ] -mkAvatarLookup avatars = [ (avatarKey a,a) | a <- avatars] - -checkObject primMap o = - foldM checkPrim primMap (primKeys o) - where root = head (primKeys o) - checkPrim m k = - case M.lookup k m of - Nothing -> fail ("prim " ++ k ++ " not found in definition") - Just prim -> - return (if (k == root) then m - else M.insert k (prim { primParent = Just root }) m) - -checkObjects primMap os = foldM checkObject primMap os - -activateScripts scriptIdInfo compiledScripts primMap = - mapM (activateScript compiledScripts primMap) scriptIdInfo >>= (\ ms -> return [ s | Just s <- ms ]) - -activateScript scripts primMap (k@(primKey,invName),(scriptID)) = - do let script = case lookup scriptID scripts of - Nothing -> fail "script not found" - Just v -> v - prim <- (lift . fctx ("looking up prim " ++ primKey ++ " failed")) (mlookup primKey primMap) - when (isNothing (findByInvName invName (primInventory prim))) $ fail (invName ++ " doesn't exist in prim " ++ primKey) - case script of - Left (_,s) -> tell [("script \"" ++ invName ++ "\" in prim " ++ primKey ++ " failed to activate because of error: " ++ s)] - >> return Nothing - Right code -> return $ Just (k,mkScript $ initLSLScript code) - -newKey xref = do - (m,i) <- lift SM.get - let k = mkKey i - let m' = case xref of - Nothing -> m - Just v -> M.insert v k m - lift $ SM.put (m',i+1) - return k - -findRealKey k = lift SM.get >>= mlookup k . fst - ---worldElement :: ElemAcceptor KeyManagerM FullWorldDef -worldElement = - let f (Elem _ _ contents) = do - (maxTime, c1) <- findValue "maxTime" (elementsOnly contents) - (handler, c2) <- findOptionalElement (simpleElement "simEventHandler") c1 - (sliceSizeStr, c3) <- findSimple "sliceSize" c2 - (avatars,c4) <- findElement avatarsElement c3 - (prims,c5) <- findElement primsElement c4 - (objects,[]) <- findElement objectsElement c5 - sliceSize <- readM sliceSizeStr - (m,keyIndex) <- lift SM.get - let webHandling = if isNothing handler then WebHandlingByDoingNothing else WebHandlingByFunction - return $ (FullWorldDef maxTime sliceSize webHandling handler objects prims avatars (defaultRegions "") keyIndex) - in ElemAcceptor "world-def" f - -activeScriptsElement :: ElemAcceptor KeyManagerM [((String,String),String)] -activeScriptsElement = elementList "scripts" activeScriptElement - -activeScriptElement :: ElemAcceptor KeyManagerM ((String,String),String) -activeScriptElement = ElemAcceptor "script" $ - \ (Elem _ _ contents) -> do - (primKey,c1) <- findSimple "primKey" (elementsOnly contents) - realPrimKey <- findRealKey primKey - (scriptName, c2) <- findSimple "scriptName" c1 - (scriptId, []) <- findSimple "scriptId" c2 - return $ ((realPrimKey,scriptName), scriptId) - -objectsElement :: ElemAcceptor KeyManagerM [LSLObject] -objectsElement = elementList "objects" objectElement - -objectElement :: ElemAcceptor KeyManagerM LSLObject -objectElement = ElemAcceptor "object" $ - \ (Elem _ _ contents) -> do - (position,c) <- findOrDefault (0,0,0) (vecAcceptor "position") (elementsOnly contents) - (primKeys,[]) <- findElement (elementList "primKeys" (simpleElement "string")) c - --(m,i) <- lift SM.get - realPrimKeys <- mapM findRealKey primKeys - return $ LSLObject realPrimKeys (defaultDynamics { objectPosition = position }) - -primsElement :: ElemAcceptor KeyManagerM [Prim] -primsElement = elementList "prims" primElement - -primElement :: ElemAcceptor KeyManagerM Prim -primElement = ElemAcceptor "prim" $ - \ (Elem _ _ contents) -> do - (name,c1) <- findSimple "name" (elementsOnly contents) - (key,c2) <- findSimple "key" c1 - realKey <- newKey (Just key) - (description, c3) <- findSimpleOrDefault "" "description" c2 - (scripts,c4) <- findElement (elementList "scripts" (scriptAcceptor "script")) c3 - (owner,c5) <- findSimpleOrDefault "" "owner" c4 - realOwner <- findRealKey owner - (position,c6) <- findOrDefault (128.0,128.0,0.0) (vecAcceptor "position") c5 - (eulerRotation,c7) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "rotation") c6 - (scale,c8) <- findOrDefault (1.0,1.0,1.0) (vecAcceptor "scale") c7 - (faces,c9) <- findOrDefault (replicate 6 defaultFace) (elementList "faces" (faceAcceptor "face")) c8 - (flexibility,c10) <- findOptionalElement (flexibilityAcceptor "flexibility") c9 - (material,c11) <- findValueOrDefault 0 "material" c10 - (status,c12) <- findValueOrDefault 0x0e "status" c11 - (light,c13) <- findOptionalElement (lightAcceptor "light") c12 - (tempOnRez, c14) <- findValueOrDefault False "tempOnRez" c13 - (typeInfo, c15) <- findOrDefault basicBox (primTypeAcceptor "typeInfo") c14 - (permissions, c16) <- findOrDefault [0] (elementList "permissions" (valueAcceptor "int")) c15 - (dropAllowed,c17) <- findValueOrDefault False "dropAllowed" c16 - (inventory,[]) <- findOrDefault [] (elementListWith "inventory" acceptInventoryItem) c17 - return $ Prim { primName = name, - primKey = realKey, - primParent = Nothing, - primDescription = description, - primInventory = scripts ++ inventory, - primOwner = realOwner, - primGroup = Nothing, - primCreator = realOwner, - primPosition = position, - primRotation = rotationsToQuaternion P123 eulerRotation, - primScale = scale, - primFaces = faces, - primFlexibility = flexibility, - primMaterial = material, - primStatus = status, - primVehicleFlags = 0, - primLight = light, - primTempOnRez = tempOnRez, - primTypeInfo = typeInfo, - primPermissions = permissions, - primAllowInventoryDrop = dropAllowed, - primSitTarget = Nothing , - primSittingAvatar = Nothing, - primPendingEmails = [], - primPassTouches = False, - primPassCollisions = False, - primPayInfo = (-2, -2, -2, -2, -2), - primAttachment = Nothing, - primRemoteScriptAccessPin = 0 } - -acceptInventoryItem e = matchChoice (map (uncurry mkInventoryItemAcceptor) - [("notecardItem",acceptNotecardData), - ("textureItem", acceptTextureData), - ("bodyPartItem", acceptBodyPartData), - ("clothingItem", acceptClothingData), - ("gestureItem", acceptGestureData), - ("soundItem", acceptSoundData), - ("animationItem", acceptAnimationData), - ("inventoryObjectItem", acceptInventoryObjectData), - ("landmarkItem", acceptLandmarkData) - ]) e - -acceptNotecardData contents = do - (lines,c1) <- findOrDefault [] (elementList "lines" (simpleElement "string")) contents - return (InvNotecard lines,c1) - -acceptTextureData contents = return (InvTexture,contents) -acceptBodyPartData contents = return (InvBodyPart,contents) -acceptClothingData contents = return (InvClothing,contents) -acceptGestureData contents = return (InvGesture,contents) -acceptSoundData contents = do - (duration,c1) <- findValue "duration" contents - return (InvSound duration,c1) -acceptAnimationData contents = do - (duration,c1) <- findValue "duration" contents - return (InvAnimation (if duration == 0 then Nothing else Just duration),c1) -acceptInventoryObjectData contents = do - (prims,c1) <- findElement primsElement contents - return (InvObject prims,c1) - -acceptLandmarkData contents = do - (region,c1) <- findElement (regionAcceptor "region") contents - (position, c2) <- findElement (vecAcceptor "position") c1 - return (InvLandmark (region,position), c2) - -mkInventoryItemAcceptor s f = ElemAcceptor s $ - \ (Elem _ _ contents) -> do - let c0 = elementsOnly contents - (name,c1) <- findSimple "name" c0 - key <- newKey Nothing - (creator,c2) <- findSimple "creator" c1 - realCreator <- findRealKey creator - (itemData,[]) <- f c2 - return $ InventoryItem (InventoryItemIdentification (name, key)) (InventoryInfo creator defaultInventoryPermissions) - itemData - -scriptAcceptor s = ElemAcceptor s $ - \ (Elem _ _ contents) -> do - let c0 = elementsOnly contents - (scriptName, c1) <- findSimple "scriptName" c0 - (scriptId, []) <- findSimple "scriptId" c1 - k <- newKey Nothing - return $ scriptInventoryItem scriptName k scriptId - -faceAcceptor s = ElemAcceptor s $ - \ (Elem _ _ contents) -> do - let c0 = elementsOnly contents - (alpha,c1) <- findValueOrDefault 0.0 "alpha" c0 - (color,c2) <- findOrDefault (1.0,1.0,1.0) (vecAcceptor "color") c1 - (shininess, c3) <- findValueOrDefault 0 "shininess" c2 - (bumpiness, c4) <- findValueOrDefault 0 "bumpiness" c3 - (fullbright, c5) <- findValueOrDefault False "fullbright" c4 - (textureMode, c6) <- findValueOrDefault 0 "textureMode" c5 - (textureInfo, []) <- findOrDefault defaultTextureInfo (textureInfoAcceptor "textureInfo") c6 - return $ PrimFace { - faceAlpha = alpha, - faceColor = color, - faceShininess = shininess, - faceBumpiness = bumpiness, - faceFullbright = fullbright, - faceTextureMode = textureMode, - faceTextureInfo = textureInfo - } - -textureInfoAcceptor s = ElemAcceptor s $ - \ (Elem _ _ contents) -> do - let c0 = elementsOnly contents - (name,c1) <- findSimpleOrDefault "" "name" c0 - (repeats,c2) <- findOrDefault (1.0,1.0,1.0) (vecAcceptor "repeats") c1 - (offsets,c3) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "offsets") c2 - (rotation,[]) <- findValueOrDefault 0.0 "rotation" c3 - return $ TextureInfo { - textureKey = name, - textureRepeats = repeats, - textureOffsets = offsets, - textureRotation = rotation - } - -flexibilityAcceptor s = ElemAcceptor s $ - \ (Elem _ _ contents) -> do - let c0 = elementsOnly contents - (softness,c1) <- findValueOrDefault 0 "softness" c0 - (gravity,c2) <- findValueOrDefault 1.0 "gravity" c1 - (friction,c3) <- findValueOrDefault 0.0 "friction" c2 - (wind,c4) <- findValueOrDefault 0.0 "wind" c3 - (tension,c5) <- findValueOrDefault 1.0 "tension" c4 - (force, []) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "force") c5 - return $ Flexibility { - flexSoftness = softness, - flexGravity = gravity, - flexFriction = friction, - flexWind = wind, - flexTension = tension, - flexForce = force - } - -lightAcceptor s = ElemAcceptor s $ - \ (Elem _ _ contents) -> do - let c0 = elementsOnly contents - (color,c1) <- findOrDefault (1.0,1.0,1.0) (vecAcceptor "color") c0 - (intensity,c2) <- findValueOrDefault 1.0 "intensity" c1 - (radius,c3) <- findValueOrDefault 10.0 "radius" c2 - (falloff,[]) <- findValueOrDefault 1.0 "falloff" c3 - return $ LightInfo { - lightColor = color, - lightIntensity = intensity, - lightRadius = radius, - lightFalloff = falloff - } - -primTypeAcceptor s = ElemAcceptor s $ - \ (Elem _ _ contents) -> do - let c0 = elementsOnly contents - (version, c1) <- findValueOrDefault 9 "version" c0 - (typeCode, c2) <- findValueOrDefault 0 "typeCode" c1 - (holeshape, c3) <- findValueOrDefault 0 "holeshape" c2 - (cut, c4) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "cut") c3 - (twist, c5) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "twist") c4 - (holesize, c6) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "holesize") c5 - (topshear, c7) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "topshear") c6 - (hollow, c8) <- findValueOrDefault 0.0 "hollow" c7 - (taper, c9) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "taper") c8 - (advancedCut, c10) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "advancedCut") c9 - (radiusOffset, c11) <- findValueOrDefault 0.0 "radiusOffset" c10 - (revolutions, c12) <- findValueOrDefault 0.0 "revolutions" c11 - (skew, c13) <- findValueOrDefault 0.0 "skew" c12 - (sculptTexture, c14) <- findOptionalElement (simpleElement "sculptTexture") c13 - (sculptType, []) <- findValueOrDefault 0 "sculptType" c14 - return $ PrimType { - primVersion = version, -- 1 or 9 - primTypeCode = typeCode, - primHoleshape = holeshape, - primCut = cut, - primTwist = twist, - primHolesize = holesize, - primTopshear = topshear, - primHollow = hollow, - primTaper = taper, - primAdvancedCut = advancedCut, - primRadiusOffset = radiusOffset, - primRevolutions = revolutions, - primSkew = skew, - primSculptTexture = sculptTexture, - primSculptType = sculptType - } - -avatarsElement :: ElemAcceptor KeyManagerM [Avatar] -avatarsElement = elementList "avatars" avatarElement - -avatarElement :: ElemAcceptor KeyManagerM Avatar -avatarElement = ElemAcceptor "avatar" $ - \ (Elem _ _ contents) -> do - (name,c2) <- findSimple "name" (elementsOnly contents) - realKey <- newKey (Just name) - (x,c3) <- findValue "xPos" c2 - (y,c4) <- findValue "yPos" c3 - (z,c5) <- findValue "zPos" c4 - (handlerName,_) <- findOptionalElement (simpleElement "avatarEventHandler") c5 - let initialHandler = fmap (flip (,) []) handlerName - return $ (defaultAvatar realKey) { avatarName = name, - avatarPosition = (x,y,z), - avatarCameraPosition = (x,y,z), - avatarEventHandler = initialHandler } - -vecAcceptor s = ElemAcceptor s $ - \ (Elem _ _ contents) -> do - (x,c1) <- findValue "x" (elementsOnly contents) - (y,c2) <- findValue "y" c1 - (z,[]) <- findValue "z" c2 - return $ (x,y,z) - -rotAcceptor s = ElemAcceptor s $ - \ (Elem _ _ contents) -> do - (x,c1) <- findValue "x" (elementsOnly contents) - (y,c2) <- findValue "y" c1 - (z,c3) <- findValue "z" c2 - (s,[]) <- findValue "s" c3 - return $ (x,y,z,s) - -regionAcceptor s = ElemAcceptor s $ - \ (Elem _ _ contents) -> do - (x,c1) <- findValue "x" (elementsOnly contents) - (y,[]) <- findValue "y" (c1) - return $ (x,y)
LslPlus.cabal view
@@ -1,6 +1,6 @@ Name: LslPlus -version: 0.1.1 -Synopsis: An execution and testing framework for the Linden Scripting Language (LSL)+version: 0.1.2 +Synopsis: An execution and testing framework for the Linden Scripting Language (LSL) Description: Provides a framework for executing Linden Scripting Language scripts offline, i.e. outside a Second Life® simulator. The primary product is the LslPlus executable, @@ -9,7 +9,7 @@ corresponding quasiquoter, a unit test framework for LSL, and a simulator for running scripts. Cabal-Version: >= 1.5 -Homepage: http:/lslplus.sourceforge.net/+Homepage: http:/lslplus.sourceforge.net/ License: BSD3 License-file: LICENSE Category: Language @@ -19,6 +19,7 @@ Stability: experimental Build-Type: Simple Tested-With: GHC ==6.10.1 +Extra-source-files: NOTICE, noqqsrc/Language/Lsl/Internal/BuiltInModules.hs Library Build-Depends: ghc >= 6.10, base >= 4.0 && < 4.1, haskell98, filepath >= 1.1.0.0 && < 1.2, parsec >= 2.1.0.0 && < 3, @@ -27,47 +28,48 @@ 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+ 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 + Hs-Source-Dirs: src, qqsrc 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, network >= 2.1 && < 2.3, random >= 1.0, containers >= 0.1 && < 0.3, old-time, utf8-string >= 0.3 && < 0.4, 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 Main-Is: LslPlus.hs - Hs-Source-Dirs: . + Hs-Source-Dirs: src, qqsrc Ghc-Options: -fwarn-unused-imports - +
− LslPlus.hs
@@ -1,35 +0,0 @@-module Main where - -import qualified Language.Lsl.Internal.MetaData as MetaData -import qualified Language.Lsl.Internal.Compiler as Compiler -import qualified Language.Lsl.Internal.ExpressionHandler as ExpressionHandler -import qualified Language.Lsl.Internal.SimMetaData as SimMetaData -import qualified Language.Lsl.Internal.SystemTester as SystemTester -import qualified Language.Lsl.Internal.UnitTester as UnitTester - -import Control.Monad -import IO -import System -import System.Exit - -version="0.1.1" -usage progName = "Usage: " ++ progName ++ " [Version|MetaData|Compiler|ExpressionHandler|SimMetaData|SystemTester|UnitTester]" -main = do - progName <- getProgName - args <- getArgs - when (length args /= 1) $ do - hPutStrLn stderr "Invalid number of command line arguments" - hPutStrLn stderr (usage progName) - exitFailure - case head args of - "Version" -> putStrLn version - "MetaData" -> MetaData.printMeta - "Compiler" -> Compiler.main0 - "ExpressionHandler" -> ExpressionHandler.validateExpression stdin stdout - "SimMetaData" -> SimMetaData.printSimMeta - "SystemTester" -> SystemTester.testSystem - "UnitTester" -> UnitTester.main2 - val -> do - hPutStrLn stderr ("Invalid argument: " ++ val) - hPutStrLn stderr (usage progName) - exitFailure
+ NOTICE view
@@ -0,0 +1,11 @@+Except where otherwise indicated the LSLPlus Plug-in was written by and is copyright to: + Copyright 2007-2008, Robert Greayer. All rights reserved. + +This software is licensed under the terms of a "BSD3" style license, the text of which can +be found in a file called 'LICENSE'. + +The copyright for some portions of this software are held by others. Where the copyright holder +is different from the above, the copyright holder is clearly indicated within the source file with +the differing copyright, or in an associated license file in cases in which source is not provided. +The copyright notice specifies under what terms the contribution is provided. +
Setup.hs view
@@ -1,3 +1,7 @@ import Distribution.Simple -main = defaultMain +import Distribution.Simple.Haddock (haddock, hscolour) +import Distribution.PackageDescription + +main = defaultMainWithHooks (simpleUserHooks { + preHaddock = \_ _ -> return (Just $ emptyBuildInfo { hsSourceDirs = ["noqqsrc"]},[]) })
+ noqqsrc/Language/Lsl/Internal/BuiltInModules.hs view
@@ -0,0 +1,6 @@+module Language.Lsl.Internal.BuiltInModules(avEventGen) where + +import Language.Lsl.Syntax + +avEventGen :: (String,LModule) +avEventGen = ("$avEventGen", undefined)
+ qqsrc/Language/Lsl/Internal/BuiltInModules.hs view
@@ -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)
+ src/Language/Lsl/Internal/Animation.hs view
@@ -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)]
+ src/Language/Lsl/Internal/AvEvents.hs view
@@ -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)
+ src/Language/Lsl/Internal/Breakpoint.hs view
@@ -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 + [] -> []
+ src/Language/Lsl/Internal/BreakpointsDeserialize.hs view
@@ -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
+ src/Language/Lsl/Internal/CodeHelper.hs view
@@ -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) ++ [")"])
+ src/Language/Lsl/Internal/Compiler.hs view
@@ -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" +
+ src/Language/Lsl/Internal/Constants.hs view
@@ -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
+ src/Language/Lsl/Internal/DOMProcessing.hs view
@@ -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++";"
+ src/Language/Lsl/Internal/DOMSourceDescriptor.hs view
@@ -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
+ src/Language/Lsl/Internal/DOMUnitTestDescriptor.hs view
@@ -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''
+ src/Language/Lsl/Internal/Evaluation.hs view
@@ -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) +
+ src/Language/Lsl/Internal/EventSigs.hs view
@@ -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
+ src/Language/Lsl/Internal/Exec.hs view
@@ -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
+ src/Language/Lsl/Internal/ExecInfo.hs view
@@ -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)]
+ src/Language/Lsl/Internal/ExpressionHandler.hs view
@@ -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) + +
+ src/Language/Lsl/Internal/FuncSigs.hs view
@@ -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"))]
+ src/Language/Lsl/Internal/InternalLLFuncs.hs view
@@ -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,'=','=']
+ src/Language/Lsl/Internal/Key.hs view
@@ -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)
+ src/Language/Lsl/Internal/Load.hs view
@@ -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)
+ src/Language/Lsl/Internal/Log.hs view
@@ -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"
+ src/Language/Lsl/Internal/Math.hs view
@@ -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)
+ src/Language/Lsl/Internal/MetaData.hs view
@@ -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"]
+ src/Language/Lsl/Internal/NumberParsing.hs view
@@ -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]
+ src/Language/Lsl/Internal/Optimize.hs view
@@ -0,0 +1,73 @@+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} +module Language.Lsl.Internal.Optimize(optimizeScript) where + +import Language.Lsl.Syntax(CompiledLSLScript(..),Expr(..),Statement(..),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
+ src/Language/Lsl/Internal/Physics.hs view
@@ -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) +
+ src/Language/Lsl/Internal/SimMetaData.hs view
@@ -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")] []
+ src/Language/Lsl/Internal/SystemTester.hs view
@@ -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
+ src/Language/Lsl/Internal/TestResult.hs view
@@ -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
+ src/Language/Lsl/Internal/Type.hs view
@@ -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)
+ src/Language/Lsl/Internal/UnitTester.hs view
@@ -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]
+ src/Language/Lsl/Internal/Util.hs view
@@ -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!!!"
+ src/Language/Lsl/Internal/WorldState.hs view
@@ -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
+ src/Language/Lsl/Internal/XmlCreate.hs view
@@ -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 "</" . showString name . 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)
+ src/Language/Lsl/Parse.hs view
@@ -0,0 +1,629 @@+module Language.Lsl.Parse( + parseScript, + parseModule, + exprParser, + parseType, + parseScriptFromString, + parseModuleFromString, + parseScriptFromStringAQ, + parseModuleFromStringAQ + ) where + +import Data.Char(digitToInt) +import Data.List(intersperse) +import Language.Lsl.Syntax(Expr(..),Statement(..),Func(..),FuncDec(..),Handler(..),State(..),Ctx(..),SourceContext(..),LSLType(..), + Component(..),Var(..),LModule(..),LSLScript(..),GlobDef(..),goodHandlers) +import Text.ParserCombinators.Parsec hiding (State) +import qualified Text.ParserCombinators.Parsec.Token as P +import Text.ParserCombinators.Parsec.Language( javaStyle ) +import Text.ParserCombinators.Parsec.Error +import Control.Monad.Error(liftIO) +import Control.Monad.Trans(MonadIO) + +-- define basic rules for lexical analysis +lslStyle = javaStyle + { P.reservedOpNames= ["*","/","+","++","-","--","^","&","&&", + "|","||","==","=","!=","<","<=",">=",">", + "<<",">>","!","%","~","@","+=","-=","*=","/=","%="], + P.reservedNames = ["state","default","string","integer","list","vector","rotation","key","float","if","else", + "while","for","do","jump","return","default", "$import", "$module","quaternion"], + P.caseSensitive = True, + P.identStart = letter <|> char '_', + P.opLetter = oneOf "*/+:!#$%&*+./=?@\\^|-~", + P.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~" } +lexer :: P.TokenParser Bool +lexer = P.makeTokenParser lslStyle + +identLetter = P.identLetter lslStyle + +identifier = P.identifier lexer +reserved = P.reserved lexer +operator = P.operator lexer +reservedOp = P.reservedOp lexer + +charLiteral = P.charLiteral lexer +-- stringLiteral = P.stringLiteral lexer +natural = P.natural lexer +integer = P.integer lexer +float = P.float lexer +--naturalOrFloat = P.naturalOrFloat lexer +decimal = P.decimal lexer +hexadecimal = P.hexadecimal lexer +octal = P.octal lexer + +symbol = P.symbol lexer +lexeme = P.lexeme lexer +whiteSpace = P.whiteSpace lexer + +parens = P.parens lexer +braces = P.braces lexer +angles = P.angles lexer +brackets = P.brackets lexer +semi = P.semi lexer +comma = P.comma lexer +colon = P.colon lexer +dot = P.dot lexer +semiSep = P.semiSep lexer +semiSep1 = P.semiSep1 lexer +commaSep = P.commaSep lexer +commaSep1 = P.commaSep1 lexer + +decimalFraction w = do char '.' + fracPart True w + +fracPart reqDigit w = do digits <- (if reqDigit then many1 else many) digit <?> "fractional part of decimal" + p <- option 1.0 expon + return $ p * (w + (foldr (\ b d -> (b + d) / 10.0) 0 $ map (fromIntegral.digitToInt) digits)) + +expon = do oneOf "eE" + s <- option '+' (oneOf "+-") + let k x = if s == '+' then x else 1/x + digits <- many1 digit <?> "exponent" + let p = foldl (\ b d -> b * 10 + d) 0 $ map digitToInt digits + return ((k (10^p))::Float) + +hex = do oneOf "xX" + digits <- many1 hexDigit <?> "hex digit" + return (foldl (\ b d -> b * 16 + d) 0 $ map digitToInt digits) +-- lsl doesn't support octal! +-- oct = do oneOf "oO" +-- digits <- many1 octDigit <?> "octal digit" +-- return (foldl (\ b d -> b * 8 + d) 0 $ map digitToInt digits) + +-- Like Parsec 'naturalOrFloat', but accept <digits>. and .<digits><exp> as valid floating point numbers +naturalOrFloat = do v <- natOrFloat <?> "number" + whiteSpace + return v +natOrFloat = (decimalFraction 0.0 >>= return . Right) + <|> do char '0' + option (Left 0) prefZeroNum + <|> decimalOrFloat + +prefZeroNum = (hex >>= return . Left) + <|> (decimalFraction 0.0 >>= return . Right) + <|> decimalOrFloat +decimalOrFloat = + do wholeDigits <- many1 digit <?> "number" + let w = foldl (\ b d -> b * 10 + d) 0 $ map digitToInt wholeDigits + mf <- option Nothing (char '.' >> option (fromIntegral w) (fracPart False (fromIntegral w)) >>= return . Just) + return $ case mf of + Nothing -> Left w + Just f -> Right f + +stringLiteral = lexeme ( + do{ str <- between (char '"') + (char '"' <?> "end of string") + (many stringChar) + ; return (foldr (maybe id (:)) "" str) + } + <?> "literal string") + +stringChar :: CharParser st (Maybe Char) +stringChar = do{ c <- stringLetter; return (Just c) } + <|> try stringEscape + <|> (char '\\' >> return (Just '\\')) + <?> "string character" + +stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) + +stringEscape = do + char '\\' + choice [char 't' >> return (Just '\t'), + char 'n' >> return (Just '\n'), + char '\"' >> return (Just '\"'), + char '\\' >> return (Just '\\')] + +--- EXPRESSION PARSING ------------------------------------------------------- +--mtrace s v = return v -- trace (s ++ show v) (return v) +mtrace s v = + -- trace (s ++ show v) + (return v) + +combineExprs e [] = e +combineExprs e0 ((p0,p1,op,e1):rest) = combineExprs (op p0 p1 e0 e1) rest + +opmatch s f = (reservedOp s >> return f) +op0 = ((opmatch "*" mulop) <|> (opmatch "/" divop) <|> (opmatch "%" modop)) <?> "operator" +op1 = ((opmatch "+" addop) <|> (opmatch "-" subop)) <?> "operator" +op2 = ((opmatch "<<" shiftlop) <|> (opmatch ">>" shiftrop)) <?> "operator" +op3 = (choice [opmatch "<" ltop, opmatch "<=" leop, opmatch ">" gtop, opmatch ">=" geop]) <?> "operator" +op4 = ((opmatch "==" eqop) <|> (opmatch "!=" neop)) <?> "operator" + +opAndExpr opf ef = do pos0 <- getPosition + op <- opf + pos1 <- getPosition + e <- ef + return (pos0,pos1,op,e) + +exprChain opf ef = do e0 <- ef + rest <- many (opAndExpr opf ef) + return $ combineExprs e0 rest + +mulExpr = exprChain op0 expr2 +addExpr = exprChain op1 mulExpr +shiftExpr = exprChain op2 addExpr +relExpr = do e0 <- shiftExpr + rest <- (try (many (try (opAndExpr op3 shiftExpr))) <|> return []) + return $ combineExprs e0 rest +eqExpr = exprChain op4 relExpr +bandExpr = exprChain (opmatch "&" bandop <?> "operator") eqExpr +xorExpr = exprChain (opmatch "^" xorop <?> "operator") bandExpr +borExpr = exprChain (opmatch "|" borop <?> "operator") xorExpr +andExpr = exprChain (opmatch "&&" andop <?> "operator") borExpr +orExpr = exprChain (opmatch "||" orop <?> "operator") andExpr + +bop op pos0 pos1 e0 e1 = + let ctx = combineContexts (srcCtx e0, pos0, pos1, srcCtx e1) in Ctx ctx $ op e0 e1 + +mulop pos0 pos1 = bop Mul pos0 pos1 +divop pos0 pos1 = bop Div pos0 pos1 +modop pos0 pos1 = bop Mod pos0 pos1 +addop pos0 pos1 = bop Add pos0 pos1 +subop pos0 pos1 = bop Sub pos0 pos1 +shiftlop pos0 pos1 = bop ShiftL pos0 pos1 +shiftrop pos0 pos1 = bop ShiftR pos0 pos1 +ltop pos0 pos1 = bop Lt pos0 pos1 +leop pos0 pos1 = bop Le pos0 pos1 +gtop pos0 pos1 = bop Gt pos0 pos1 +geop pos0 pos1 = bop Ge pos0 pos1 +eqop pos0 pos1 = bop Equal pos0 pos1 +neop pos0 pos1 = bop NotEqual pos0 pos1 +bandop pos0 pos1 = bop BAnd pos0 pos1 +xorop pos0 pos1 = bop Xor pos0 pos1 +borop pos0 pos1 = bop BOr pos0 pos1 +andop pos0 pos1 = bop And pos0 pos1 +orop pos0 pos1 = bop Or pos0 pos1 + +structAccess = do id <- ctxify identifier + whiteSpace + dot + whiteSpace + c <- oneOf "xyzs" + whiteSpace + return (id,stringToComponent [c]) +var = try structAccess + <|> do id <- ctxify identifier + return (id,All) + +assignment = ctxify $ + do v <- var + op <- choice [reservedOp "+=" >> (return $ IncBy), + reservedOp "-=" >> (return $ DecBy), + reservedOp "*=" >> (return $ MulBy), + reservedOp "/=" >> (return $ DivBy), + reservedOp "%=" >> (return $ ModBy), + reservedOp "=" >> (return $ Set)] <?> "assignment operator" + e <- expr + return $ op v e + +stringToComponent "" = All +stringToComponent "x" = X +stringToComponent "y" = Y +stringToComponent "z" = Z +stringToComponent "s" = S + +listExpr = do whiteSpace + exprs <- (brackets $ commaSep expr) <?> "list expression" + return $ ListExpr exprs + +-- structExpr = do whiteSpace +-- char '<' <?> "vector/rotation expression" +-- whiteSpace +-- e1 <- expr +-- mtrace "structExpr:1 " e1 +-- char ',' +-- whiteSpace +-- e2 <- expr +-- mtrace "structExpr:2 " e2 +-- char ',' +-- whiteSpace +-- e3 <- expr +-- mtrace "structExpr:3 " e3 +-- return (e1,e2,e3) +-- vecRotExpr = do (x,y,z) <- structExpr +-- mtrace "vec/rot" "hi" +-- (do char '>' +-- whiteSpace +-- return $ VecExpr x y z) <|> +-- (do char ',' +-- whiteSpace +-- e <- expr +-- char '>' +-- whiteSpace +-- return $ RotExpr x y z e) + +-- there's a conflict between a relational expression embedded in the last component of a vector/rotation and the +-- the normal end of the expression... in particular: +-- v = <1,1,1 > -<1,2,3>>; +-- is not a syntax error (but is a type error), but you can't tell the difference between that and +-- v = <1,1,1 > -<1,2,3>; +-- which is the difference between two vectors (which is both syntactically correct and type correct) until you +-- parse the ';'. So the complexity of the grammar here exists to disambiguate these cases (which requires a +-- bit of lookahead...) +structStart = do whiteSpace + char '<' <?> "vector/rotation expression" + whiteSpace + e1 <- expr + mtrace "structExpr:1 " e1 + char ',' + whiteSpace + e2 <- expr + mtrace "structExpr:2 " e2 + char ',' >> whiteSpace + return (e1,e2) + +vecRotExpr = do (x,y) <- structStart + ((try (do z <- expr + char ',' >> whiteSpace + s <- tailStruct + return $ RotExpr x y z s)) <|> + (do z <- tailStruct + return $ VecExpr x y z)) + +tailStruct = (try (do e <- expr + char '>' >> whiteSpace + return e)) + <|> (do e <- shiftExpr + char '>' >> whiteSpace + return e) +callExpr = do + name <- ctxify identifier + exprs <- parens $ commaSep expr + return $ Call name exprs + +castExpr = ctxify $ + do t <- parens typeName + e <- choice [try postfixExpr, atomicExpr] + return $ Cast t e + +ctxify f = do + pos0 <- getPosition + v <- f + pos1 <- getPosition + return $ Ctx (pos2Loc (pos0,pos1)) v + +notExpr = ctxify ((char '!' <?> "prefix operator") >> whiteSpace >> expr2 >>= return.Not) +invExpr = ctxify ((char '~' <?> "prefix operator") >> whiteSpace >> expr2 >>= return.Inv) +negExpr = ctxify ((char '-' <?> "prefix operator") >> whiteSpace >> expr2 >>= return.Neg) + +atomicExpr = do + aq <- getState + (ctxify $ + try ( do m <- option 1 (reservedOp "-" >> return (-1)) + n <- naturalOrFloat + return $ case n of + Left nat -> (IntLit $ m * fromIntegral nat) + Right flt -> (FloatLit $ fromRational $ toRational m * toRational flt))) + <|> (ctxify (stringLiteral >>= return.StringLit)) + <|> (if aq then (ctxify (reservedOp "$string:" >> identifier >>= return . AQString)) else fail "") + <|> (if aq then (ctxify (reservedOp "$integer:" >> identifier >>= return . AQInteger)) else fail "") + <|> (if aq then (ctxify (reservedOp "$key:" >> identifier >>= return . AQKey)) else fail "") + <|> (if aq then (ctxify (reservedOp "$float:" >> identifier >>= return . AQFloat)) else fail "") + <|> (ctxify listExpr) + <|> (ctxify vecRotExpr) + <|> (ctxify $ try callExpr) + <|> (ctxify $ do v <- var + return $ Get v) + <|> parens expr + +postfixExpr = ctxify $ + do v <- var + f <- choice [reservedOp "++" >> return PostInc, + reservedOp "--" >> return PostDec] <?> "postfix operator" + return $ f v +prefixExpr = ctxify $ + do f <- choice [reservedOp "--" >> return (PreDec), + reservedOp "++" >> return PreInc] <?> "prefix operator" + v <- var + return $ f v + +unaryExpr = choice [try prefixExpr,notExpr,invExpr, negExpr,try castExpr,atomicExpr] + +expr2 :: GenParser Char Bool (Ctx Expr) +expr2 = choice [try assignment, try postfixExpr, unaryExpr] + +expr1 = orExpr + +expr :: GenParser Char Bool (Ctx Expr) +expr = + do r <- choice [try assignment, expr1] + mtrace "expr: " r + +exprParser :: String -> Either ParseError (Ctx Expr) +exprParser text = runParser expr False "" text + +------------------------------------------------------------------------------ +-- STATEMENT PARSING + +statements = do whiteSpace + many (ctxify statement) + +statement = declStatement + <|> returnStatement + <|> jumpStatement + <|> labelStatement + <|> exprStatement + <|> blockStatement + <|> nullStatement + <|> whileStatement + <|> ifElseStatement + <|> stateStatement + <|> doWhileStatement + <|> forStatement + +declStatement = do t <- typeName + id <- identifier + rest <- (option Nothing (reservedOp "=" >> expr >>= return . Just)) + semi + return $ Decl (Var id t) rest + +integerType = (reserved "integer" >> return LLInteger) +floatType = (reserved "float" >> return LLFloat) +keyType = (reserved "key" >> return LLKey) +vectorType = (reserved "vector" >> return LLVector) +stringType = (reserved "string" >> return LLString) +rotationType = ((reserved "rotation"<|>reserved "quaternion") >> return LLRot) +listType = (reserved "list" >> return LLList) + +typeName = choice [integerType,floatType,keyType,vectorType,stringType,rotationType,listType] + +returnStatement = do reserved "return" + e <- (option Nothing (expr >>= return . Just)) + semi + return $ Return e +jumpStatement = do reserved "jump" + id <- identifier + semi + return $ Jump id +labelStatement = do reservedOp "@" + id <- identifier + semi + return $ Label id +exprStatement = do e <- expr + semi + return $ Do e + +blockStatement = do stmts <- braces statements + return $ Compound stmts + +nullStatement = (semi >> return NullStmt) + +whileStatement = do reserved "while" + e <- parens expr + stmt <- statement + return $ While e stmt +ifElseStatement = do reserved "if" + e <- parens expr + stmt1 <- statement + stmt2 <- (option NullStmt (reserved "else" >> statement)) + return $ If e stmt1 stmt2 + +stateStatement = do reserved "state" + id <- (identifier <|> (reserved "default" >> return "default")) + semi + return $ StateChange id + +forStatement = do reserved "for" + char '(' + whiteSpace + mexpr1 <- commaSep expr + semi + mexpr2 <- option Nothing (expr >>= return . Just) + semi + mexpr3 <- commaSep expr + char ')' + whiteSpace + stmt <- statement + return $ For mexpr1 mexpr2 mexpr3 stmt + +doWhileStatement = do reserved "do" + stmt <- statement + reserved "while" + e <- parens expr + return $ DoWhile stmt e + +parseType text = runParser typeName False "" text +------------------------------------------------------------ +-- HANDLER Parsing + +hparam theType = ctxify $ + do t <- (typeParser theType) + id <- identifier + return $ Var id t + +typeParser LLInteger = integerType +typeParser LLFloat = floatType +typeParser LLList = listType +typeParser LLString = stringType +typeParser LLVector = vectorType +typeParser LLKey = keyType +typeParser LLRot = rotationType + +hparams [] = return [] +hparams (theType:[]) = (hparam theType >>= return . (:[])) +hparams (theType:ts) = do p <- hparam theType + comma + ps <- hparams ts + return (p:ps) + +handlerName name = try (do id <- symbol name; notFollowedBy identLetter; return id) + +handler' name types = do ctxname <- ctxify $ handlerName name + parms <- parens (hparams types) + stmts <- braces statements + return $ Handler ctxname parms stmts + +handler = choice $ map (\ (n,ts) -> handler' n ts) goodHandlers + +------------------------------------------------------------- +-- STATE parsing + +stateName = choice [reserved "default" >> return "default" , reserved "state" >> identifier >>= return] + +stateDecl = do name <- ctxify stateName + handlers <- braces $ many handler + return $ State name handlers + +stateDecls = many stateDecl + +-------------------------------------------------------------- +varOrFunc = do (Ctx ctx (t,id)) <- ctxify $ do + t <- try typeName + id <- ctxify identifier <?> "identifier" + return (t,id) + choice [func t id, gvar ctx t id] + <|> do id <- ctxify identifier <?> "identifier" + func LLVoid id +func t id = do ps <- parens params + stmts <- braces statements + return $ GF $ Func (FuncDec id t ps) stmts +gvar ctx t (Ctx _ id) = do mexpr <- option Nothing (reservedOp "=" >> expr >>= return . Just) + semi + return $ GV (Ctx ctx (Var id t)) mexpr +-------------------------------------------------------------- +-- FUNCTION parsing + +param = ctxify $ + do t <- typeName + id <- identifier + return $ Var id t +params = commaSep param + +-- function = do (t,id,ps) <- try $ do t <- option LLVoid typeName <?> "type name" +-- id <- ctxify identifier <?> "function name" +-- ps <- parens params +-- return (t,id,ps) +-- stmts <- braces statements +-- return $ GF $ Func (FuncDec id t ps) stmts +--------------------------------------------------------------- +-- GLOBAL VARIABLES parsing + +-- globals allow no initialization or initialization by 'constant' expressions... +-- we can allow any expressions though and have semantic analysis catch problems + +-- globvar = do var <- ctxify $ do +-- t <- typeName <?> "type name" +-- id <- identifier +-- return (Var id t) +-- mexpr <- option Nothing (reservedOp "=" >> expr >>= return.Just) +-- semi +-- return $ GV var mexpr +---------------------------------------------------------------- +-- IMPORT (meta-lsl directive) parsing + +gimport = do reserved "$import" <?> "$import keyword" + ids <- (ctxify $ (char '$' >> identifier >>= return . (:[]) . ("$"++))) + <|>(ctxify $ sepBy identifier dot) + let id = fmap (concat . intersperse ".") ids + let binding = do id0 <- identifier + reservedOp "=" + id1 <- identifier + return (id0,id1) + bindings <- option [] $ parens $ commaSep binding + prefix <- option "" identifier + semi + return $ GI id bindings prefix +---------------------------------------------------------------- +-- all globals parsing + +globals = many $ choice [gimport,varOrFunc] + +lslParser = do whiteSpace + globs <- globals + ss <- stateDecls + eof + return $ LSLScript globs ss + +moduleParser = do whiteSpace + reserved "$module" + freevars <- option [] $ parens params + globs <- globals + eof + return $ LModule globs freevars + +parseFromString parser string = + case runParser parser False "" string of + Left err -> Left (snd (fromParseError err)) + Right x -> Right x + +-- | Parse an LSL script into its syntax tree.+parseScriptFromString :: String -> Either String LSLScript +parseScriptFromString s = parseFromString lslParser s +-- | Parse an LSL (Plus) module into its syntax tree.+parseModuleFromString :: String -> Either String LModule +parseModuleFromString s = parseFromString moduleParser s + +-- | Parse an LSL script, with possible antiquotations, into its syntax tree.+parseScriptFromStringAQ :: String -> Either ParseError LSLScript +parseScriptFromStringAQ s = runParser lslParser True "" s +-- | Parse an LSL (Plus) module, with possible antiquotations, into its syntax tree.+parseModuleFromStringAQ :: String -> Either ParseError LModule +parseModuleFromStringAQ s = runParser moduleParser True "" s + +parseModule :: (MonadIO m) => SourceName -> m (Either (SourceContext,String) LModule)+parseModule file = parseFile moduleParser file +parseScript file = parseFile lslParser file + +fromParseError :: ParseError -> (SourceContext,String) +fromParseError err = + let pos = errorPos err + msg = showErrorMessages "or" "unknown parse error" + "expecting" "unexpected" "end of input" (errorMessages err) + in (TextLocation { textLine0 = sourceLine pos, textColumn0 = sourceColumn pos, + textLine1 = sourceLine pos, textColumn1 = sourceColumn pos, + textName = sourceName pos }, + msg) + +parseFile p file = + do s <- liftIO $ readFile file + case parser s of + Left err -> return $ Left (fromParseError err) + Right x -> return $ Right x + where parser = runParser p False file + +txtLoc pos len = + TextLocation { textName = sourceName pos, + textColumn0 = sourceColumn pos, + textLine0 = sourceLine pos, + textColumn1 = sourceColumn pos + (len-1), + textLine1 = sourceLine pos } + +idLoc pos id = txtLoc pos $ length id + +pos2Loc (pos0,pos1) = + TextLocation { + textName = sourceName pos0, + textColumn0 = sourceColumn pos0, + textLine0 = sourceLine pos0, + textColumn1 = sourceColumn pos1, + textLine1 = sourceLine pos1 + } + +combineContexts (UnknownSourceContext,pos0,pos1,UnknownSourceContext) = pos2Loc (pos0,pos1) +combineContexts (TextLocation l0 c0 l1 c1 n,_,_,TextLocation l0' c0' l1' c1' n') = + TextLocation l0 c0 l1' c1' n +combineContexts (TextLocation l0 c0 l1 c1 n,_,pos,_) = + TextLocation l0 c0 (sourceLine pos) (sourceColumn pos) n +combineContexts (_,pos,_,TextLocation l0 c0 l1 c1 n) = + TextLocation (sourceLine pos) (sourceColumn pos) l1 c1 n +
+ src/Language/Lsl/QQ.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE TemplateHaskell #-} +module Language.Lsl.QQ(lslm,lsl) where + +import Data.Generics.Aliases(extQ) +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH.Quote(QuasiQuoter(..),dataToPatQ,dataToExpQ) +import Language.Lsl.Syntax(Expr(..)) +import Language.Lsl.Parse(parseModuleFromStringAQ,parseScriptFromStringAQ) +import Text.ParserCombinators.Parsec.Error(errorPos,errorMessages,showErrorMessages) +import Text.ParserCombinators.Parsec.Pos + +aqe (AQString v) = Just $ TH.appE (TH.conE 'StringLit) $ TH.varE $ TH.mkName v +aqe (AQInteger v) = Just $ TH.appE (TH.conE 'IntLit) $ TH.varE $ TH.mkName v +aqe (AQKey v) = Just $ TH.appE (TH.conE 'KeyLit) $ TH.varE $ TH.mkName v +aqe (AQFloat v) = Just $ TH.appE (TH.conE 'FloatLit) $ TH.varE $ TH.mkName v +aqe _ = Nothing +aqp (AQString v) = Just $ TH.conP 'StringLit [TH.varP $ TH.mkName v] +aqp (AQInteger v) = Just $ TH.conP 'IntLit [TH.varP $ TH.mkName v] +aqp (AQKey v) = Just $ TH.conP 'KeyLit [TH.varP $ TH.mkName v] +aqp (AQFloat v) = Just $ TH.conP 'FloatLit [TH.varP $ TH.mkName v] +aqp _ = Nothing + +lslModulePat :: String -> TH.Q TH.Pat +lslModulePat s = + case parseModuleFromStringAQ s of + Left err -> let (pos,msgs) = (errorPos err, errorMessages err) in do + l <- TH.location + let (line,col) = TH.loc_start l + let (line1, col1) = (sourceLine pos, sourceColumn pos) + fail $ "at " ++ show (line + line1 - 1) ++ ":" ++ show (col1) ++ ": " ++ + showErrorMessages "or" "unknown" "expecting" "unexpected" "end of input" msgs + Right x -> dataToPatQ (const Nothing `extQ` aqp) x +lslModuleExp :: String -> TH.Q TH.Exp +lslModuleExp s = + case parseModuleFromStringAQ s of + Left err -> let (pos,msgs) = (errorPos err, errorMessages err) in do + l <- TH.location + let (line,col) = TH.loc_start l + let (line1, col1) = (sourceLine pos, sourceColumn pos) + fail $ "at " ++ show (line + line1 - 1) ++ ":" ++ show (col1) ++ ": " ++ + showErrorMessages "or" "unknown" "expecting" "unexpected" "end of input" msgs + Right x -> dataToExpQ (const Nothing `extQ` aqe) x + +-- | A quasi-quoter for an LSL (Plus) module. +lslm :: QuasiQuoter+lslm = QuasiQuoter lslModuleExp lslModulePat + +lslScriptPat :: String -> TH.Q TH.Pat +lslScriptPat s = + case parseScriptFromStringAQ s of + Left err -> let (pos,msgs) = (errorPos err, errorMessages err) in do + l <- TH.location + let (line,col) = TH.loc_start l + let (line1, col1) = (sourceLine pos, sourceColumn pos) + fail $ "at " ++ show (line + line1 - 1) ++ ":" ++ show (col1) ++ ": " ++ + showErrorMessages "or" "unknown" "expecting" "unexpected" "end of input" msgs + Right x -> dataToPatQ (const Nothing `extQ` aqp) x +lslScriptExp :: String -> TH.Q TH.Exp +lslScriptExp s = + case parseScriptFromStringAQ s of + Left err -> let (pos,msgs) = (errorPos err, errorMessages err) in do + l <- TH.location + let (line,col) = TH.loc_start l + let (line1, col1) = (sourceLine pos, sourceColumn pos) + fail $ "at " ++ show (line + line1 - 1) ++ ":" ++ show (col1) ++ ": " ++ + showErrorMessages "or" "unknown" "expecting" "unexpected" "end of input" msgs + Right x -> dataToExpQ (const Nothing `extQ` aqe) x + +-- | A quasi-quoter for an LSL script. +lsl :: QuasiQuoter+lsl = QuasiQuoter lslScriptExp lslScriptPat
+ src/Language/Lsl/Render.hs view
@@ -0,0 +1,198 @@+module Language.Lsl.Render(renderCompiledScript) where + +import Data.List(foldl',intersperse) +import Language.Lsl.Syntax(Expr(..),Func(..),FuncDec(..),Global(..),Handler(..),State(..),Statement(..), + Ctx(..),Var(..),LSLType(..),Component(..),ctxItems,validLSLScript,CompiledLSLScript(..)) + +-- | Generate a string representing an LSL script from a timestamp (string) +-- and a compiled (i.e. validated, with referenced modules included) LSL script.+renderCompiledScript :: String -> CompiledLSLScript -> String+renderCompiledScript stamp (CompiledLSLScript globals funcs states) = + (renderString "// LSL script generated: " . renderString stamp . renderString "\n" . + renderGlobals globals . renderFuncs funcs . renderStates states) "" + +renderSequence r = (foldl' (.) blank) . (map r) + +renderGlobals = renderSequence renderGlobal + +renderGlobal (GDecl var val) = renderVar var . + case val of + Nothing -> renderString ";\n" + Just expr -> renderString " = " . renderSimple expr . renderString ";\n" + +renderCtxSimple (Ctx _ expr) = renderSimple expr +renderSimple (Neg expr) = renderChar '-' . renderCtxExpr expr +renderSimple (ListExpr l) = + renderChar '[' . + (foldl' (.) id $ intersperse (renderChar ',') $ map renderCtxSimple l) . + renderChar ']' +renderSimple (VecExpr x y z) = renderChar '<' . renderCtxSimple x . + renderChar ',' . renderCtxSimple y . + renderChar ',' . renderCtxSimple z . + renderChar '>' +renderSimple (RotExpr x y z s) = renderChar '<' . renderCtxSimple x . + renderChar ',' . renderCtxSimple y . + renderChar ',' . renderCtxSimple z . + renderChar ',' . renderCtxSimple s . + renderChar '>' +renderSimple e = renderExpression e + +renderStates = renderSequence renderState + +renderState (State (Ctx _ "default") handlers) = + renderString "default {\n" . renderHandlers handlers . renderString "}\n" +renderState (State (Ctx _ name) handlers) = + renderString "state " . renderString name . renderString " {\n" . renderHandlers handlers . renderString "}\n" + +renderHandlers = renderSequence renderHandler + +renderHandler (Handler (Ctx _ name) vars stmts) = renderHandler' name vars stmts + +renderHandler' name vars stmts = + renderIndent 0 . renderString name . renderChar '(' . renderVarList (ctxItems vars) . renderString ") {\n" . + renderStatements 1 stmts . renderIndent 0 . renderString "}\n" + +renderChar = showChar +renderVar (Var nm t) = (renderType t) . renderChar ' ' . (renderString nm) +renderFuncDec (FuncDec name t vars) = + let sp = if t == LLVoid then "" else " " in + renderType t . renderString sp . renderString (ctxItem name) . renderChar '(' . + renderVarList (ctxItems vars) . renderChar ')' + +renderVarList [] = blank +renderVarList (v:vars) = + (renderVar v) . + let render' [] = blank + render' (v:vars) = renderChar ',' . renderVar v . render' vars in render' vars + +renderFuncs = renderSequence renderFunc + +renderFunc (Func dec stmts) = + renderFuncDec dec . renderString "{\n" . renderStatements 0 stmts . renderString "}\n" + +renderIndent 0 = renderString " " +renderIndent n = renderString " " . renderIndent (n - 1) + +renderCtxStatement hang n (Ctx _ s) = renderStatement hang n s + +renderStatements n = renderSequence (renderCtxStatement False n) + +doHang True n = renderString " " +doHang False n = renderIndent n + +renderOptionalExpression Nothing = blank +renderOptionalExpression (Just expr) = renderCtxExpr expr + +renderStatement hang n stmt = doHang hang n . renderStatement' n stmt +renderStatement' n (Compound stmts) = + renderString "{\n" . renderStatements (n+1) stmts . renderIndent n . renderString "}\n" +renderStatement' n (While expr stmt) = + renderString "while (" . renderCtxExpr expr . renderChar ')' . renderStatement True n stmt +renderStatement' n (DoWhile stmt expr) = + renderString "do " . renderStatement True n stmt . doHang False n . renderString "while (" . renderCtxExpr expr . renderString ");\n" +renderStatement' n (For mexpr1 mexpr2 mexpr3 stmt) = + renderString "for (" . renderCtxExprs "" mexpr1 . renderString "; " . renderOptionalExpression mexpr2 . + renderString "; " . renderCtxExprs "" mexpr3 . renderString ")" . renderStatement True n stmt +renderStatement' n (If expr stmt1 stmt2) = + renderString "if (" . renderCtxExpr expr . renderChar ')' . renderStatement True n stmt1 . + case stmt2 of + NullStmt -> blank + _ -> renderIndent n . renderString "else " . (renderStatement True n stmt2) +renderStatement' n (Decl var val) = + renderVar var . + case val of + Nothing -> renderString ";\n" + Just expr -> renderString " = " . renderCtxExpr expr . renderString ";\n" +renderStatement' n (NullStmt) = blank +renderStatement' n (Return Nothing) = renderString "return;\n" +renderStatement' n (Return (Just expr)) = renderString "return " . renderCtxExpr expr . renderString ";\n"; +renderStatement' n (StateChange name) = renderString "state " . renderString name . renderString ";\n"; +renderStatement' n (Do expr) = renderCtxExpr expr . renderString ";\n"; +renderStatement' n (Label s) = renderChar '@' . renderString s . renderString ";\n"; +renderStatement' n (Jump s) = renderString "jump " . renderString s . renderString ";\n"; + +renderExpressions prefix [] = blank +renderExpressions prefix (e:es) = renderString prefix . renderExpression e . renderExpressions "," es + +renderCtxName (Ctx _ n) = renderString n +renderCtxExpr (Ctx _ e) = renderExpression e + +renderCtxExprs prefix [] = blank +renderCtxExprs prefix (e:es) = renderString prefix . renderCtxExpr e . renderCtxExprs "," es + +renderExpression (IntLit i) = shows i +renderExpression (FloatLit f) = shows f +renderExpression (StringLit s) = shows s +renderExpression (KeyLit k) = shows k +renderExpression (VecExpr x y z) = + renderChar '<' . renderCtxExpr x . renderChar ',' . + renderCtxExpr y . renderChar ',' . + renderCtxExpr z . renderChar '>' +renderExpression (RotExpr x y z s) = + renderChar '<' . renderCtxExpr x . renderChar ',' . + renderCtxExpr y . renderChar ',' . + renderCtxExpr z . renderChar ',' . + renderCtxExpr s . renderChar '>' +renderExpression (ListExpr l) = + let r prefix [] = blank + r prefix (i:is) = renderString prefix . renderCtxExpr i . r "," is + in renderChar '[' . r "" l . renderChar ']' +renderExpression (Add expr1 expr2) = renderBinExpr "+" expr1 expr2 +renderExpression (Sub expr1 expr2) = renderBinExpr "-" expr1 expr2 +renderExpression (Mul expr1 expr2) = renderBinExpr "*" expr1 expr2 +renderExpression (Div expr1 expr2) = renderBinExpr "/" expr1 expr2 +renderExpression (Mod expr1 expr2) = renderBinExpr "%" expr1 expr2 +renderExpression (BAnd expr1 expr2) = renderBinExpr "&" expr1 expr2 +renderExpression (Xor expr1 expr2) = renderBinExpr "^" expr1 expr2 +renderExpression (BOr expr1 expr2) = renderBinExpr "|" expr1 expr2 +renderExpression (Lt expr1 expr2) = renderBinExpr "<" expr1 expr2 +renderExpression (Gt expr1 expr2) = renderBinExpr ">" expr1 expr2 +renderExpression (Le expr1 expr2) = renderBinExpr "<=" expr1 expr2 +renderExpression (Ge expr1 expr2) = renderBinExpr ">=" expr1 expr2 +renderExpression (And expr1 expr2) = renderBinExpr "&&" expr1 expr2 +renderExpression (Or expr1 expr2) = renderBinExpr "||" expr1 expr2 +renderExpression (ShiftL expr1 expr2) = renderBinExpr "<<" expr1 expr2 +renderExpression (ShiftR expr1 expr2) = renderBinExpr ">>" expr1 expr2 +renderExpression (Inv expr) = renderChar '(' . renderChar '~' . renderCtxExpr expr . renderChar ')' +renderExpression (Not expr) = renderChar '(' . renderChar '!' . renderCtxExpr expr . renderChar ')' +renderExpression (Neg expr) = renderChar '(' . renderChar '-' . renderCtxExpr expr . renderChar ')' +renderExpression (Call name exprs) = renderCtxName name . renderChar '(' . renderCtxExprs "" exprs . renderChar ')' +renderExpression (Cast t expr) = renderString "((" . renderType t . renderChar ')' . renderCtxExpr expr . renderChar ')' +renderExpression (Get var) = renderVarAccess var +--renderExpression (Const var) = renderVarAccess var +renderExpression (Set var expr) = renderVarAccess var . renderString " = " . renderCtxExpr expr +renderExpression (IncBy va expr) = renderAssignment va "+=" expr +renderExpression (DecBy va expr) = renderAssignment va "-=" expr +renderExpression (MulBy va expr) = renderAssignment va "*=" expr +renderExpression (DivBy va expr) = renderAssignment va "/=" expr +renderExpression (ModBy va expr) = renderAssignment va "%=" expr +renderExpression (Equal expr1 expr2) = renderBinExpr "==" expr1 expr2 +renderExpression (NotEqual expr1 expr2) = renderBinExpr "!=" expr1 expr2 +renderExpression (PostInc va) = renderVarAccess va . renderString "++" +renderExpression (PostDec va) = renderVarAccess va . renderString "--" +renderExpression (PreInc va) = renderString "++" . renderVarAccess va +renderExpression (PreDec va) = renderString "--" . renderVarAccess va + +renderBinExpr op expr1 expr2 = renderChar '(' . renderCtxExpr expr1 . renderChar ' ' . + renderString op . renderChar ' ' . renderCtxExpr expr2 . renderChar ')' +renderAssignment va op expr = renderVarAccess va . renderChar ' ' . renderString op . renderChar ' ' . renderCtxExpr expr +renderComponent All = blank +renderComponent X = renderString ".x" +renderComponent Y = renderString ".y" +renderComponent Z = renderString ".z" +renderComponent S = renderString ".s" + +renderVarAccess (v,c) = renderCtxName v . renderComponent c + +renderString s s' = s ++ s' +renderType LLList = renderString "list" +renderType LLInteger = renderString "integer" +renderType LLVector = renderString "vector" +renderType LLFloat = renderString "float" +renderType LLString = renderString "string" +renderType LLRot = renderString "rotation" +renderType LLKey = renderString "key" +renderType LLVoid = blank + +blank :: String -> String +blank = id
+ src/Language/Lsl/Sim.hs view
@@ -0,0 +1,3712 @@+{-# OPTIONS_GHC -XFlexibleContexts -fwarn-unused-binds #-} +module Language.Lsl.Sim(SimStatus(..), + SimStateInfo(..), + SimCommand(..), + SimInputEventDefinition(..), + SimParam(..), + SimParamType(..), + -- imported types re=exported + LogMessage(..), + LogLevel(..), + Breakpoint, + BreakpointManager, + EvalResult, + ScriptInfo(..), + AvatarOutputEvent(..), + AvatarInputEvent(..), + SimEvent(..), + SimEventArg(..), + WorldM, + World, + -- + eventDescriptors, + simStep, + unimplementedFuncs + --module Language.Lsl.Internal.WorldState + ) where + +import Control.Monad(MonadPlus(..),(>=>),filterM,foldM,forM_,liftM,liftM2,unless,when) +import Control.Monad.State(StateT(..),lift) +import Control.Monad.Identity(Identity(..)) +import Control.Monad.Error(MonadError(..),ErrorT(..)) +import Data.List(elemIndex,find,foldl',isSuffixOf,nub,sortBy) +import Data.Bits((.&.),(.|.),bit,clearBit,complement,xor,setBit,shiftL,testBit) +import Data.Int() +import Data.Map(Map) +import Data.Maybe(fromMaybe,isJust,isNothing) +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.IntMap as IM + +import Language.Lsl.Internal.Animation(builtInAnimations) +import Language.Lsl.Internal.AvEvents(AvatarOutputEvent(..),AvatarInputEvent(..)) +import Language.Lsl.Internal.Breakpoint(Breakpoint,BreakpointManager,emptyBreakpointManager,setStepOverBreakpoint,setStepOutBreakpoint,replaceBreakpoints, + setStepBreakpoint,breakpointFile,breakpointLine,checkBreakpoint) +import Language.Lsl.Internal.CodeHelper(renderCall) +import Language.Lsl.Internal.Constants +import Language.Lsl.Internal.Evaluation(ScriptInfo(..),Event(..),EvalResult(..)) +import Language.Lsl.Internal.EventSigs(EventAdditionalData(..),EventDelivery(..),lslEventDescriptors) +import Language.Lsl.Internal.Exec(ExecutionState(..),ExecutionInfo(ExecutionInfo),ScriptImage(..),executeLsl,frameInfo,hardReset,hasActiveHandler,initLSLScript) +import Language.Lsl.Internal.ExpressionHandler(evaluateExpression) +import Language.Lsl.Internal.FuncSigs(funcSigs) +import Language.Lsl.Internal.InternalLLFuncs(internalLLFuncs) +import Language.Lsl.Internal.Key(nullKey) +import Language.Lsl.Internal.Log(LogLevel(..),LogMessage(..)) +import Language.Lsl.Internal.Physics(calcAccel,checkIntersections,dampForce,dampTorque,dampZForce,gravC,kin,primMassApprox,rotDyn,totalTorque) +import Language.Lsl.Syntax(Ctx(..),FuncDec(..),predefFuncs) +import Language.Lsl.Internal.Type(LSLValue(..),LSLType(..),defaultValue,isIVal,isLVal,isSVal, + lslShowVal,lslTypeString,lslValString,rVal2Rot,rot2RVal,typeOfLSLValue,vVal2Vec,vec2VVal) +import Language.Lsl.UnitTestEnv(simFunc,hasFunc) +import Language.Lsl.Internal.Util(add3d,angleBetween,diff3d,dist3d2,fac,findM,fromInt,generatePermutation,ilookup,lookupByIndex, + mag3d,mlookup,neg3d,norm3d,quaternionMultiply,quaternionToMatrix,rot3d,rotationBetween,scale3d,tuplify) +import Language.Lsl.WorldDef(Attachment(..),Avatar(..),AvatarControlListener(..),Email(..),Flexibility(..),InventoryInfo(..), + InventoryItem(..),InventoryItemData(..),InventoryItemIdentification(..),LightInfo(..),LSLObject(..), + ObjectDynamics(..),Parcel(..),Prim(..),PrimFace(..),PrimType(..),PositionTarget(..),Region(..),RotationTarget(..), + Script(..),TextureInfo(..),WebHandling(..), + defaultCamera,defaultDynamics,emptyPrim,findByInvKey,findByInvName, + inventoryInfoPermValue,inventoryItemName,mkScript, + isInvAnimationItem,isInvBodyPartItem,isInvClothingItem,isInvGestureItem,isInvNotecardItem, + isInvObjectItem,isInvScriptItem,isInvSoundItem,isInvTextureItem, + primPhantomBit,primPhysicsBit,scriptInventoryItem,worldFromFullWorldDef) +import Language.Lsl.Internal.WorldState + +import System.Random(mkStdGen) +import System.Time(ClockTime(..),CalendarTime(..),TimeDiff(..),addToClockTime,toUTCTime) +import Text.Printf(PrintfType(..),printf) + +-- execute a predefined ('ll') function +doPredef :: Monad m => String -> ScriptInfo -> [LSLValue] -> WorldM m (EvalResult,LSLValue) +doPredef name info@(ScriptInfo oid pid sid pkey event) args = + do predefs <- getPredefFuncs + -- find the correct function to execute + case tryPredefs name predefs of + Just (t,f) -> runErrFunc info name (defaultValue t) args f + Nothing -> do + (_,rettype,argtypes) <- findM (\ (x,y,z) -> x == name) funcSigs + logAMessage LogDebug (pkey ++ ":" ++ sid) ("unimplemented predefined function called: " ++ renderCall name args) + continueWith $ defaultValue rettype + + +getParcelByPosition regionIndex (x,y,_) = + do region <- getRegion regionIndex + findParcel 0 (regionParcels region) + where findParcel _ [] = throwError "parcel not found" -- mzero + findParcel i (p:ps) = + let (south,north,west,east) = parcelBoundaries p + (xc,yc) = (floor x, floor y) in + if xc < east && xc >= west && yc < north && yc >= south + then return (i,p) else findParcel (i + 1) ps + +getPrimParcel pk = do + regionIndex <- getPrimRegion pk + pos <- getRootPrim pk >>= getObject >>= return . objectPosition . objectDynamics + (index,parcel) <- getParcelByPosition regionIndex pos + return (regionIndex,index,parcel) + +putParcel regionIndex index parcel = do + region <- getRegion regionIndex + let (before,after) = splitAt index (regionParcels region) + let parcels' = if null after then parcel : before else before ++ (parcel : tail after) + lift $ setRegion regionIndex $ region { regionParcels = parcels' } + +tryPredefs name predefs = + case M.lookup name predefs of + Just (PredefFunc _ t predef) -> Just (t,predef) + Nothing -> Nothing + +defaultPredef name predef = + case lookup name $ map (\ (FuncDec n t ps) -> (ctxItem n,t)) predefFuncs of + Nothing -> error ("undefined predef " ++ name) + Just t -> PredefFunc name t predef + +runErrFunc info fname defval args f = + do v <- evalErrorT (f info args) + case v of + Left s -> logFromScript info (fname ++ ": " ++ s) >> return (EvalIncomplete,defval) + Right result -> return result + +runFace k i action = action <||> throwError ("face " ++ (show i) ++ " or prim " ++ k ++ " not found") + +(<||>) a b = a `catchError` (\ _ -> b) + +infixl 0 <||> + +primErr k = (\ s -> throwError ("problem - can't find prim " ++ k)) + +--- Web related functions ---------------------------------------------------- + +llHTTPRequest info@(ScriptInfo _ _ sn pk _) [SVal url, LVal params, SVal body] = + do t <- lift getTick + -- verify the parameters + when (length params `mod` 2 /= 0) (throwError "invalid parameter list") + when (length params > 8) (throwError "invalid parameter list") + let params' = tuplify params + when (not $ all (\ (x,_) -> x `elem` [llcHTTPMethod,llcHTTPMimetype,llcHTTPBodyMaxlength,llcHTTPVerifyCert]) params') + (throwError "invalid parameter list") + method <- maybe (return "GET") + (\ v -> if not $ v `elem` (map SVal ["GET","POST","PUT","DELETE"]) + then throwError ("invalid HTTP method " ++ lslValString v) + else let SVal s = v in return s) + (lookup llcHTTPMethod params') + mimetype <- maybe (return "text/plain;charset=utf-8") + (\ v -> if LLString /= typeOfLSLValue v then throwError "invalid mimtype" else let SVal s = v in return s) + (lookup llcHTTPMimetype params') + maxlength <- maybe (return 2048) + (\ v -> if LLInteger /= typeOfLSLValue v then throwError "invalid body length" else return (let IVal i = v in i)) + (lookup llcHTTPBodyMaxlength params') + verify <- maybe (return 1) + (\ v -> if LLInteger /= typeOfLSLValue v then throwError "invalid verify cert value" else return (let IVal i = v in i)) + (lookup llcHTTPVerifyCert params') + -- parameters ok + key <- lift newKey + lift $ putWorldEvent 0 (HTTPRequestEvent (pk,sn) key url method mimetype maxlength verify body) + continueWith $ KVal key + +--- Sensor related functions ------------------------------------------------- + +llSensor info@(ScriptInfo _ _ sn pk _) [SVal name, KVal key, IVal etype, FVal range, FVal arc] = + lift $ putWorldEvent 0 (SensorEvent (pk,sn) name key etype range arc Nothing) >> continueWith VoidVal +llSensorRepeat info@(ScriptInfo _ _ sn pk _) [SVal name, KVal key, IVal etype, FVal range, FVal arc, FVal interval] = + let interval' = if interval < 0 then 0 else interval in + lift $ putWorldEvent 0 (SensorEvent (pk,sn) name key etype range arc (Just interval')) >> continueWith VoidVal +llSensorRemove info@(ScriptInfo _ _ sn pk _) [] = + do q <- lift getWQueue + lift $ setWQueue [ qentry | qentry@(_,event) <- q, not (isSensorEvent event) || sensorAddress event /= (pk,sn)] + continueWith VoidVal +------------------------------------------------------------------------------ + +llRequestAgentData info@(ScriptInfo _ _ sn pk _) [KVal ak, IVal d] = + do key <- lift newKey + av <- (lift getWorldAvatars >>= mlookup ak) <||> (throwError ("no such avatar" ++ ak)) + dataVal <- case d of + d | d == cDataBorn -> return "1981-01-01" + | d == cDataOnline -> return "1" + | d == cDataRating -> return "0,0,0,0,0" + | d == cDataName -> return $ avatarName av + | d == cDataPayinfo -> return "3" + | otherwise -> throwError ("invalid data requested: " ++ show d) + lift $ pushDataserverEvent pk sn key dataVal + continueWith (KVal key) + +llRequestSimulatorData info@(ScriptInfo _ _ sn pk _) [SVal simName, IVal d] = + do key <- lift newKey + regions <- lift getWorldRegions + let findRegion = findM ((==simName) . regionName . snd) (M.toList regions) + let simErr = throwError ("unknown simulator " ++ simName) + val <- case d of + d | d == cDataSimStatus -> (findRegion >> return "up") <||> return "unknown" + | d == cDataSimRating -> (findRegion >> return "PG") <||> simErr + | d == cDataSimPos -> (do ((x,y),_) <- findRegion + return $ lslValString $ vec2VVal (256 * fromIntegral x, 256 * fromIntegral y, 0)) + <||> simErr + | otherwise -> throwError ("invalid data requested: " ++ show d) + lift $ pushDataserverEvent pk sn key val + continueWith (KVal key) +--- INVENTORY related functions ---------------------------------------------- + +sortByInvName l = sortBy (\ i i' -> compare (invName i) (invName i')) l + +invName = inventoryItemName + +getPrimInventoryInfo info@(ScriptInfo _ _ _ pk _) invType = + case invType of + i | i == llcInventoryAll -> getPrimInventory pk >>= return . sortByInvName + | i == llcInventoryAnimation -> getPrimAnimations pk >>= return . sortByInvName + | i == llcInventoryBodyPart -> getPrimBodyParts pk >>= return . sortByInvName + | i == llcInventoryClothing -> getPrimClothing pk >>= return . sortByInvName + | i == llcInventoryGesture -> getPrimGestures pk >>= return . sortByInvName + | i == llcInventoryNotecard -> getPrimNotecards pk >>= return . sortByInvName + | i == llcInventoryObject -> getPrimObjects pk >>= return . sortByInvName + | i == llcInventoryScript -> getPrimScripts pk >>= return . sortByInvName + | i == llcInventorySound -> getPrimSounds pk >>= return . sortByInvName + | i == llcInventoryTexture -> getPrimTextures pk >>= return . sortByInvName + | otherwise -> do lift $ logFromScript info ("invalid inventory type: " ++ lslValString invType) + return [] + +llGetInventoryNumber info@(ScriptInfo _ _ _ pk _) [invType@(IVal _)] = do + getPrimInventoryInfo info invType >>= continueWith . IVal . length + +llGetInventoryCreator info@(ScriptInfo _ _ _ pk _) [SVal name] = + do all <- getPrimInventory pk + result <- case findByInvName name all of + Nothing -> (lift $ putChat (Just 20.0) pk 0 ("no item named '" ++ name ++ "'")) >> return nullKey + Just item -> return $ inventoryInfoCreator $ inventoryItemInfo item + continueWith $ KVal result + +llGetInventoryPermMask info@(ScriptInfo _ _ _ pk _) [SVal name, IVal mask] = + do all <- getPrimInventory pk + mask <- case findByInvName name all of + Nothing -> (lift $ putChat (Just 20.0) pk 0 ("No item named '" ++ name ++ "'")) >> throwError ("No item named '" ++ name ++ "'") + Just item -> inventoryInfoPermValue mask (inventoryInfoPerms $ inventoryItemInfo item) + continueWith (IVal mask) + +llGetInventoryKey info@(ScriptInfo _ _ _ pk _) [SVal name] = + do all <- getPrimInventory pk + result <- case findByInvName name all of + Nothing -> return nullKey + Just (InventoryItem id invInfo _) -> + let Right perms = inventoryInfoPermValue cMaskOwner (inventoryInfoPerms invInfo) in + if perms .&. cFullPerm == cFullPerm then + return $ snd (inventoryItemNameKey id) + else return nullKey + continueWith $ KVal result + +llGetInventoryName info@(ScriptInfo _ _ _ pk _) [invType@(IVal _), IVal index] = + getPrimInventoryInfo info invType >>= return . map (\ item -> invName item) >>= continueWith . SVal . fromMaybe "" . lookupByIndex index + +llGetInventoryType info@(ScriptInfo _ _ _ pk _) [SVal name] = do + getPrimInventory pk >>= continueWith . classify . findByInvName name + where classifications = [(isInvAnimationItem,llcInventoryAnimation),(isInvBodyPartItem,llcInventoryBodyPart), + (isInvClothingItem,llcInventoryClothing),(isInvGestureItem,llcInventoryGesture), + (isInvNotecardItem,llcInventoryNotecard),(isInvObjectItem,llcInventoryObject), + (isInvSoundItem,llcInventorySound),(isInvTextureItem,llcInventoryTexture), + (isInvScriptItem,llcInventoryScript)] + classify Nothing = IVal (-1) + classify (Just item) = foldl' (\ (IVal cur) (f,i) -> if (cur >= 0) || not (f item) then IVal cur else i) (IVal (-1)) classifications + +llRemoveInventory info@(ScriptInfo _ _ _ pk _) [SVal name] = + do inv <- getPrimInventory pk + maybe (lift $ putChat (Just 20) pk cDebugChannel ("Missing inventory item '" ++ name ++ "'")) + (\ _ -> let inv' = [ item | item <- inv, name /= (inventoryItemName item)] in + lift $ setPrimInventory pk inv') + (findByInvName name inv) + continueWith VoidVal + +copyInventoryItem newOwner newGroup item = + case item of + item | isInvObjectItem item -> do + let copyLink prim = do + k <- lift newKey + inventory <- mapM (copyInventoryItem newOwner newGroup) (primInventory prim) + return (prim { primKey = k, primInventory = inventory, primOwner = newOwner, primGroup = newGroup }) + InvObject links <- return $ inventoryItemData item + links' <- mapM copyLink links + when (null links') $ throwError "empty linkset!" + let info = inventoryItemInfo item + return (InventoryItem (InventoryItemIdentification (inventoryItemName item,primKey $ head links')) + info (InvObject links')) + | otherwise -> do + k <- lift newKey + let info = inventoryItemInfo item + let dat = inventoryItemData item + return (InventoryItem (InventoryItemIdentification (inventoryItemName item, k)) info dat) +changeName (InventoryItem (InventoryItemIdentification (name,key)) info dat) newName = + (InventoryItem (InventoryItemIdentification (newName,key)) info dat) + +llGiveInventory info@(ScriptInfo _ _ _ pk _) [KVal k, SVal inv] = + do inventory <- getPrimInventory pk <||> throwError "cant find prim!" + item <- maybe (throwError ("inventory item " ++ inv ++ "not found")) (return . id) (findByInvName inv inventory) + prims <- lift getPrims + case M.lookup k prims of + Just p -> do + owner <- getPrimOwner pk + group <- getPrimGroup pk + let (_,ownerP,groupP,everybodyP,_) = let [p1,p2,p3,p4,p5] = take 5 (primPermissions p) ++ repeat 0 in (p1,p2,p3,p4,p5) + let hasModifyPerm = (cPermModify .&. everybodyP /= 0) || + (cPermModify .&. groupP /= 0 && not (isNothing group) && group == primGroup p) || + (cPermModify .&. ownerP /= 0 && owner == primOwner p) + if hasModifyPerm || primAllowInventoryDrop p + then do + let newOwner = primOwner p + let newGroup = primGroup p + item' <- copyInventoryItem newOwner newGroup item + let inventory' = primInventory p + let findAName i base = let name = base ++ " " ++ show i in + if isNothing (findByInvName name inventory') then name + else findAName (i + 1) base + let inventory'' = case findByInvName inv inventory' of + Nothing -> item' : inventory' + Just _ -> let newName = findAName 1 inv in (changeName item' newName) : inventory' + lift $ setPrimInventory k inventory'' + -- TODO: are scripts handled right? + lift $ pushDeferredScriptEventToPrim + (Event "changed" [if hasModifyPerm then llcChangedInventory else llcChangedAllowedDrop] M.empty) k 0 + else throwError ("can't modify/drop inventory on target") + Nothing -> do + avatars <- lift getWorldAvatars + case M.lookup k avatars of + Nothing -> throwError ("no object or avatar found with key " ++ k) + Just av -> lift (putWorldEvent 0 (GiveAvatarInventoryEvent k item)) >> + (lift $ logFromScript info $ "llGiveInventory: avatar " ++ k ++ " given option of accepting inventory") + continueWith VoidVal + +llSetRemoteScriptAccessPin info@(ScriptInfo _ _ _ pk _) [IVal pin] = + lift $ setPrimRemoteScriptAccessPin pk pin >> continueWith VoidVal +llRemoteLoadScript info@(ScriptInfo _ _ _ pk _) [KVal _,SVal _, IVal _, IVal _] = + lift $ putChat (Just 20.0) pk cDebugChannel "Deprecated. Please use llRemoteLoadScriptPin instead." >> continueWith VoidVal + +llRezObject info params = rezObject False info params +llRezAtRoot info params = rezObject True info params + +rezObject atRoot info@(ScriptInfo _ _ _ pk _) [SVal inventory, VVal px py pz, VVal vx vy vz, RVal rx ry rz rs, IVal param] = + do objects <- getPrimObjects pk + maybe (do lift $ putChat (Just 20) pk 0 ("Couldn't find object '" ++ inventory ++ "'") + throwError ("no such inventory item - " ++ inventory)) + (\ item -> do + let copy = isCopyable item + let InvObject linkSet = inventoryItemData item + lift $ putWorldEvent 0 (RezObjectEvent linkSet (px,py,pz) (vz,vy,vz) (rz,ry,rz,rs) param pk copy atRoot) + when (not copy) $ do -- delete! + wholeInventory <- getPrimInventory pk + lift $ setPrimInventory pk + [ item | item <- wholeInventory, inventory /= inventoryItemName item] + ) + (findByInvName inventory objects) + continueWith VoidVal + +isCopyable item = + let (_,perm,_,_,_) = inventoryInfoPerms $ inventoryItemInfo item in + if cPermCopy .&. perm == 0 + then False + else + (if isInvObjectItem item + then let InvObject links = inventoryItemData item + primCopyable prim = all isCopyable (primInventory prim) + in all primCopyable links + else True) + +llResetScript info@(ScriptInfo _ _ sn pk _) [] = + do lift $ putWorldEvent 0 (ResetScriptEvent pk sn) + return (EvalComplete Nothing,VoidVal) + +llResetOtherScript info@(ScriptInfo _ _ sn pk _) [SVal sn'] = + do when (sn == sn') $ throwError ("trying to reset the current script - must use llResetScript for this") + lift getWorldScripts >>= mlookup (pk,sn) >>= return . scriptActive >>= flip when (throwError "can't reset a stopped script") . not + resetScript pk sn' + continueWith VoidVal + +resetScript pk sn = do + lift $ logAMessage LogDebug "sim" "resetting a script" + scripts <- lift getWorldScripts + script <- mlookup (pk,sn) scripts + t <- lift getTick + let img = scriptImage script + let doReset execState = + let script' = script { + scriptImage = (hardReset img) {executionState = execState}, + scriptActive = True, + scriptPermissions = M.empty, + scriptLastPerm = Nothing, + scriptLastResetTick = t, + scriptEventQueue = [Event "state_entry" [] M.empty] + } in lift $ setWorldScripts (M.insert (pk,sn) script' scripts) + in case executionState img of + Executing -> doReset Waiting + Waiting -> doReset Waiting + SleepingTil i -> doReset (WaitingTil i) + WaitingTil i -> doReset (WaitingTil i) + _ -> throwError ("can't reset script that is crashed or suspended") + +llGetScriptState info@(ScriptInfo _ _ _ pk _) [SVal sn] = + do script <- (lift getWorldScripts >>= mlookup (pk,sn)) <||> throwError "no such script/invalid script" + (continueWith . IVal) $ if not $ scriptActive script then 0 + else case executionState (scriptImage script) of + Halted -> 0 + Erroneous _ -> 0 + Crashed _ -> 0 + _ -> 1 + +llSetScriptState info@(ScriptInfo _ _ sn pk _) [SVal sn', IVal state] = + do when (sn == sn') $ throwError ("can't change your own state") + scripts <- lift getWorldScripts + script <- mlookup (pk,sn') scripts <||> throwError "no such script (could be invalid script)" + if state == 0 + then + if (scriptActive script) + then lift $ setWorldScripts (M.insert (pk,sn') (script { scriptActive = False }) scripts) + else return () + else case executionState (scriptImage script) of + Crashed _ -> throwError "can't change state of crashed script" + Erroneous _ -> throwError "can't change state of erroneous script" + _ -> if scriptActive script + then throwError "script is already running" + else resetScript pk sn' + continueWith VoidVal +------------------------------------------------------------------------------ +llSetPayPrice info@(ScriptInfo _ _ sn pk _) [IVal price, LVal l] = + let toI (IVal i) = if (i < (-2)) then (-1) else i + toI _ = (-1) + [i1,i2,i3,i4] = take 4 $ (map toI l) ++ replicate 4 (-1) in + do hasMoney <- scriptHasActiveHandler pk sn "money" + when (not hasMoney) $ throwError ("no money handler, pay price info ignored") + lift $ setPrimPayInfo pk (price,i1,i2,i3,i4) + continueWith VoidVal + +llGetStartParameter info@(ScriptInfo _ _ sn pk _) [] = + (lift getWorldScripts >>= mlookup (pk,sn) >>= continueWith . IVal . scriptStartParameter) +------------------------------------------------------------------------------ +llCloud info [v@(VVal x y z)] = + do lift $ logFromScript info "llCloud: returning default density" + continueWith $ FVal 0 + +llWind info [v@(VVal x y z)] = + lift $ logFromScript info "llWind: returning default density" >> continueWith (VVal 0 0 0) + +llWater info [v@(VVal x y z)] = + do lift $ logFromScript info "llWater: returning default water elevation" + continueWith $ FVal 0 + +llSitTarget (ScriptInfo _ _ _ pk _) [v@(VVal _ _ _),r@(RVal _ _ _ _)] = + lift $ setPrimSitTarget pk (Just (vVal2Vec v, rVal2Rot r)) >> continueWith VoidVal + +llAvatarOnSitTarget info@(ScriptInfo _ _ _ pk _) [] = + do sitTarget <- getPrimSitTarget pk + when (sitTarget == Nothing) (throwError ("no sit target")) + k <- getPrimSittingAvatar pk >>= return . fromMaybe nullKey + continueWith (KVal k) + +llUnSit info@(ScriptInfo _ _ _ pk _) [KVal k] = + do val <- getPrimSittingAvatar pk + maybe (throwError "no avatar sitting on prim (land unsit not implemented") + (\ ak -> if ak == k then lift $ setPrimSittingAvatar pk Nothing + else throwError "unsit of avatar not sitting on prim attempted (land unsit not implemented)") + val + continueWith VoidVal + +llMessageLinked info@(ScriptInfo oid pid sid pkey _) [IVal link,IVal val,SVal msg,KVal key] = + do LSLObject { primKeys = links } <- (getObject oid) <||> throwError ("object not found!") + when (null links) $ throwError ("object is has no links!") + let targetLinkIndices = targetLinks (length links) link pid + let targetLinks = map (links !!) targetLinkIndices + let event = (Event "link_message" [IVal pid, IVal val, SVal msg, KVal key] M.empty) + lift $ mapM_ (\ pk -> pushDeferredScriptEventToPrim event pk 0) targetLinks + continueWith VoidVal + +targetLinks n link pid = + case link of + l | l == linkSet -> [0 .. (n - 1)] + | l == linkAllOthers -> [0..(pid - 1)] ++ [(pid + 1).. (n - 1)] + | l == linkAllChildren -> [1..(n - 1)] + | l == linkThis -> [pid] + | otherwise -> [link - 1] + +-- the key to 'sleep' is that instead of returning 'EvalIncomplete' as its EvalResult, it returns +-- 'YieldTil <some-tick>', which puts the script into a sleep state. +-- other functions which have a built in delay should use this mechanism as well. +llSleep info@(ScriptInfo oid pid sid pkey event) [FVal f] = + do tick <- lift $ getTick + return $ (YieldTil (tick + durationToTicks f),VoidVal) + + +llInstantMessage info@(ScriptInfo _ _ _ pk _) [KVal ak, SVal message] = + do tick <- lift getTick + name <- getPrimName pk + av <- (lift getWorldAvatars >>= mlookup ak) <||> throwError ("no such user: " ++ ak) + let avname = avatarName av + lift $ logAMessage LogInfo "sim" ("IM to " ++ avname ++ " from " ++ name ++ ": " ++ message) + return (YieldTil (tick + durationToTicks 2),VoidVal) + +llSay info params= lift $ chat (Just 20.0) info params +llWhisper info params = lift $ chat (Just 10.0) info params +llShout info params = lift $ chat (Just 100.0) info params +llRegionSay info params@[IVal chan, SVal message] = + if (chan == 0) + then do lift $ logAMessage LogWarn (scriptInfoPrimKey info ++ ": " ++ scriptInfoScriptName info) "attempt to llRegionSay on channel 0" + return (EvalIncomplete,VoidVal) + else lift $ chat Nothing info params + +chat range info@(ScriptInfo oid pid sid pkey event) [IVal chan, SVal message] = + do logFromScript info $ concat ["chan = ", show chan, ", message = ", message] + putChat range pkey chan message + return (EvalIncomplete,VoidVal) + +putChat range k chan message = do + prims <- getPrims + case M.lookup k prims of + Just prim -> runErrPrim k () $ do + region <- (getPrimRegion k) + pos <- getRootPrim k >>= getObject >>= return . objectPosition . objectDynamics + lift $ putWorldEvent 0 $ Chat chan (primName prim) k message (region, pos) (range) + Nothing -> do + avatars <- getWorldAvatars + case M.lookup k avatars of + Just avatar -> putWorldEvent 0 $ Chat chan (avatarName avatar) k message (avatarRegion avatar, avatarPosition avatar) (range) + Nothing -> logAMessage LogWarn "sim" ("Trying to chat from unknown object/avatar with key " ++ k) + +llListen (ScriptInfo oid pid sid pkey event) [IVal chan, SVal sender, KVal key, SVal msg] = + (lift $ registerListener $ Listener pkey sid chan sender key msg) >>= continueWith . IVal + +llListenRemove (ScriptInfo _ _ sid pk _) [IVal id] = + (unregisterListener pk sid id) >> continueWith VoidVal + +llListenControl (ScriptInfo _ _ sid pk _) [IVal id, IVal active] = + (updateListener pk sid id $ active /= 0) >> continueWith VoidVal + +llFrand _ [FVal maxval] = + lift $ do r <- wrand + continueWith $ FVal (maxval * r) + +llTeleportAgentHome info@(ScriptInfo _ _ _ pk _) [KVal ak] = + do owner <- getPrimOwner pk + regionIndex <- getPrimRegion pk + (_,_,parcel) <- getPrimParcel pk + if parcelOwner parcel == owner + then lift $ logFromScript info ("llTeleportAgentHome: user " ++ ak ++ " teleported home (in theory)") + else lift $ logFromScript info ("llTeleportAgentHome: not permitted to teleport agents from this parcel") + continueWith VoidVal + +llEjectFromLand info@(ScriptInfo oid _ _ pk _) [KVal user] = + do owner <- getPrimOwner pk + regionIndex <- getPrimRegion pk + (_,parcel) <- getObjectPosition oid >>= getParcelByPosition regionIndex + if parcelOwner parcel == owner + then lift $ logFromScript info ("llEjectFromLand: user " ++ user ++ " ejected (in theory)") + else lift $ logFromScript info ("llEjectFromLand: not permitted to eject from this parcel") + continueWith VoidVal + +llBreakLink info@(ScriptInfo oid _ sid pk _) [IVal link] = + do perm <- getPermissions pk sid + if perm .&. cPermissionChangeLinks /= 0 + then do + objects <- lift getObjects + LSLObject { primKeys = links, objectDynamics = dynamics } <- mlookup oid objects + attachment <- getPrimAttachment oid + case attachment of + Nothing -> + if link < 1 || link > length links then lift $ logFromScript info ("llBreakLink: invalid link id") + else do + let (dyn1,dyn2) = if link == 1 then (defaultDynamics,dynamics) else (dynamics,defaultDynamics) + let (xs,y:ys) = splitAt (link - 1) links + let (linkSet1,linkSet2) = (xs ++ ys, [y]) + let objects' = if null linkSet1 then objects else M.insert (head linkSet1) (LSLObject linkSet1 dyn1) objects + lift $ setObjects (M.insert (head linkSet2) (LSLObject linkSet2 dyn2) objects') + when (not (null linkSet1)) $ do + lift $ pushChangedEventToObject (head linkSet1) cChangedLink + lift $ setPrimParent (head linkSet1) Nothing + lift $ pushChangedEventToObject (head linkSet2) cChangedLink + lift $ setPrimParent (head linkSet2) Nothing + _ -> lift $ logFromScript info ("llBreakLink: can't change links of attached object") + else lift $ logFromScript info ("llBreakLink: no permission") + continueWith VoidVal + +llBreakAllLinks info@(ScriptInfo oid _ sid pk _) [] = + do perm <- getPermissions pk sid + if perm .&. cPermissionChangeLinks /= 0 + then do + objects <- lift getObjects + LSLObject links dynamics <- mlookup oid objects + attachment <- getPrimAttachment oid + case attachment of + Nothing -> + if length links > 1 + then do + -- order of parameters to union is vital: union is left biased, so we want the + -- new objects (in the left argument) to replace the old (in the right) where + -- both exist (the root key of the old object is found in both) + let objects' = M.union + (M.fromList $ map (\ k -> (k, LSLObject [k] (if k == oid then dynamics else defaultDynamics))) links) objects + lift $ setObjects objects' + lift $ mapM_ (\ link -> pushChangedEventToObject link cChangedLink >> + setPrimParent link Nothing) links + else return () + _ -> lift $ logFromScript info ("llBreakAllLinks: can't change links of attached object") + else lift $ logFromScript info ("llBreakAllLinks: no permission") + continueWith VoidVal + +-- TODO: verify link order +llCreateLink info@(ScriptInfo oid _ sid pk _) [KVal target, IVal iparent] = + do perm <- getPermissions pk sid + if perm .&. cPermissionChangeLinks /= 0 + then do + objects <- lift getObjects + LSLObject (link:links) dynamics <- mlookup oid objects + case M.lookup target objects of + Nothing -> lift $ logFromScript info "llCreateLink: target not found" + Just (LSLObject (link':links') dynamics') -> do + attachment0 <- getPrimAttachment oid + attachment1 <- getPrimAttachment target + case (attachment0,attachment1) of + (Nothing,Nothing) -> do + mask <- getObjectPermMask target cMaskOwner + ownerTarget <- getPrimOwner target + owner <- getPrimOwner oid + if mask .&. cPermModify /= 0 && owner == ownerTarget + then do + let (newLinkset,deleteKey,newDynamics) = if parent + then ((link:link':links') ++ links, link',dynamics) + else ((link':link:links) ++ links', link,dynamics') + lift $ setObjects (M.insert (head newLinkset) (LSLObject newLinkset newDynamics) $ M.delete deleteKey objects) + lift $ pushChangedEventToObject (head newLinkset) cChangedLink + else lift $ logFromScript info "llCreateLink: no modify permission on target" + _ -> lift $ logFromScript info ("llCreateLink: can't change links of attached object") + else lift $ logFromScript info ("llCreateLink: no permission to change links") + continueWith VoidVal + where parent = iparent /= 0 + +llDie info@(ScriptInfo oid _ _ pk _) [] = + do attachment <- getPrimAttachment oid + case attachment of + Nothing -> do + objects <- lift getObjects + LSLObject { primKeys = (links) } <- mlookup oid objects + allScripts <- mapM getPrimScripts links + let primsWithScriptNames = zip links (map (map (invName)) allScripts) + let skeys = concat $ map ( \ (k,list) -> map ((,)k) list) primsWithScriptNames + lift $ mapM_ delScript skeys + lift $ mapM_ (\ link -> (getPrims >>= return . M.delete link >>= setPrims)) links + lift $ setObjects (M.delete oid objects) + lift $ logFromScript info ("object, and therefore this script, is dying") + return (EvalComplete Nothing,VoidVal) + where delScript (k,s) = getWorldScripts >>= return . M.delete (k,s) >>= setWorldScripts + _ -> do lift $ logFromScript info ("attachment cannot die") + return (EvalIncomplete,VoidVal) + +llAttachToAvatar info@(ScriptInfo oid _ sid pk _) [IVal attachPoint] = + if attachPoint `elem` validAttachmentPoints then + do script <- (lift getWorldScripts >>= mlookup (pk,sid)) + attachment <- getPrimAttachment oid + case attachment of + Just _ -> lift $ logFromScript info "llAttachToAvatar: already attached" + Nothing -> + case scriptLastPerm script of + Nothing -> throwError "no permission to attach" + Just k -> do + perm <- mlookup k (scriptPermissions script) + when (perm .&. cPermissionAttach == 0) $ throwError "no permission to attach" + owner <- getPrimOwner pk + if (k /= owner) + then lift $ putChat (Just 20.0) pk 0 ("Script trying to attach to someone other than owner!") + else do + avatars <- lift getWorldAvatars + let av = M.lookup k avatars + case av of + Nothing -> throwError "avatar not present in sim" + Just av -> + let attachments = avatarAttachments av in + case IM.lookup attachPoint attachments of + Nothing -> let av' = av { avatarAttachments = IM.insert attachPoint oid attachments } in + do lift $ setWorldAvatars (M.insert k av' avatars) + lift $ setPrimAttachment oid (Just $ Attachment k attachPoint) + lift $ pushAttachEvent pk k + Just _ -> throwError "attachment point already occupied" + continueWith VoidVal + else throwError ("invalid attachment point: " ++ show attachPoint) + +llDetachFromAvatar info@(ScriptInfo oid _ sid pk _) [] = + do when (oid /= pk) $ throwError "can't detach from within child prim" + script <- (lift getWorldScripts >>= mlookup (pk,sid)) <||> throwError "can't find current script!" + attachment <- getPrimAttachment oid + when (isNothing attachment) $ throwError "not attached!" + Just (Attachment k attachPoint) <- return attachment + perm <- (mlookup k $ scriptPermissions script) <||> throwError "no permission to detach" + when (perm .&. cPermissionAttach == 0) $ throwError "no permission to attach" + avatars <- lift getWorldAvatars + avatar <- mlookup k avatars <||> throwError "can't find avatar!" + let attachments = avatarAttachments avatar + lift $ setWorldAvatars (M.insert k (avatar { avatarAttachments = IM.delete attachPoint attachments }) avatars) + lift $ setPrimAttachment oid Nothing + lift $ pushAttachEvent oid nullKey + lift $ putWorldEvent 1 (DetachCompleteEvent oid k) + continueWith VoidVal + +llGetAttached info@(ScriptInfo oid _ _ _ _) [] = + getPrimAttachment oid >>= return . maybe 0 attachmentPoint >>= continueWith . IVal + +llGiveMoney info@(ScriptInfo _ _ sn pk _) [KVal ak, IVal amount] = + do script <- (lift getWorldScripts >>= mlookup (pk,sn)) <||> (throwError "can't find script!") + permKey <- maybe (throwError "no permission") (return . id) (scriptLastPerm script) + perm <- mlookup permKey (scriptPermissions script) + when (perm .&. cPermissionAttach == 0) $ throwError "no permission" + lift $ logFromScript info ("llGiveMoney: pretending to give " ++ show amount ++ " to avatar with key " ++ ak) + continueWith (IVal 0) + +llGetPermissionsKey (ScriptInfo _ _ sid pk _) [] = + lift getWorldScripts >>= mlookup (pk,sid) >>= continueWith . KVal . fromMaybe nullKey . scriptLastPerm + +llGetPermissions (ScriptInfo _ _ sid pk _) [] = getPermissions pk sid >>= continueWith . IVal + +getPermissions pk s = do + script <- (lift getWorldScripts >>= mlookup (pk,s)) + case scriptLastPerm script of + Nothing -> return 0 + Just k -> mlookup k (scriptPermissions script) + +getPermittedAvKey info@(ScriptInfo _ _ s pk _) fname perm = do + script <- (lift getWorldScripts >>= mlookup (pk,s)) + case scriptLastPerm script of + Nothing -> lift $ logFromScript info (fname ++ ": not permitted") >> return Nothing + Just k -> case M.lookup k (scriptPermissions script) of + Nothing -> lift $ logFromScript info (fname ++ ": internal error getting permissions") >> return Nothing + Just i | i .&. perm /= 0 -> return (Just k) + | otherwise -> return Nothing + +llRequestPermissions (ScriptInfo _ _ sid pk _) [KVal k, IVal mask] = + do avatars <- lift $ getWorldAvatars + case M.lookup k avatars of + Nothing -> lift $ logAMessage LogInfo (pk ++ ":" ++ sid) ("Invalid permissions request: no such avatar: " ++ k) + _ -> lift $ putWorldEvent 0 (PermissionRequestEvent pk sid k mask) + continueWith VoidVal + +llClearCameraParams info@(ScriptInfo _ _ sid pk _) [] = + do avKey <- getPermittedAvKey info "llClearCameraParams" cPermissionControlCamera + case avKey of + Nothing -> return () + Just k -> do + avatars <- lift getWorldAvatars + av <- mlookup k avatars + lift $ setWorldAvatars (M.insert k (av { avatarCameraControlParams = defaultCamera }) avatars) + continueWith VoidVal + +llGetCameraPos info@(ScriptInfo _ _ sid pk _) [] = + do avKey <- getPermittedAvKey info "llGetCameraPos" cPermissionTrackCamera + maybe (return (0,0,0)) (\ k -> lift getWorldAvatars >>= mlookup k >>= return . avatarCameraPosition) avKey >>= + continueWith . vec2VVal + +llGetCameraRot info@(ScriptInfo _ _ sid pk _) [] = + do avKey <- getPermittedAvKey info "llGetCameraRot" cPermissionTrackCamera + maybe (return (0,0,0,1)) (\ k -> lift getWorldAvatars >>= mlookup k >>= return . avatarCameraRotation) avKey + >>= continueWith . rot2RVal + +llTakeCamera info _ = lift $ logFromScript info "llTakeCamera: deprecated!" >> continueWith VoidVal +llReleaseCamera info _ = lift $ logFromScript info "llRelaaseCamera: deprecated!" >> continueWith VoidVal +llPointAt info _ = lift $ logFromScript info "llPointAt: deprecated!" >> continueWith VoidVal +llStopPointAt info _ = lift $ logFromScript info "llStopPointAt: deprecated!" >> continueWith VoidVal + +llSetPrimURL info _ = lift $ logFromScript info "llSetPrimURL: unimplemented!" >> continueWith VoidVal +llRefreshPrimURL info _ = lift $ logFromScript info "llRefreshPrimURL: unimplemted!" >> continueWith VoidVal + +llGetRot info@(ScriptInfo oid _ _ pk _) [] = + getGlobalRot pk >>= continueWith . rot2RVal + +llGetLocalRot info@(ScriptInfo oid _ _ pk _) [] = + (if oid == pk + then getObjectRotation oid + else getPrimRotation pk) >>= continueWith . rot2RVal + +llGetRootRotation info@(ScriptInfo oid _ _ pk _) [] = getObjectRotation oid >>= continueWith . rot2RVal + +--TODO: handle attachments... +--TODO: confirm order of rotations in both of these +llSetRot info@(ScriptInfo oid _ _ pk _) [r@(RVal _ _ _ _)] = + (if oid == pk then setRootRotation oid rot else setChildRotation oid pk rot) >> continueWith VoidVal + where rot = rVal2Rot r + +-- TODO: fix this!! +setChildRotation rk pk rot = do + rootRot <- getPrimRotation rk + lift $ setPrimRotation pk (rot `quaternionMultiply` rootRot `quaternionMultiply` rootRot) + +setRootRotation rk rot = do + obj <- getObject rk + lift $ setObject rk (obj { objectDynamics = (objectDynamics obj) { objectRotation = rot }}) + +llSetLocalRot info@(ScriptInfo oid _ _ pk _) [r@(RVal _ _ _ _)] = + (if oid == pk then setRootRotation oid rot else lift $ setPrimRotation pk rot) >> continueWith VoidVal + where rot = rVal2Rot r + +llSetPos info@(ScriptInfo oid pid sid pk event) [val] = + (if oid == pk then setRootPos oid v else setChildPos pk v) >> continueWith VoidVal + where v = vVal2Vec val + +setChildPos pk val = lift $ setPrimPosition pk val + +-- updates the world coordinates of object +-- does NOT consider region boundaries (TODO: fix!) +setRootPos oid v = + do v0 <- getObjectPosition oid + let vec = diff3d v v0 + let dist = mag3d vec + let vec' = if dist <= 10.0 + then vec + else scale3d 10.0 $ norm3d vec + --objects <- lift getObjects + obj <- getObject oid + lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectPosition = v0 `add3d` vec' } }) + +llGetOwner info [] = + let k = scriptInfoPrimKey info in getPrimOwner k >>= continueWith . KVal +llGetCreator info [] = + let k = scriptInfoPrimKey info in getPrimCreator k >>= continueWith . KVal +llSameGroup info@(ScriptInfo _ _ _ pk _) [KVal k] = + do group <- avGroup <||> getPrimGroup k <||> throwError ("no such object or avatar: " ++ k) + myGroup <- getPrimGroup pk <||> throwError ("can't find " ++ pk) + continueWith (IVal (if group == myGroup then 1 else 0)) + where avGroup = lift getWorldAvatars >>= mlookup k >>= return . avatarActiveGroup + +llGetLinkKey (ScriptInfo oid _ _ _ _) [IVal link] = do + do LSLObject { primKeys = pkeys } <- getObject oid + pk <- lookupByIndex (link - 1) pkeys + continueWith (KVal pk) + +-- TODO: should check for av/prim in same region +-- TODO: no concept of online/offline for av +llKey2Name info [KVal k] = lift $ + do avs <- getWorldAvatars + case M.lookup k avs of + Just av -> continueWith $ SVal (avatarName av) + _ -> do + prims <- getPrims + case M.lookup k prims of + Just prim -> continueWith $ SVal (primName prim) + Nothing -> continueWith (SVal "") +llOwnerSay info [SVal s] = + do lift $ logAMessage LogInfo (infoToLogSource info) ("Owner Say: " ++ s) + owner <- getPrimOwner (scriptInfoObjectKey info) + lift $ putWorldEvent 0 (AvatarInputEvent owner (AvatarOwnerSay (scriptInfoPrimKey info) s)) + continueWith VoidVal + +llGetGeometricCenter info@(ScriptInfo oid _ _ _ _) [] = + do LSLObject { primKeys = links } <- getObject oid + when (null links) $ throwError "error: empty linkset!" + rootPos <- getObjectPosition oid + foldM (\ v k -> getGlobalPos k >>= return . add3d v) (0,0,0) links + >>= continueWith . vec2VVal . scale3d (1 / fromIntegral (length links)) + +llGetMass info@(ScriptInfo oid _ _ _ _) [] = + objectMass oid >>= continueWith . FVal + +objectMass oid = do + LSLObject { primKeys = links } <- getObject oid + foldM (\ v k -> getPrim k >>= ( \ prim -> return $ v + primMassApprox prim)) 0.0 links + +llGetObjectMass info [KVal k] = + do avatars <- lift getWorldAvatars + val <- case M.lookup k avatars of + Just _ -> return 80.0 + Nothing -> objectMass k + continueWith (FVal val) + +llGetVel info@(ScriptInfo oid _ _ _ _) [] = + getObject oid >>= continueWith . vec2VVal . objectVelocity . objectDynamics + +llGetForce info@(ScriptInfo oid _ _ _ _) [] = + getObject oid >>= return . objectForce . objectDynamics >>= continueWith . vec2VVal . fst + +llSetForce info@(ScriptInfo oid _ _ _ _) [v@(VVal x y z), IVal local] = + do obj <- getObject oid + lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectForce = ((x,y,z), local /= 0) }}) + continueWith VoidVal + +llSetBuoyancy info@(ScriptInfo { scriptInfoObjectKey = oid }) [FVal buoy] = + do obj <- getObject oid + lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectBuoyancy = buoy }}) + continueWith VoidVal + +llApplyImpulse info@(ScriptInfo oid _ _ _ _) [v@(VVal x y z), IVal local] = + do t <- lift getTick + obj <- getObject oid + lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectImpulse = (((x,y,z), local /= 0), t + durationToTicks 1) } }) + continueWith VoidVal + +llGetAccel info@(ScriptInfo oid _ _ _ _) [] = + do prim <- getPrim oid + obj <- getObject oid + let dyn = objectDynamics obj + let force = fst (objectForce dyn) `rot3d` rotation + where rotation = if snd $ objectForce dyn then objectRotation dyn else (0,0,0,1) + let impulse = ((fst . fst . objectImpulse) dyn `rot3d` rotation, (snd . objectImpulse) dyn) + where rotation = if (snd . fst . objectImpulse) dyn then objectRotation dyn else (0,0,0,1) + t <- lift getTick + mass <- objectMass oid + pos <- getObjectPosition oid + continueWith $ vec2VVal $ calcAccel t 0 mass pos force impulse + +llSetTorque info@(ScriptInfo { scriptInfoObjectKey = oid }) [VVal x y z, IVal local] = + do obj <- getObject oid + lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectTorque = ((x,y,z),local /= 0) } }) + continueWith VoidVal + +llSetForceAndTorque info@(ScriptInfo { scriptInfoObjectKey = oid}) [VVal fx fy fz, VVal tx ty tz, IVal local] = + do obj <- getObject oid + let loc = local /= 0 + lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { + objectForce = ((fx,fy,fz),loc), objectTorque = ((tx,ty,tz),loc) } }) + continueWith VoidVal + +llGetTorque info@(ScriptInfo { scriptInfoObjectKey = oid }) [] = + getObject oid >>= continueWith . vec2VVal . fst . objectTorque . objectDynamics + +llGetOmega info@(ScriptInfo { scriptInfoObjectKey = oid }) [] = + getObject oid >>= continueWith . vec2VVal . objectOmega . objectDynamics + +llApplyRotationalImpulse info@(ScriptInfo { scriptInfoObjectKey = oid }) [VVal x y z, IVal local] = + do obj <- getObject oid + t <- lift getTick + lift $ setObject oid (obj { + objectDynamics = (objectDynamics obj) { objectRotationalImpulse = (((x,y,z),local /= 0), t + durationToTicks 1) } }) + continueWith VoidVal + +llGetPos info@(ScriptInfo _ _ _ pk _) [] = getGlobalPos pk >>= continueWith . vec2VVal +llGetRootPosition info@(ScriptInfo oid _ _ _ _) [] = getObjectPosition oid >>= continueWith . vec2VVal + +getGlobalPos pk = do + oid <- getRootPrim pk + root <- getObjectPosition oid + rel <- getPrimPosition pk + rot <- getObjectRotation oid + return (root `add3d` (rot3d rel rot)) + +getGlobalRot pk = do + oid <- getRootPrim pk + rot0 <- getObjectRotation oid + rot <- getPrimRotation pk + return (rot `quaternionMultiply` rot0) + +llRotLookAt info@(ScriptInfo oid _ _ _ _) [RVal x y z s, FVal strength, FVal tau] = + rotLookAt oid (x,y,z,s) strength tau >> continueWith VoidVal + +llLookAt info@(ScriptInfo oid _ _ _ _) [VVal x y z, FVal strength, FVal tau] = + do pos <- getObjectPosition oid + rot <- getGlobalRot oid + let v = diff3d (x,y,z) pos + let rot1 = rot `quaternionMultiply` (rotationBetween (rot3d (0,0,1) rot) v) + rotLookAt oid rot1 strength tau + continueWith VoidVal + +rotLookAt oid (x,y,z,s) strength tau = do + obj <- getObject oid + lift $ setObject oid $ obj { objectDynamics = (objectDynamics obj) { objectRotationTarget = + Just (RotationTarget { + rotationTarget = (x,y,z,s), + rotationTargetStrength = strength, + rotationTargetTau = tau } ) }} + +llStopLookAt info@(ScriptInfo oid _ _ _ _) [] = + do obj <- getObject oid + lift $ setObject oid $ obj { objectDynamics = (objectDynamics obj) { objectRotationTarget = Nothing }} + continueWith VoidVal + +llGetLocalPos info@(ScriptInfo oid _ _ pk _) [] = + getLocalPos pk >>= continueWith . vec2VVal + +getLocalPos k = getPrimPosition k + +llMoveToTarget info@(ScriptInfo { scriptInfoObjectKey = oid, scriptInfoScriptName = sn, scriptInfoPrimKey = pk }) [VVal x y z, FVal tau] = + do obj <- getObject oid + let action = setTarg obj + case objectPositionTarget (objectDynamics obj) of + Nothing -> action + Just (PositionTarget { positionTargetSetBy = scriptId }) + | scriptId == (pk,sn) -> action + | otherwise -> lift $ logAMessage LogInfo "llMoveToTarget" ("target already set by another script: " ++ show scriptId) + Just _ -> action + continueWith VoidVal + where setTarg obj = lift $ setObject oid obj' + where targ = PositionTarget { positionTargetTau = tau, + positionTargetLocation = (x,y,z), + positionTargetSetBy = (pk,sn) } + obj' = obj { objectDynamics = (objectDynamics obj) { objectPositionTarget = Just targ } } + +llStopMoveToTarget info@(ScriptInfo { scriptInfoObjectKey = oid, scriptInfoScriptName = sn, scriptInfoPrimKey = pk }) [] = + do obj <- getObject oid + case objectPositionTarget $ objectDynamics obj of + Just (PositionTarget {}) -> lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectPositionTarget = Nothing }}) + _ -> return () + continueWith VoidVal + +llGroundRepel info@(ScriptInfo { scriptInfoObjectKey = oid }) [FVal height, IVal water, FVal tau] = + do obj <- getObject oid + lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { + objectPositionTarget = Just $ Repel { + positionTargetTau = tau, + positionTargetOverWater = water /= 0, + positionTargetHeight = height } } }) + continueWith VoidVal + +llSetHoverHeight info@(ScriptInfo { scriptInfoObjectKey = oid }) [FVal height, IVal water, FVal tau] = + do obj <- getObject oid + lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { + objectPositionTarget = Just $ Hover { + positionTargetTau = tau, + positionTargetOverWater = water /= 0, + positionTargetHeight = height } } }) + continueWith VoidVal + +llStopHover info@(ScriptInfo { scriptInfoObjectKey = oid }) [] = + do obj <- getObject oid + case objectPositionTarget $ objectDynamics obj of + Just (Hover {}) -> lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectPositionTarget = Nothing }}) + _ -> lift $ logAMessage LogWarn "llStopHover" "not hovering" + continueWith VoidVal + +llGetAlpha (ScriptInfo _ _ _ pkey _) [IVal side] = + computeAlpha >>= continueWith + where computeAlpha = if (side /= -1) + then runFace pkey side $ (getPrimFaceAlpha pkey side >>= return . FVal) + else runFace pkey side $ do + faces <- getPrimFaces pkey + let n = length faces + let alpha = if n > 0 then sum (map faceAlpha faces) / (fromInt $ length faces) + else 1.0 + return $ FVal alpha + +llSetAlpha (ScriptInfo _ _ _ pkey _) [FVal alpha, IVal face] = lift $ setAlpha alpha face pkey + +setAlpha alpha face pkey = + if face == -1 + then runErrFace pkey face (EvalIncomplete,VoidVal) $ do + faces <- getPrimFaces pkey + let faces' = map (\ face -> face { faceAlpha = alpha }) faces + lift $ setPrimFaces pkey faces' + continueWith VoidVal + else setPrimFaceAlpha pkey face alpha >> continueWith VoidVal + +llSetLinkAlpha (ScriptInfo oid pid _ _ _) [IVal link, FVal alpha, IVal face] = do + pks <- lift $ getTargetPrimKeys oid link pid + lift $ mapM_ (setAlpha alpha face) pks + continueWith VoidVal + +getTargetPrimKeys oid link pid = do + LSLObject { primKeys = prims } <- runAndLogIfErr ("can't find object " ++ oid) (LSLObject [] defaultDynamics) $ getObject oid + let targetList = targetLinks (length prims) link pid + mapM (flip lookupByIndex prims) targetList + +llGetColor (ScriptInfo _ _ _ pkey _) [IVal side] = + computeColor >>= continueWith + where computeColor = if (side /= -1) + then runFace pkey side $ (getPrimFaceColor pkey side >>= return . vec2VVal) + else runFace pkey side $ do + faces <- getPrimFaces pkey + let n = length faces + let color = if n > 0 then scale3d (1.0/ (fromInt $ length faces) ) + (foldr add3d (0.0,0.0,0.0) (map faceColor faces)) + else (1.0,1.0,1.0) + return $ vec2VVal color + +llSetColor (ScriptInfo _ _ _ pkey _) [color, IVal face] = setColor color face pkey + +setColor color face pkey = + if face == -1 + then runFace pkey face $ do + faces <- getPrimFaces pkey + let colorVal = vVal2Vec color + let faces' = map (\ face -> face { faceColor = colorVal }) faces + lift $ setPrimFaces pkey faces' + continueWith VoidVal + else lift $ setPrimFaceColor pkey face (vVal2Vec color) >> continueWith VoidVal + +llSetLinkColor (ScriptInfo oid pid _ _ _) [IVal link, color, IVal face] = do + pks <- lift $ getTargetPrimKeys oid link pid + mapM (setColor color face) pks + continueWith VoidVal + +llGetTextureOffset (ScriptInfo _ _ _ pkey _) [IVal face] = + let face' = if face == -1 then 0 else face in + runFace pkey face (getPrimFaceTextureInfo pkey face' >>= return . textureOffsets) >>= continueWith . vec2VVal +llGetTextureScale (ScriptInfo _ _ _ pkey _) [IVal face] = + let face' = if face == -1 then 0 else face in + runFace pkey face (getPrimFaceTextureInfo pkey face' >>= return . textureRepeats) >>= continueWith . vec2VVal +llGetTextureRot (ScriptInfo _ _ _ pkey _) [IVal face] = + let face' = if face == -1 then 0 else face in + runFace pkey face (getPrimFaceTextureInfo pkey face' >>= return . textureRotation) >>= continueWith . FVal + +llSetTexture info@(ScriptInfo _ _ _ pk _) [SVal texture,IVal face] = + do tk <- findTexture pk texture + setTexture tk face pk + continueWith VoidVal + +-- TODO: worry about texture permissions +llGetTexture (ScriptInfo _ _ _ pkey _) [IVal face] = + let face' = if face == -1 then 0 else face in + runFace pkey face (do + info <- getPrimFaceTextureInfo pkey face' + invTextures <- getPrimTextures pkey + let tKey = textureKey info + case findByInvKey tKey invTextures of + Nothing -> return tKey + Just item -> return $ invName item) >>= continueWith . SVal + +llSetLinkTexture info@(ScriptInfo oid pid _ pk _) [IVal link, SVal texture,IVal face] = do + pks <- lift $ getTargetPrimKeys oid link pid + tk <- findTexture pk texture + mapM_ (setTexture tk face) pks + continueWith VoidVal + +findTexture pk id = + do textures <- getPrimTextures pk + case findByInvName id textures of + Just item -> return $ snd $ inventoryItemNameKey $ inventoryItemIdentification item + Nothing -> do + result <- return $ findTextureAsset id + case result of + Nothing -> throwError ("cannot find texture " ++ id) + Just item -> return $ snd $ inventoryItemNameKey $ inventoryItemIdentification item + +setTexture tk face pkey = do + if face == -1 + then do faces <- getPrimFaces pkey + let faces' = map (\ face -> + let info = faceTextureInfo face in + face { faceTextureInfo = info { textureKey = tk } }) faces + lift $ setPrimFaces pkey faces' + else do faces <- getPrimFaces pkey + f <- lookupByIndex face faces + let tInfo = faceTextureInfo f + updatePrimFace pkey face (\ f -> f { faceTextureInfo = tInfo { textureKey = tk } }) + +updateTextureInfo update pk faceIndex = + runFace pk faceIndex ( + if faceIndex == -1 + then do + faces <- getPrimFaces pk + let faces' = map (\ face -> + let info = faceTextureInfo face in + face { faceTextureInfo = update info }) faces + lift $ setPrimFaces pk faces' + else do + f <- getPrimFaces pk >>= lookupByIndex faceIndex + let tInfo = update $ faceTextureInfo f + updatePrimFace pk faceIndex (\ f -> f { faceTextureInfo = tInfo }) + ) >> continueWith VoidVal + +llScaleTexture info@(ScriptInfo _ _ _ pk _) [FVal h,FVal v,IVal faceIndex] = + updateTextureInfo update pk faceIndex where update info = info { textureRepeats = (h,v,0) } +llOffsetTexture (ScriptInfo _ _ _ pk _) [FVal h, FVal v, IVal faceIndex] = + updateTextureInfo update pk faceIndex where update info = info { textureOffsets = (h,v,0) } +llRotateTexture (ScriptInfo _ _ _ pk _) [FVal rot, IVal faceIndex] = + updateTextureInfo update pk faceIndex where update info = info { textureRotation = rot } + +getPos pkey = runErrPrim pkey + (VVal 0.0 0.0 0.0) + (getRootPrim pkey >>= getObjectPosition >>= return . vec2VVal) + +getRegionIndex pkey = return (0,0) + +groupList _ [] = [] +groupList n l | n > 0 = take n l : groupList n (drop n l) + | otherwise = groupList 1 l + +genNum :: [Int] -> Integer -> Integer +genNum rands maxval = + let rands' :: [Integer] + rands' = map ((0x80000000-).toInteger) rands + topval :: Rational + topval = fromInteger $ + foldl' (.|.) 0 $ zipWith (shiftL) (replicate (length rands') 0xffffffff) [0,32..] + randval :: Rational + randval = fromInteger $ foldl' (.|.) 0 $ zipWith (shiftL) rands' [0,32] + in floor ((randval / topval) * (fromInteger maxval)) + + +llListRandomize _ [LVal list, IVal stride] = + let l1 = groupList stride list + n = fac (toInteger $ length l1) + randsNeeded = ceiling $ (logBase 2 (fromInteger n)) / 32 + wrands = replicate randsNeeded wrand + in lift $ do + rands <- sequence wrands + let permutation = genNum rands n + let list' = generatePermutation list permutation + continueWith $ LVal list' + +llGetNumberOfPrims (ScriptInfo oid _ _ pkey _) [] = + do (LSLObject { primKeys = prims }) <- getObject oid + continueWith $ IVal (length prims) + +llGetObjectPrimCount info@(ScriptInfo oid _ _ pkey _) [KVal k] = + do + region <- getPrimRegion oid + p <- getPrim k + region' <- getPrimRegion k + if region /= region' + then continueWith (IVal 0) + else getRootPrim k >>= primCount >>= continueWith . IVal + where primCount oid = do + (LSLObject { primKeys = l}) <- getObject oid + return $ length l + +llGetNumberOfSides (ScriptInfo _ _ _ pkey _) [] = + getPrimFaces pkey >>= continueWith . IVal . length + +llGetObjectDesc (ScriptInfo _ _ _ pkey _) [] = + getPrimDescription pkey >>= continueWith . SVal +llGetObjectName (ScriptInfo _ _ _ pkey _) [] = + getPrimName pkey >>= continueWith . SVal + +llSetObjectName (ScriptInfo _ _ _ pkey _) [SVal name] = + lift $ setPrimName pkey (take 255 name) >> continueWith VoidVal + +llSetObjectDesc (ScriptInfo _ _ _ pkey _) [SVal desc] = + lift $ setPrimDescription pkey (take 127 desc) >> continueWith VoidVal + +llGetObjectPermMask (ScriptInfo oid _ _ _ _) [IVal maskId] = + getObjectPermMask oid maskId >>= continueWith . IVal + +getObjectPermMask oid maskId = do + masks <- getPrimPermissions oid + let base = if null masks then 0x0008e000 else masks !! 0 + let n = length masks + return (if maskId `elem` [0..(n-1)] then masks !! maskId else + if maskId == 3 then 0 else base) + +llGetScale (ScriptInfo _ _ _ pkey _) [] = getPrimScale pkey >>= continueWith . vec2VVal + +llSetScale (ScriptInfo _ _ _ pk _) [scale] = + if tooSmall then continueWith VoidVal else lift $ setPrimScale pk clippedVec >> continueWith VoidVal + where (x,y,z) = vVal2Vec scale + tooSmall = (x < 0.01 || y < 0.01 || z < 0.01) + clippedVec = (min x 10.0, min y 10.0, min z 10.0) + +llGetBoundingBox info [KVal k] = + do lift $ logAMessage LogInfo "sim" "note: llGetBoundingBox does not return accurate results (yet)" + avatars <- lift getWorldAvatars + case M.lookup k avatars of + Just avatar -> let pos = avatarPosition avatar in + continueWith (LVal $ map (vec2VVal . (add3d pos)) [(-1.0,-1.0,-1.0),(1.0,1.0,1.0)]) + Nothing -> getRootPrim k >>= getPrimBox >>= continueWith . LVal . map vec2VVal . tup2l + where tup2l (x,y) = [x,y] + +getPrimBox pk = do + pos <- getGlobalPos pk + scale <- getPrimScale pk + let (xs,ys,zs) = scale3d 0.5 scale + return (add3d pos (-xs, -ys, -zs),add3d pos (xs,ys,zs)) + +-- this is extremely approximate.... +objRadius oid = do + LSLObject { primKeys = keys } <- getObject oid + foldM f 0 keys + where f r k = do + (x,y,z) <- getPrimPosition k + (sx,sy,sz) <- getPrimScale k + let (rx,ry,rz) = (sx / 2 + abs x, sy / 2 + abs y, sz / 2 + abs z) + return $ maximum [r,rx,ry,rz] + +llSetTimerEvent (ScriptInfo _ _ sn pk _) [FVal interval] = + -- TODO: this may not accurately reflect buggy behavior in SL + do lift $ removePendingTimerEvent pk sn + when (interval > 0) $ lift $ putWorldEvent interval (TimerEvent interval (pk,sn)) + continueWith VoidVal + where removePendingTimerEvent pk sn = do + wq <- getWQueue + let wq' = flip filter wq $ \ e -> case e of + (_,TimerEvent _ (pk',sn')) -> pk /= pk' || sn /= sn' + _ -> True + setWQueue wq' + +llSetVehicleFlags info@(ScriptInfo _ _ _ pk _) [IVal flagsToSet] = + do flags <- getPrimVehicleFlags pk `catchError` primErr pk + lift $ setPrimVehicleFlags pk (flags .|. flagsToSet) + continueWith VoidVal + +llRemoveVehicleFlags info@(ScriptInfo _ _ _ pk _) [IVal flagsToClear] = + do flags <- getPrimVehicleFlags pk `catchError` primErr pk + lift $ setPrimVehicleFlags pk (flags .&. complement flagsToClear) + continueWith VoidVal + +---------------------------------------------------------------------- +-- get/set prim parameters +llGetPrimitiveParams (ScriptInfo _ _ _ pk _) [LVal l] = getPrimParameters pk l >>= continueWith . LVal +llSetPrimitiveParams (ScriptInfo _ _ _ pk _) [LVal l] = setPrimParameters pk l >> continueWith VoidVal + +llSetLinkPrimitiveParams (ScriptInfo oid pid _ _ _) [IVal link,LVal l] = do + do LSLObject { primKeys = pks } <- getObject oid + let targetList = targetLinks (length pks) link pid + pkList <- mapM (flip lookupByIndex pks) targetList + mapM_ (flip setPrimParameters l) pkList + continueWith VoidVal + +getPrimParameters pk params = + case params of + [] -> return [] + (x:xs) | x `elem` [llcPrimBumpShiny,llcPrimFullbright,llcPrimColor,llcPrimTexture,llcPrimTexgen] && null xs -> return [] + | x == llcPrimBumpShiny -> queryAndDoRest (queryPrimBumpShiny $ head xs) (tail xs) + | x == llcPrimColor -> queryAndDoRest (queryPrimColor $ head xs) (tail xs) + | x == llcPrimTexture -> queryAndDoRest (queryPrimTexture $ head xs) (tail xs) + | x == llcPrimTexgen -> queryAndDoRest (queryPrimTexgen $ head xs) (tail xs) + | x == llcPrimFullbright -> queryAndDoRest (queryPrimFullbright $ head xs) (tail xs) + | x == llcPrimMaterial -> queryAndDoRest queryPrimMaterial xs + | x == llcPrimPhantom -> queryAndDoRest (queryPrimStatus primPhantomBit) xs + | x == llcPrimPhysics -> queryAndDoRest (queryPrimStatus primPhysicsBit) xs + | x == llcPrimFlexible -> queryAndDoRest queryPrimFlexible xs + | x == llcPrimPointLight -> queryAndDoRest queryPrimLight xs + | x == llcPrimPosition -> queryAndDoRest queryPrimPosition xs + | x == llcPrimRotation -> queryAndDoRest queryPrimRotation xs + | x == llcPrimSize -> queryAndDoRest queryPrimScale xs + | x == llcPrimTempOnRez -> queryAndDoRest queryPrimTempOnRez xs + | x == llcPrimType -> queryAndDoRest queryPrimType xs + | x == IVal 1 -> queryAndDoRest queryPrimTypeOldSkool xs + | otherwise -> getPrimParameters pk xs + where queryAndDoRest q rest = liftM2 (++) (q pk) (getPrimParameters pk rest) + +queryPrimTempOnRez k = getPrimTempOnRez k >>= return . return . IVal . (\ b -> if b then 1 else 0) +queryPrimRotation k = getGlobalRot k >>= return . return . rot2RVal +queryPrimPosition k = getGlobalPos k >>= return . return . vec2VVal +queryPrimScale k = getPrimScale k >>= return . return . vec2VVal +queryPrimFlexible k = + getPrimFlexibility k >>= (\ flex -> case flex of + Nothing -> return [IVal 0, IVal 0, FVal 0, FVal 0, FVal 0, FVal 0, VVal 0.0 0.0 0.0] + Just flex' -> return $ map ($ flex') [const (IVal 1),IVal . flexSoftness, FVal . flexGravity, FVal . flexFriction, + FVal . flexWind, FVal . flexTension, vec2VVal . flexForce]) +queryPrimLight k = + getPrimLight k >>= (\ light -> case light of + Nothing -> return [IVal 0, VVal 0 0 0, FVal 0, FVal 0, FVal 0] + Just light' -> return $ map ($ light') [const (IVal 1), vec2VVal . lightColor, FVal . lightIntensity, FVal . lightRadius, FVal . lightFalloff]) + +queryPrimMaterial k = getPrimMaterial k >>= return . return . IVal +queryPrimStatus bit k = getPrimStatus k >>= return . return . IVal . (\ i -> if testBit i bit then 1 else 0) +queryPrimBumpShiny side = queryFaceVals bumpShiny side + where bumpShiny face = [IVal $ faceShininess face, IVal $ faceBumpiness face] +queryPrimColor side = queryFaceVals colorAlpha side + where colorAlpha face = [vec2VVal $ faceColor face, FVal $ faceAlpha face] +queryPrimTexture side = queryFaceVals textureInfo side + where textureInfo face = let tinfo = faceTextureInfo face in map ($ tinfo) + [SVal .textureKey,vec2VVal . textureRepeats,vec2VVal . textureOffsets,FVal . textureRotation] +queryPrimTexgen side = queryFaceVals (return . IVal . faceTextureMode) side +queryPrimFullbright side = queryFaceVals (\ face -> if faceFullbright face then [IVal 1] else [IVal 0]) side + +queryFaceVals f (IVal side) k = + if side == -1 + then getPrimFaces k >>= return . concat . (map f) + else getPrimFaces k >>= fromErrorT [] . (\ faces -> (lookupByIndex side faces >>= return . f)) + +-- TODO: get these out of here +Just (Constant _ llcObjectUnknownDetail) = findConstant "OBJECT_UNKNOWN_DETAIL" +Just (Constant _ llcObjectName) = findConstant "OBJECT_NAME" +Just (Constant _ llcObjectDesc) = findConstant "OBJECT_DESC" +Just (Constant _ llcObjectPos) = findConstant "OBJECT_POS" +Just (Constant _ llcObjectRot) = findConstant "OBJECT_ROT" +Just (Constant _ llcObjectVelocity) = findConstant "OBJECT_VELOCITY" +Just (Constant _ llcObjectOwner) = findConstant "OBJECT_OWNER" +Just (Constant _ llcObjectGroup) = findConstant "OBJECT_GROUP" +Just (Constant _ llcObjectCreator) = findConstant "OBJECT_CREATOR" + +queryPrimType k = do + (PrimType version typecode holeshape cut twist holesize topshear hollow taper advancedcut roffset revs skew sculpt sculptType) <- + getPrimTypeInfo k + case typecode of + i | (IVal i) `elem` [llcPrimTypeBox,llcPrimTypeCylinder,llcPrimTypePrism] -> + return [IVal i,IVal holeshape, vec2VVal cut, FVal hollow, vec2VVal twist, vec2VVal taper, vec2VVal topshear] + | (IVal i) == llcPrimTypeSphere -> return [IVal i,IVal holeshape, vec2VVal cut, FVal hollow, vec2VVal twist, vec2VVal advancedcut] + | (IVal i) `elem` [llcPrimTypeRing,llcPrimTypeTorus,llcPrimTypeTube] -> + return [IVal i,IVal holeshape, vec2VVal cut, FVal hollow, vec2VVal twist, vec2VVal holesize, vec2VVal topshear, + vec2VVal advancedcut, vec2VVal taper, FVal revs, FVal roffset, FVal skew] + | (IVal i) == llcPrimTypeSculpt -> return [IVal i,SVal $ fromMaybe "" sculpt, IVal sculptType] + | otherwise -> return [] + +queryPrimTypeOldSkool k = do + (PrimType version typecode holeshape cut twist holesize topshear hollow taper advancedcut roffset revs skew sculpt sculptType) <- + getPrimTypeInfo k + case typecode of + i | (IVal i) `elem` [llcPrimTypeBox,llcPrimTypeCylinder,llcPrimTypePrism] -> + return [IVal i, vec2VVal cut, FVal hollow, FVal $ yOf twist, vec2VVal taper, vec2VVal topshear] + | (IVal i) == llcPrimTypeSphere -> return [IVal i,vec2VVal cut, FVal hollow,vec2VVal advancedcut] + | (IVal i) == llcPrimTypeTorus -> + return [IVal i, vec2VVal cut, FVal hollow, FVal $ yOf twist, FVal $ yOf taper, vec2VVal topshear, vec2VVal advancedcut] + | (IVal i) == llcPrimTypeTube -> + return [IVal i, vec2VVal cut, FVal hollow, FVal $ yOf twist, FVal $ xOf topshear] + | otherwise -> return [] + where xOf (x,y,z) = x + yOf (x,y,z) = y + +setPrimParameters pk params = updatePrimParameters pk params >> return () + +updatePrimParameters pk [] = return [] +updatePrimParameters pk (code:rest) = do + result <- case code of + i | i == llcPrimTempOnRez -> updatePrimTempOnRez pk rest + | i == llcPrimMaterial -> updatePrimMaterial pk rest + | i == llcPrimPhantom -> updatePrimPhantom pk rest + | i == llcPrimPhysics -> updatePrimPhysics pk rest + | i == llcPrimPosition -> updatePrimPosition pk rest + | i == llcPrimRotation -> updatePrimRotation pk rest + | i == llcPrimSize -> updatePrimScale pk rest + | i == llcPrimFlexible -> updatePrimFlexible pk rest + | i == llcPrimPointLight -> updatePrimLight pk rest + | i == llcPrimBumpShiny -> updatePrimBumpShiny pk rest + | i == llcPrimColor -> updatePrimColor pk rest + | i == llcPrimTexture -> updatePrimTexture pk rest + | i == llcPrimTexgen -> updatePrimTexgen pk rest + | i == llcPrimFullbright -> updatePrimFullbright pk rest + | i == llcPrimType -> updatePrimType pk rest + | i == IVal 1 -> updatePrimTypeOldSkool pk rest + | otherwise -> fail "incorrect parameter" + updatePrimParameters pk result + +updatePrimType pk vals = getPrim pk >>= flip updatePrimType' vals >>= (\ (prim,rest) -> (lift $ setPrim pk prim) >> return rest) +updatePrimType' prim (primCode@(IVal i):rest) | primCode == llcPrimTypeSphere = updatePrimTypeSphere prim rest + | primCode `elem` [llcPrimTypeBox,llcPrimTypeCylinder,llcPrimTypePrism] = + updatePrimTypeBoxCylPrism i prim rest + | primCode `elem` [llcPrimTypeTorus,llcPrimTypeTube,llcPrimTypeRing] = + updatePrimTypeRingTorusTube i prim rest + | primCode == llcPrimTypeSculpt = updatePrimTypeSculpt prim rest + | otherwise = fail "incorrect parameters for PRIM_TYPE" +updatePrimType' _ _ = fail "insufficient or incorrect parameters for PRIM_TYPE" + +updatePrimTypeOldSkool pk vals = getPrim pk >>= flip updatePrimTypeOldSkool' vals >>= (\ (prim,rest) -> (lift $ setPrim pk prim) >> return rest) +updatePrimTypeOldSkool' prim (primCode@(IVal i):rest) | primCode == llcPrimTypeSphere = updatePrimTypeSphereOld prim rest + | primCode `elem` [llcPrimTypeBox,llcPrimTypeCylinder,llcPrimTypePrism] = + updatePrimTypeBoxCylPrismOld i prim rest + | primCode == llcPrimTypeTorus = updatePrimTypeTorusOld prim rest + | primCode == llcPrimTypeTube = updatePrimTypeTubeOld prim rest + | otherwise = fail "incorrect parameters for deprecated prim type" +updatePrimTypeOldSkool' _ _ = fail "insufficient or incorrect parameters for deprecated prim type" + +--updatePrimTempOnRez prim (IVal tempOnRez:rest) = return (prim { primTempOnRez = if tempOnRez /= 0 then True else False }, rest) +updatePrimTempOnRez pk (IVal tempOnRez:rest) = lift (setPrimTempOnRez pk (tempOnRez /= 0)) >> return rest +updatePrimTempOnRez _ _ = fail "insufficient or incorrect parameters for PRIM_TEMP_ON_REZ" + +--updatePrimMaterial prim (IVal material:rest) = return (prim { primMaterial = material }, rest) +updatePrimMaterial pk (IVal material:rest) = lift (setPrimMaterial pk material) >> return rest +updatePrimMaterial _ _ = fail "insufficient or incorrect parameters for PRIM_MATERIAL" + +updatePrimPhantom pk params = updatePrimStatus "insufficient or incorrect parameters for PRIM_PHANTOM" primPhantomBit pk params +updatePrimPhysics pk params = updatePrimStatus "insufficient or incorrect parameters for PRIM_PHYSICS" primPhysicsBit pk params + +-- updatePrimStatus _ bit prim (IVal i:rest) = return (prim { primStatus = if i == 0 then clearBit (primStatus prim) bit +-- else setBit (primStatus prim) bit }, rest) +updatePrimStatus _ bit pk (IVal i:rest) = (getPrimStatus pk) >>= lift . (setPrimStatus pk) . (if i == 0 then flip clearBit bit + else flip setBit bit) >> return rest +updatePrimStatus fMsg _ _ _ = fail fMsg + +updatePrimPosition pk (pos@(VVal _ _ _):rest) = + do getPrimParent pk >>= \ mok -> case mok of + Nothing -> setRootPos pk v + Just ok -> setChildPos pk v + return rest + where v = vVal2Vec pos +updatePrimPosition _ _ = fail "insufficient or incorrect parameters for PRIM_POSITION" + +updatePrimRotation pk (rot@(RVal _ _ _ _):rest) = + do getPrimParent pk >>= \ mok -> case mok of + Nothing -> setRootRotation pk r + Just rk -> setChildRotation rk pk r + return rest + where r = rVal2Rot rot +updatePrimRotation _ _ = fail "insufficient or incorrect parameters for PRIM_ROTATION" +updatePrimScale pk (scale@(VVal _ _ _):rest) = (lift $ setPrimScale pk (vVal2Vec scale)) >> return rest +updatePrimScale _ _ = fail "insufficient or incorrect parameters for PRIM_SIZE" + +updatePrimFlexible pk (IVal flex:IVal soft:FVal gravity:FVal friction:FVal wind:FVal tension:VVal fx fy fz:rest) = + lift (setPrimFlexibility pk (if flex == 0 then Nothing else Just (Flexibility soft gravity friction wind tension (fx,fy,fz)))) >> return rest +updatePrimFlexible _ _ = fail "insufficient or incorrect parameters for PRIM_FLEXIBLE" + +updatePrimLight pk (IVal light:VVal r g b:FVal intensity:FVal radius:FVal falloff:rest) = + lift (setPrimLight pk (if light == 0 then Nothing else Just (LightInfo (r,g,b) intensity radius falloff))) >> return rest +updatePrimLight _ _ = fail "insufficient or incorrect parameters for PRIM_POINT_LIGHT" + +updatePrimBumpShiny pk params = + let extract (IVal face:IVal bump:IVal shiny:rest) = return (face, [IVal bump, IVal shiny], rest) + extract _ = fail ("insufficient or incorrect parameters for PRIM_BUMP_SHINY") + update [IVal bump, IVal shiny] face = face { faceBumpiness = bump, faceShininess = shiny } + in updatePrimFaceParams pk params extract update +updatePrimColor pk params = + let extract (IVal face:VVal r g b:FVal alpha:rest) = return (face,[VVal r g b, FVal alpha], rest) + extract _ = fail ("insufficient or incorrect parameters for PRIM_COLOR") + update [color, FVal alpha] face = face { faceColor = vVal2Vec color, faceAlpha = alpha } + in updatePrimFaceParams pk params extract update +updatePrimTexture pk params = + let extract (IVal face:name@(SVal _):repeats@(VVal _ _ _):offsets@(VVal _ _ _):rotation@(FVal _):rest) = + return (face,[name,repeats,offsets,rotation],rest) + extract _ = fail ("insufficient or incorrect parameters for PRIM_TEXTURE") + update [SVal name,repeats,offsets,FVal rotation] face = + face { faceTextureInfo = TextureInfo name (vVal2Vec repeats) (vVal2Vec offsets) rotation } + in updatePrimFaceParams pk params extract update +updatePrimTexgen pk params = + let extract (IVal face:IVal mode:rest) = return (face,[IVal mode],rest) + extract _ = fail "insufficient or incorrect parameters for PRIM_TEXGEN" + update [IVal mode] face = face { faceTextureMode = mode } + in updatePrimFaceParams pk params extract update +updatePrimFullbright pk params = + let extract (IVal face:IVal fullbright:rest) = return (face,[IVal fullbright],rest) + extract _ = fail "insufficient or incorrect parameters for PRIM_FULLBRIGHT" + update [IVal fullbright] face = face { faceFullbright = if fullbright == 0 then False else True } + in updatePrimFaceParams pk params extract update + +updatePrimFaceParams pk params extract update = do + (face, faceParams, rest) <- extract params -- this can fail + prim <- getPrim pk + let prim' = if face == -1 + then prim { primFaces = map (update faceParams) $ primFaces prim } + else let (xs,ys) = splitAt face (primFaces prim) in + if null ys then prim else prim { primFaces = xs ++ [(update faceParams $ head ys)] ++ (tail ys) } + lift $ setPrim pk prim' + return rest + +updatePrimTypeBoxCylPrism ptype prim (IVal holeshape:VVal cx cy cz:FVal hollow:VVal twx twy twz:VVal tx ty tz:VVal sx sy sz:rest) = + return (prim { primTypeInfo = (primTypeInfo prim) { primTypeCode = ptype, primHoleshape = holeshape, primCut = (cx,cy,cz), + primHollow = hollow, primTwist = (twx,twy,twz), primTaper = (tx,ty,tz), + primTopshear = (sx,sy,sz) }}, rest) +updatePrimTypeBoxCylPrism _ _ _ = fail "insufficient or incorret parameters for PRIM_TYPE (PRIM_TYPE_PRISM, PRIM_TYPE_CYLINDER, or PRIM_TYPE_BOX)" +updatePrimTypeSphere prim (IVal holeshape:VVal cx cy cz:FVal hollow:VVal tx ty tz:VVal ax ay az:rest) = + return (prim { primTypeInfo = (primTypeInfo prim) { primTypeCode = cPrimTypeSphere, primHoleshape = holeshape, primCut = (cx,cy,cz), + primHollow = hollow, primTwist = (tx,ty,tz), primAdvancedCut = (ax,ay,az) } }, rest) +updatePrimTypeSphere _ _ = fail "insufficient or incorrect parameters for PRIM_TYPE (PRIM_TYPE_SPHERE)" +updatePrimTypeRingTorusTube ptype prim (IVal holeshape:VVal cx cy cz:FVal hollow:VVal twx twy twz:VVal hx hy hz:VVal sx sy sz: + VVal ax ay az:VVal tx ty tz:FVal revs:FVal roffset:FVal skew:rest) = + return (prim { primTypeInfo = (primTypeInfo prim) { primTypeCode = ptype, primHoleshape = holeshape, primCut = (cx,cy,cz), + primHollow = hollow, primTwist = (twx,twy,twz), primHolesize = (hx,hy,hz), + primTopshear = (sx,sy,sz), primAdvancedCut = (ax,ay,az), primTaper = (tx,ty,tz), + primRevolutions = revs, primRadiusOffset = roffset, primSkew = skew } }, rest) +updatePrimTypeRingTorusTube _ _ _ = fail "insufficient or incorrect parameters for PRIM_TYPE (PRIM_TYPE_RING, PRIM_TYPE_TORUS, or PRIM_TYPE_TUBE)" +updatePrimTypeSculpt prim (SVal name:IVal sculptType:rest) = + return (prim { primTypeInfo = (primTypeInfo prim) { primTypeCode = cPrimTypeSculpt, primSculptTexture = Just name, primSculptType = sculptType } }, rest) +updatePrimTypeSculpt _ _ = fail "insufficient or incorrect parameters for PRIM_TYPE (PRIM_TYPE_SCULPT)" + +updatePrimTypeBoxCylPrismOld ptype prim (VVal cx cy cz:FVal hollow:FVal twisty:VVal tx ty tz:VVal sx sy sz:rest) = + let info = primTypeInfo prim in + return (prim { primTypeInfo = info { primTypeCode = ptype, primCut = (cx,cy,cz), primHollow = hollow, + primTwist = let (x,_,z) = primTwist info in (x,twisty,z), primTaper = (tx,ty,tz), + primTopshear = (sx,sy,sz) } }, rest) +updatePrimTypeBoxCylPrismOld _ _ _ = fail "insufficient or inccorrect parameters for deprecated prim type (PRIM_TYPE_BOX, PRIM_TYPE_CYLINDER, or PRIM_TYPE_PRISM)" + +updatePrimTypeSphereOld prim (VVal cx cy cz:FVal hollow:VVal ax ay az:rest) = + return (prim { primTypeInfo = (primTypeInfo prim) { primTypeCode = cPrimTypeSphere, primCut = (cx,cy,cz), primHollow = hollow, + primAdvancedCut = (ax,ay,az) }}, rest) +updatePrimTypeSphereOld _ _ = fail "insufficient or incorrect parameters for deprecated prim type (PRIM_TYPE_SPHERE)" + +updatePrimTypeTorusOld prim (VVal cx cy cz:FVal hollow:FVal twisty:FVal tapery:VVal sx sy sz:VVal ax ay az:rest) = + let info = primTypeInfo prim in + return (prim { primTypeInfo = info { primTypeCode = cPrimTypeTorus, primCut = (cx,cy,cz), primHollow = hollow, + primTwist = let (x,_,z) = primTwist info in (x,twisty,z), + primTaper = let (x,_,z) = primTaper info in (x,tapery,z), + primTopshear = (sx,sy,sz), primAdvancedCut = (ax,ay,az) } }, rest) +updatePrimTypeTorusOld _ _ = fail "insufficient or incorrect parameters for deprecated prim type (PRIM_TYPE_TORUS)" + +updatePrimTypeTubeOld prim (VVal cx cy cz:FVal hollow:FVal twisty:FVal shearx:rest) = + let info = primTypeInfo prim in + return (prim { primTypeInfo = info { primTypeCode = cPrimTypeTube, primCut = (cx,cy,cz), primHollow = hollow, + primTwist = let (x,_,z) = primTwist info in (x,twisty,z), + primTopshear = let (_,y,z) = primTopshear info in (shearx,y,z) } }, rest) +updatePrimTypeTubeOld _ _ = fail "insufficient or incorrect parameters for deprecated prim type (PRIM_TYPE_TUBE)" + +llGetObjectDetails _ [KVal k, LVal params] = + -- TODO: this doesn't take into account multiple regions + do (getAvatarDetails k params <||> getPrimDetails k params) >>= continueWith . LVal + where getAvatarDetails k params = + do avs <- lift getWorldAvatars + av <- mlookup k avs + return $ map (avq av) params + where avq av i | i == llcObjectName = SVal $ avatarName av + | i == llcObjectDesc = SVal "" + | i == llcObjectPos = vec2VVal $ avatarPosition av + | i == llcObjectRot = rot2RVal $ avatarRotation av + | i == llcObjectVelocity = VVal 0.0 0.0 0.0 -- TODO: avatar velocities + | i == llcObjectOwner = KVal k + | i == llcObjectGroup = KVal nullKey + | i == llcObjectCreator = KVal nullKey + | otherwise = llcObjectUnknownDetail + getPrimDetails k params = + do prim <- getPrim k + pos <- getObjectPosition k + rot <- getObjectRotation k + vel <- getObject k >>= return . objectVelocity . objectDynamics + return $ map (primq prim pos rot vel) params + where primq prim pos rot vel i | i == llcObjectName = SVal $ primName prim + | i == llcObjectDesc = SVal $ primDescription prim + | i == llcObjectPos = vec2VVal $ pos + | i == llcObjectRot = rot2RVal $ rot + | i == llcObjectVelocity = vec2VVal $ vel + | i == llcObjectOwner = KVal $ primOwner prim + | i == llcObjectGroup = KVal nullKey -- TODO: prim groups + | i == llcObjectCreator = KVal $ primOwner prim -- TODO: prim creators + | otherwise = llcObjectUnknownDetail + +-------------------------------------------------------------------------------------------------------------- +llAllowInventoryDrop info@(ScriptInfo _ _ _ k _) [IVal add] = + (getPrim k >>= return . (\ p -> p { primAllowInventoryDrop = add /= 0 }) >>= lift . setPrim k >> + lift (logFromScript info ("drop is now " ++ (if add == 0 then "not " else "") ++ "allowed"))) >> + continueWith VoidVal + +llAdjustSoundVolume info [FVal f] = lift $ do + do if (f < 0.0 || f > 1.0) then logFromScript info ("llAdjustSoundVolume: volume " ++ show f ++ " out of range.") + else logFromScript info ("llAdjustSoundVolume: volume adjusted to " ++ show f) + continueWith VoidVal +----------------------------------------------------------------------------------------------------------------- +-- Parcel related functions + +llSetParcelMusicURL info@(ScriptInfo _ _ _ pk _) [SVal url] = + -- parcel music URL is a write-only value, so we won't worry about setting anything.... + do -- make sure object owner == parcel owner + (_,_,parcel) <- getPrimParcel pk + owner <- getPrimOwner pk + when (parcelOwner parcel /= owner) $ throwError ("prim doesn't have permission to modify parcel") + lift $ logFromScript info ("setting music url for parcel " ++ parcelName parcel ++ " to " ++ url) + continueWith VoidVal + +llGetParcelFlags info@(ScriptInfo _ _ _ pk _) [VVal x y z] = + do regionIndex <- getPrimRegion pk + (_,parcel) <- getParcelByPosition regionIndex (x,y,z) + continueWith $ IVal $ parcelFlags parcel + +llGetParcelDetails info@(ScriptInfo _ _ _ pk _) [VVal x y z, LVal details] = + do regionIndex <- getPrimRegion pk + (_,parcel) <- getParcelByPosition regionIndex (x,y,z) + detailList <- mapM (getDetail parcel) details + continueWith $ LVal [ d | Just d <- detailList] + where getDetail parcel (IVal detail) | detail == cParcelDetailsName = return $ Just $ SVal $ parcelName parcel + | detail == cParcelDetailsDesc = return $ Just $ SVal $ parcelDescription parcel + | detail == cParcelDetailsOwner = return $ Just $ KVal $ parcelOwner parcel + | detail == cParcelDetailsGroup = return $ Just $ KVal nullKey + | detail == cParcelDetailsArea = return $ Just $ FVal $ fromIntegral $ + let (bot,top,left,right) = parcelBoundaries parcel in (top - bot) * (right - left) + | otherwise = lift $ logFromScript info ("llGetParcelDetails: invalid detail flag: " ++ show detail) >> return Nothing + getDetail _ v = lift $ logFromScript info ("llGetParcelDetails: invalid detail: " ++ lslValString v) >> return Nothing + +whenParcelPermitted info pk action= do + (regionIndex,parcelIndex,parcel) <- getPrimParcel pk + prim <- getPrim pk + if parcelOwner parcel /= primOwner prim then lift $ logFromScript info "prim not permitted to change parcel" + else action regionIndex parcelIndex parcel >>= putParcel regionIndex parcelIndex + +addToLandACLList aclType aclFromParcel aclIntoParcel info@(ScriptInfo _ _ _ pk _) [KVal ak,FVal duration] = do + do + whenParcelPermitted info pk $ \ regionIndex parcelIndex parcel -> do + lift $ runAndLogIfErr ("attempt to change " ++ aclType ++ " unknown avatar " ++ ak) parcel $ do + avs <- lift getWorldAvatars + _ <- mlookup ak avs + when (duration < 0.0) $ lift $ logFromScript info (aclType ++ " change attempted with invalid duration: " ++ show duration) + t <- lift getTick + let acl = (ak, if duration == 0 then Nothing else Just $ t + durationToTicks duration) + let acllist = acl : ([ b | b@(k,Just expire) <- aclFromParcel parcel,expire < t, k /= ak] ++ + [ b | b@(k,Nothing) <- aclFromParcel parcel, k /= ak]) + let parcel' = aclIntoParcel parcel acllist + lift $ logFromScript info ("added " ++ ak ++ " to " ++ aclType ++ " list for parcel in " ++ (show regionIndex)) + return parcel' + continueWith VoidVal + +removeFromLandACLList aclFromParcel aclIntoParcel info@(ScriptInfo _ _ _ pk _) ak = do + whenParcelPermitted info pk $ \ regionIndex parcelIndex parcel -> do + avs <- lift getWorldAvatars + mlookup ak avs `catchError` (\ _ -> throwError ("unkown avatar " ++ ak)) + let acl = aclFromParcel parcel + return $ aclIntoParcel parcel [ ac | ac@(k,_) <- acl, k /= ak ] + + +llResetLandBanList info@(ScriptInfo _ _ _ pk _) [] = + do whenParcelPermitted info pk (\ regionIndex parcelIndex parcel -> return $ parcel { parcelBanList = [] }) + continueWith VoidVal +llResetLandPassList info@(ScriptInfo _ _ _ pk _) [] = + do whenParcelPermitted info pk (\ regionIndex parcelIndex parcel -> return $ parcel { parcelPassList = [] }) + continueWith VoidVal + +llRemoveFromLandPassList info [KVal ak] = + let aclFromParcel = parcelPassList + aclIntoParcel = (\ parcel list -> parcel { parcelPassList = list}) + in do removeFromLandACLList aclFromParcel aclIntoParcel info ak + lift $ logFromScript info ("llRemovFromLandPassList: removed " ++ ak) + continueWith VoidVal + +llRemoveFromLandBanList info [KVal ak] = + let aclFromParcel = parcelBanList + aclIntoParcel = (\ parcel list -> parcel { parcelBanList = list}) + in do removeFromLandACLList aclFromParcel aclIntoParcel info ak + lift $ logFromScript info ("llRemovFromLandBanList: removed " ++ ak) + continueWith VoidVal + +llAddToLandPassList info args = + let aclFromParcel = parcelPassList + aclIntoParcel = (\ parcel list -> parcel { parcelPassList = list }) + in addToLandACLList "pass" aclFromParcel aclIntoParcel info args +llAddToLandBanList info args = + let aclFromParcel = parcelBanList + aclIntoParcel = (\ parcel list -> parcel { parcelBanList = list }) + in addToLandACLList "ban" aclFromParcel aclIntoParcel info args + +llGetLandOwnerAt info@(ScriptInfo _ _ _ pk _) [VVal x y z] = + do regionIndex <- getPrimRegion pk + getParcelByPosition regionIndex (x,y,z) >>= continueWith . KVal . parcelOwner . snd + +llOverMyLand info@(ScriptInfo _ _ _ pk _) [KVal ak] = + do regionIndex <- getPrimRegion pk + owner <- getPrimOwner pk + avatars <- lift getWorldAvatars + i <- case M.lookup ak avatars of + Nothing -> lift $ logFromScript info "llOverMyLand: no such avatar" >> return 0 + Just av | avatarRegion av /= regionIndex -> lift $ logFromScript info "llOverMyLand: avatar not in sim" >> return 0 + | otherwise -> do + parcel <- getParcelByPosition regionIndex (avatarPosition av) + return $ if owner == (parcelOwner . snd) parcel then 1 else 0 + continueWith (IVal i) +------------------------------------------------------------------------------- +-- EMAIL +llGetNextEmail info@(ScriptInfo _ _ sn pk _) [SVal addr, SVal subj] = + do emails <- getPrimPendingEmails pk + case find match emails of + Nothing -> return () + Just email -> do + lift $ pushDeferredScriptEvent (Event "email" [SVal $ show $ emailTime email, SVal $ emailAddress email, SVal $ emailSubject email, + SVal $ emailMessage email, IVal (length emails - 1)] M.empty) pk sn 0 + lift $ setPrimPendingEmails pk (filter (not . match) emails) + continueWith VoidVal + where match email = (addr == "" || addr == emailAddress email) && + (subj == "" || subj == emailSubject email) + +llEmail info@(ScriptInfo _ _ _ pk _) [SVal address, SVal subject, SVal message] = + do let suffix = "@lsl.secondlife.com" + let logit = lift $ logFromScript info ("llEmail: sending email to " ++ address) + if suffix `isSuffixOf` address + then let potentialKey = take (length address - length suffix) address in + do pending <- (getPrimPendingEmails potentialKey) <||> throwError ("LSL destination addresses unknown prim") + time <- lift $ getUnixTime + lift $ setPrimPendingEmails pk (pending ++ [Email subject address message time]) + logit + else logit + continueWith VoidVal -- should do a yield til... (20 second delay!) +------------------------------------------------------------------------------- +soundExists pk sound = do + sounds <- getPrimSounds pk + case findByInvName sound sounds of + Nothing -> do + result <- lift $ findAsset sound + case result of + Nothing -> return False + Just v -> return $ if isSoundAsset v then True else False + Just _ -> return True + +llTriggerSound info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal volume] = + do found <- soundExists pk sound + let message = if found then "llTriggerSound: triggering sound " ++ sound else "llTriggerSound: sound not found - " ++ sound + lift $ logFromScript info message + continueWith VoidVal + +llTriggerSoundLimited info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal volume, VVal t n e, VVal b s w] = + do when (t <= b || n <= s || e <= w) $ lift $ logFromScript info ("llTriggerSoundLimited: bounding box has zero or negative volume") + found <- soundExists pk sound + let message = if found then "llTriggerSoundLimited: triggering sound " ++ sound else "llTriggerSoundLimited: sound no found - " ++ sound + lift $ logFromScript info message + continueWith VoidVal + +llSound info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol, IVal q, IVal loop] = + do found <- soundExists pk sound + let message = if found then "llSound (deprecated): playing sound " ++ sound else "llSound (deprecated): sound not found - " ++ sound + lift $ logFromScript info message + continueWith VoidVal + +llPlaySound info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol] = + do + found <- soundExists pk sound + let message = if found then "llPlaySound: playing sound " ++ sound else "llPlaySound: sound not found - " ++ sound + lift $ logFromScript info message + continueWith VoidVal + +llCollisionSound info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol] = + do found <- soundExists pk sound + let message = if found then "llCollisionSound: setting collision sound to " ++ sound else "llCollisionSound: sound not found - " ++ sound + lift $ logFromScript info message + continueWith VoidVal + +llPreloadSound info@(ScriptInfo _ _ _ pk _) [SVal sound] = + do found <- soundExists pk sound + let message = if found then "llPreloadSound: loading sound " ++ sound else "llPreloadSound: sound not found - " ++ sound + lift $ logFromScript info message + continueWith VoidVal + +llSoundPreload info@(ScriptInfo _ _ _ pk _) [SVal sound] = + do found <- soundExists pk sound + let message = if found then "llSoundPreload: loading sound " ++ sound else "llSoundPreload: sound not found - " ++ sound + lift $ logFromScript info message + continueWith VoidVal + +llPlaySoundSlave info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol] = + do found <- soundExists pk sound + let message = if found then "llPlaySoundSlave: playing sound " ++ sound else "llPlaySoundSlave: sound not found - " ++ sound + lift $ logFromScript info message + continueWith VoidVal + +llLoopSoundSlave info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol] = + do found <- soundExists pk sound + let message = if found then "llLoopSoundSlave: playing sound " ++ sound else "llLoopSoundSlave: sound not found - " ++ sound + lift $ logFromScript info message + continueWith VoidVal + +llLoopSound info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol] = + do found <- soundExists pk sound + let message = if found then "llLoopSound: playing sound " ++ sound else "llLoopSound: sound not found - " ++ sound + lift $ logFromScript info message + continueWith VoidVal + +llLoopSoundMaster info@(ScriptInfo _ _ _ pk _) [SVal sound, FVal vol] = + do found <- soundExists pk sound + let message = if found then "llLoopSoundMaster: playing sound " ++ sound else "llLoopSoundMaster: sound not found - " ++ sound + lift $ logFromScript info message + continueWith VoidVal + +llStopSound info [] = lift $ logFromScript info "llStopSound: stopping sound" >> continueWith VoidVal +llSetSoundRadius info [FVal radius] = + lift $ logFromScript info "llSetSoundRadius: called. In real sim, this function has no effect." >> continueWith VoidVal +llSetSoundQueueing info [IVal bool] = + lift $ logFromScript info ("llSetSoundQueuiing: set to " ++ (if bool /= 0 then "TRUE" else "FALSE")) >> continueWith VoidVal + +------------------------------------------------------------------------------ +llCollisionSprite info@(ScriptInfo _ _ _ pk _) [SVal impactSprite] = + do tk <- findTexture pk impactSprite + lift $ logFromScript info ("llCollisionSprite: set sprite to " ++ tk) + continueWith VoidVal +-- + +llGetKey (ScriptInfo _ _ _ pk _) [] = continueWith $ KVal pk + +llGetOwnerKey info@(ScriptInfo _ _ _ pk _) [KVal k] = + do regionIndex <- getPrimRegion pk + mRegionIndex <- fromErrorT Nothing (getPrimRegion k >>= return . Just) + key <- case mRegionIndex of + Nothing -> (lift $ logFromScript info "llGetOwnerKey: object key not found") >> return k + Just regionIndex' | regionIndex /= regionIndex' -> (lift $ logFromScript info "llGetOwnerKey: object in different simulator") >> return k + | otherwise -> getPrimOwner k + continueWith (KVal key) + +llGetLinkNumber (ScriptInfo oid pid _ pk _) [] = + if pid /= 0 then continueWith (IVal $ pid + 1) else + do LSLObject { primKeys = links } <- getObject oid + continueWith $ IVal (if length links == 1 then 0 else 1) + +llGetUnixTime (ScriptInfo _ _ _ _ _) [] = + lift (getUnixTime >>= continueWith . IVal) + +llGetTimestamp (ScriptInfo _ _ _ _ _) [] = lift $ do + cal <- getTimeOfDay >>= return . toUTCTime + continueWith $ SVal $ printf "%04d-%02d-%02dT%02d:%02d:%02.6f" + (ctYear cal) (1 + (fromEnum $ ctMonth cal)) (ctDay cal) (ctHour cal) (ctMin cal) + (((fromIntegral $ ctSec cal) / (10.0^12 * (fromIntegral $ ctPicosec cal))) :: Float) + +llGetDate (ScriptInfo _ _ _ _ _) [] = lift (getUTCDate >>= continueWith . SVal) +llGetGMTclock (ScriptInfo _ _ _ _ _) [] = lift $ do + cal <- getTimeOfDay >>= return . toUTCTime + continueWith $ IVal $ (24 * ctHour cal) + (60 * ctMin cal) + (ctSec cal) + +llGetWallclock (ScriptInfo _ _ _ _ _) [] = lift $ do + cal <- getLocalTimeOfDay (-8) >>= return . toUTCTime + continueWith $ IVal $ (24 * ctHour cal) + (60 * ctMin cal) + (ctSec cal) +llGetTimeOfDay (ScriptInfo _ _ _ _ _) [] = lift $ do + t <- getTick + continueWith $ FVal $ (ticksToDuration (t `mod` durationToTicks 4.0)) +getUnixTime :: (Monad (StateT (World a) a), Monad a) => StateT (World a) a Int +getUnixTime = (liftM2 (+) getWorldZeroTime (getTick >>= return . floor . ticksToDuration)) >>= return . fromIntegral +getTimeOfDay :: (Monad (StateT (World a) a), Monad a) => StateT (World a) a ClockTime +getTimeOfDay = getUnixTime >>= return . (flip TOD 0) . fromIntegral + +getLocalTimeOfDay offset = getTimeOfDay >>= return . (addToClockTime (TimeDiff 0 0 0 offset 0 0 0)) + +getUTCDate :: (Monad (StateT (World a) a), Monad a, PrintfType (Int -> Int -> Int -> b)) => StateT (World a) a b +getUTCDate = do + cal <- getTimeOfDay >>= return . toUTCTime + return $ printf "%04d-%02d-%02d" (ctYear cal) (1 + fromEnum (ctMonth cal)) (ctDay cal) + +llGetRegionFPS _ _ = continueWith $ FVal 45.0 +llGetRegionTimeDilation _ _ = continueWith $ FVal 1.0 + +llGetTime (ScriptInfo _ _ sid pk _) [] = + do t <- lift getTick + script <- lift getWorldScripts >>= mlookup (pk,sid) + continueWith $ FVal $ ticksToDuration (t - scriptLastResetTick script) + +getAndResetTick pk sid = + do + scripts <- lift getWorldScripts + script <- mlookup (pk,sid) scripts + let t = scriptLastResetTick script + t' <- lift getTick + lift $ setWorldScripts (M.insert (pk,sid) (script { scriptLastResetTick = t' } ) scripts) + return $ t' - t + +llGetAndResetTime (ScriptInfo _ _ sid pk _) [] = + getAndResetTick pk sid >>= continueWith . FVal . ticksToDuration + +llResetTime (ScriptInfo _ _ sid pk _) [] = + getAndResetTick pk sid >> continueWith VoidVal + +llSetText info [SVal text, VVal r g b, FVal alpha] = lift $ setText "llSetText" 254 info text +llSetSitText info [SVal text] = lift $ setText "llSetSitText" 9 info text +llSetTouchText info [SVal text] = lift $ setText "llSetTouchText" 9 info text + +setText func lim info text = + do logFromScript info (func ++ ": setting text to " ++ text) + when (length text > lim) $ logFromScript info (func ++ ": text exceeds " ++ show lim ++ " character limit") + continueWith VoidVal + +llGetScriptName (ScriptInfo _ _ sid _ _) [] = continueWith (SVal sid) + +llGetNumberOfNotecardLines (ScriptInfo _ _ sn pk _) [SVal name] = + do notecards <- getPrimNotecards pk + key <- case find ((name==) . inventoryItemName) notecards of + Nothing -> (lift $ putChat (Just 20.0) pk 0 ("Couldn't find notecard " ++ name)) >> return nullKey + Just notecard -> do + key <- lift newKey + lift $ pushDataserverEvent pk sn key (show $ length $ invNotecardLines $ inventoryItemData notecard) + return key + continueWith (KVal key) + +llGetNotecardLine (ScriptInfo _ _ sn pk _) [SVal name, IVal lineNumber] = + do notecards <- getPrimNotecards pk + key <- case find ((name==) . inventoryItemName) notecards of + Nothing -> (lift $ putChat (Just 20.0) pk cDebugChannel ("Couldn't find notecard " ++ name)) >> return nullKey + Just notecard -> do + key <- lift newKey + let line = case lookupByIndex lineNumber $ invNotecardLines $ inventoryItemData notecard of + Nothing -> cEOF + Just v -> take 255 v + lift $ pushDataserverEvent pk sn key line + return key + continueWith (KVal key) + +llRequestInventoryData info@(ScriptInfo _ _ sn pk _) [SVal name] = do + do t <- lift getTick + landmarks <- getPrimLandmarks pk + landmark <- maybe (throwError ("no landmark named " ++ name)) (\ l -> return l) (findByInvName name landmarks) + let (_,v) = invLandmarkLocation $ inventoryItemData landmark + key <- lift newKey + lift $ pushDataserverEvent pk sn key (lslValString (vec2VVal v)) + return (YieldTil $ t + durationToTicks 1,KVal key) + +llGetLinkName (ScriptInfo oid _ _ _ _) [IVal linkNumber] = + do LSLObject { primKeys = links } <- getObject oid + name <- if length links == 0 + then if linkNumber == 0 + then getPrimName oid + else return nullKey + else case lookupByIndex (linkNumber - 1) links of + Nothing -> return nullKey + Just k -> getPrimName k + continueWith (SVal name) + +llGetStatus (ScriptInfo _ _ _ pk _) [IVal check] = + do status <- getPrimStatus pk + continueWith $ IVal $ case mssb check of + Nothing -> 0 + Just b -> if bit b .&. status /= 0 then 1 else 0 + where mssb i = foldl' (\ x y -> x `mplus` (if testBit i y then Just y else Nothing)) Nothing [31,30..0] + +llSetStatus info@(ScriptInfo _ _ _ pk _) [IVal mask, IVal val] = + do status <- getPrimStatus pk + let status' = if val == 0 + then status .&. (complement mask) + else status .|. mask + lift $ setPrimStatus pk status' + continueWith VoidVal + +llPassTouches info@(ScriptInfo _ _ _ pk _) [IVal val] = + lift $ setPrimPassTouches pk (if val /= 0 then True else False) >> continueWith VoidVal + +llPassCollisions info@(ScriptInfo _ _ _ pk _) [IVal val] = + lift $ setPrimPassCollisions pk (if val /= 0 then True else False) >> continueWith VoidVal + +llGetRegionCorner (ScriptInfo _ _ _ pk _) [] = + do (x,y) <- getPrimRegion pk + continueWith $ vec2VVal (256 * fromIntegral x, 256 * fromIntegral y, 0) + +llGetRegionFlags info@(ScriptInfo _ _ _ pk _) [] = + getPrimRegion pk >>= getRegion >>= return . regionFlags >>= continueWith . IVal + +llGetSimulatorHostname (ScriptInfo _ _ _ pk _) [] = + do (i,j) <- getPrimRegion pk + (continueWith . SVal) (show i ++ "x" ++ show j ++ ".example.com") + +llGetRegionName (ScriptInfo _ _ _ pk _) [] = + do regionIndex <- getPrimRegion pk + regions <- lift getWorldRegions + region <- mlookup regionIndex regions + continueWith $ SVal $ regionName region + +llGetAgentSize info@(ScriptInfo _ _ _ pk _) [KVal ak] = + do region <- getPrimRegion pk + avatars <- lift getWorldAvatars + size <- case M.lookup ak avatars of + Nothing -> lift $ logFromScript info ("llGetAgentSize: no such agent - " ++ ak) >> return (0,0,0) + Just av -> if avatarRegion av == region + then return $ (0.45,0.6,avatarHeight av) + else lift $ logFromScript info ("llGetAgentSize: agent not in sim") >> return (0,0,0) + continueWith (vec2VVal size) + +llGetAgentInfo info@(ScriptInfo _ _ _ pk _) [KVal ak] = + do region <- getPrimRegion pk + avatars <- lift getWorldAvatars + i <- case M.lookup ak avatars of + Nothing -> lift $ logFromScript info ("llGetAgentInfo: no such agent - " ++ ak) >> return 0 + Just av -> if avatarRegion av == region then return $ avatarState av + else lift $ logFromScript info ("llGetAgentInfo: agent not in sim") >> return 0 + continueWith (IVal i) + +-- llDetected* functions ------------------------------------------------------ +-- TODO: only setup for 1 detected thing at a time... +-- This is a problem especially for sensor testing + +llDetectedKey (ScriptInfo _ _ _ pk mevent) [IVal i] = + continueWith $ maybe (KVal nullKey) id $ do + event <- mevent + M.lookup ("key_" ++ show i) (eventInfo event) + +llDetectedLinkNumber (ScriptInfo _ _ _ pk mevent) [IVal i] = + continueWith $ maybe (IVal 0) id (mevent >>= M.lookup ("integer_" ++ (show i)) . eventInfo) + +llDetectedGrab (ScriptInfo _ _ _ _ mevent) [IVal i] = + continueWith $ maybe (VVal 0 0 0) id (mevent >>= M.lookup ("vector_" ++ show i) . eventInfo) + +llDetectedPos (ScriptInfo _ _ _ _ mevent) [IVal i] = + do avatars <- lift getWorldAvatars + Just event <- return mevent + KVal key <- mlookup ("key_" ++ show i) (eventInfo event) + v <- case M.lookup key avatars of + Just av -> return $ avatarPosition av + Nothing -> getRootPrim key >>= getObjectPosition + continueWith (vec2VVal v) + +llDetectedRot (ScriptInfo _ _ _ _ mevent) [IVal i] = + do + avatars <- lift getWorldAvatars + Just event <- return mevent + KVal key <- mlookup ("key_" ++ show i) (eventInfo event) + r <- case M.lookup key avatars of + Just av -> return $ avatarRotation av + Nothing -> getRootPrim key >>= getObjectRotation + continueWith (rot2RVal r) + +llDetectedName (ScriptInfo _ _ _ _ mevent) [IVal i] = + do avatars <- lift getWorldAvatars + Just event <- return mevent + KVal key <- mlookup ("key_" ++ show i) (eventInfo event) + name <- case M.lookup key avatars of + Just av -> return $ avatarName av + Nothing -> getPrimName key + continueWith (SVal name) + +llDetectedOwner (ScriptInfo _ _ _ _ mevent) [IVal i] = + do avatars <- lift getWorldAvatars + Just event <- return mevent + KVal key <- mlookup ("key_" ++ show i) (eventInfo event) + k <- case M.lookup key avatars of + Just av -> return key + Nothing -> getPrimOwner key + continueWith (KVal k) + +llDetectedGroup info@(ScriptInfo _ _ _ _ mevent) [IVal i] = + do Just event <- return mevent + KVal key <- mlookup ("key_" ++ show i) (eventInfo event) <||> throwError ("index " ++ show i ++ " out of range") + avatars <- lift getWorldAvatars + prims <- lift getPrims + k <- (mlookup key avatars >>= return . fromMaybe nullKey . avatarActiveGroup) <||> + (mlookup key prims >>= return . fromMaybe nullKey . primGroup) <||> throwError ("error: key not an avatar or an object!") + continueWith (KVal k) + +llDetectedVel _ [IVal i] = continueWith $ VVal 0 0 0 -- TODO: physics!!! + +llDetectedType (ScriptInfo _ _ _ _ mevent) [IVal i] = + do Just event <- return mevent + KVal key <- mlookup ("key_" ++ show i) (eventInfo event) + avatars <- lift getWorldAvatars + t <- case M.lookup key avatars of + Just _ -> return cAgent + Nothing -> determineActivePassiveScripted key + continueWith (IVal t) + +determineActivePassiveScripted key = do + status <- getPrimStatus key + case status of + st | st .&. cStatusPhysics /= 0 -> return cActive + | otherwise -> do + scripts <- getPrimScripts key + return (if length scripts > 0 then cScripted else cPassive) + +------------------------------------------------------------------------------- +-- animation functions + +llGetAnimationList info@(ScriptInfo _ _ _ pk _) [KVal ak] = + do rp <- getPrimRegion pk + avatars <- lift getWorldAvatars + list <- case M.lookup ak avatars of + Nothing -> lift $ logFromScript info ("llGetAnimationList: no such avatar: " ++ ak) >> return [] + Just av | avatarRegion av /= rp -> lift $ logFromScript info ("llGetAnimationList: avatar not in sim") >> return [] + | otherwise -> do + now <- lift getTick + return [ KVal anim | (t,anim) <- avatarActiveAnimations av, maybe True (<now) t] + continueWith (LVal list) + +llGetAnimation info@(ScriptInfo _ _ _ pk _) [KVal ak] = + do rp <- getPrimRegion pk + avatars <- lift getWorldAvatars + nm <- case M.lookup ak avatars of + Nothing -> lift $ logFromScript info ("llGetAnimation: no such avatar: " ++ ak) >> return "" + Just av | avatarRegion av /= rp -> lift $ logFromScript info ("llGetAnimationList: avatar no in sim") >> return "" + | otherwise -> return "Standing" -- TODO: real animation state + continueWith (SVal nm) + +llStartAnimation info@(ScriptInfo _ _ sid pk _) [SVal anim] = + do avKey <- getPermittedAvKey info "llStartAnimation" cPermissionTriggerAnimation + case avKey of + Nothing -> return () + Just ak -> do + avatars <- lift getWorldAvatars + av <- mlookup ak avatars + let anims = avatarActiveAnimations av + now <- lift getTick + result <- findAnimation pk anim + case result of + Just (key,mduration) -> do + let anims' = updateAnims anims now mduration key + lift $ setWorldAvatars (M.insert ak (av { avatarActiveAnimations = anims' }) avatars) + Nothing -> lift $ logFromScript info ("llStartAnimation: animation not found - " ++ anim) + where updateAnims anims now mduration key = + (expire,key):[(t,k) | (t,k) <- anims, (maybe True (<now) t) && key /= k] + where expire = fmap ((now+) . durationToTicks) mduration + continueWith VoidVal + +findAnimation pk anim = + do primAnims <- getPrimAnimations pk + case find (\ item -> invName item == anim) primAnims of + Just item -> do + return $ Just (snd $ inventoryItemNameKey $ inventoryItemIdentification item, invAnimationDuration $ inventoryItemData item) + Nothing -> + case find (\ (name,_,_) -> name == anim) builtInAnimations of + Just (_,key,mduration) -> return $ Just (key,mduration) + Nothing -> return Nothing + +llStopAnimation info@(ScriptInfo _ _ sid pk _) [SVal anim] = + do avKey <- getPermittedAvKey info "llStartAnimation" cPermissionTriggerAnimation + case avKey of + Nothing -> return () + Just ak -> do + avatars <- lift getWorldAvatars + av <- mlookup ak avatars + let anims = avatarActiveAnimations av + result <- findAnimation pk anim + case result of + Just (key,_) -> do + case find (\ (_,k) -> k == key) anims of + Nothing -> lift $ logFromScript info "llStopAnimation: animation not active" + Just _ -> do + let anims' = [(expire,k) | (expire,k) <- anims, k /= key] + lift $ setWorldAvatars $ M.insert ak (av { avatarActiveAnimations = anims' }) avatars + Nothing -> lift $ logFromScript info ("llStopAnimation: animation not found - " ++ anim) + continueWith VoidVal + +llSetClickAction info [IVal action] = + lift $ (if action `elem` cClickActions then logFromScript info "llSetClickAction: setting click action" + else logFromScript info "llSetClickAction: invalid click action") >> continueWith VoidVal +------------------------------------------------------------------------------- +-- XML RPC related functions +llCloseRemoteDataChannel info@(ScriptInfo _ _ sn pk _) [KVal key] = + do -- according to LSL wiki this function has no effect, + -- so we'll just log a message indicating whether or not the passed in key is valid + (lookupScriptFromChan key) <||> throwError "key not an open channel" + return () + continueWith VoidVal + +llOpenRemoteDataChannel info@(ScriptInfo _ _ sn pk _) [] = + do key <- lookupDataChannel (pk,sn) <||> lift newKey + insertScriptChannelPair (pk,sn) key + lift $ logFromScript info ("pushing remote data channel to script") + lift $ pushDeferredScriptEvent (Event "remote_data" [llcRemoteDataChannel, KVal key, KVal nullKey, SVal "", IVal 0, SVal ""] M.empty) pk sn 0 + continueWith VoidVal + +llSendRemoteData info [KVal channel, SVal dest, IVal idata, SVal sdata] = + do -- according to LSL Wiki, this function doesn't do anything... but we'll check + -- for a valid channel and log a message. + lookupScriptFromChan channel <||> throwError "key not an open channel" + lift newKey >>= continueWith . KVal + +llRemoteDataReply info@(ScriptInfo _ _ _ _ mevent) [KVal channel, KVal messageId, SVal sdata, IVal idata] = + do Just event <- return mevent + when (eventName event /= "remote_data") $ throwError "no effect unless called within remote_data handler" + let m = eventInfo event + (KVal k) <- mlookup "requestKey" m <||> throwError ("problem: invalid or mistyped request key in event") + lift $ putWorldEvent 0 (XMLReplyEvent k channel messageId sdata idata) + lift $ logFromScript info ("llRemoteDataReply: (" ++ show channel ++ "," ++ show messageId ++ "," ++ show sdata ++ "," ++ + show idata ++ ")") + continueWith VoidVal + +llRemoteDataSetRegion info [] = lift $ logFromScript info "llRemoteDataSetRegion: this function has no effect" >> continueWith VoidVal +------------------------------------------------------------------------------- + +llDialog info@(ScriptInfo _ _ _ pk _) [KVal ak, SVal message, LVal buttons, IVal channel] = + do when (length message > 512) $ doErr "message too long, must be less than 512 characters" + when (null message) $ doErr "must supply a message" + when (not $ all (==LLString) $ map typeOfLSLValue buttons) $ doErr "button list must contain only strings" + let buttons' = take 12 $ map ( \ (SVal s) -> s) buttons + when (any ((24 <) . length) buttons') $ doErr "Button Labels cannot have more that 24 characters" + when (any null buttons') $ doErr "all buttons must have label strings" + (lift getWorldAvatars >>= mlookup ak) <||> throwError ("no such agent/avatar - " ++ ak) + lift $ putWorldEvent 0 (DialogEvent ak message buttons' channel pk) -- deprecated! + lift $ putWorldEvent 0 (AvatarInputEvent ak (AvatarDialog message buttons' channel pk)) + continueWith VoidVal + where doErr msg = (lift $ putChat (Just 20) pk cDebugChannel ("llDialog: " ++ msg)) >> throwError msg +------------------------------------------------------------------------------- +-- old (deprecated) functions for visual effects + +llMakeExplosion info _ = lift $ logFromScript info "llMakeExplosion: deprecated" >> continueWith VoidVal +llMakeSmoke info _ = lift $ logFromScript info "llMakeSmoke: deprecated" >> continueWith VoidVal +llMakeFire info _ = lift $ logFromScript info "llMakeFire: deprecated" >> continueWith VoidVal +llMakeFountain info _ = lift $ logFromScript info "llMakeFountain: deprecated" >> continueWith VoidVal + +-------------------------------------------------------------------------------- +llTakeControls info@(ScriptInfo {scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [IVal controls, IVal accept, IVal pass] = + do allScripts <- lift getWorldScripts + script <- mlookup (pk,sn) allScripts + case scriptLastPerm script of + Nothing -> lift $ logFromScript info "no persmission to take controls from any agent" + Just ak -> do + av <- getWorldAvatar ak + maybe (throwError $ "no permission to take controls from " ++ avatarName av) + (\ perms -> if perms .&. cPermissionTakeControls /= 0 + then when (accept /= 0) $ lift $ setWorldAvatar ak (av { avatarControlListener = Just acl }) + else (throwError $ "no permission to take controls from " ++ avatarName av)) + (M.lookup ak $ scriptPermissions script) + where acl = AvatarControlListener { avatarControlListenerMask = controls, avatarControlListenerScript = (pk,sn) } + continueWith VoidVal +-------------------------------------------------------------------------------- + +llVolumeDetect info@(ScriptInfo { scriptInfoObjectKey = oid }) [IVal i] = + do obj <- getObject oid + lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectVolumeDetect = i /= 0 }}) + continueWith VoidVal + +llCollisionFilter info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn }) [SVal name, KVal k, IVal i] = + do allScripts <- lift getWorldScripts + script <- mlookup (pk,sn) allScripts + lift $ setWorldScripts (M.insert (pk,sn) (script { scriptCollisionFilter = (name,k, i /= 0) }) allScripts) + continueWith VoidVal + +llTarget info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [VVal x y z, FVal range] = + do allScripts <- lift getWorldScripts + script <- mlookup (pk,sn) allScripts + let index = scriptTargetIndex script + let script' = script {scriptTargetIndex = index + 1, + scriptPositionTargets = IM.insert index ((x,y,z),range) (scriptPositionTargets script) + } + lift $ setWorldScripts (M.insert (pk,sn) script' allScripts) + continueWith $ IVal index + +llTargetRemove info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [IVal tnumber] = + do allScripts <- lift getWorldScripts + script <- mlookup (pk,sn) allScripts + let script' = script { scriptPositionTargets = IM.delete tnumber (scriptPositionTargets script) } + lift $ setWorldScripts (M.insert (pk,sn) script' allScripts) + continueWith VoidVal + +llRotTarget info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [RVal x y z s, FVal err] = + do allScripts <- lift getWorldScripts + script <- mlookup (pk,sn) allScripts + let index = scriptTargetIndex script + let script' = script { scriptTargetIndex = index + 1, + scriptRotationTargets = IM.insert index ((x,y,z,s),err) (scriptRotationTargets script) + } + lift $ setWorldScripts (M.insert (pk,sn) script' allScripts) + continueWith VoidVal + +llRotTargetRemove info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [IVal tnumber] = + do allScripts <- lift getWorldScripts + script <- mlookup (pk,sn) allScripts + let script' = script { scriptRotationTargets = IM.delete tnumber (scriptRotationTargets script) } + lift $ setWorldScripts (M.insert (pk,sn) script' allScripts) + continueWith VoidVal + +-------------------------------------------------------------------------------- +llGround info [VVal _ _ _] = continueWith (FVal 0) -- the world is flat! +llGroundContour info [VVal _ _ _] = continueWith (VVal 1 0 0) -- could be any vector +llGroundNormal info [VVal _ _ _] = continueWith (VVal 0 0 1) -- straight up! +llGroundSlope info [VVal _ _ _] = continueWith (VVal 0 1 0) +-------------------------------------------------------------------------------- +llGetSunDirection info [] = lift $ do + az <- getTick >>= return . (*(pi/7200)) . ticksToDuration + let el = 80 * pi + continueWith $ vec2VVal (sin az * cos el, sin el, cos az * cos el) + +-------------------------------------------------------------------------------- +llLoadURL info [KVal ak, SVal msg, SVal url] = do + getWorldAvatar ak + lift $ putWorldEvent 0 (AvatarInputEvent ak (AvatarLoadURL msg url)) + continueWith VoidVal + +llMapDestination info [SVal simName, (VVal x y z), (VVal _ _ _)] = do + case mevent of + Nothing -> do + attachment <- getPrimAttachment oid + case attachment of + Nothing -> lift $ logFromScript info ("prim neither attached nor touched, so call to llMapDestination is not valid") + Just (Attachment { attachmentKey = ak }) -> putIt ak + Just (Event "touch" _ m) -> + case M.lookup "key_0" m of + Just (SVal ak) -> putIt ak + _ -> throwError "invalid touch event!" + continueWith VoidVal + where oid = scriptInfoObjectKey info + mevent = scriptInfoCurrentEvent info + putIt ak = lift $ putWorldEvent 0 (AvatarInputEvent ak (AvatarMapDestination simName (x,y,z))) +-------------------------------------------------------------------------------- +continueWith val = return (EvalIncomplete,val) + +defaultPredefs :: Monad m => M.Map String (PredefFunc m) +defaultPredefs = M.fromList $ map (\(x,y) -> (x, defaultPredef x y)) [ + ("llAddToLandBanList",llAddToLandBanList), + ("llAddToLandPassList",llAddToLandPassList), + ("llAdjustSoundVolume",llAdjustSoundVolume), + ("llAllowInventoryDrop",llAllowInventoryDrop), + ("llApplyImpulse",llApplyImpulse), + ("llApplyRotationalImpulse", llApplyRotationalImpulse), + ("llAttachToAvatar",llAttachToAvatar), + ("llAvatarOnSitTarget",llAvatarOnSitTarget), + ("llBreakAllLinks",llBreakAllLinks), + ("llBreakLink",llBreakLink), + ("llClearCameraParams",llClearCameraParams), + ("llCloseRemoteDataChannel",llCloseRemoteDataChannel), + ("llCloud",llCloud), + ("llCollisionFilter", llCollisionFilter), + ("llCollisionSound",llCollisionSound), + ("llCollisionSprite",llCollisionSprite), + ("llCreateLink",llCreateLink), + ("llDetachFromAvatar", llDetachFromAvatar), + ("llDetectedGrab",llDetectedGrab), + ("llDetectedGroup",llDetectedGroup), + ("llDetectedKey", llDetectedKey), + ("llDetectedLinkNumber", llDetectedLinkNumber), + ("llDetectedName", llDetectedName), + ("llDetectedOwner", llDetectedOwner), + ("llDetectedPos", llDetectedPos), + ("llDetectedRot", llDetectedRot), + ("llDetectedType", llDetectedType), + ("llDetectedVel", llDetectedVel), + ("llDialog", llDialog), + ("llDie",llDie), + ("llEjectFromLand",llEjectFromLand), + ("llEmail",llEmail), + ("llFrand",llFrand), + ("llGetAccel",llGetAccel), + ("llGetAgentInfo",llGetAgentInfo), + ("llGetAgentSize",llGetAgentSize), + ("llGetAlpha",llGetAlpha), + ("llGetAndResetTime", llGetAndResetTime), + ("llGetAnimation", llGetAnimation), + ("llGetAnimationList",llGetAnimationList), + ("llGetAttached",llGetAttached), + ("llGetBoundingBox",llGetBoundingBox), + ("llGetCameraPos",llGetCameraPos), + ("llGetCameraRot",llGetCameraRot), + ("llGetColor",llGetColor), + ("llGetCreator",llGetCreator), + ("llGetDate",llGetDate), + ("llGetForce", llGetForce), + ("llGetGeometricCenter",llGetGeometricCenter), + ("llGetGMTclock",llGetGMTclock), + ("llGetInventoryCreator",llGetInventoryCreator), + ("llGetInventoryKey",llGetInventoryKey), + ("llGetInventoryName",llGetInventoryName), + ("llGetInventoryNumber",llGetInventoryNumber), + ("llGetInventoryPermMask", llGetInventoryPermMask), + ("llGetInventoryType",llGetInventoryType), + ("llGetKey",llGetKey), + ("llGetLocalPos",llGetLocalPos), + ("llGetNextEmail",llGetNextEmail), + ("llGetNumberOfPrims",llGetNumberOfPrims), + ("llGetNumberOfSides",llGetNumberOfSides), + ("llGetLinkKey",llGetLinkKey), + ("llGetLinkName",llGetLinkName), + ("llGetLinkNumber", llGetLinkNumber), + ("llGetLocalRot", llGetLocalRot), + ("llGetLandOwnerAt", llGetLandOwnerAt), + ("llGetMass",llGetMass), + ("llGetNotecardLine", llGetNotecardLine), + ("llGetNumberOfNotecardLines",llGetNumberOfNotecardLines), + ("llGetObjectDesc", llGetObjectDesc), + ("llGetObjectDetails", llGetObjectDetails), + ("llGetObjectMass", llGetObjectMass), + ("llGetObjectName", llGetObjectName), + ("llGetObjectPermMask", llGetObjectPermMask), + ("llGetObjectPrimCount",llGetObjectPrimCount), + ("llGetOmega",llGetOmega), + ("llGetOwner", llGetOwner), + ("llGetOwnerKey",llGetOwnerKey), + ("llGetParcelFlags", llGetParcelFlags), + ("llGetParcelDetails", llGetParcelDetails), + ("llGetPermissions",llGetPermissions), + ("llGetPermissionsKey",llGetPermissionsKey), + ("llGetPos", llGetPos), + ("llGetPrimitiveParams", llGetPrimitiveParams), + ("llGetRegionCorner", llGetRegionCorner), + ("llGetRegionFlags", llGetRegionFlags), + ("llGetRegionFPS", llGetRegionFPS), + ("llGetRegionName", llGetRegionName), + ("llGetRegionTimeDilation", llGetRegionTimeDilation), + ("llGetRot",llGetRot), + ("llGetRootPosition",llGetRootPosition), + ("llGetRootRotation",llGetRootRotation), + ("llGetScale", llGetScale), + ("llGetScriptName", llGetScriptName), + ("llGetScriptState", llGetScriptState), + ("llGetSimulatorHostname", llGetSimulatorHostname), + ("llGetStartParameter",llGetStartParameter), + ("llGetStatus",llGetStatus), + ("llGetSunDirection",llGetSunDirection), + ("llGetTexture", llGetTexture), + ("llGetTextureOffset", llGetTextureOffset), + ("llGetTextureRot", llGetTextureRot), + ("llGetTextureScale", llGetTextureScale), + ("llGetTime",llGetTime), + ("llGetTimeOfDay",llGetTimeOfDay), + ("llGetTimestamp",llGetTimestamp), + ("llGetTorque",llGetTorque), + ("llGetUnixTime",llGetUnixTime), + ("llGetWallclock",llGetWallclock), + ("llGetVel",llGetVel), + ("llGiveInventory", llGiveInventory), + ("llGiveMoney",llGiveMoney), + ("llGround", llGround), + ("llGroundContour", llGroundContour), + ("llGroundNormal", llGroundNormal), + ("llGroundRepel",llGroundRepel), + ("llGroundSlope",llGroundSlope), + ("llHTTPRequest",llHTTPRequest), + ("llInstantMessage",llInstantMessage), + ("llKey2Name", llKey2Name), + ("llListRandomize",llListRandomize), + ("llListen", llListen), + ("llListenControl",llListenControl), + ("llListenRemove",llListenRemove), + ("llLoadURL",llLoadURL), + ("llLookAt", llLookAt), + ("llLoopSound",llLoopSound), + ("llLoopSoundSlave",llLoopSoundSlave), + ("llLoopSoundMaster", llLoopSoundMaster), + ("llMakeExplosion",llMakeExplosion), + ("llMakeFire",llMakeFire), + ("llMakeFountain",llMakeFountain), + ("llMakeSmoke",llMakeSmoke), + ("llMapDestination", llMapDestination), + ("llMessageLinked", llMessageLinked), + ("llMoveToTarget", llMoveToTarget), + ("llOffsetTexture", llOffsetTexture), + ("llOpenRemoteDataChannel", llOpenRemoteDataChannel), + ("llOverMyLand", llOverMyLand), + ("llOwnerSay", llOwnerSay), + ("llPassCollisions", llPassCollisions), + ("llPassTouches", llPassTouches), + ("llPlaySound", llPlaySound), + ("llPlaySoundSlave", llPlaySoundSlave), + ("llPointAt",llPointAt), + ("llPreloadSound", llPreloadSound), + ("llRefreshPrimURL", llRefreshPrimURL), + ("llRegionSay", llRegionSay), + ("llReleaseCamera", llReleaseCamera), + ("llRemoteDataReply", llRemoteDataReply), + ("llRemoteDataSetRegion", llRemoteDataSetRegion), + ("llRemoteLoadScript", llRemoteLoadScript), + ("llRemoveFromLandPassList",llRemoveFromLandPassList), + ("llRemoveFromLandBanList",llRemoveFromLandBanList), + ("llRemoveInventory",llRemoveInventory), + ("llRemoveVehicleFlags",llRemoveVehicleFlags), + ("llRequestAgentData", llRequestAgentData), + ("llRequestInventoryData",llRequestInventoryData), + ("llRequestPermissions",llRequestPermissions), + ("llRequestSimulatorData",llRequestSimulatorData), + ("llResetLandPassList",llResetLandPassList), + ("llResetLandBanList",llResetLandBanList), + ("llResetOtherScript",llResetOtherScript), + ("llResetScript",llResetScript), + ("llResetTime",llResetTime), + ("llRezAtRoot",llRezAtRoot), + ("llRezObject",llRezObject), + ("llRotLookAt",llRotLookAt), + ("llRotTarget",llRotTarget), + ("llRotTargetRemove",llRotTargetRemove), + ("llRotateTexture", llRotateTexture), + ("llSameGroup", llSameGroup), + ("llSay",llSay), + ("llScaleTexture", llScaleTexture), + ("llSensor",llSensor), + ("llSensorRemove",llSensorRemove), + ("llSensorRepeat",llSensorRepeat), + ("llSendRemoteData",llSendRemoteData), + ("llSetAlpha", llSetAlpha), + ("llSetBuoyancy", llSetBuoyancy), + ("llSetClickAction", llSetClickAction), + ("llSetColor", llSetColor), + ("llSetForce", llSetForce), + ("llSetForceAndTorque", llSetForceAndTorque), + ("llSetHoverHeight", llSetHoverHeight), + ("llSetLinkAlpha",llSetLinkAlpha), + ("llSetLinkColor",llSetLinkColor), + ("llSetLinkPrimitiveParams",llSetLinkPrimitiveParams), + ("llSetLinkTexture",llSetLinkTexture), + ("llSetLocalRot",llSetLocalRot), + ("llSetObjectName",llSetObjectName), + ("llSetObjectDesc",llSetObjectDesc), + ("llSetParcelMusicURL",llSetParcelMusicURL), + ("llSetPayPrice",llSetPayPrice), + ("llSetPos",llSetPos), + ("llSetPrimitiveParams",llSetPrimitiveParams), + ("llSetPrimURL",llSetPrimURL), + ("llSetRemoteScriptAccessPin", llSetRemoteScriptAccessPin), + ("llSetRot",llSetRot), + ("llSetScale",llSetScale), + ("llSetScriptState",llSetScriptState), + ("llSetSoundQueueing",llSetSoundQueueing), + ("llSetSoundRadius",llSetSoundRadius), + ("llSetSitText",llSetSitText), + ("llSetStatus",llSetStatus), + ("llSetText",llSetText), + ("llSetTexture",llSetTexture), + ("llSetTorque",llSetTorque), + ("llSetTouchText",llSetTouchText), + ("llSetVehicleFlags",llSetVehicleFlags), + ("llSitTarget",llSitTarget), + ("llShout",llShout), + ("llSleep", llSleep), + ("llSetTimerEvent",llSetTimerEvent), + ("llSound",llSound), + ("llSoundPreload", llSoundPreload), + ("llStartAnimation", llStartAnimation), + ("llStopAnimation", llStopAnimation), + ("llStopHover",llStopHover), + ("llStopLookAt",llStopLookAt), + ("llStopMoveToTarget", llStopMoveToTarget), + ("llStopPointAt", llStopPointAt), + ("llStopSound",llStopSound), + ("llTakeCamera",llTakeCamera), + ("llTakeControls",llTakeControls), + ("llTarget",llTarget), + ("llTargetRemove",llTargetRemove), + ("llTeleportAgentHome",llTeleportAgentHome), + ("llTriggerSound",llTriggerSound), + ("llTriggerSoundLimited",llTriggerSoundLimited), + ("llUnSit",llUnSit), + ("llVolumeDetect", llVolumeDetect), + ("llWhisper",llWhisper), + ("llWind",llWind), + ("llWater",llWater) + ] ++ map (\ (n,f) -> (n, defaultPredef n (\ i args -> lift $ f i args))) internalLLFuncs + +allFuncs = (map (\ (name,_,_) -> name) funcSigs) +implementedFuncs = (map fst $ M.toList (defaultPredefs::(M.Map String (PredefFunc Maybe)))) +unimplementedFuncs = S.toList (S.difference (S.fromList allFuncs) (S.fromList implementedFuncs)) + +--------------------------------------------------------------------------------------------------- +logFromScript :: Monad m => ScriptInfo -> String -> WorldM m () +logFromScript scriptInfo msg = logAMessage LogInfo (infoToLogSource scriptInfo) msg + +infoToLogSource info = (scriptInfoPrimKey info ++ ": " ++ scriptInfoScriptName info) + +addScript prim invScript = prim { primInventory = (invScript:(primInventory prim)) } + +-- should monadify further... +getPrimInfo pkey = + do prims <- getPrims + case M.lookup pkey prims of + Nothing -> return Nothing + Just p -> + case primParent p of + Nothing -> return $ Just (pkey, 0, primName p) + Just p1Key -> do + objects <- getObjects + case M.lookup p1Key objects of + Nothing -> return Nothing + Just (LSLObject { primKeys = plist }) -> + case elemIndex pkey plist of + Nothing -> return Nothing + Just i -> return $ Just (p1Key, i, primName p) + +pushEvent e key sid = + do scripts <- getWorldScripts + case M.lookup (key,sid) scripts of + Nothing -> logAMessage LogWarn "sim" ("no such script: " ++ (show (key, sid)) ++ ", event: " ++ show e) + Just script -> setWorldScripts (M.insert (key,sid) (script { scriptEventQueue = (scriptEventQueue script) ++ [e] } ) scripts) + +pushEventToPrim e key = + runErrPrim key () (getPrimScripts key >>= mapM_ (lift . pushEvent e key) . (map invName)) + +pushEventToObject e key = + do objects <- getObjects + case M.lookup key objects of + Nothing -> logAMessage LogWarn "sim" ("no such object: " ++ key) + Just o -> mapM_ (pushEventToPrim e) (primKeys o) + +pushDataserverEvent pk sn key val = pushDeferredScriptEvent (Event "dataserver" [KVal key, SVal val] M.empty) pk sn 0 +pushChangedEventToObject oid val = pushDeferredScriptEventToObject (Event "changed" [IVal val] M.empty) oid 0 +pushAttachEvent pk k = pushDeferredScriptEventToPrim (Event "attach" [KVal k] M.empty) pk 0 + +pushDeferredScriptEvent event pk sn delay = + putWorldEvent delay (DeferredScriptEvent event (DeferredScriptEventScriptTarget (pk,sn))) +pushDeferredScriptEventToPrim event pk delay = + putWorldEvent delay (DeferredScriptEvent event (DeferredScriptEventPrimTarget pk)) +pushDeferredScriptEventToObject event oid delay = + putWorldEvent delay (DeferredScriptEvent event (DeferredScriptEventObjectTarget oid)) + +putHTTPTimeoutEvent pk sn key delay = + pushDeferredScriptEvent (Event "http_response" [KVal key, IVal 499, LVal [], SVal ""] M.empty) pk sn delay +putHTTPResponseEvent pk sn key status metadata body delay = + pushDeferredScriptEvent (Event "http_response" [KVal key, IVal status, LVal metadata, body] M.empty) pk sn delay + +getObject name = lift getObjects >>= mlookup name +setObject oid obj = getObjects >>= setObjects . M.insert oid obj +getObjectDynamics k = getObject k >>= return . objectDynamics +getObjectPosition k = getObjectDynamics k >>= return . objectPosition +getObjectRotation k = getObjectDynamics k >>= return . objectRotation + +newWorld slice maxt iq lib scripts avatars objs prims activeScripts regions keyIndex webHandling eventHandler log = World { + sliceSize = slice, + maxTick = maxt, + nextPause = slice, + wqueue = iq, + wlisteners = IM.empty, + nextListenerId = 0, + wobjects = objs, + wprims = prims, + worldScripts = activeScripts, + inventory = [], + tick = 0, + msglog = [LogMessage 0 LogWarn "init" s | s <- log ], + predefs = defaultPredefs, + randGen = mkStdGen 1, + wlibrary = lib, + wscripts = scripts, + worldEventHandler = fmap (flip (,) []) eventHandler, + worldAvatars = avatars, + worldBreakpointManager = emptyBreakpointManager, + worldSuspended = Nothing, + worldRegions = regions, + worldZeroTime = 0, + worldKeyIndex = keyIndex, + worldWebHandling = webHandling, + worldOutputQueue = [], + worldPendingHTTPRequests = [], + worldOpenDataChannels = (M.empty,M.empty), + worldXMLRequestRegistry = M.empty, + worldPhysicsTime = 0, + worldTargetCheckTime = 0, + worldLastPositions = M.empty, + worldCollisions = S.empty, + worldLandCollisions = S.empty, + worldTouches = M.empty, + worldTouchCheckTime = 0 + } + +putWorldEvent delay we = + do weq <- getWQueue + t <- getTick + setWQueue $ putWQ (t + max (durationToTicks delay) 1) we weq + +checkBp bp sm = + do bpm <- getWorldBreakpointManager + let (result,bpm',sm') = checkBreakpoint bp bpm sm + setWorldBreakpointManager bpm' + return (result,sm') + +updatePrim f key = + do prims <- getPrims + case M.lookup key prims of + Nothing -> logAMessage LogWarn "sim" ("prim " ++ key ++ " not found") + Just p -> do p' <- f p + setPrims (M.insert key p' prims) + +registerListener listener = + do listeners <- getListeners + id <- getNextListenerId + let id' = id + 1 + setNextListenerId id' + setListeners $ IM.insert id (listener,True) listeners + return id +unregisterListener pk sname id = + do listeners <- lift getListeners + (listener,_) <- ilookup id listeners + when (listenerScriptName listener /= sname && listenerPrimKey listener /= pk) + (throwError ("listener " ++ show id ++ " not registered for calling script")) + lift $ setListeners $ IM.delete id listeners +updateListener pk sname id active = + do listeners <- lift getListeners + (listener,_) <- ilookup id listeners + when (listenerScriptName listener /= sname && listenerPrimKey listener /= pk) + (throwError ("listener " ++ show id ++ " not registered for calling script")) + lift $ setListeners $ IM.insert id (listener,active) listeners + +processEvents :: (Monad m) => WorldM m () +processEvents = + do suspenseInfo <- getWorldSuspended + when (isNothing suspenseInfo) $ do + tick <- getTick + weq <- getWQueue + case takeWQ tick weq of + (Nothing,_) -> return () + (Just we,weq') -> + do setWQueue weq' + w <- queryWorld id + processEvent we + processEvents + where isNothing = maybe True (const False) + +processEvent (DeferredScriptEvent event (DeferredScriptEventScriptTarget (pk,sn))) = pushEvent event pk sn +processEvent (DeferredScriptEvent event (DeferredScriptEventPrimTarget pk)) = pushEventToPrim event pk +processEvent (DeferredScriptEvent event (DeferredScriptEventObjectTarget oid)) = pushEventToObject event oid +processEvent (CreatePrim name key) = + do worldPrims <- getPrims + objects <- getObjects + let prim = emptyPrim name key + setPrims (M.insert key prim worldPrims) + setObjects (M.insert key (LSLObject [key] defaultDynamics) objects) +processEvent (AddScript (name,script) key active) = + do scripts <- getWScripts + t <- getTick + case lookup script scripts of + Nothing -> logAMessage LogWarn "sim" ("no such script: " ++ script) + Just (Left s) -> do + scriptKey <- newKey + updatePrim (\ p -> return $ addScript p (scriptInventoryItem name scriptKey script)) key +-- scripts <- getWorldScripts +-- setWorldScripts (M.insert (key,name) ((mkScript (Invalid s)) { scriptActive = False, scriptStartTick = t, scriptLastResetTick = t, scriptEventQueue = []}) scripts) + Just (Right code) -> do + scriptKey <- newKey + updatePrim (\ p -> return $ addScript p (scriptInventoryItem name scriptKey script)) key + let sstate = initLSLScript code + scripts <- getWorldScripts + setWorldScripts (M.insert (key,name) ((mkScript sstate) { scriptStartTick = t, scriptLastResetTick = t }) scripts) +processEvent chat@(Chat chan name key msg location range) = + do listeners <- getListeners + locatedListeners <- mapM locateListener (IM.elems listeners) + let listeners'= [ l | (l,_,_) <- filter (matchListener chat) locatedListeners] + -- event goes to all UNIQUE addresses in list + let addresses = nub $ map listenAddress listeners' + mapM_ (\ (key',sid) -> pushEvent (Event "listen" [IVal chan, SVal name, KVal key, SVal msg] M.empty) key' sid) addresses + when (chan == 0) $ case range of + Nothing -> return () + Just dist -> pushChatToAvatars location dist + where locateListener (listener,active) = do + (VVal x y z) <- getPos (listenerPrimKey listener) + region <- getRegionIndex (listenerPrimKey listener) + return (listener,active,(region,(x,y,z))) + pushChatToAvatars location range = do + avatars <- getWorldAvatars >>= return . M.elems + mapM_ (pushChatToAvatar location range) avatars + pushChatToAvatar (region,pos) range avatar = + when (region == avatarRegion avatar && dist3d2 pos (avatarPosition avatar) <= range^2) $ do + putWorldEvent 0 $ (AvatarInputEvent (avatarKey avatar) (AvatarHearsChat name key msg)) +processEvent (WorldSimEvent name args) = + case M.lookup name eventDescriptors of + Nothing -> logAMessage LogWarn "sim" ("event " ++ name ++ " not understood") + Just def -> handleSimInputEvent def args +processEvent (PermissionRequestEvent pk sname ak mask) = + runAndLogIfErr ("can't find prim/script: " ++ pk ++ "/" ++ sname) () $ do + scripts <- lift getWorldScripts + script <- mlookup (pk,sname) scripts + let script' = script { scriptPermissions = M.insert ak mask (scriptPermissions script), scriptLastPerm = Just ak } + lift $ setWorldScripts (M.insert (pk,sname) script' scripts) + lift $ pushEvent (Event "run_time_permissions" [IVal mask] M.empty) pk sname +processEvent evt@(TimerEvent interval (primKey,scriptName)) = + do pushEvent (Event "timer" [] M.empty) primKey scriptName + putWorldEvent interval evt +processEvent evt@(SensorEvent (pk,sn) name key stype range arc rpt) = + runAndLogIfErr "problem processing sensor even" () $ do + t <- lift getTick + maybe (return ()) (\ interval -> lift $ putWorldEvent interval evt) rpt + sensedObjects <- senseObjects + sensedAvatars <- senseAvatars + let list = take 16 (sensedObjects ++ sensedAvatars) + if null list + then lift $ pushEvent (Event "no_sensor" [] M.empty) pk sn + else lift $ pushEvent (Event "sensor" [(IVal $ length list)] (M.fromList (zipWith (\ i k -> ("key_" ++ show i,KVal k)) [0..] list))) pk sn + where senseObjects = do + pos <- getGlobalPos pk + rot <- getGlobalRot pk + root <- getRootPrim pk + let fwd = fwdFromRot rot + prims <- rootPrims root + poss <- mapM getGlobalPos (map primKey prims) + let pprims = zip poss prims + statuses <- mapM objectStatus (map primKey prims) + return [ primKey p | ((pos,p),stat) <- zip pprims statuses, withinSensorArea pos fwd range arc pos, stat .&. stype /= 0] + senseAvatars = + if stype .&. cAgent /= 0 then do + pos <- getGlobalPos pk + rot <- getGlobalRot pk + attachKey <- getPrimAttachment pk >>= return . liftM attachmentKey + let fwd = fwdFromRot rot + avs <- allAvs attachKey + return [ avatarKey av | av <- avs, withinSensorArea pos fwd range arc (avatarPosition av)] + else return [] + fwdFromRot rot = let ((x,_,_),(y,_,_),(z,_,_)) = quaternionToMatrix rot in (x,y,z) + angleBetweenV (x0,y0,z0) (x1,y1,z1) = acos (x0*x1 + y0*y1 + z0*z1) + withinSensorArea origin direction range arc pos = + let v = diff3d pos origin + m = mag3d v + v' = norm3d v + in if m == 0 + then True + else m <= range && (angleBetweenV v' direction) <= arc + rootPrims exclude = do + objs <- lift getObjects + mapM getPrim [ k | LSLObject { primKeys = (k:_) } <- M.elems objs, exclude /= k] + objectStatus root = do + LSLObject { primKeys = pks } <- getObject root + stat <- foldM (\ x k -> determineActivePassiveScripted k >>= return . (x .|.)) 0 pks + if (stat .&. cActive /= 0 && stat .&. cPassive /= 0) + then return (stat .&. complement cPassive) + else return stat + allAvs exclude = do + avs <- lift getWorldAvatars + return [ av | av <- M.elems avs, exclude /= Just (avatarKey av)] +processEvent (HTTPRequestEvent (pk,sn) key url method mimetype maxlength verify body) = do + logAMessage LogDebug "sim" "processing an HTTP request event" + handling <- getWorldWebHandling + case handling of + WebHandlingByDoingNothing -> putHTTPTimeoutEvent pk sn key 60 + WebHandlingByFunction -> runAndLogIfErr "problem with handler" () $ do + (moduleName, state) <- lift getWorldEventHandler >>= maybe (throwError "no handler defined") return + lib <- lift getWLibrary + -- invoke the function to get the results + case simFunc lib (moduleName,"httpRequest") state [SVal url, SVal method, SVal mimetype, IVal maxlength, IVal verify, SVal body] of + Left s -> throwError s + Right (SVal msg,results) | not (null msg) -> do + lift $ setWorldEventHandler (Just (moduleName, results)) + throwError msg + | otherwise -> + let IVal status = maybe (IVal 200) id (lookup "outHttpStatus" results >>= ( \ val -> if isIVal val then Just val else Nothing)) + LVal metadata = maybe (LVal []) id (lookup "outHttpMetadata" results >>= ( \ val -> if isLVal val then Just val else Nothing)) + body = maybe (SVal "") id (lookup "outHttpBody" results >>= ( \ val -> if isSVal val then Just val else Nothing)) + events = maybe (LVal []) id (lookup "outEvents" results) + in do lift $ putHTTPResponseEvent pk sn key status metadata body 2 + lift $ processEventsList events + lift $ setWorldEventHandler (Just (moduleName, results)) + Right _ -> throwError ("invalid web handling function, must return a string") + WebHandlingByInternet timeout -> do + let event = SimEvent "http_request" [ + SimEventArg "url" url, + SimEventArg "prim" pk, + SimEventArg "script" sn, + SimEventArg "requestKey" key, + SimEventArg "HTTP_METHOD" method, + SimEventArg "HTTP_MIMETYPE" mimetype, + SimEventArg "HTTP_BODY_MAXLENGTH" (show maxlength), + SimEventArg "HTTP_VERIFY_CERT" (show verify), + SimEventArg "body" body] 0 + (getWorldOutputQueue >>= return . (event:) >>= setWorldOutputQueue) + (getWorldPendingHTTPRequests >>= return . (key:) >>= setWorldPendingHTTPRequests) + -- put a timeout event on the queue. 'real' time and sim time are much different, so the + -- 'real' world timeout is much different + putHTTPTimeoutEvent pk sn key timeout +processEvent (XMLRequestEvent source channel idata sdata) = + runAndLogIfErr "invalid xml request" () $ do + lift $ logAMessage LogInfo "sim" "processing XMLRequestEvent" + (pk,sn) <- lookupScriptFromChan channel <||> throwError ("no such channel" ++ channel) + key <- lift newKey + lift getWorldXMLRequestRegistry >>= return . (M.insert key source) >>= lift . setWorldXMLRequestRegistry + lift $ pushEvent (Event "remote_data" [llcRemoteDataRequest, KVal channel, KVal nullKey, SVal "", IVal idata, SVal sdata] + (M.fromList [("requestKey",KVal key)])) pk sn +processEvent (XMLReplyEvent key channel messageId sdata idata) = do + runAndLogIfErr "invalid xml reply" () $ do + source <- (lift getWorldXMLRequestRegistry >>= mlookup key) <||> throwError "missing source for XML request" + lift (getWorldXMLRequestRegistry >>= return . M.delete key >>= setWorldXMLRequestRegistry) + case source of + XMLRequestInternal tag -> do + (moduleName, state) <- lift getWorldEventHandler >>= maybe (throwError "no handler defined") return + lib <- lift getWLibrary + case simFunc lib (moduleName, "xmlReply") state [SVal tag, SVal channel, SVal sdata, IVal idata] of + Left s -> throwError s + Right (SVal msg, results) | not (null msg) -> do + lift $ setWorldEventHandler (Just (moduleName, results)) + throwError msg + | otherwise -> + let events = maybe (LVal []) id (lookup "outEvents" results) in do + lift $ processEventsList events + lift $ setWorldEventHandler (Just (moduleName, results)) + XMLRequestExternal tag -> do + let event = SimEvent "xml_reply" [ + SimEventArg "tag" tag, + SimEventArg "channel" channel, + SimEventArg "sdata" sdata, + SimEventArg "idata" (show idata)] 0 + lift $ (getWorldOutputQueue >>= return . (event:) >>= setWorldOutputQueue) +processEvent (DialogEvent agent message buttons channel source) = + runAndLogIfErr "invalid dialog event" () $ do + lift getWorldEventHandler >>= (\ mhandler -> case mhandler of + Nothing -> return () + Just (moduleName,state) -> do + lib <- lift getWLibrary + avName <- (lift getWorldAvatars >>= mlookup agent >>= return . avatarName) <||> throwError "problem finding avatar" + objName <- getPrimName source <||> throwError "problem finding object" + case hasFunc lib (moduleName,"dialog") of + Left s -> throwError s + Right False -> return () + Right True -> + case simFunc lib (moduleName, "dialog") state + [SVal avName, SVal message, LVal (map SVal buttons), IVal channel, SVal objName] of + Left s -> throwError s + Right (SVal msg, results) | not (null msg) -> do + warn + lift $ setWorldEventHandler (Just (moduleName, results)) + throwError msg + | otherwise -> + let (IVal selection) = maybe (IVal (-1)) id (lookup "outDialogButtonSelected" results) + events = maybe (LVal []) id (lookup "outEvents" results) + in do + warn + when (selection >= 0 && selection < length buttons) $ + lift $ putChat (Just 20.0) agent channel (buttons !! selection) + lift $ processEventsList events + lift $ setWorldEventHandler (Just (moduleName, results))) + where warn = lift $ logAMessage LogWarn "sim" + "the 'dialog' entry point for the world event handler is deprecated, use the avatar event handler instead" + +processEvent (RezObjectEvent links pos vel rot start pk copy atRoot) = + runAndLogIfErr "invalid rez object event" () $ do + when (null links) $ throwError "empty link set!" + -- reset positions relative to root + let geomCenter = scale3d ( 1 / fromIntegral (length links)) + (foldl' add3d (0,0,0) (map ((flip diff3d (0,0,0)) . primPosition) links)) + let pos' = if atRoot then pos else (pos `add3d` (neg3d geomCenter)) + let update = if copy then (\ p -> updateKeys p) else return + -- TODO: rotation and velocity + links' <- mapM update links + mapM activateScripts links' + let rootKey = primKey (head links') + lift (getObjects >>= return . M.insert rootKey (LSLObject (map primKey links') defaultDynamics { objectPosition = pos' }) >>= setObjects) + lift $ (getPrims >>= (\ m -> return (foldl' (\ m l -> M.insert (primKey l) l m) m links')) >>= setPrims) + lift $ pushEventToObject (Event "on_rez" [IVal start] M.empty) rootKey + lift $ pushEventToPrim (Event "object_rez" [KVal rootKey] M.empty) pk + where activateScripts prim = do + let scripts = [ item | item <- primInventory prim, isInvScriptItem item ] + let activateScriptItem item = + let InvScript id state = inventoryItemData item + name = inventoryItemName item in + activateScript (primKey prim) name id state start + mapM activateScriptItem scripts + updateKeys prim = do + key <- lift newKey + newInventory <- mapM updateItemKeys (primInventory prim) + return $ prim { primKey = key, primInventory = newInventory } + updateItemKeys item = do + key <- lift newKey + let name = inventoryItemName item + newData <- if isInvObjectItem item + then mapM updateKeys (invObjectPrims $ inventoryItemData item) >>= return . InvObject + else return (inventoryItemData item) + return $ item { inventoryItemIdentification = InventoryItemIdentification (name,key), inventoryItemData = newData } +processEvent (ResetScriptEvent pk sn) = + runAndLogIfErr "invalid reset script event" () (resetScript pk sn) +processEvent (DetachCompleteEvent oid ak) = + runAndLogIfErr "invalid detach complete event" () $ do + -- need to remove the object and it's prims and its active scripts from the live lists, but + -- save the script states + avatars <- lift getWorldAvatars + avatar <- mlookup ak avatars + LSLObject { primKeys = links } <- getObject oid + prims <- mapM passivatePrim links + when (null prims) $ throwError "object has no prims!" + let root = head prims + let object = InventoryItem (InventoryItemIdentification (primName root,primKey root)) + (InventoryInfo (primCreator root) (0x0008e000,0x0008e000,0x0008e000,0x0008e000,0x0008e000)) + (InvObject prims) + let avInv = avatarInventory avatar + lift $ setWorldAvatars (M.insert ak (avatar { avatarInventory = object:avInv }) avatars) + objects <- lift getObjects + lift $ setObjects (M.delete oid objects) + where passivatePrim pk = do + scriptItems <- getPrimScripts pk + mapM_ (moveScriptStateToPrim pk) (map inventoryItemName scriptItems) + prims <- lift getPrims + prim <- mlookup pk prims + lift $ setPrims $ M.delete pk prims + return prim + moveScriptStateToPrim pk sn = do + scripts <- lift getWorldScripts + script <- mlookup (pk,sn) scripts + let img = scriptImage script + primInv <- getPrimInventory pk + let (xs,ys) = break (\ item -> sn == inventoryItemName item) primInv + when (null ys) $ throwError ("script inexplicably not in inventory") + (y:ys') <- return ys + let scriptData = inventoryItemData y + lift $ setPrimInventory pk (((y { inventoryItemData = scriptData { invScriptState = Just img } }) : xs) ++ ys) + lift $ setWorldScripts (M.delete (pk,sn) scripts) +processEvent (GiveAvatarInventoryEvent ak item) = logAMessage LogInfo "sim" "giving avatar inventory: not implemented" +processEvent (AvatarOutputEvent ak avEv) = processAvatarOutputEvent ak avEv +processEvent (AvatarInputEvent ak avEv) = processAvatarInputEvent ak avEv +processEvent _ = error "not implemented" + +processEventsList (LVal []) = return () +processEventsList (LVal ((IVal i):l)) = do + processEventList (take i l) + processEventsList (LVal (drop i l)) +processEventsList _ = logAMessage LogWarn "sim" ("user supplied event handler has invalid type for 'outEvents' variable") + +processEventList [SVal "xml_request", SVal sourceId, KVal channel, IVal idata, SVal sdata, FVal delay] = do + putWorldEvent delay (XMLRequestEvent (XMLRequestInternal sourceId) channel idata sdata) +processEventList l = logAMessage LogWarn "sim" ("Invalid event from event handler: " ++ lslShowVal (LVal l)) + +processAvatarOutputEvent k (AvatarTouch {avatarTouchPrimKey = pk, avatarTouchDuration = secs}) = do + touches <- getWorldTouches + now <- getTick + setWorldTouches (M.alter (alt now) pk touches) + where alt start Nothing = Just [newTouch start] + alt start (Just ts) = Just (newTouch start:ts) + newTouch start = Touch {touchAvatarKey = k, touchPrimKey = pk, touchStartTick = start, touchEndTick = start + durationToTicks secs} +processAvatarOutputEvent k (AvatarWhisper {avatarChatChannel = chan, avatarChatMessage = msg}) = avChat 10 msg k chan +processAvatarOutputEvent k (AvatarSay {avatarChatChannel = chan, avatarChatMessage = msg}) = avChat 20 msg k chan +processAvatarOutputEvent k (AvatarShout {avatarChatChannel = chan, avatarChatMessage = msg}) = avChat 100 msg k chan +processAvatarOutputEvent k (AvatarPay {avatarPayPrimKey = pk, avatarPayAmount = val}) = runAndLogIfErr "problem handling avatar payment" () $ + primHasActiveHandler k "money" >>= flip when (lift $ pushEventToPrim (Event "money" [KVal pk, IVal val] M.empty) pk) +processAvatarOutputEvent k (AvatarControl { avatarNewControlBits = newBits }) = runAndLogIfErr "problem processing control change" () $ do + av <- getWorldAvatar k + let prev = avatarControls av + lift $ setWorldAvatar k (av { avatarControls = newBits }) + flip (maybe (return ())) (avatarControlListener av) $ + \ (AvatarControlListener {avatarControlListenerMask = mask, avatarControlListenerScript = (pk,sn)}) -> + lift $ pushEvent (Event "control" [KVal k, IVal newBits, IVal (newBits `xor` prev)] M.empty) pk sn +--processAvatarOutputEvent _ _ = error "not yet implemented(1)" + +avChat range msg key chan = runAndLogIfErr "problem processing chat" () $ do + av <- getWorldAvatar key + lift $ putWorldEvent 0 $ Chat chan (avatarName av) key msg (avatarRegion av,avatarPosition av) (Just range) + +processAvatarInputEvent k inputEvent = runAndLogIfErr "problem processing event for avatar" () $ do + av <- getWorldAvatar k + flip (maybe (return ())) (avatarEventHandler av) $ (\ (moduleName,state) -> do + lib <- lift getWLibrary + case callAvatarEventProcessor k moduleName inputEvent lib state of + Nothing -> return () + Just (Left s) -> throwError s + Just (Right (LVal events,result)) -> do + mapM_ (putAvatarOutputEvent k) events + lift $ setWorldAvatar k (av { avatarEventHandler = Just (moduleName,result) })) + +avEventProcCallInfo (AvatarOwnerSay key msg) = ("onOwnerSay",[SVal key, SVal msg]) +avEventProcCallInfo (AvatarHearsChat name key msg) = ("onChat",[SVal name, SVal key, SVal msg]) +avEventProcCallInfo (AvatarDialog msg buttons chan source) = ("onDialog",[SVal msg, LVal $ map SVal buttons, IVal chan, SVal source]) +avEventProcCallInfo (AvatarLoadURL msg url) = ("onLoadURL",[SVal msg, SVal url]) +avEventProcCallInfo (AvatarMapDestination simName position) = ("onMapDestination",[SVal simName, vec2VVal position]) +callAvatarEventProcessor k moduleName avEvent lib state = + case hasFunc lib (moduleName,funcName) of + Left s -> Just (Left s) + Right True -> Just $ simFunc lib (moduleName, funcName) state args + Right False -> Nothing + where (funcName,args) = avEventProcCallInfo avEvent + +putAvatarOutputEvent k (SVal s) = + case reads s of + ((ev,_):_) -> lift $ putWorldEvent 0 (AvatarOutputEvent k ev) + [] -> lift $ logAMessage LogWarn "sim" ("avatar event handler for " ++ k ++ " returned invalid event: " ++ show s) +putAvatarOutputEvent k v = lift $ logAMessage LogWarn "sim" ("avatar event handler for " ++ k ++ " returned invalid event: " ++ lslShowVal v) + +activateScript pk sn scriptId Nothing startParam = + do wscripts <- lift getWScripts + worldScripts <- lift getWorldScripts + case lookup scriptId wscripts of + Nothing -> lift $ logAMessage LogWarn "sim" ("script " ++ scriptId ++ " not found") + Just (Left s) -> lift $ logAMessage LogWarn "sim" ("script " ++ scriptId ++ " not valid") + Just (Right code) -> + lift $ setWorldScripts + (M.insert (pk,sn) (mkScript (initLSLScript code)) worldScripts) +activateScript pk sn _ (Just image) startParam = do + worldScripts <- lift getWorldScripts + lift $ setWorldScripts + (M.insert (pk,sn) ((mkScript image) { scriptStartParameter = startParam }) worldScripts) + +matchListener (Chat chan' sender' key' msg' (region,position) range) ((Listener pkey sid chan sender key msg),active,(region',position')) = + active && + region == region' && + chan == chan' && + key' /= pkey && + (sender == "" || sender == sender') && + (key == "" || key == nullKey || key == key') && + (msg == "" || msg == msg') && + (case range of + Nothing -> True + Just dist -> dist3d2 position position' <= dist^2) + +listenAddress l = (listenerPrimKey l, listenerScriptName l) + +nextActivity :: (Monad (StateT (World a) a), Monad a) => StateT (World a) a (Maybe Int) +nextActivity = + do scripts <- getWorldScripts + t <- getTick >>= return . (+1) + let ns = foldl' (calcNxt t) Nothing $ M.elems scripts + wq <- getWQueue + let ne = case wq of + [] -> Nothing + ((i,x):_) -> Just $ max t i + return $ mmin ne ns + where calcNxt t n (Script { scriptActive = False }) = n + calcNxt t n (Script { scriptImage = img , scriptEventQueue = q }) = + case executionState img of + Executing -> (Just t) + Suspended _ -> (Just t) + Waiting -> if null q then n else (Just t) + WaitingTil i -> if isNothing n then Just (max t i) else fmap (max t . min i) n + SleepingTil i -> if isNothing n then Just (max t i) else fmap (max t . min i) n + _ -> n + mmin Nothing Nothing = Nothing + mmin Nothing (Just i) = (Just i) + mmin (Just i) Nothing = (Just i) + mmin (Just i) (Just j) = Just (min i j) + +runScripts :: Monad m => WorldM m () +runScripts = + do scripts <- getWorldScripts + mapM_ findAndRunScript (M.keys scripts) + +findAndRunScript scriptKey = + do scripts <- getWorldScripts + case M.lookup scriptKey scripts of + Nothing -> return () + Just script -> checkAndRunScript scriptKey script +checkAndRunScript _ (Script { scriptActive = False }) = return () +checkAndRunScript k@(pkey,sname) (Script {scriptImage = img, scriptEventQueue = q}) = + do pInfo <- getPrimInfo pkey + suspenseInfo <- getWorldSuspended + case suspenseInfo of + Nothing -> run pInfo + Just (suspKey,suspName) | pkey == suspKey && suspName == sname -> run pInfo + | otherwise -> return () + where run pInfo = + case pInfo of + Nothing -> logAMessage LogWarn "sim" ("script " ++ (show k) ++ ": prim not found!") + Just (parent, index, primName) -> runScript parent index pkey sname primName img q +runScript parent index pkey sname primName img q = + do slice <- getSliceSize + tick <- getTick + let img' = img { scriptImageName = sname ++ "/" ++ primName ++ "/" ++ pkey } + let log = logTrace (pkey ++ ":" ++ sname) + --let checkBp _ sm = return (False,sm) + result <- executeLsl img' parent index sname pkey doPredef log getTick setTick checkBp q (tick + slice) + case result of + Left s -> logAMessage LogWarn "sim" ("execution error in script " ++ "(" ++ pkey ++ "," ++ sname ++ ") ->" ++ s) + Right (img'',q') -> do + scripts <- getWorldScripts + let result = M.lookup (pkey,sname) scripts + case result of + Nothing -> do logAMessage LogInfo "sim" ("script seems to have disappeared while executing (result of llDie?)") + Just script -> do + let script' = script { scriptImage = img'', scriptEventQueue = q' } + setWorldScripts (M.insert (pkey,sname) script' scripts) + case executionState img'' of + Suspended bp -> setWorldSuspended (Just (pkey,sname)) + _ -> setWorldSuspended Nothing + + +handleTouches :: Monad m => WorldM m () +handleTouches = do + now <- getTick + before <- getWorldTouchCheckTime + when (now - before > durationToTicks 0.05) $ do + touchLists <- getWorldTouches >>= return . M.toList + runAndLogIfErr "problem handling touches" () $ do + starts <- collectTouches "touch_start" M.empty $ + concatMap (\ (_,tl) -> [ touch | touch@(Touch { touchStartTick = t }) <- tl, t > before]) touchLists + ongoings <- collectTouches "touch" M.empty $ + concatMap + (\ (_,tl) -> [ touch | touch@(Touch { touchStartTick = ts, touchEndTick = te }) <- tl, te >= now && ts <= before]) touchLists + ends <- collectTouches "touch_end" M.empty $ + concatMap (\ (_,tl) -> [ touch | touch@(Touch { touchEndTick = te }) <- tl, te <= now]) touchLists + lift $ mapM_ (uncurry (sendTouch "touch_start")) $ M.toList starts + lift $ mapM_ (uncurry (sendTouch "touch")) $ M.toList ongoings + lift $ mapM_ (uncurry (sendTouch "touch_end")) $ M.toList ends + let nonends = [ (pk,[ t | t@(Touch { touchEndTick = te }) <- list, te > now]) | (pk,list) <- touchLists ] + setWorldTouchCheckTime now + setWorldTouches (M.fromList nonends) + return () + +sendTouch ttype k tl = + pushEventToPrim (Event ttype [IVal $ length tl] payload) k + where payload = foldl' ins M.empty (zip [0..] tl) + ins m (i,(Touch { touchAvatarKey = ak },link)) = + (M.insert ("vector_" ++ show i) (VVal 0 0 0)) . + (M.insert ("key_" ++ show i) (KVal ak)) . + (M.insert ("integer_" ++ show i) (IVal link)) $ m + +collectTouches touchType acc [] = return acc +collectTouches touchType acc (t@(Touch { touchPrimKey = pk }):ts) = do + lneeds <- primHasActiveHandler pk touchType + linkNum <- getPrimLinkNum pk + rk <- getRootPrim pk + if pk == rk && lneeds then collectTouches touchType (M.alter (alt (t,linkNum)) pk acc) ts + else do + pass <- getPrimPassTouches pk + rneeds <- primHasActiveHandler rk touchType + let r = if rneeds && pass then [(rk,(t { touchPrimKey = rk }, linkNum))] else [] + let p = if lneeds then [(pk,(t, linkNum))] else [] + collectTouches touchType (foldl' ( \ m (k,d) -> M.alter (alt d) k m) acc (r ++ p)) ts + where alt i Nothing = Just [i] + alt i (Just l) = Just (i:l) +runPhysics :: Monad m => WorldM m () +runPhysics = do + t0 <- getWorldPhysicsTime + t1 <- getTick + os <- getObjects + let tlist = [t0,(t0+10)..t1] ++ if (t1 - t0) `mod` 10 > 0 then [t1] else [] + let intervals = zip tlist $ tail tlist + forM_ intervals $ \ (t0,t1) -> do + forM_ (M.toList os) $ \ (pk,obj) -> runErrPrim pk () $ do + prim <- getPrim pk + obj <- getObject pk + when ((flip testBit) primPhysicsBit $ primStatus prim) $ do + mass <- objectMass pk + let dyn = objectDynamics obj + let pos0@(_,_,z0) = objectPosition dyn + let vel0@(_,_,vz0) = objectVelocity dyn + let force = (fst (objectForce dyn) `rot3d` rotation) `add3d` (0,0,mass * (objectBuoyancy dyn) * (-gravC)) + where rotation = if snd $ objectForce dyn then objectRotation dyn else (0,0,0,1) + let impulse = ((fst . fst . objectImpulse) dyn `rot3d` rotation, (snd . objectImpulse) dyn) + where rotation = if (snd . fst . objectImpulse) dyn then objectRotation dyn else (0,0,0,1) + let impulseFNow = if snd impulse >= t1 then fst impulse else (0,0,0) + let heightDampF tau z = (0,0, dampZForce tau z z0 mass vz0 fz0) + where (_,_,fz0) = force `add3d` impulseFNow + let dampF = case objectPositionTarget dyn of + Nothing -> (0,0,0) + Just (PositionTarget { positionTargetTau = tau, positionTargetLocation = l }) -> + dampForce tau l pos0 mass vel0 (force `add3d` impulseFNow) + Just (Repel { positionTargetTau = tau, positionTargetHeight = z }) -> + if z0 <= 0.5 * z then heightDampF tau z else (0,0,0) + Just (Hover { positionTargetTau = tau, positionTargetHeight = z}) -> heightDampF tau z + let (pos,vel) = kin t0 t1 ticksToDuration 0 mass pos0 vel0 (force `add3d` dampF) impulse + -- TODO: local vs global rotations in torque + -- TODO: rotational impulses + radius <- objRadius pk + let torque = totalTorque t0 t1 ticksToDuration + [(fst $ objectTorque dyn,t1),(fst $ fst $ objectRotationalImpulse dyn, snd $ objectRotationalImpulse dyn)] + let dampingTorque = case objectRotationTarget dyn of + Nothing -> (0,0,0) + Just rt@(RotationTarget {rotationTargetTau = tau, + rotationTargetStrength = strength, + rotationTarget = target}) -> + dampTorque tau strength target + (objectRotation dyn) mass radius (objectOmega dyn) torque + let (rot,omega) = rotDyn (ticksToDuration (t1 - t0)) radius mass (objectRotation dyn) (objectOmega dyn) + (torque `add3d` dampingTorque) + lift $ setObject pk $! (obj { objectDynamics = (objectDynamics obj) + { objectVelocity = vel, + objectPosition = pos, + objectRotation = rot, + objectOmega = omega }}) + return () + handleCollisions + handleMovers + handleTargets + setWorldPhysicsTime $! t1 + +handleMovers :: Monad m => WorldM m () +handleMovers = runAndLogIfErr "problem determining which objects moved" () $ + do lastPositions <- lift $ getWorldLastPositions + let lastKeys = S.fromList $ M.keys lastPositions + curPositions <- lift getObjects >>= return . M.keys >>= mapM (\ k -> getObjectPosition k >>= return . ((,)k)) + let curKeys = S.fromList $ map fst curPositions + let newKeys = curKeys `S.difference` lastKeys + let keysFromBefore = curKeys `S.difference` newKeys + m <- return . M.fromList =<< mapM ( \ (k,pos) -> if k `S.member` keysFromBefore + then do (moving,lpos) <- mlookup k lastPositions + let moving' = lpos /= pos + when (moving' && not moving) $ + lift $ pushEventToPrim (Event "moving_start" [] M.empty) k + when (moving && not moving') $ + lift $ pushEventToPrim (Event "moving_end" [] M.empty) k + return (k,(moving', pos)) + else return (k,(False,pos))) curPositions + lift $ setWorldLastPositions m + +handleObjectCollisions prims = do + -- look at all non-phantom prims + primBoxes <- mapM (\ (k,p) -> getPrimBox k >>= return . ((,) k ) . ((,)p) ) prims + --let voldtct = map fst $ filter (primVolumeDetect . snd) prims + voldtct <- flip filterM prims (\ (_,prim) -> + let f k = (getObject k >>= return . objectVolumeDetect . objectDynamics) in + case primParent prim of + Nothing -> f (primKey prim) + Just k -> f k + ) >>= return . map fst + let cmp x y = compare (fst x) (fst y) + let curCollisions = S.fromList [ (k0,k1) | ((k0,(p0,_)),(k1,(p1,_))) <- checkIntersections (snd . snd) cmp primBoxes, + primParent p0 /= Just k1 && + primParent p1 /= Just k0 && + not (primParent p0 == primParent p1 && isJust (primParent p0))] + oldCollisions <- lift getWorldCollisions + let formerCollisions = oldCollisions `S.difference` curCollisions + let newCollisions = curCollisions `S.difference` oldCollisions + toObjCollisions newCollisions "collision_start" >>= mapM_ (send "collision_start") + (do + objCollisions <- toObjCollisions curCollisions "collision" + -- filter out volume detect objects, except for those objects that are attatched + let attachment k = do + parent <- getPrimParent k + case parent of + Nothing -> getPrimAttachment k + Just ok -> getPrimAttachment ok + objCollisions' <- (mapM (\ v@(k,_) -> (attachment k >>= return . ((,) v))) objCollisions) + >>= return . (filter (\ ((k,_),mv) -> (k `notElem` voldtct) || isJust mv)) + >>= return . (map fst) + mapM_ (send "collision") objCollisions') + toObjCollisions formerCollisions "collision_end" >>= mapM_ (send "collision_end") + lift $ setWorldCollisions curCollisions + where send :: Monad m => String -> (String,[(Int,String)]) -> ErrorT String (WorldM m) () + send hn (pk,oinfo) = collisionScripts >>= mapM_ (sendScript hn pk oinfo) + where collisionScripts = do + scripts <- getPrimScripts pk >>= return . (map invName) + filterM (\ sn -> scriptHasActiveHandler pk sn hn) scripts + sendScript :: Monad m => String -> String -> [(Int,String)] -> String -> ErrorT String (WorldM m) () + sendScript hn pk oinfo sn = do + scripts <- lift $ getWorldScripts + return () + case M.lookup (pk,sn) scripts of + Nothing -> throwError "can't find script" + Just (Script { scriptCollisionFilter = (name,key,accept) }) + | null name && (null key || nullKey == key) && accept -> pushit oinfo + | null name && (null key || nullKey == key) && not accept -> return () + | accept -> filterM (matchesIn name key) oinfo >>= pushit + | otherwise -> filterM (matchesOut name key) oinfo >>= pushit + where matchesIn name key (_,k) = if k == key + then return True + else (if null key || key == nullKey + then (getPrimName k >>= return . (name==)) + else return False) + matchesOut name key (_,k) = if k == key + then return False + else (if null key || key == nullKey + then (getPrimName k >>= return . not . (name==)) + else return True) + pushit oinfo = unless (null oinfo) $ lift (pushEvent ev pk sn) + where ev = Event hn [IVal $ length oinfo] + (M.fromList $ + (zipWith (\ i (_,k) -> ("key_" ++ show i, KVal k)) [0..] oinfo) ++ + (zipWith (\ i (n,_) -> ("integer_" ++ show i, IVal n)) [0..] oinfo)) + toObjCollisions collisionsS hn = do + passed <- passes primColliders + colliders' <- mapM (\ (k,cs) -> (getPrimLinkNum k >>= \ i -> return (k,i,cs))) primColliders + colliders'' <- mapM pk2ok (colliders' ++ passed) + colliders''' <- mapM (\ (k,i,cs) -> filterM (objectHasVolDetect >=> (return . not)) cs >>= return . ((,,) k i)) colliders'' + return $ M.toList (foldl' combine M.empty (map dist colliders''')) + where collisions = S.toList collisionsS + dist (pk,i,cs) = (pk, zip (repeat i) cs) + combine m (k,lv) = case M.lookup k m of + Nothing -> M.insert k lv m + Just lv' -> M.insert k (lv ++ lv') m + --prims = fromListOfPairs collisions + primColliders = map (\ k -> (k, collectColliders collisions k)) (S.toList $ fromListOfPairs collisions) + passes [] = return [] + passes ((pk,cs):pcs) = do + passed <- pass hn pk + if passed + then do + parent <- getPrimParent pk >>= maybe (throwError "can't get parent") return + rest <- passes pcs + num <- getPrimLinkNum pk + return ((parent,num,cs):rest) + else passes pcs + pk2ok (pk,i,cs) = primsToObjects cs >>= return . ((,,) pk i) + primsToObjects ks = mapM getPrimParent ks >>= (\ parents -> (return (nub $ zipWith fromMaybe ks parents))) + pass hn k = do + parent <- getPrimParent k + case parent of + Nothing -> return False + Just pk -> do + passOverride <- getPrimPassTouches k + pass <- (k `primHasActiveHandler` hn) >>= return . not + return (pass || passOverride) + fromListOfPairs [] = S.empty + fromListOfPairs ((x,y):ps) = (S.insert x . S.insert y) (fromListOfPairs ps) + collectColliders intsns pk = [ j | (Just j) <- map (other pk) intsns] + objectHasVolDetect ok = do + attach <- getPrimAttachment ok + if isJust attach + then return False + else getObject ok >>= return . objectVolumeDetect . objectDynamics + other k (x,y) | k == x = Just y + | k == y = Just x + | otherwise = Nothing + +handleLandCollisions prims = do + primBoxes <- mapM (\ (k,p) -> getPrimBox k >>= return . ((,) k )) prims + let curCollisions = S.fromList [ k | (k,((_,_,z),_)) <- primBoxes, z <= 0] + oldCollisions <- lift getWorldLandCollisions + let formerCollisions = oldCollisions `S.difference` curCollisions + let newCollisions = curCollisions `S.difference` oldCollisions + mapM_ (send "land_collision_end") $ S.toList formerCollisions + mapM_ (send "land_collision") $ S.toList curCollisions + mapM_ (send "land_collision_start") $ S.toList newCollisions + lift $ setWorldLandCollisions curCollisions + where send hn pk = do + pass <- getPrimPassCollisions pk + pos <- getGlobalPos pk >>= ( \ (x,y,_) -> return (x,y,0)) + liveScripts <- getActualPrimScripts pk >>= + (\ ss -> return [ s | s@(_,Script { scriptActive = True }) <- ss]) + when (not $ null liveScripts) $ send' pos pk + when (null liveScripts || pass) $ getRootPrim pk >>= send' pos + where send' pos k = do + scripts <- getPrimScripts k >>= return . (map invName) >>= + filterM (\ sn -> scriptHasActiveHandler k sn hn) + forM_ scripts $ (lift . pushEvent (Event hn [vec2VVal pos] M.empty) k) + +handleCollisions :: (Monad m) => WorldM m () +handleCollisions = runAndLogIfErr "can't handle collisions" () $ do + prims <- getNonPhantomPrims + handleObjectCollisions prims + handleLandCollisions prims + +getNonPhantomPrims :: (Monad m) => ErrorT String (WorldM m) [(String,Prim)] +getNonPhantomPrims = lift getPrims >>= return . M.assocs >>= (return . filter ((==0) . (.&. cStatusPhantom) . primStatus . snd)) + +handleTargets :: Monad m => WorldM m () +handleTargets = do + t <- getTick + t0 <- getWorldTargetCheckTime + when (t - t0 > durationToTicks 0.1) $ do + getObjects >>= return . M.keys >>= mapM_ (\ k -> do + runErrPrim k () $ do + pos <- getGlobalPos k + rot <- getGlobalRot k + scripts <- getActualPrimScripts k + forM_ scripts (\ ((_,sn),script) -> do + forM_ (IM.toList $ scriptPositionTargets script) $ (\ (i,(target,range)) -> + let image = scriptImage script + inRange = (dist3d2 target pos <= range^2) in + if hasActiveHandler image "at_target" && inRange + then lift $ pushEvent (Event "at_target" [IVal i, vec2VVal target, vec2VVal pos] M.empty) k sn + else if hasActiveHandler image "not_at_target" && not inRange + then lift $ pushEvent (Event "not_at_target" [] M.empty) k sn + else return () + ) + forM_ (IM.toList $ scriptRotationTargets script) $ (\ (i,(target,range)) -> + let image = scriptImage script + inRange = (angleBetween target rot <= range) in + if hasActiveHandler image "at_rot_target" && inRange + then lift $ pushEvent (Event "at_rot_target" [IVal i, rot2RVal target, rot2RVal rot] M.empty) k sn + else if hasActiveHandler image "not_at_rot_target" && not inRange + then lift $ pushEvent (Event "not_at_rot_target" [] M.empty) k sn + else return () + ) + ) + + ) + +simulate :: Monad m => WorldM m () +simulate = + do processEvents + runScripts + runPhysics + handleTouches + mn <- nextActivity + t <- getTick + let t' = case mn of + Nothing -> t + 10 + Just n -> min (t + 10) n + setTick t' + --setTick (t + 1) + pauseTime <- getNextPause + suspendInfo <- getWorldSuspended + if t' >= pauseTime || isSuspended suspendInfo then return () else simulate + where isSuspended Nothing = False + isSuspended _ = True + +linkSet = -1::Int +linkAllOthers = -2::Int +linkAllChildren = -3::Int +linkThis = -4::Int + +-- etrace :: Monad m => String -> m () +-- etrace val = trace val $ return () +-- trace1 s val = trace (s ++ ": " ++ show val) val + +-- -------------------------------------------------------------------------------------------- + +data SimCommand = SimContinue { simCmdBreakpoints :: [Breakpoint], simCmdEvents :: [SimEvent] } + | SimStep { simCmdBreakpoints :: [Breakpoint], simCmdEvents :: [SimEvent] } + | SimStepOver { simCmdBreakpoints :: [Breakpoint], simCmdEvents :: [SimEvent] } + | SimStepOut { simCmdBreakpoints :: [Breakpoint], simCmdEvents :: [SimEvent] } deriving (Show) + +data SimStatus = SimEnded { simStatusMessage :: String, simStatusLog :: [LogMessage], simStatusState :: SimStateInfo } | + SimInfo { simStatusEvents :: [SimEvent], simStatusLog :: [LogMessage], simStatusState :: SimStateInfo } | + SimSuspended { simStatusEvents :: [SimEvent], + simStatusSuspendInfo :: ExecutionInfo, + simStatusLog :: [LogMessage], + simStatusState :: SimStateInfo } deriving (Show) + +data SimStateInfo = SimStateInfo { + simStateInfoTime :: Int, + simStateInfoPrims :: [(String,String)], + simStateInfoAvatars :: [(String,String)], + simStateInfoScripts :: [(String,String)] + } deriving (Show) + +nullSimState = SimStateInfo 0 [] [] [] + +stateInfoFromWorld world = + SimStateInfo { + simStateInfoTime = tick world, + simStateInfoPrims = map (\ p -> (primKey p, primName p)) (M.elems $ wprims world), + simStateInfoAvatars = map (\ (_,a) -> (avatarKey a, avatarName a)) (M.toList $ worldAvatars world), + simStateInfoScripts = M.keys (worldScripts world) + } + +data SimInputEventDefinition m = SimInputEventDefinition { + simInputEventName :: String, + simInputEventDescription :: String, + simInputEventParameters :: [SimParam], + simInputEventHandler :: String -> [LSLValue] -> WorldM m () } + +data SimParam = SimParam { simParamName :: String, simParamDescription :: String, + simParamType :: SimParamType } + deriving (Show) +data SimParamType = SimParamPrim | SimParamAvatar | SimParamLSLValue LSLType | SimParamRootPrim | SimParamKey | + SimParamScript + deriving (Show) + +initWorld def scripts lib = worldFromFullWorldDef newWorld def lib scripts + +simStep init@(Left (worldDef, scripts, lib)) command = +-- let world = initWorld worldDef scripts lib in simStep (Right world) command + case initWorld worldDef scripts lib of + Left s -> -- initialization failed + (SimEnded ("Error initializing: " ++ s) [LogMessage 0 LogError "sim" ("Error initializing: " ++ s)] nullSimState, init) + Right world -> simStep (Right world) command +simStep (Right world) command = + let t = tick world + events = simCmdEvents command + newBreakpointManager = replaceBreakpoints (simCmdBreakpoints command) (worldBreakpointManager world) + slice = sliceSize world + newScripts = case worldSuspended world of + Nothing -> worldScripts world + Just (k,s) -> + let Just script = M.lookup (k,s) (worldScripts world) + img = scriptImage script + stepMgr = stepManager img + img' = case command of + SimStep _ _ -> img { stepManager = setStepBreakpoint stepMgr } + SimStepOver _ _ -> img { stepManager = setStepOverBreakpoint stepMgr } + SimStepOut _ _ -> img { stepManager = setStepOutBreakpoint stepMgr } + _ -> img + in M.insert (k,s) (script { scriptImage = img' }) (worldScripts world) + simEventToWorldEvent (SimEvent name args delay) = (t + delay, WorldSimEvent name args) + wq' = putManyWQ (map simEventToWorldEvent events) (wqueue world) + world' = world { wqueue = wq', + nextPause = t + slice, + worldBreakpointManager = newBreakpointManager, + worldScripts = newScripts } + (_,world'') = runIdentity $ runStateT simulate world' + log = msglog world'' + outputEvents = reverse $ worldOutputQueue world'' + world''' = world'' { msglog = [], worldOutputQueue = [] } in + if (tick world''') < (maxTick world''') + then case worldSuspended world''' of + Nothing -> + (SimInfo { simStatusEvents = outputEvents, + simStatusLog = log, + simStatusState = stateInfoFromWorld world''' }, Right world''') + Just (k,s) -> + let Just script = M.lookup (k,s) (worldScripts world''') -- TODO: non-exhaustive but MUST succeed + img = scriptImage script + (Suspended bp) = executionState img -- TODO: non-exhaustive but MUST succeed + executionInfo = ExecutionInfo (breakpointFile bp) (breakpointLine bp) (frameInfo img) + in + (SimSuspended { simStatusEvents = outputEvents, + simStatusSuspendInfo = executionInfo, + simStatusLog = reverse log, + simStatusState = stateInfoFromWorld world''' }, Right world''') + else (SimEnded { simStatusMessage = "ended", + simStatusLog = reverse log, + simStatusState = stateInfoFromWorld world''' }, Right world''') + +-- Event Descriptions and Handlers ------------------------------------------- +------------------------------------------------------------------------------ +--checkArgs def args = do +checkEventArgs def args = + do + when (length params /= length args) $ fail "wrong number of parameters" + mapM (uncurry checkEventArg) argList + where params = simInputEventParameters def + argList = map (\ p -> ( p , find (\ a -> simParamName p == simEventArgName a) args)) params + +checkEventArg (SimParam _ _ SimParamPrim) (Just arg) = return $ KVal (simEventArgValue arg) +checkEventArg (SimParam _ _ SimParamRootPrim) (Just arg) = return $ KVal (simEventArgValue arg) +checkEventArg (SimParam _ _ SimParamScript) (Just arg) = return $ SVal (simEventArgValue arg) +checkEventArg (SimParam name _ SimParamAvatar) (Just arg) = return $ KVal (simEventArgValue arg) +checkEventArg (SimParam name _ SimParamKey) (Just arg) = return $ KVal (simEventArgValue arg) +checkEventArg (SimParam name _ (SimParamLSLValue t)) (Just arg) = + case evaluateExpression t (simEventArgValue arg) of + Nothing -> fail $ ("invalid " ++ (lslTypeString t) ++ " expression" ) + Just v -> return v +checkEventArg (SimParam name _ _) Nothing = fail ("event argument " ++ name ++ " not found") + +handleSimInputEvent def args = + case checkEventArgs def args of + Left s -> logAMessage LogWarn "sim" s + Right argValues -> (simInputEventHandler def) (simInputEventName def) argValues + +mkTouchStartEvent pk nd ak ln = + WorldSimEvent "touch_start" [SimEventArg "Prim Key" pk, SimEventArg "num_detected" nd, + SimEventArg "Avatar key" ak, SimEventArg "Link Number" (show ln)] +mkTouchEvent pk nd ak ln = + WorldSimEvent "touch" [SimEventArg "Prim Key" pk, SimEventArg "num_detected" nd, + SimEventArg "Avatar key" ak, SimEventArg "Grab vector" "<0.0,0.0,0.0>", + SimEventArg "Link Number" (show ln)] +mkTouchEndEvent pk nd ak ln = + WorldSimEvent "touch_end" [SimEventArg "Prim Key" pk, SimEventArg "num_detected" nd, + SimEventArg "Avatar key" ak, SimEventArg "Link Number" (show ln)] + +userTouchEventDef :: Monad m => SimInputEventDefinition m +userTouchEventDef = + SimInputEventDefinition { + simInputEventName = "Touch Prim", + simInputEventDescription = "Avatar touches a prim for a duration", + simInputEventParameters = [ + SimParam "Prim" "The prim the avatar should touch" SimParamPrim, + SimParam "Avatar" "The avatar that should do the touching" SimParamAvatar, + SimParam "Duration" "The duration of the touch (in seconds)" (SimParamLSLValue LLFloat)], + simInputEventHandler = + let f _ [KVal pk, KVal ak, FVal duration] = runAndLogIfErr "can't find prim? " () $ do + -- should we pass touches? + prim <- getPrim pk + linkNum <- getPrimLinkNum pk +-- linkNum <- (case primParent prim of +-- Nothing -> return 0 +-- Just parent -> do +-- LSLObject { primKeys = links } <- getObject parent +-- Just i <- return $ elemIndex pk links +-- return (i + 1)) <||> +-- (do lift $ logAMessage LogWarn "sim" ("can't figure out link number of prim: " ++ pk) +-- return 0) + needstouches <- liftM or $ mapM (primHasActiveHandler pk) ["touch","touch_start","touch_end"] + let touchList = (if needstouches then [pk] else []) ++ + (if (primPassTouches prim || not needstouches) then maybe [] return (primParent prim) else []) + lift $ mapM_ (doTouch linkNum) touchList + where doTouch linkNum k = do + putWorldEvent 0 (mkTouchStartEvent k "1" ak linkNum) + let tdur = floor (1000 * duration) + let tTimes = map ((/1000.0) . fromIntegral) [1,(1 + 500) .. tdur] + mapM_ ((flip putWorldEvent) (mkTouchEvent pk "1" ak linkNum)) tTimes + putWorldEvent duration (mkTouchEndEvent pk "1" ak linkNum) + f name _ = logAMessage LogWarn "sim" ("invalid event activation: " ++ name) + in f + } + +userChatEventDef :: Monad m => SimInputEventDefinition m +userChatEventDef = + SimInputEventDefinition { + simInputEventName = "Chat", + simInputEventDescription = "Avatar chats", + simInputEventParameters = [ + SimParam "Avatar" "The avatar that should do the chatting" SimParamAvatar, + SimParam "Message" "What the avatar should say" (SimParamLSLValue LLString), + SimParam "Channel" "The channel to chat on" (SimParamLSLValue LLInteger)], + simInputEventHandler = + let f _ [KVal ak, SVal message, IVal chan] = do + avatars <- getWorldAvatars + case M.lookup ak avatars of + Nothing -> logAMessage LogWarn "sim" ("avatar with key " ++ ak ++ " not found") + Just av -> do + putWorldEvent 0 $ Chat chan (avatarName av) ak message (avatarRegion av,avatarPosition av) (Just 20.0) + f name _ = logAMessage LogWarn "sim" ("invalid event activation: " ++ name) + in f + } + +eventDescriptors :: Monad m => Map [Char] (SimInputEventDefinition m) +eventDescriptors = M.fromList $ mkEventDefList ([userTouchEventDef,userChatEventDef] ++ rawLslEventDescriptors) + +mkEventDefList eventDefs = map (\ e -> (simInputEventName e, e)) eventDefs + +rawLslEventDescriptors :: Monad m => [SimInputEventDefinition m] +rawLslEventDescriptors = map lslEventDescriptorToSimInputDef lslEventDescriptors + +lslEventDescriptorToSimInputDef (name, params, delivery, additionalData, description) = + SimInputEventDefinition { + simInputEventName = name, + simInputEventDescription = "This is a raw LSL event: " ++ description, + simInputEventParameters = + (case delivery of + EventDeliveryScript -> [SimParam "Script" "name of script to deliver to" SimParamScript, + SimParam "Prim Key" "key of prim to deliver to" SimParamPrim] + EventDeliveryObject -> [SimParam "Object Key" "key of object to deliver to" SimParamRootPrim] + EventDeliveryRoot -> [SimParam "Object Key" "key of object to deliver to" SimParamRootPrim] + EventDeliveryPrim -> [SimParam "Prim Key" "key of prim to deliver to" SimParamPrim] + ) ++ + (flip map additionalData (\ d -> case d of + EventAdditionalInts name description -> SimParam name description (SimParamLSLValue LLInteger) + EventAdditionalKeys name description -> SimParam name description SimParamKey + EventAdditionalAvatarKeys name description -> SimParam name description SimParamAvatar + EventAdditionalVectors name description -> SimParam name description (SimParamLSLValue LLVector))) ++ + map ( \ (t,name) -> SimParam name "" (SimParamLSLValue t)) params, + simInputEventHandler = + let f _ list = + let lenAddl = length additionalData + (df,rest) = case (delivery,list) of + (EventDeliveryScript,SVal sn:KVal pk:vals) -> (\ e -> pushEvent e pk sn,vals) + (EventDeliveryObject,KVal key:vals) -> (\ e -> pushEventToObject e key,vals) + (EventDeliveryRoot, KVal key:vals) -> ((\ e -> pushEventToPrim e key), vals) + (EventDeliveryPrim, KVal key:vals) -> ((\ e -> pushEventToPrim e key), vals) + _ -> (\ _ -> logAMessage LogWarn "sim" "invalid user event - bad script address",[]) + in df (Event name (drop lenAddl rest) (M.fromList (zipWith mkInfo additionalData (take lenAddl rest))) ) + where mkInfo (EventAdditionalVectors _ _) val = ("vector_0",val) + mkInfo (EventAdditionalInts _ _) val = ("integer_0",val) + mkInfo _ val = ("key_0",val) + in f + }
+ src/Language/Lsl/Syntax.hs view
@@ -0,0 +1,966 @@+{-# OPTIONS_GHC -XDeriveDataTypeable -XTypeSynonymInstances -XFlexibleContexts #-} +-- | Defines the abstract syntax tree for LSL (and LSL Plus extensions). +module Language.Lsl.Syntax ( + -- Types + Expr(..), + Var(..), + FuncDec (..), + Func(..), + LModule(..), + Component(..), + Statement(..), + LSLType(..), + Handler(..), + State(..), + GlobDef(..), + LSLScript(..), + Validity, + Global(..), + SourceContext(..), + Ctx(..), + CompiledLSLScript(..), + Library, + AugmentedLibrary, + CodeErr, + CtxVar, + CtxName, + CtxExpr, + CtxStmt, + ModuleInfo, + -- Values + fromMCtx, + ctxItems, + nullCtx, + ctxVr2Vr, + findFunc, + validLSLScript, + validLibrary, + findState, + predefFuncs, + findFuncDec, + goodHandlers, + libFromAugLib, + isTextLocation) where + +import Language.Lsl.Internal.Type(Component(..),LSLType(..),lslTypeString) +import Language.Lsl.Internal.Constants(isConstant,findConstType) +import Language.Lsl.Internal.EventSigs(simpleLslEventDescriptors) +import Language.Lsl.Internal.FuncSigs(funcSigs) +import Data.Data(Data,Typeable) +import Data.List(find,sort,sortBy,nub) +import Language.Lsl.Internal.Util(ctx,findM,lookupM,filtMap,throwStrError) +import Control.Monad(when,foldM,MonadPlus(..)) +import Control.Monad.Error(MonadError(..),Error(..)) +--trace1 s v = trace (s ++ show v) v + +type CtxVar = Ctx Var + +-- | An LSL variable (a name, and a type). +data Var = Var { varName :: String, varType :: LSLType } deriving (Show,Typeable,Data) + +type CtxName = Ctx String + +-- | An LSL function declaration (the function name and type information, without associated +-- statements. +data FuncDec = FuncDec { funcName :: CtxName, funcType :: LSLType, funcParms :: [CtxVar] } + deriving (Show,Typeable,Data) + +type CtxStmt = Ctx Statement +-- | An LSL function definition (return type, parameters and statements. +data Func = Func FuncDec [CtxStmt] deriving (Show,Typeable,Data) + +-- | An LSL Plus module, which is a separately 'compiled' unit that can contain +-- both global variables and functions, but not states or handlers. +data LModule = LModule [GlobDef] [CtxVar] + deriving (Show,Typeable,Data) + +type CtxExpr = Ctx Expr +-- | An LSL expression. +data Expr = IntLit Int + | FloatLit Float + | StringLit String + | ListExpr [CtxExpr] + | VecExpr CtxExpr CtxExpr CtxExpr + | RotExpr CtxExpr CtxExpr CtxExpr CtxExpr + | KeyLit String + | Call CtxName [CtxExpr] + | Add CtxExpr CtxExpr + | Sub CtxExpr CtxExpr + | Mul CtxExpr CtxExpr + | Div CtxExpr CtxExpr + | Mod CtxExpr CtxExpr + | Get (CtxName,Component) + | Set (CtxName,Component) CtxExpr + | BAnd CtxExpr CtxExpr + | BOr CtxExpr CtxExpr + | Xor CtxExpr CtxExpr + | ShiftL CtxExpr CtxExpr + | ShiftR CtxExpr CtxExpr + | And CtxExpr CtxExpr + | Or CtxExpr CtxExpr + | Equal CtxExpr CtxExpr + | NotEqual CtxExpr CtxExpr + | Lt CtxExpr CtxExpr + | Le CtxExpr CtxExpr + | Gt CtxExpr CtxExpr + | Ge CtxExpr CtxExpr + | IncBy (CtxName,Component) CtxExpr + | DecBy (CtxName,Component) CtxExpr + | MulBy (CtxName,Component) CtxExpr + | DivBy (CtxName,Component) CtxExpr + | ModBy (CtxName,Component) CtxExpr + | PostInc (CtxName,Component) + | PostDec (CtxName,Component) + | PreInc (CtxName,Component) + | PreDec (CtxName,Component) + | Not CtxExpr + | Neg CtxExpr + | Inv CtxExpr + | Cast LSLType CtxExpr + | AQString String + | AQInteger String + | AQKey String + | AQFloat String + deriving (Show,Typeable,Data) + +-- | An LSL statement. +data Statement = Compound [CtxStmt] + | While CtxExpr Statement + | DoWhile Statement CtxExpr + | For ([CtxExpr]) (Maybe CtxExpr) ([CtxExpr]) Statement + | If CtxExpr Statement Statement + | Decl Var (Maybe CtxExpr) + | NullStmt + | Return (Maybe CtxExpr) + | StateChange String + | Do CtxExpr + | Label String + | Jump String + deriving (Show,Typeable,Data) + +isLabel (Label _) = True +isLabel _ = False + +-- | An LSL global variable (this is actually not a source level/syntactic entity -- the set of globals +-- for a script is derived after analyzing all included modules. +data Global = GDecl Var (Maybe Expr) + deriving (Show,Typeable,Data) + +-- | A global definition (a function, a variable, or a module import statement). +data GlobDef = GV CtxVar (Maybe CtxExpr) | GF Func | GI CtxName [(String,String)] String + deriving (Show,Typeable,Data) +-- | An LSL event handler definition. +data Handler = Handler CtxName [CtxVar] [CtxStmt] + deriving (Show,Typeable,Data) + +-- | The set of valid handlers supported by LSL. +goodHandlers :: [(String,[LSLType])] +goodHandlers = simpleLslEventDescriptors + +-- | An LSL state definition. +data State = State CtxName [Handler] + deriving (Show,Typeable,Data) + +-- | An LSL script. +data LSLScript = LSLScript [GlobDef] [State] deriving (Show,Typeable,Data) + +type ModuleInfo = ([Global],[Func]) +-- | A collection of modules. +type Library = [(String,Validity LModule)] +-- | A collection of mouldes, augmented with additional derived information. +type AugmentedLibrary = [(String,Validity (LModule,ModuleInfo))] + +lslFunc (name,t,ts) = + FuncDec (nullCtx name) t (zipWith (\ x y -> nullCtx $ Var [y] x) ts ['a'..]) +predefFuncs = map lslFunc funcSigs + +findVar name = find (\(Var n _ ) -> n == name) +findType name = + let f Nothing = Nothing + f (Just (Var _ t )) = Just t in f . (findVar name) +findFuncDec name = ctx ("finding function " ++ name) . findM (\ fd -> ctxItem (funcName fd) == name) +findState name = ctx ("finding state " ++ name) . findM (\ (State n _) -> ctxItem n == name) +findFunc name = ctx ("finding function " ++ name) . findM (\ (Func fd _) -> ctxItem (funcName fd) == name) + +lookupModule name lib = + case lookup name lib of + Nothing -> throwStrError "unknown module" + Just (Left (_,s)) -> throwStrError ("invalid library (" ++ s ++ ")") + Just (Right m) -> return m + +-- A description of an error and where to find it in the source. +type CodeErr = (SourceContext,String) + +-- | An error monad for representing validation errors with respect to LSL code. +type Validity a = Either CodeErr a + +instance Error CodeErr where + noMsg = (UnknownSourceContext,"") + strMsg s = (UnknownSourceContext,s) + +incontext (ctx,s) (Left (ctx',s')) = + case ctx' of + UnknownSourceContext -> Left (ctx,msg) + _ -> Left (ctx',msg) + where msg = if null s then s' else s ++ ": " ++ s' +incontext _ v = v + +incontext' (ctx,s) (Left (_,s')) = Left (ctx,s ++ ": " ++ s') +incontext' _ v = v + +-------------------- +matchTypes LLFloat LLInteger = True +matchTypes dest src = dest == src || (all (`elem` [LLKey,LLString]) [dest,src]) + +typeGlob library prefix (vars,funcs) (GV (Ctx ctx (Var name t)) _) = return ((Var (prefix ++ name) t):vars,funcs) +typeGlob library prefix (vars,funcs) (GF (Func (FuncDec name t params) _)) = + return (vars,(FuncDec (fmap (prefix++) name) t params):funcs) +typeGlob library prefix v@(vars,funcs) (GI moduleName _ prefix') = + do (LModule globs _) <- lookupModule (ctxItem moduleName) library + foldM (typeGlob library (prefix++prefix')) (vars,funcs) globs +typeGlobs library gs = foldM (typeGlob library "") ([],[]) gs + +noDupVars :: [String] -> [CtxVar] -> Validity [String] +noDupVars used [] = return used +noDupVars used ((Ctx ctx (Var n t)):vs) = do + when (n `elem` used) $ throwError (ctx, n ++ " already defined") + noDupVars (n:used) vs + +checkName :: Maybe SourceContext -> String -> [String] -> Validity () +checkName (Just ctx) name names = + when (name `elem` names) $ throwError (ctx, name ++ " is multiply defined") + +noDupGlobs :: Maybe SourceContext -> String -> [String] -> Library -> [GlobDef] -> Validity [String] +noDupGlobs forceCtx prefix usedNames library [] = return usedNames +noDupGlobs forceCtx prefix usedNames library ((GV (Ctx ctx (Var name t)) _):gs) = do + checkName (forceCtx `mplus` Just ctx) globName usedNames + noDupGlobs forceCtx prefix (globName:usedNames) library gs + where globName = prefix ++ name +noDupGlobs forceCtx prefix usedNames library ((GF (Func (FuncDec (Ctx ctx name) t params) _)):gs) = do + checkName (forceCtx `mplus` Just ctx) globName usedNames + noDupGlobs forceCtx prefix (globName:usedNames) library gs + where globName = prefix ++ name +noDupGlobs forceCtx prefix usedNames library ((GI (Ctx ctx moduleName) _ prefix'):gs) = do + (LModule globs _) <- incontext (ctx,"") $ lookupModule moduleName library + usedNames' <- noDupGlobs (forceCtx `mplus` Just ctx) (prefix ++ prefix') usedNames library globs + noDupGlobs forceCtx prefix usedNames' library gs + +data CompiledLSLScript = CompiledLSLScript { + scriptGlobals :: ![Global], + scriptFuncs :: ![Func], + scriptStates :: ![State]} + deriving (Show) + +validLSLScript :: Library -> LSLScript -> Validity CompiledLSLScript +validLSLScript library (LSLScript globs states) = + do --noDupGlobs Nothing "" [] library globs + (typedVars,typedFuncs) <- typeGlobs library globs + let vars = reverse typedVars + let funcDecs = typedFuncs ++ predefFuncs + (globvars,funcs,_,_) <- foldM (validGlob library vars funcDecs) ([],[],[],[]) globs + validStates snames [] vars funcDecs states + return (CompiledLSLScript (reverse globvars) funcs states) + where snames = let sname (State cn _) = ctxItem cn in map sname states +validGlob _ vars funcDecs (globvars,funcs,imports,namesUsed) (GV v mexpr) = + do when (isConstant $ varName v') $ throwError (srcCtx v, varName v' ++ " is a predefined constant") + -- find the vars that are defined prior to this global variable -- only one of these + -- vars may be used to initialize the global variable. + when (varName v' `elem` namesUsed) $ throwError (srcCtx v, varName v' ++ " is already defined") + let (vars',_) = break (\ var -> varName var == varName v') vars + case mexpr of + Nothing -> return (GDecl v' Nothing:globvars,funcs,imports, (varName v'):namesUsed) + Just expr -> do + t <- validCtxSimple vars' expr + let vt = varType v' + when (not (matchTypes vt t)) $ throwError (srcCtx expr, "expression not of the correct type") + return ((GDecl v' $ Just (ctxItem expr)):globvars,funcs,imports, (varName v'):namesUsed) + where v' = ctxItem v +validGlob _ vars funcDecs (globvars,funcs,imports,namesUsed) (GF f@(Func (FuncDec name t params) statements)) = + do noDupVars [] params + when (ctxItem name `elem` namesUsed) $ throwError (srcCtx name, ctxItem name ++ " is already defined") + returns <- validStatements False [] funcDecs vars t [] [[],params'] statements + when (not returns && t /= LLVoid) $ + throwError (srcCtx name, "function " ++ (ctxItem name) ++ ": not all code paths return a value") + return (globvars,f:funcs,imports,(ctxItem name):namesUsed) + where params' = ctxItems params +validGlob library vars funcDecs vstate@(globvars,funcs,imports,namesUsed) (GI (Ctx ctx name) bindings prefix) = + let context = incontext' (ctx,"module " ++ name) in + do let imp = (name,sort bindings,prefix) + if imp `elem` imports + then return (globvars,funcs,imports,namesUsed) + else context $ do + (LModule globs freevars) <- context $ lookupModule name library + context $ validBindings vars freevars bindings + (vars',funcDecs') <- context $ typeGlobs library globs + let renames = bindings ++ (map (\ x -> (x,prefix ++ x)) ((map varName vars') ++ (funcNames funcDecs'))) + (gvs,fs,imports',namesUsed') <- foldM (rewriteGlob prefix library renames ((map ctxItem freevars) ++ vars')) vstate globs + return (gvs,fs,imp:imports',namesUsed') + +rewriteGlob _ _ renames vars (globvars,funcs,imports,namesUsed) (GF (Func (FuncDec name t params) statements)) = + do name' <- incontext (srcCtx name, "renaming function " ++ ctxItem name ++ ", " ++ show renames) $ lookupM (ctxItem name) renames + when (name' `elem` namesUsed) $ throwStrError (name' ++ " imported from module is already defined") + let rewrittenFunc = (Func (FuncDec (Ctx (srcCtx name) name') t params) $ rewriteStatements 0 renames statements) + return (globvars,rewrittenFunc:funcs,imports,name':namesUsed) +rewriteGlob _ _ renames vars (globvars,funcs,imports,namesUsed) (GV (Ctx ctx (Var name t)) mexpr) = + do name' <- incontext (ctx,"renaming variable " ++ name) $ lookupM name renames + when (name' `elem` namesUsed) $ throwStrError (name' ++ " imported from module is already defined") + let rewrittenGlobVar = GDecl (Var name' t) $ + case mexpr of + Nothing -> Nothing + Just expr -> Just $ (ctxItem (rewriteCtxExpr renames expr)) + return (rewrittenGlobVar:globvars,funcs,imports,name':namesUsed) +rewriteGlob prefix0 library renames vars vstate@(globvars,funcs,imports,namesUsed) (GI (Ctx ctx mName) bindings prefix) = + do (LModule globs freevars) <- incontext (ctx, "rewriting module " ++ mName) $ lookupModule mName library + incontext (ctx,"") $ validBindings vars freevars bindings + bindings' <- mapM rewriteBinding bindings + let imp = (mName,sort bindings',prefix0 ++ prefix) + if (imp `elem` imports) + then return (globvars,funcs,imports,namesUsed) + else do + (vars',funcDecs') <- typeGlobs library globs + let renames = bindings' ++ map (\ x -> (x,prefix0 ++ prefix ++ x)) (map varName vars' ++ map (ctxItem . funcName) funcDecs') + (gvs,fs,imports',namesUsed') <- foldM (rewriteGlob (prefix0 ++ prefix) library renames vars') vstate globs + return (gvs,fs,imp:imports',namesUsed') + where rewriteBinding (fv,rn) = lookupM rn renames >>= return . ((,) fv) + +validBindings vars freevars bindings = + if length freevars /= length bindings then + throwStrError ("wrong number of bindings in import: " ++ (show $ length freevars) ++ " required") + else let f [] = return () + f ((x,y):xys) = + case (findType x (ctxItems freevars), findType y vars) of + (Nothing,_) -> throwStrError ("free variable " ++ x ++ " not found") + (_,Nothing) -> throwStrError ("global variable " ++ y ++ " not found") + (Just t0,Just t1) | not (matchTypes t0 t1) -> throwStrError ("types of " ++ x ++ " and " ++ y ++ " don't match") + | otherwise -> f xys + in f bindings + +validState snames used vars funcs (State (Ctx ctx name) handlers) = + do when (name `elem` used) $ throwError (ctx, name ++ " already used") + incontext (ctx,"") $ validHandlers snames [] funcs vars handlers + return name + +validStates snames used vars funcs [] = return () +validStates snames used vars funcs (s:ss) = + do name <- validState snames used vars funcs s + validStates snames (name:used) vars funcs ss + +validCast t0 t1 = + let validCasts = [(LLInteger,LLFloat), (LLFloat,LLInteger), + (LLInteger,LLString),(LLString,LLInteger), + (LLFloat,LLString),(LLString,LLFloat), + (LLString,LLVector),(LLVector,LLString), + (LLString,LLKey),(LLKey,LLString), + (LLRot,LLString),(LLString,LLRot), + (LLList,LLString),(LLString,LLList)] in + do when (t0 /= t1 && (t0,t1) `notElem` validCasts) $ throwStrError ("can't cast from " ++ (lslTypeString t0) ++ " to " ++ (lslTypeString t1)) + +validCtxSimple :: [Var] -> Ctx Expr -> Validity LSLType +validCtxSimple vars (Ctx ctx expr) = incontext (ctx,"") $ validSimple vars expr + +validSimple :: [Var] -> Expr -> Validity LSLType +validSimple vars (IntLit i) = return LLInteger +validSimple vars (FloatLit f) = return LLFloat +validSimple vars (StringLit s) = return LLString +validSimple vars (KeyLit k) = return LLKey +validSimple vars (Get (Ctx ctx name,All)) = + (do (Var _ t) <- incontext (ctx, "variable " ++ name) $ findM (\ v -> varName v == name) vars + return t) + `mplus` (findConstType name) +validSimple vars (Get (Ctx ctx name,_)) = throwError (ctx,"can't access vector/rotation component in global variable initialization") +validSimple vars (ListExpr []) = return LLList +validSimple vars (ListExpr (e:es)) = + do t <- validCtxSimple vars e + when (t == LLList) $ throwError (srcCtx e,"lists cannot contain other lists") + validSimple vars (ListExpr es) +validSimple vars (VecExpr e1 e2 e3) = validSimpleStructure vars LLVector [e1,e2,e3] +validSimple vars (RotExpr e1 e2 e3 e4) = validSimpleStructure vars LLRot [e1,e2,e3,e4] +validSimple vars (Neg e) = + do t <- validCtxSimple vars e + when (t `notElem` [LLFloat, LLInteger]) $ throwError (srcCtx e,"operator only applicable to integers and floats in this context") + return t +validSimple vars e = throwStrError ("expression is not valid in a static context.") + +validSimpleStructure vars t [] = return t +validSimpleStructure vars t (e:es) = + do t' <- validCtxSimple vars e + when (t' `notElem` [LLFloat,LLInteger]) $ throwError (srcCtx e, "literal of type " ++ + (lslTypeString t') ++ " not a valid element of " ++ (lslTypeString t)) + validSimpleStructure vars t es + +validExpression :: Expr -> [FuncDec] -> [Var] -> [[Var]] -> Validity LSLType +validExpression (Cast t expr) funcs vars locals = + do t' <- validCtxExpr expr funcs vars locals + incontext (srcCtx expr, "") $ validCast t' t + return t +validExpression (Get ((Ctx ctx name),component)) funcs vars locals = + case (findType name (concat locals ++ vars) `mplus` findConstType name,component) of + (Nothing,_) -> throwError (ctx, "undefined variable or constant: " ++ name) + (Just LLRot,All) -> return LLRot + (Just LLRot,_) -> return LLFloat + (Just LLVector,All) -> return LLVector + (Just LLVector,S) -> throwError (ctx,"s is not a valid component of a vector") + (Just LLVector,_) -> return LLFloat + (Just t,All) -> return t + (Just t,_) -> throwError (ctx,"only vectors and rotations have components") +validExpression (Call name exprs) funcs vars locals = validCall funcs vars locals name exprs +validExpression (Not expr) funcs vars locals = + do t <- validCtxExpr expr funcs vars locals + when (t /= LLInteger) $ throwError (srcCtx expr, "expression is not an integer expression, which is required for applying the Not operator") + return t +validExpression (Neg expr) funcs vars locals = + do t <- validCtxExpr expr funcs vars locals + when (t == LLList) $ throwError (srcCtx expr, "operator not applicable to list type") + return t +validExpression (Inv expr) funcs vars locals = + do t <- validCtxExpr expr funcs vars locals + when (t /= LLInteger) $ throwError (srcCtx expr, "expression is not an integer expression, which is required for applying the inverse operator") + return t +validExpression plus@(Add expr1 expr2) funcs vars locals = + do (t1,t2) <- validEach (expr1,expr2) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLInteger,LLFloat) -> return LLFloat + (LLFloat,LLInteger) -> return LLFloat + (LLFloat,LLFloat) -> return LLFloat + (LLVector,LLVector) -> return LLVector + (LLRot,LLRot) -> return LLRot + (LLString,LLString) -> return LLString + (LLList,LLList) -> return LLList + (t,LLList) -> return LLList + (LLList,t) -> return LLList + (t0,t1) -> incompatibleOperands plus t0 t1 +validExpression minus@(Sub expr1 expr2) funcs vars locals = + do (t1,t2) <- validEach (expr1,expr2) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLInteger,LLFloat) -> return LLFloat + (LLFloat,LLInteger) -> return LLFloat + (LLFloat,LLFloat) -> return LLFloat + (LLVector,LLVector) -> return LLVector + (LLRot,LLRot) -> return LLRot + (t0,t1) -> incompatibleOperands minus t0 t1 +validExpression expr@(Mul expr1 expr2) funcs vars locals= + do (t1,t2) <- validEach (expr1,expr2) funcs vars locals + case (t1,t2) 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 + (LLFloat,LLVector) -> return LLVector + (LLInteger,LLVector) -> return LLVector + (LLVector,LLVector) -> return LLFloat + (LLVector,LLRot) -> return LLVector + (LLRot,LLRot) -> return LLRot + (t0,t1) -> incompatibleOperands expr t0 t1 +validExpression expr@(Div expr1 expr2) funcs vars locals = + do (t1,t2) <- validEach (expr1,expr2) funcs vars locals + case (t1,t2) 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 + (t0,t1) -> incompatibleOperands expr t0 t1 +validExpression expr@(Mod expr1 expr2) funcs vars locals = + do (t1,t2) <- validEach (expr1,expr2) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLVector,LLVector) -> return LLVector + _ -> incompatibleOperands expr t1 t2 +validExpression e@(Equal expr1 expr2) funcs vars locals = + do (t1,t2) <- validEach (expr1,expr2) funcs vars locals + case (t1,t2) of + (LLInteger,LLFloat) -> return LLInteger + (LLFloat,LLInteger) -> return LLInteger + (LLString,LLKey) -> return LLInteger + (LLKey,LLString) -> return LLInteger + (t1,t2) | (t1 == t2) -> return LLInteger + | otherwise -> incompatibleOperands e t1 t2 +validExpression e@(NotEqual expr1 expr2) funcs vars locals = + do (t1,t2) <- validEach (expr1,expr2) funcs vars locals + case (t1,t2) of + (LLInteger,LLFloat) -> return LLInteger + (LLFloat,LLInteger) -> return LLInteger + (LLString,LLKey) -> return LLInteger + (LLKey,LLString) -> return LLInteger + (t1,t2) | (t1 == t2) -> return LLInteger + | otherwise -> incompatibleOperands e t1 t2 +validExpression e@(BAnd expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals +validExpression e@(BOr expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals +validExpression e@(Xor expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals +validExpression e@(ShiftL expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals +validExpression e@(ShiftR expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals +validExpression e@(Gt expr1 expr2) funcs vars locals = validRelExpr (expr1,expr2) funcs vars locals +validExpression e@(Ge expr1 expr2) funcs vars locals = validRelExpr (expr1,expr2) funcs vars locals +validExpression e@(Le expr1 expr2) funcs vars locals = validRelExpr (expr1,expr2) funcs vars locals +validExpression e@(Lt expr1 expr2) funcs vars locals = validRelExpr (expr1, expr2) funcs vars locals +validExpression e@(And expr1 expr2) funcs vars locals = validBothInteger (expr1, expr2) funcs vars locals +validExpression e@(Or expr1 expr2) funcs vars locals = validBothInteger (expr1, expr2) funcs vars locals +validExpression e@(IncBy (name,All) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLFloat,LLInteger) -> return LLFloat + (LLFloat,LLFloat) -> return LLFloat + (LLVector,LLVector) -> return LLVector + (LLRot,LLRot) -> return LLRot + (LLString,LLString) -> return LLString + (LLList,LLList) -> return LLList + (LLList,t) -> return LLList + (t0,t1) -> incompatibleOperands e t0 t1 +validExpression e@(IncBy (name,_) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat + | otherwise -> incompatibleOperands e t1 t2 +validExpression e@(DecBy (name,All) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLFloat,LLInteger) -> return LLFloat + (LLFloat,LLFloat) -> return LLFloat + (LLVector,LLVector) -> return LLVector + (LLRot,LLRot) -> return LLRot + (t0,t1) -> incompatibleOperands e t0 t1 +validExpression e@(DecBy (name,_) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat + | otherwise -> incompatibleOperands e t1 t2 +validExpression e@(MulBy (name,All) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLFloat,LLInteger) -> return LLFloat + (LLFloat,LLFloat) -> return LLFloat + (LLVector,LLInteger) -> return LLVector + (LLVector,LLFloat) -> return LLVector + (LLVector,LLVector) -> return LLVector -- note: LSL compiles this, but it results in runtime error! + (LLVector,LLRot) -> return LLVector + (LLRot,LLRot) -> return LLRot + (t0,t1) -> incompatibleOperands e t0 t1 +validExpression e@(MulBy (name,_) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat + | otherwise -> incompatibleOperands e t1 t2 +validExpression e@(DivBy (name,All) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLFloat,LLInteger) -> return LLFloat + (LLFloat,LLFloat) -> return LLFloat + (LLVector,LLInteger) -> return LLVector + (LLVector,LLFloat) -> return LLVector + (LLVector,LLRot) -> return LLVector + (LLRot,LLRot) -> return LLRot + (t0,t1) -> incompatibleOperands e t0 t1 +validExpression e@(DivBy (name,_) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat + | otherwise -> incompatibleOperands e t1 t2 +validExpression e@(ModBy (name,All) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLVector,LLVector) -> return LLVector + (t0,t1) -> incompatibleOperands e t0 t1 +validExpression e@(ModBy (name,_) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (t1,t2) -> incompatibleOperands e t1 t2 +validExpression e@(PostInc var) funcs vars locals = validIncDecOp var vars locals "++" +validExpression e@(PostDec var) funcs vars locals = validIncDecOp var vars locals "--" +validExpression e@(PreInc var) funcs vars locals = validIncDecOp var vars locals "++" +validExpression e@(PreDec var) funcs vars locals = validIncDecOp var vars locals "++" +validExpression expr0@(Set (name,All) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (LLFloat,LLInteger) -> return LLFloat + (LLKey,LLString) -> return LLKey + (LLString,LLKey) -> return LLString + (t1,t2) | t1 == t2 -> return t1 + | otherwise -> incompatibleOperands expr0 t1 t2 +validExpression expr0@(Set (name,S) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (LLRot,LLFloat) -> return LLFloat + (LLRot,LLInteger) -> return LLFloat + (t0,t1) -> incompatibleOperands expr0 t0 t1 +validExpression expr0@(Set (name,_) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (LLVector,LLFloat) -> return LLFloat + (LLVector,LLInteger) -> return LLFloat + (LLRot,LLFloat) -> return LLFloat + (LLRot,LLInteger) -> return LLFloat + (t0,t1) -> incompatibleOperands expr0 t0 t1 +validExpression (IntLit i) _ _ _ = return LLInteger +validExpression (FloatLit _) _ _ _ = return LLFloat +validExpression (StringLit _) _ _ _ = return LLString +validExpression (KeyLit _) _ _ _ = return LLKey +validExpression (ListExpr es) fs vs ls = do + mapM (\ e -> validListExprElement e fs vs ls) es + return LLList +validExpression (VecExpr xExpr yExpr zExpr) funcs vars locals = + do xt <- validCtxExpr xExpr funcs vars locals + yt <- validCtxExpr yExpr funcs vars locals + zt <- validCtxExpr zExpr funcs vars locals + when (not (all (`elem` [LLInteger,LLFloat]) [xt,yt,zt])) $ throwStrError "invalid components for vector" + return LLVector +validExpression (RotExpr xExpr yExpr zExpr sExpr) funcs vars locals = + do xt <- validCtxExpr xExpr funcs vars locals + yt <- validCtxExpr yExpr funcs vars locals + zt <- validCtxExpr zExpr funcs vars locals + st <- validCtxExpr sExpr funcs vars locals + when (not (all (`elem` [LLInteger,LLFloat]) [xt,yt,zt,st])) $ throwStrError "invalid components for rotation" + return LLRot +--validExpression x funcs vars locals = error ("what to do with " ++ (show x)) + +validListExprElement (Ctx ctx e) funcs vars locals = do + t <- validExpression e funcs vars locals + when (t `elem` [LLVoid,LLList]) $ throwError (ctx,"invalid type for list element") + return () + +validMExpression Nothing funcs vars locals = return LLVoid +validMExpression (Just expr) funcs vars locals = validCtxExpr expr funcs vars locals + +validExpressions es funcs vars locals = mapM_ (\ e -> validCtxExpr e funcs vars locals) es + +validRelExpr (expr1,expr2) funcs vars locals = + do (t1,t2) <- validEach (expr1,expr2) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLInteger,LLFloat) -> return LLInteger + (LLFloat, LLInteger) -> return LLInteger + (LLFloat, LLFloat) -> return LLInteger + (t0,t1) -> throwStrError ("operands are of incompatible types") +validBothInteger (expr1, expr2) funcs vars locals = + do (t1,t2) <- validEach (expr1,expr2) funcs vars locals + when (t1 /= LLInteger || t2 /= LLInteger) $ throwStrError ("operands are of incompatible types") + return LLInteger +validEach (expr1, expr2) funcs vars locals = + do t1 <- validCtxExpr expr1 funcs vars locals + t2 <- validCtxExpr expr2 funcs vars locals + return (t1,t2) + +validNameExpr (Ctx ctx name, expr) funcs vars locals = + case (findType name (concat locals ++ vars), + validCtxExpr expr funcs vars locals) of + (Just t1, Right t2) -> return (t1,t2) + (Nothing, _) -> throwError (ctx, "variable " ++ name ++ " not defined") + (_,Left s) -> throwError s +validCall funcs vars locals (Ctx ctx fname) exprs = + do (FuncDec _ t params) <- findFuncDec fname funcs + let vArg _ [] [] = return () + vArg _ (p:ps) [] = throwError (ctx, "mismatch of arguments vs. formal paramters in call to function " ++ fname) + vArg _ [] (a:as) = throwError (ctx, "mismatch of arguments vs. formal paramters in call to function " ++ fname) + vArg n (Var name t:ts) (arg:args) = + do t' <- validCtxExpr arg funcs vars locals + when (not (matchTypes t t')) $ throwError (ctx, "argument " ++ (show n) ++ " in call to function (" ++ fname ++ ") is of wrong type:" ++ (lslTypeString t') ++ ", should be " ++ (lslTypeString t)) + vArg (n+1) ts args + vArg 1 (ctxItems params) exprs + return t + +validCtxExpr (Ctx ctx e) fs vs ls = incontext (ctx,"") $ validExpression e fs vs ls + +validIncDecOp (n@(Ctx ctx name),c) vars locals op = + do failIfNoModify n + case (findType name (concat locals ++ vars),c) of + (Nothing,_) -> throwError (ctx, "variable " ++ name ++ " not found") + (Just LLInteger,All) -> return LLInteger + (Just LLFloat,All) -> return LLFloat + (Just LLRot,S) -> return LLFloat + (Just LLVector,S) -> throwError (ctx, "s is not a valid component of " ++ name) + (Just t,All) -> throwError (ctx, name ++ " is not a valid operand for " ++ op) + (Just LLVector,_) -> return LLFloat + (Just LLRot,_) -> return LLFloat + _ -> throwError (ctx, name ++ " is not a valid operand for " ++ op) + +failIfNoModify (Ctx ctx name) = + when (isConstant name) $ throwError (ctx,"cannot modify " ++ name ++ " because it is a constant") + +incompatibleOperands expr t0 t1 = + throwStrError ("types of the operands aren't compatible (" ++ + (lslTypeString t0) ++ " vs. " ++ (lslTypeString t1) ++ ")") + +defined :: String -> [Var] -> Bool +defined n = any (\ (Var n' _) -> n == n') + +validStatement _ _ funcs vars rtype labels locals@(scope:scopes) returns (Decl var@(Var name t) expr) = + do when (defined name $ concat locals) $ throwStrError ("variable " ++ name ++ " already defined") -- can't hide another local, even in a surrounding scope + when (isConstant name) $ throwStrError ("variable " ++ name ++ " is a predefined constant") + case expr of + Nothing -> return ((var:scope):scopes,returns) + Just expr' -> do t' <- validCtxExpr expr' funcs vars locals + when (not $ matchTypes t t') $ throwError (srcCtx expr', "type of expression in declaration of " ++ name ++ " does not match " ++ lslTypeString t) + return ((var:scope):scopes,returns) +validStatement scallow snames funcs vars rtype labels locals returns (While expr statement) = + do t <- validCtxExpr expr funcs vars locals + --when (t /= LLInteger) $ throwError (srcCtx expr, "expression is not a valid loop condition") + validStatement scallow snames funcs vars rtype labels locals False statement + return (locals,returns) +validStatement scallow snames funcs vars rtype labels locals returns (DoWhile statement expr) = + do t <- validCtxExpr expr funcs vars locals + --when (t /= LLInteger) $ throwError (srcCtx expr, "expression is not a valid loop condition") + validStatement scallow snames funcs vars rtype labels locals False statement + return (locals,returns) +validStatement scallow snames funcs vars rtype labels locals returns (For mexpr1 mexpr2 mexpr3 statement) = + do validExpressions mexpr1 funcs vars locals + validExpressions mexpr3 funcs vars locals + t <- validMExpression mexpr2 funcs vars locals + --when (t /= LLInteger) $ throwStrError ("expression is not a valid loop condition") + validStatement scallow snames funcs vars rtype labels locals False statement + return (locals,returns) +validStatement scallow snames funcs vars rtype labels locals returns (If expr thenStmt elseStmt) = + do t <- validCtxExpr expr funcs vars locals + --when (t /= LLInteger) $ throwError (srcCtx expr, "expression is not a valid 'if' condition") + (_,ret1) <- validStatement scallow snames funcs vars rtype labels locals False thenStmt + (_,ret2) <- validStatement scallow snames funcs vars rtype labels locals False elseStmt + return (locals,returns || ret1 && ret2) +validStatement _ _ _ _ _ _ locals returns NullStmt = return (locals,returns) +validStatement _ _ funcs vars rtype labels locals _ (Return Nothing) = + do when (rtype /= LLVoid) (throwStrError "function must return a value") + return (locals,True) +validStatement _ _ funcs vars rtype labels locals _ (Return (Just expr)) = + do t <- validCtxExpr expr funcs vars locals + when (t /= rtype && not (all (`elem` [LLString,LLKey]) [t,rtype])) (throwStrError "inappropriate return type for function/handler") + return (locals,True) +validStatement scallow snames funcs vars rtype labels locals returns (StateChange name) = do + when (not scallow) $ throwStrError "state changes not allowed from this context" + when (not (name `elem` snames)) $ throwStrError (name ++ " is not a valid state") + return (locals,returns) +validStatement _ _ funcs vars rtype labels locals returns (Do expr) = validCtxExpr expr funcs vars locals>>return (locals,returns) +validStatement scallow snames funcs vars rtype labels locals returns (Compound stmts) = + do returns' <- validStatements scallow snames funcs vars rtype labels ([]:locals) stmts + return (locals,returns || returns') +validStatement _ _ funcs vars rtype labels locals _ (Label _) = return (locals,False) +validStatement _ _ funcs vars rtype labels locals returns (Jump s) = + do when (s `notElem` concat labels) $ throwStrError ("no such label to jump to: " ++ s) + return (locals,returns) + +validStatement' scallow snames funcs vars rtype labels locals returns line (Ctx ctx stmt) = + incontext (ctx, "") $ validStatement scallow snames funcs vars rtype labels locals returns stmt + +validStatements :: Bool -> [String] -> [FuncDec] -> [Var] -> LSLType -> [[String]] -> [[Var]] -> [CtxStmt] -> Validity Bool +validStatements scallow snames funcs vars rtype labels locals stmts = + do let newLabels = map (\ (Label s) -> s) $ filter isLabel (ctxItems stmts) + (_,r') <- foldM (\ (l,r) (n, s) -> + validStatement' scallow snames funcs vars rtype (newLabels:labels) l r n s) (locals,False) $ zip ([1..]::[Int]) stmts + return r' + +validHandler snames used funcs vars (Handler (Ctx ctx name) args stmts) = + do when (name `elem` used) $ throwError (ctx,name ++ " already used in state") + types <- incontext (ctx,"handler: ") $ lookupM name goodHandlers + when (types /= map varType args') $ throwError (ctx,"invalid argument types for handler " ++ name) + when (length args /= (length $ nub $ map varName args')) $ throwError (ctx,"not all argument names are unique for handler " ++ name) + validStatements True snames funcs vars LLVoid [] [[],args'] stmts + return name + where args' = ctxItems args + +validHandlers _ _ _ _ [] = return () +validHandlers snames used funcs vars (h:hs) = + do name <- validHandler snames used funcs vars h + validHandlers snames (name:used) funcs vars hs + +-- Validating a library of modules + +-- +validModule library m@(LModule globs freevars) = + do --used <- noDupGlobs Nothing "" [] library globs + (typedVars, typedFuncs) <- typeGlobs library globs + let used = (map varName typedVars) ++ (map (ctxItem . funcName) typedFuncs) + noDupVars used freevars + let vars = freevars' ++ reverse typedVars + let funcDecs = typedFuncs ++ predefFuncs + (vs,fs,_,_) <- foldM (validGlob library vars funcDecs) ([],[],[],[]) globs + return (vs,fs) + where freevars' = ctxItems freevars + +-- this function isn't partiuclarly efficient! +moduleDependencies lib chain m = + let f (GI s _ _) = Just (ctxItem s) + f _ = Nothing + in do (LModule globs _) <- lookupM m lib + case filtMap f globs of + [] -> return [] + list -> if any (`elem` list) (m:chain) then throwStrError "circular dependency" + else + do deps <- fmap concat ( + let chain' = (m:chain) in + mapM (moduleDependencies lib chain') list) + return $ nub (list ++ deps) + +-- sort modules by dependency: for each module in the list, after sorting that module +-- will depend only on modules preceding it in the list. This of course implies that +-- there can be no circular dependencies in the modules. +sortModules :: [(String,(LModule,[String]))] -> [(String,LModule)] +sortModules modules = + let cmp (name,(_,deplist)) (name',(_,deplist')) = compare (length deplist, name) (length deplist', name') + sort1 [] = [] + sort1 list = + let sorted = sortBy cmp list + (nodeps,deps) = span ((==0).length.snd.snd) sorted + exclude = map fst nodeps + newlist = if length nodeps == 0 then error "circular depencencies in library" + else map (\ (nm,(m,l)) -> (nm, (m,filter (`notElem` exclude) l))) deps + in nodeps ++ sort1 newlist + in map (\ (s,(m,_)) -> (s,m)) $ sort1 modules + +validLibrary modules = + let checkDep (n,m) = case moduleDependencies modules [] n of + Right deps -> (n,Right (m,deps)) + Left s -> (n,Left s) + categorize (good,bad) (n,Left s) = (good,(n,s):bad) + categorize (good,bad) (n,Right (m,deps)) = ((n,(m,deps)):good,bad) + (good,bad) = foldl categorize ([],[]) $ map checkDep modules + sorted = sortModules good + validate augLib (name,m) = + case validModule (libFromAugLib augLib) m of + Left s -> (name, Left s):augLib + Right gs -> (name,Right (m,gs)):augLib + in (foldl validate [] sorted) ++ (map (\ (n,s) -> (n,Left s)) bad) + +libFromAugLib :: AugmentedLibrary -> Library +libFromAugLib augLib = + let f (name,Left s) = (name,Left s) + f (name,Right (lm,_)) = (name, Right lm) + in map f augLib + +tstLib = [ + ("alpha", LModule [GI (nullCtx "beta") [] []] []), + ("beta", LModule [GI (nullCtx "gamma") [] []] []), + ("gamma", LModule [GI (nullCtx "alpha") [] []] []), + ("omega", LModule [GI (nullCtx "lambda") [] []] []), + ("lambda", LModule [GI (nullCtx "kappa") [] [], GI (nullCtx "sigma") [] []] []), + ("kappa", LModule [] []), + ("sigma", LModule [] [])] + +rewriteName renames (Ctx ctx name) = + case lookup name renames of + Nothing -> Ctx ctx name + Just name' -> Ctx ctx name' +rewriteStatements _ _ [] = [] +rewriteStatements n bindings (Ctx c s:ss) = + let (n',bindings',s') = rewriteStatement n bindings s in + (Ctx c s'):(rewriteStatements n' bindings' ss) + +rewriteStatement n bindings (Compound stmts) = (n, bindings, Compound $ rewriteStatements n bindings stmts) +rewriteStatement n bindings (While expr stmt) = + let (_,_,stmt') = rewriteStatement n bindings stmt in + (n, bindings, While (rewriteCtxExpr bindings expr) stmt') +rewriteStatement n bindings (DoWhile stmt expr) = + let (_,_,stmt') = rewriteStatement n bindings stmt in + (n, bindings, DoWhile stmt' (rewriteCtxExpr bindings expr)) +rewriteStatement n bindings (For mexpr1 mexpr2 mexpr3 stmt) = + let (_,_,stmt') = rewriteStatement n bindings stmt + rewriteMExpr = rewriteMExpression bindings + rewriteEs = rewriteCtxExprs bindings in + (n, bindings, For (rewriteEs mexpr1) (rewriteMExpr mexpr2) (rewriteEs mexpr3) stmt') +rewriteStatement n bindings (If expr stmt1 stmt2) = + let (_,_,stmt1') = rewriteStatement n bindings stmt1 + (_,_,stmt2') = rewriteStatement n bindings stmt2 in + (n, bindings, If (rewriteCtxExpr bindings expr) stmt1' stmt2') +rewriteStatement n bindings (Decl (Var name t) val) = + let (n',bindings', newname) = + if any (\(name',_) -> name == name') bindings then let newname = "local" ++ (show n) in (n + 1, (name,newname):bindings, newname) + else (n,bindings,name) + in (n',bindings',Decl (Var newname t) (rewriteMExpression bindings val)) +rewriteStatement n bindings (Return Nothing) = (n, bindings, Return Nothing) +rewriteStatement n bindings (Return (Just expr)) = (n, bindings, Return $ Just $ rewriteCtxExpr bindings expr) +rewriteStatement n bindings (Do expr) = (n, bindings, Do $ rewriteCtxExpr bindings expr) +rewriteStatement n bindings s = (n, bindings, s) + +--rewriteExpressions bindings es = map (rewriteExpression bindings) es + +rewriteCtxExpr bindings (Ctx ctx expr) = Ctx ctx $ rewriteExpression bindings expr +rewriteCtxExprs bindings ctxExprs = map (rewriteCtxExpr bindings) ctxExprs + +rewriteExpression _ (IntLit i) = IntLit i +rewriteExpression _ (FloatLit f) = FloatLit f +rewriteExpression _ (StringLit s) = StringLit s +rewriteExpression _ (KeyLit k) = KeyLit k +rewriteExpression bindings (ListExpr l) = ListExpr $ rewriteCtxExprs bindings l +rewriteExpression bindings (VecExpr e1 e2 e3) = VecExpr (rewriteCtxExpr bindings e1) (rewriteCtxExpr bindings e2) (rewriteCtxExpr bindings e3) +rewriteExpression bindings (RotExpr e1 e2 e3 e4) = RotExpr (rewriteCtxExpr bindings e1) (rewriteCtxExpr bindings e2) (rewriteCtxExpr bindings e3) (rewriteCtxExpr bindings e4) +rewriteExpression bindings (Add expr1 expr2) = Add (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) +rewriteExpression bindings (Sub expr1 expr2) = Sub (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) +rewriteExpression bindings (Mul expr1 expr2) = Mul (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) +rewriteExpression bindings (Div expr1 expr2) = Div (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) +rewriteExpression bindings (Mod expr1 expr2) = Mod (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) +rewriteExpression bindings (BAnd expr1 expr2) = BAnd (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) +rewriteExpression bindings (Xor expr1 expr2) = Xor (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) +rewriteExpression bindings (BOr expr1 expr2) = BOr (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) +rewriteExpression bindings (Lt expr1 expr2) = Lt (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) +rewriteExpression bindings (Gt expr1 expr2) = Gt (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) +rewriteExpression bindings (Le expr1 expr2) = Le (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) +rewriteExpression bindings (Ge expr1 expr2) = Ge (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) +rewriteExpression bindings (And expr1 expr2) = And (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) +rewriteExpression bindings (Or expr1 expr2) = Or (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) +rewriteExpression bindings (ShiftL expr1 expr2) = ShiftL (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) +rewriteExpression bindings (ShiftR expr1 expr2) = ShiftR (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) +rewriteExpression bindings (Equal expr1 expr2) = Equal (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) +rewriteExpression bindings (NotEqual expr1 expr2) = NotEqual (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) +rewriteExpression bindings (Inv expr) = Inv $ rewriteCtxExpr bindings expr +rewriteExpression bindings (Not expr) = Not $ rewriteCtxExpr bindings expr +rewriteExpression bindings (Neg expr) = Neg $ rewriteCtxExpr bindings expr +rewriteExpression bindings (Call name exprs) = Call (rewriteName bindings name) $ rewriteCtxExprs bindings exprs +rewriteExpression bindings (Cast t expr) = Cast t $ rewriteCtxExpr bindings expr +rewriteExpression bindings (Get (name,component)) = Get (rewriteName bindings name,component) +--rewriteExpression bindings c@(Const _) = c +rewriteExpression bindings (Set (name,component) expr) = Set (rewriteName bindings name,component) (rewriteCtxExpr bindings expr) +rewriteExpression bindings (IncBy (name,component) expr) = IncBy (rewriteName bindings name,component) (rewriteCtxExpr bindings expr) +rewriteExpression bindings (DecBy (name,component) expr) = DecBy (rewriteName bindings name,component) (rewriteCtxExpr bindings expr) +rewriteExpression bindings (MulBy (name,component) expr) = MulBy (rewriteName bindings name,component) (rewriteCtxExpr bindings expr) +rewriteExpression bindings (DivBy (name,component) expr) = DivBy (rewriteName bindings name,component) (rewriteCtxExpr bindings expr) +rewriteExpression bindings (ModBy (name,component) expr) = ModBy (rewriteName bindings name,component) (rewriteCtxExpr bindings expr) +rewriteExpression bindings e@(PostInc _) = e +rewriteExpression bindings e@(PostDec _) = e +rewriteExpression bindings e@(PreInc _) = e +rewriteExpression bindings e@(PreDec _) = e +rewriteMExpression bindings = fmap (rewriteCtxExpr bindings) + +data SourceContext = TextLocation { textLine0 :: Int, textColumn0 :: Int, textLine1 :: Int, textColumn1 :: Int, textName :: String } | + UnknownSourceContext + deriving (Show,Typeable,Data) + +isTextLocation (TextLocation _ _ _ _ _) = True +isTextLocation _ = False + +-- | A wrapper that can associate a source code context with a value (e.g. a syntax value). +data Ctx a = Ctx { srcCtx :: SourceContext, ctxItem :: a } deriving (Show,Typeable,Data) +instance Functor Ctx where + fmap f (Ctx c v) = (Ctx c $ f v) + +ctxItems = map ctxItem + +fromMCtx :: Maybe (Ctx a) -> Maybe a +fromMCtx = fmap ctxItem + +nullCtx :: a -> Ctx a +nullCtx = Ctx UnknownSourceContext + +funcNames = map (ctxItem.funcName) + +ctxVr2Vr :: (Ctx a,b) -> (a,b) +ctxVr2Vr (Ctx _ name,c) = (name,c)
+ src/Language/Lsl/UnitTest.hs view
@@ -0,0 +1,73 @@+module Language.Lsl.UnitTest( + LSLUnitTest(..), + FuncCallExpectations(..), + ExpectationMode(..), + EntryPoint(..), + Binding, + expectedReturns, + removeExpectation) where + +import Control.Monad(liftM2) +import Data.List(maximumBy) +import Language.Lsl.Internal.Type(LSLValue(..)) +import Language.Lsl.Internal.Exec(Binding(..)) +import Language.Lsl.Internal.Util(removeLookup) + +data FuncCallExpectations = FuncCallExpectations { + expectationMode :: ExpectationMode, + callList :: [((String, [Maybe LSLValue]),LSLValue)] } deriving (Show) + +data ExpectationMode = Nice | Normal | Exhaust | Strict deriving (Show,Eq) + +data EntryPoint = ModuleFunc String String | ScriptFunc String String | ScriptHandler String String String + deriving (Show) + +data LSLUnitTest = LSLUnitTest { + unitTestName :: String, + entryPoint :: EntryPoint, + initialGlobs :: [Binding], + arguments :: [LSLValue], + expectedCalls :: FuncCallExpectations, + expectedReturn :: Maybe LSLValue, + expectedGlobalVals :: [Binding], + expectedNewState :: Maybe String + } deriving (Show) + +argMatch (Just x) y | lslValuesMatch x y = Just 1 + | otherwise = Nothing +argMatch Nothing _ = Just 0 +argsMatch expectArgs args = foldl (liftM2 (+)) (Just 0) $ zipWith argMatch expectArgs args + +lslValuesMatch (FVal a) (FVal b) = a == b || + if a == 0.0 then b < 0.000001 + else if b == 0.0 then a < 0.000001 + else abs ((b - a) / a) < 0.000001 +lslValuesMatch x y = x == y + +matchFail :: Monad m => m a +matchFail = fail "no matching call" + +expectedReturns :: (Monad m) => String -> [LSLValue] -> FuncCallExpectations -> m ((String,[Maybe LSLValue]),LSLValue) +expectedReturns name args (FuncCallExpectations Strict (match@((name',expectArgs),returns):_)) = + if name /= name' || argsMatch expectArgs args == Nothing then matchFail + else return match +expectedReturns name args (FuncCallExpectations Strict _) = matchFail +expectedReturns n a (FuncCallExpectations mode callList) = + let rightNames = filter ((n==) . fst . fst) callList + argMatch (Just x) y | x == y = Just 1 + | otherwise = Nothing + argMatch Nothing _ = Just 0 + argsMatch args expectArgs = foldl (liftM2 (+)) (Just 0) $ zipWith argMatch expectArgs args + ranked = zip (map (argsMatch a) (map (snd . fst) rightNames)) rightNames + orderMatch (Nothing,_) (Nothing,_) = EQ + orderMatch _ (Nothing,_) = GT + orderMatch (Nothing,_) _ = LT + orderMatch ((Just a),_) ((Just b),_) = compare a b + in case ranked of + [] -> fail matchFail + _ -> case maximumBy orderMatch ranked of + (Nothing,_) -> matchFail + (_,e) -> return e + +removeExpectation :: (String,[Maybe LSLValue]) -> FuncCallExpectations -> FuncCallExpectations +removeExpectation m fce = fce { callList = removeLookup m (callList fce) }
+ src/Language/Lsl/UnitTestEnv.hs view
@@ -0,0 +1,270 @@+module Language.Lsl.UnitTestEnv( + simStep, + simFunc, + hasFunc, + SimpleWorld, + TestEvent(..), + ExecutionInfo(..), + ExecCommand(..), + FrameInfo, + TestResult) where + +import Control.Monad(liftM2) +import Control.Monad.State(MonadState(..),State(..),StateT(..),evalState) +import Control.Monad.Error(ErrorT(..)) +import Data.List(find,intersperse) +import Data.Maybe(isJust) +import Language.Lsl.Internal.Breakpoint(Breakpoint,BreakpointManager,checkBreakpoint,emptyBreakpointManager, + replaceBreakpoints,setStepBreakpoint,setStepOverBreakpoint,setStepOutBreakpoint, + breakpointFile,breakpointLine) +import Language.Lsl.Internal.CodeHelper(renderCall) +import Language.Lsl.Internal.FuncSigs(funcSigs) +import Language.Lsl.Internal.InternalLLFuncs(internalLLFuncs) +import Language.Lsl.Syntax hiding (State) +import qualified Language.Lsl.Syntax as L +import Language.Lsl.Internal.Type(LSLValue,lslValString,lslShowVal,defaultValue) +import Language.Lsl.Internal.Evaluation(EvalResult(..)) +import Language.Lsl.Internal.Exec( + EvalState,ExecutionInfo(..),FrameInfo,ScriptImage(..),evalSimple,runEval,scriptImage,setupSimple,initStateSimple,frameInfo) +import Language.Lsl.Internal.TestResult(TestResult(..)) +import Language.Lsl.UnitTest(EntryPoint(..),LSLUnitTest(..),ExpectationMode(..),FuncCallExpectations(..),expectedReturns,removeExpectation) +import Language.Lsl.Internal.Util(findM,ctx) + +--trace1 v = trace ("->>" ++ (show v)) v + +data SimpleWorld = SimpleWorld { + maxTick :: Int, + tick :: Int, + msgLog :: [(Int,String)], + wScripts :: [(String,Validity CompiledLSLScript)], + wLibrary :: [(String,Validity LModule)], + expectations :: FuncCallExpectations, + breakpointManager :: BreakpointManager + } + +type SimpleWorldM = ErrorT String (State SimpleWorld) +simpleWorldM = ErrorT . State +getTick :: SimpleWorldM Int +getTick = get >>= return . tick +getMaxTick :: SimpleWorldM Int +getMaxTick = get >>= return . maxTick +getMsgLog :: SimpleWorldM [(Int,String)] +getMsgLog = get >>= return . msgLog +getWScripts :: SimpleWorldM [(String, Validity CompiledLSLScript)] +getWScripts = get >>= return . wScripts +getWLibrary :: SimpleWorldM [(String, Validity LModule)] +getWLibrary = get >>= return . wLibrary +getExpectations :: SimpleWorldM FuncCallExpectations +getExpectations = get >>= return . expectations +getBreakpointManager :: SimpleWorldM BreakpointManager +getBreakpointManager = get >>= return . breakpointManager + +setTick t = do w <- get; put (w { tick = t }) +setMsgLog l = do w <- get; put (w { msgLog = l }) +setExpectations e = do w <- get; put (w { expectations = e }) +setBreakpointManager bpm = do w <- get; put (w { breakpointManager = bpm }) +modifyMsgLog f = do w <- get; put (w { msgLog = f (msgLog w) }) + +checkBp bp sm = + do bpm <- getBreakpointManager + let (result,bpm',sm') = checkBreakpoint bp bpm sm + setBreakpointManager bpm' + return (result,sm') + +logMsg s = do + tick <- getTick + modifyMsgLog ((tick,s):) + +doPredef n i a = + do logMsg $ "call: " ++ renderCall n a + case lookup n internalLLFuncs of + Just f -> do + result@(m, v) <- f i a + logMsg ("return: " ++ lslShowVal v) + return result + Nothing -> do + fce <- getExpectations + let allowed = Nice == expectationMode fce + case expectedReturns n a fce of + Nothing -> handleUnexpected allowed + Just (m, v) -> do + logMsg ("return: " ++ lslShowVal v) + setExpectations $ removeExpectation m fce + return (EvalIncomplete,v) + where handleUnexpected allowed = + if allowed then + do (_,rt,_) <- ctx ("finding predef " ++ n) $ + findM (\ (n',_,_) -> n' == n) funcSigs + return $ (EvalIncomplete, defaultValue rt) + else fail ("unexpected call: " ++ renderCall n a) + +mkScript (LModule globdefs vars) = + LSLScript (varsToGlobdefs ++ globdefs) [L.State (nullCtx "default") []] + where varsToGlobdefs = map (\ v -> GV v Nothing) vars + +getValidScript name = + do scripts <- getWScripts + case lookup name scripts of + Nothing -> return (Left $ "No such script: " ++ name) + Just (Left s) -> return $ Left $ "Invalid script: " ++ name + Just (Right script) -> return $ Right script + +convertEntryPoint (ScriptFunc scriptName funcName) = + do script <- getValidScript scriptName + return $ liftM2 (,) script (Right [funcName]) +convertEntryPoint (ScriptHandler scriptName stateName handlerName) = + do script <- getValidScript scriptName + return $ liftM2 (,) script (Right [stateName,handlerName]) +convertEntryPoint (ModuleFunc moduleName funcName) = + do lib <- getWLibrary + case lookup moduleName lib of + Nothing -> return (Left $ "No such module: " ++ moduleName) + Just (Left s) -> return (Left $ "Invalid module: " ++ moduleName) + Just (Right lmodule) -> + case validLSLScript lib (mkScript lmodule) of + Left _ -> return $ Left "Invalid entry point (internal error?)" + Right script -> return $ Right (script,[funcName]) + +checkResults (ms1, val, globs, w) unitTest = + let name = unitTestName unitTest + ms0 = expectedNewState unitTest + expectedR = expectedReturn unitTest in + if ((expectationMode $ expectations w) `elem` [Strict,Exhaust]) && + (not (null (callList $ expectations w))) then + FailureResult name ("some expected function calls not made: " ++ + concat (intersperse ", " $ map (fst.fst) $ callList $ expectations w)) + (msgLog w) + else case (ms0, ms1) of + (Nothing, Just st) -> + FailureResult name ("expected no state change, but changed to " ++ st) (msgLog w) + (Just st, Nothing) -> + FailureResult name ("expected state change to " ++ st ++ ", but no change occurred") (msgLog w) + (ms0, ms1) | ms0 /= ms1 -> let (Just s0, Just s1) = (ms0,ms1) in + FailureResult name ("expected state change to " ++ s0 ++ + ", but acutally changed to " ++ s1) (msgLog w) + | otherwise -> + if expectedR /= Nothing && expectedR /= Just val then + let (Just val') = expectedR in + FailureResult name ("expected return value was " ++ (lslValString val') ++ + ", but actually was " ++ (lslValString val)) (msgLog w) + else + case find (`notElem` globs) (expectedGlobalVals unitTest) of + Just (globname,val) -> + case lookup globname globs of + Nothing -> + FailureResult name ("expected global " ++ globname ++ " to have final value of " ++ + (lslValString val) ++ ", but no such global was found") + (msgLog w) + Just val' -> + FailureResult name ("expected global " ++ globname ++ " to have final value of " ++ + (lslValString val) ++ ", but actually had value of " ++ + (lslValString val')) (msgLog w) + Nothing -> SuccessResult name (msgLog w) + +-------------------------------------------------- +-- 'Interactive' testing + +data TestEvent = TestComplete TestResult | TestSuspended ExecutionInfo | AllComplete + +data ExecCommand = ExecContinue [Breakpoint] | ExecStep [Breakpoint] | ExecStepOver [Breakpoint] | + ExecStepOut [Breakpoint] + +breakpointsFromCommand (ExecContinue bps) = bps +breakpointsFromCommand (ExecStep bps) = bps +breakpointsFromCommand (ExecStepOver bps) = bps +breakpointsFromCommand (ExecStepOut bps) = bps + +hasFunc :: [(String,Validity LModule)] -> (String,String) -> Either String Bool +hasFunc lib (moduleName,functionName) = + case converted of + Left s -> Left ("no such module: " ++ moduleName) + Right (Left s) -> Left ("no such module: " ++ moduleName) + Right (Right (script,path)) -> Right $ isJust (findFunc functionName $ scriptFuncs script) + where converted = evalState (runErrorT (convertEntryPoint ep)) world + ep = ModuleFunc moduleName functionName + world = SimpleWorld { maxTick = 10000, tick = 0, msgLog = [], wScripts = [], wLibrary = lib, + expectations = FuncCallExpectations Nice [], breakpointManager = emptyBreakpointManager } + +simFunc :: [(String,Validity LModule)] -> (String,String) -> [(String,LSLValue)] -> [LSLValue] -> Either String (LSLValue,[(String,LSLValue)]) +simFunc lib (moduleName,functionName) globs args = + let world = SimpleWorld { maxTick = 10000, tick = 0, msgLog = [], wScripts = [], wLibrary = lib, + expectations = FuncCallExpectations Nice [], breakpointManager = emptyBreakpointManager } + ep = ModuleFunc moduleName functionName + init = runState (runErrorT ( + do converted <- convertEntryPoint ep + case converted of + Left s -> fail s + Right (script,path) -> + do result <- runEval (setupSimple path globs args) exec + case result of + (Left s, _) -> fail s + (Right (), exec') -> return exec' + where exec = initStateSimple script doPredef logMsg getTick setTick checkBp)) world + in case init of + (Left s, world') -> Left s + (Right exec,world') -> + case (runState $ runErrorT $ (runStateT $ runErrorT $ evalSimple 1000) exec) world of + (Left s,_) -> Left s + (Right r, _) -> + case r of + (Left s,_) -> Left s + (Right (EvalComplete newState, Just val), exec') -> Right (val,glob $ scriptImage exec') + (Right (EvalComplete newState, _),_) -> Left "execution error" + (Right (EvalIncomplete,_),_) -> Left "execution error: timeout" + (Right _,_) -> Left "execution error" + +simSome exec world = runState (runErrorT ( + do maxTick <- getMaxTick + (runStateT $ runErrorT $ evalSimple maxTick) exec)) world + +-- no more tests, not currently executing +simStep _ _ ([], Nothing) _ = (AllComplete,([],Nothing)) +-- not currently executing, more tests +simStep scripts lib (unitTest:tests, Nothing) command = + let world = (SimpleWorld { maxTick = 10000, tick = 0, msgLog = [], + wScripts = scripts, wLibrary = lib, expectations = (expectedCalls unitTest), + breakpointManager = emptyBreakpointManager}) + ep = entryPoint unitTest + globs = initialGlobs unitTest + args = arguments unitTest + name = unitTestName unitTest + init = runState (runErrorT ( + do converted <- convertEntryPoint ep + case converted of + Left s -> fail s + Right (script,path) -> + do result <- runEval (setupSimple path globs args) exec + case result of + (Left s, _) -> fail s + (Right (),exec') -> return exec' + where exec = initStateSimple script doPredef logMsg getTick setTick checkBp)) world + in case init of + (Left s,world') -> (TestComplete $ ErrorResult name s [],(tests, Nothing)) + (Right exec,world') -> simStep scripts lib (unitTest:tests, Just (world',exec)) command +-- currently executing +simStep _ _ (unitTest:tests, Just (world,exec)) command = + let name = unitTestName unitTest + breakpoints = breakpointsFromCommand command + world' = world { breakpointManager = replaceBreakpoints breakpoints (breakpointManager world) } + updateStepManager f ex = let img = scriptImage ex + stepMgr = stepManager img in ex { scriptImage = img { stepManager = f stepMgr } } + execNew = case command of + ExecStep _ -> updateStepManager setStepBreakpoint exec + ExecStepOver _ -> updateStepManager setStepOverBreakpoint exec + ExecStepOut _ -> updateStepManager setStepOutBreakpoint exec + _ -> exec + in + case simSome execNew world' of + (Left s,world'') -> (TestComplete $ ErrorResult name s (msgLog world''),(tests,Nothing)) + (Right res,world'') -> + case res of + (Left s,_) -> (TestComplete $ ErrorResult name s (msgLog world''),(tests,Nothing)) + (Right (EvalComplete newState,Just val), exec') -> (TestComplete checkedResult, (tests,Nothing)) + where checkedResult = checkResults (newState, val, glob $ scriptImage exec', world'') unitTest + (Right (EvalIncomplete,_),_) -> (TestComplete $ Timeout name (msgLog world''),(tests,Nothing)) + (Right (BrokeAt bp,_),exec') -> + (TestSuspended (ExecutionInfo file line frames),(unitTest:tests,Just (world'',exec'))) + where file = breakpointFile bp + line = breakpointLine bp + frames = frameInfo (scriptImage exec') +
+ src/Language/Lsl/WorldDef.hs view
@@ -0,0 +1,821 @@+{-# OPTIONS_GHC -XFlexibleContexts #-} +module Language.Lsl.WorldDef(Avatar(..), + AvatarControlListener(..), + Prim(..), + PrimFace(..), + TextureInfo(..), + Flexibility(..), + LightInfo(..), + LSLObject(..), + ObjectDynamics(..), + PositionTarget(..), + RotationTarget(..), + PrimType(..), + FullWorldDef(..), + Region(..), + Parcel(..), + InventoryItemIdentification(..), + InventoryItem(..), + InventoryInfo(..), + InventoryItemData(..), + Script(..), + ScriptId, + Attachment(..), + CameraParams(..), + Email(..), + WebHandling(..), + -- imported types + LSLValue(..), + Event(..), + ScriptImage, + defaultAvatar, + defaultCamera, + defaultDynamics, + isInvScriptItem, + isInvBodyPartItem, + isInvGestureItem, + isInvClothingItem, + isInvTextureItem, + isInvSoundItem, + isInvAnimationItem, + isInvLandmarkItem, + isInvNotecardItem, + isInvObjectItem, + inventoryInfoPermValue, + defaultInventoryPermissions, + inventoryItemName, + inventoryItemNames, + scriptInventoryItem, + findByInvName, + findByInvKey, + emptyPrim, + primPhantomBit, + primPhysicsBit, + worldFromFullWorldDef, + worldElement, + defaultRegions, + mkScript + ) where + +import Control.Monad(when,foldM) +import Control.Monad.Error(MonadError(..),ErrorT(..)) +import Control.Monad.Writer(tell,lift,runWriterT) + +import qualified Control.Monad.State as SM(get,put,State) +import Data.List(find) +import qualified Data.Map as M +import qualified Data.IntMap as IM +import Data.Maybe(isNothing) + +import Language.Lsl.Internal.DOMProcessing(ElemAcceptor(..),Element(..),findOrDefault,findValueOrDefault,elementList, + findOptionalElement,elementsOnly,findValue,findElement,findSimple,simpleElement, + findSimpleOrDefault,valueAcceptor,elementListWith,matchChoice) +import Language.Lsl.Internal.Evaluation(Event(..)) +import Language.Lsl.Internal.Exec(ScriptImage,initLSLScript) +import Language.Lsl.Internal.Key(mkKey,nullKey) +import Language.Lsl.Internal.Type(LSLValue(..)) +import Language.Lsl.Internal.Util(mlookup,readM,Permutation3(..),rotationsToQuaternion) + +type KeyManagerM = ErrorT String (SM.State (M.Map String String,Integer)) + +type ScriptId = (String,String) + +data FullWorldDef = FullWorldDef { + fullWorldDefMaxTime :: Int, + fullWorldDefSliceSize :: Int, + fullWorldDefWebHandling :: WebHandling, + fullWorldDefEventHandler :: Maybe String, + fullWorldDefObjects :: [LSLObject], + fullWorldDefPrims :: [Prim], + fullWorldDefAvatars :: [Avatar], + fullWorldDefRegions :: [((Int,Int),Region)], + fullWorldDefInitialKeyIndex :: Integer } deriving (Show) + +data WebHandling = WebHandlingByFunction + | WebHandlingByDoingNothing + | WebHandlingByInternet { webHandlingTimeout :: Float } deriving (Show) + +data LSLObject = LSLObject { primKeys :: [String], objectDynamics :: !ObjectDynamics } deriving (Show) + +data ObjectDynamics = ObjectDynamics { + objectPosition :: (Float,Float,Float), + objectRotation :: (Float,Float,Float,Float), + objectVelocity :: (Float,Float,Float), + objectForce :: ((Float,Float,Float),Bool), + objectBuoyancy :: Float, + objectImpulse :: (((Float,Float,Float),Bool),Int), + objectTorque :: ((Float,Float,Float),Bool), + objectRotationalImpulse :: (((Float,Float,Float),Bool),Int), + objectOmega :: (Float,Float,Float), + objectPositionTarget :: !(Maybe PositionTarget), + objectRotationTarget :: !(Maybe RotationTarget), + objectVolumeDetect :: Bool + } deriving (Show) + +defaultDynamics = ObjectDynamics { objectPosition = (0,0,0), + objectRotation = (0,0,0,1), + objectVelocity = (0,0,0), + objectForce = ((0,0,0),False), + objectBuoyancy = 0, + objectImpulse = (((0,0,0),False),0), + objectTorque = ((0,0,0),False), + objectRotationalImpulse = (((0,0,0),False),0), + objectOmega = (0,0,0), + objectPositionTarget = Nothing, + objectRotationTarget = Nothing, + objectVolumeDetect = False } +data PositionTarget = Repel { positionTargetTau :: Float, + positionTargetOverWater :: Bool, + positionTargetHeight :: Float } + | Hover { positionTargetTau :: Float, + positionTargetOverWater :: Bool, + positionTargetHeight :: Float } + | PositionTarget { positionTargetTau :: Float, + positionTargetLocation :: (Float,Float,Float), + positionTargetSetBy :: ScriptId } + deriving (Show) + +data RotationTarget = RotationTarget { rotationTarget :: (Float,Float,Float,Float), + rotationTargetStrength :: Float, + rotationTargetTau :: Float } deriving (Show) + +data Avatar = Avatar { avatarKey :: String, + avatarName :: String, + avatarActiveGroup :: Maybe String, + avatarRegion :: (Int,Int), + avatarPosition :: (Float,Float,Float), + avatarRotation :: (Float,Float,Float,Float), + avatarHeight :: Float, + avatarState :: Int, + avatarInventory :: [InventoryItem], + avatarCameraPosition :: (Float,Float,Float), + avatarCameraRotation :: (Float,Float,Float,Float), + avatarCameraControlParams :: CameraParams, + avatarActiveAnimations :: [(Maybe Int,String)], + avatarAttachments :: IM.IntMap String, + avatarEventHandler :: !(Maybe (String,[(String,LSLValue)])), + avatarControls :: !Int, + avatarControlListener :: !(Maybe AvatarControlListener) } deriving (Show) + +data AvatarControlListener = AvatarControlListener { avatarControlListenerMask :: !Int, avatarControlListenerScript :: !(String,String) } deriving (Show) + +data CameraParams = CameraParams { cameraActive :: Bool, + cameraBehindednessAngle :: Float, + cameraBehindednessLag :: Float, + cameraDistance :: Float, + cameraFocus :: Maybe (Float,Float,Float), + cameraFocusLag :: Float, + cameraFocusLocked :: Bool, + cameraFocusOffset :: (Float,Float,Float), + cameraFocusThreshold :: Float, + cameraPitch :: Float, + cameraPosition :: Maybe (Float,Float,Float), + cameraPositionLag :: Float, + cameraPositionLocked :: Bool, + cameraPositionThreshold :: Float } deriving Show +defaultCamera = CameraParams { cameraActive = False, + cameraBehindednessAngle = 10.0, + cameraBehindednessLag = 0, + cameraDistance = 3.0, + cameraFocus = Nothing, + cameraFocusLag = 0, + cameraFocusLocked = False, + cameraFocusOffset = (0,0,0), + cameraFocusThreshold = 1.0, + cameraPitch = 0.0, + cameraPosition = Nothing, + cameraPositionLag = 0.1, + cameraPositionLocked = False, + cameraPositionThreshold = 1 } + +defaultAvatar key = + Avatar { avatarKey = key, + avatarName = "Default Avatar", + avatarActiveGroup = Nothing, + avatarRegion = (0,0), + avatarPosition = (128.0,128.0,0.0), + avatarRotation = (0.0, 0.0, 0.0, 1.0), + avatarHeight = 2, + avatarState = 0, + avatarInventory = [], + avatarCameraPosition = (128.0,128.0,0.0), + avatarCameraRotation = (0,0,0,1), + avatarCameraControlParams = defaultCamera, + avatarActiveAnimations = [], + avatarAttachments = IM.empty, + avatarEventHandler = Nothing, + avatarControls = 0, + avatarControlListener = Nothing } + +-- these are bit INDEXES not MASKS (0 == least significant bit) +primPhantomBit :: Int +primPhantomBit = 4 +primPhysicsBit :: Int +primPhysicsBit = 0 + +data InventoryItemData = InvScript { invScriptLibId :: String, invScriptState :: Maybe ScriptImage } + | InvBodyPart + | InvGesture + | InvClothing + | InvTexture + | InvSound { invSoundDuration :: Float } + | InvAnimation { invAnimationDuration :: Maybe Float } + | InvLandmark { invLandmarkLocation :: ((Int,Int),(Float,Float,Float)) } + | InvNotecard { invNotecardLines :: [String] } + | InvObject { invObjectPrims :: [Prim] } deriving (Show) +isInvScript (InvScript _ _) = True +isInvScript _ = False +isInvBodyPart InvBodyPart = True +isInvBodyPart _ = False +isInvGesture InvGesture = True +isInvGesture _ = False +isInvClothing InvClothing = True +isInvClothing _ = False +isInvTexture InvTexture = True +isInvTexture _ = False +isInvSound (InvSound _) = True +isInvSound _ = False +isInvAnimation (InvAnimation _) = True +isInvAnimation _ = False +isInvLandmark (InvLandmark _) = True +isInvLandmark _ = False +isInvNotecard (InvNotecard _) = True +isInvNotecard _ = False +isInvObject (InvObject _) = True +isInvObject _ = False + +isInvScriptItem = isInvScript . inventoryItemData +isInvBodyPartItem = isInvBodyPart . inventoryItemData +isInvGestureItem = isInvGesture . inventoryItemData +isInvClothingItem = isInvClothing . inventoryItemData +isInvTextureItem = isInvTexture . inventoryItemData +isInvSoundItem = isInvSound . inventoryItemData +isInvAnimationItem = isInvAnimation . inventoryItemData +isInvLandmarkItem = isInvLandmark . inventoryItemData +isInvNotecardItem = isInvNotecard . inventoryItemData +isInvObjectItem = isInvObject . inventoryItemData + +newtype InventoryItemIdentification = InventoryItemIdentification { inventoryItemNameKey :: (String,String) } deriving (Show) +-- data InventoryItem a = InventoryItem { inventoryItemIdentification :: InventoryItemIdentification, +-- inventoryItemInfo :: InventoryInfo, +-- inventoryItemData :: a } deriving (Show) +data InventoryInfo = InventoryInfo { inventoryInfoCreator :: String, + --inventoryInfoOwner :: String, + inventoryInfoPerms :: (Int,Int,Int,Int,Int) } deriving (Show) +data InventoryItem = InventoryItem { inventoryItemIdentification :: InventoryItemIdentification, + inventoryItemInfo :: InventoryInfo, + inventoryItemData :: InventoryItemData } deriving (Show) + +--inventoryItemInfoMap = map ( \ item -> (inventoryItemIdentification item, inventoryItemInfo item)) +inventoryItemName = fst . inventoryItemNameKey . inventoryItemIdentification +inventoryItemNames = map inventoryItemName +scriptInventoryItem s k id = InventoryItem (InventoryItemIdentification (s,k)) (InventoryInfo "" defaultInventoryPermissions) (InvScript id Nothing) +inventoryItemIdentifications = map inventoryItemIdentification +findByInvName name = find ((== name) . (fst . inventoryItemNameKey . inventoryItemIdentification)) +findByInvKey key = find ((== key) . (snd . inventoryItemNameKey . inventoryItemIdentification)) + +inventoryInfoPermValue 0 (i,_,_,_,_) = return i +inventoryInfoPermValue 1 (_,i,_,_,_) = return i +inventoryInfoPermValue 2 (_,_,i,_,_) = return i +inventoryInfoPermValue 3 (_,_,_,i,_) = return i +inventoryInfoPermValue 4 (_,_,_,_,i) = return i +inventoryInfoPermValue i _ = throwError ("no such perm mask - " ++ show i) + +defaultInventoryPermissions :: (Int,Int,Int,Int,Int) +defaultInventoryPermissions = (0xffffffff,0xffffffff,0xffffffff,0xffffffff,0xffffffff) + +data Prim = Prim { + primName :: String, + primKey :: String, + primParent :: Maybe String, + primDescription :: String, + primInventory :: [InventoryItem], + primOwner :: String, + primGroup :: Maybe String, + primCreator :: String, + primPosition :: (Float, Float, Float), + primRotation :: (Float, Float, Float, Float), + primScale :: (Float, Float, Float), + primFaces :: [PrimFace], + primFlexibility :: Maybe Flexibility, + primMaterial :: Int, + primStatus :: Int, + primVehicleFlags :: Int, + primLight :: Maybe LightInfo, + primTempOnRez :: Bool, + primTypeInfo :: PrimType, + primPermissions :: [Int], + primAllowInventoryDrop :: Bool, + primSitTarget :: Maybe ((Float,Float,Float),(Float,Float,Float,Float)), + primSittingAvatar :: Maybe String, + primPendingEmails :: [Email], + primPassTouches :: Bool, + primPassCollisions :: Bool, + primPayInfo :: (Int,Int,Int,Int,Int), + primAttachment :: Maybe Attachment, + primRemoteScriptAccessPin :: Int } deriving (Show) + +data PrimType = PrimTypeUnknown + | PrimType { + primVersion :: Int, -- 1 or 9 + primTypeCode :: Int, + primHoleshape :: Int, + primCut :: (Float,Float,Float), + primTwist :: (Float,Float,Float), + primHolesize :: (Float,Float,Float), + primTopshear :: (Float, Float, Float), + primHollow :: Float, + primTaper :: (Float,Float,Float), + primAdvancedCut :: (Float,Float,Float), + primRadiusOffset :: Float, + primRevolutions :: Float, + primSkew :: Float, + primSculptTexture :: Maybe String, + primSculptType :: Int + } deriving (Show) + +basicBox = PrimType 9 0 0 (0,1,0) (0,0,0) (0,0,0) (0,0,0) 0 (0,0,0) (0,1,0) 0 0 0 Nothing 0 + +data Attachment = Attachment { attachmentKey :: String, attachmentPoint :: Int } deriving (Show) + +data LightInfo = LightInfo { + lightColor :: (Float,Float,Float), + lightIntensity :: Float, + lightRadius :: Float, + lightFalloff :: Float + } deriving (Show) + +data Flexibility = Flexibility { + flexSoftness :: Int, + flexGravity :: Float, + flexFriction :: Float, + flexWind :: Float, + flexTension :: Float, + flexForce :: (Float,Float,Float) + } deriving (Show) + +data PrimFace = PrimFace { + faceAlpha :: Float, + faceColor :: (Float,Float,Float), + faceShininess :: Int, + faceBumpiness :: Int, + faceFullbright :: Bool, + faceTextureMode :: Int, + faceTextureInfo :: TextureInfo + } deriving (Show) + +defaultFace = PrimFace 1.0 (1.0,1.0,1.0) 0 0 False 0 defaultTextureInfo + +data TextureInfo = TextureInfo { + textureKey :: String, + textureRepeats :: (Float,Float,Float), + textureOffsets :: (Float,Float,Float), + textureRotation :: Float + } deriving (Show) + +defaultTextureInfo = TextureInfo "" (1.0,1.0,0.0) (0.0,0.0,0.0) 0.0 + +data Email = Email { + emailSubject :: String, + emailAddress :: String, -- sender address + emailMessage :: String, + emailTime :: Int } deriving (Show) + +emptyPrim name key = + Prim { primName = name, + primKey = key, + primParent = Nothing, + primDescription = "", + primInventory = [], + primOwner = "", + primGroup = Nothing, + primCreator = "", + primPosition = (0.0,0.0,0.0), + primRotation = (0.0,0.0,0.0,1.0), + primScale = (1.0,1.0,1.0), + primFaces = replicate 6 defaultFace, + primFlexibility = Nothing, + primMaterial = 0, + primStatus = 0x0e, + primVehicleFlags = 0, + primLight = Nothing, + primTempOnRez = False, + primTypeInfo = basicBox, + primPermissions = [0], + primAllowInventoryDrop = False, + primSitTarget = Nothing, + primSittingAvatar = Nothing, + primPendingEmails = [], + primPassTouches = False, + primPassCollisions = False, + primPayInfo = ( -2, -2, -2, -2, -2), + primAttachment = Nothing, + primRemoteScriptAccessPin = 0 } + +data Region = Region { + regionName :: String, + regionFlags :: Int, + regionParcels :: [Parcel] + } deriving (Show) + +data Parcel = Parcel { + parcelName :: String, + parcelDescription :: String, + parcelBoundaries :: (Int,Int,Int,Int), -- bottom, top, left, right aka south,north,west,east + parcelOwner :: String, + parcelFlags :: Int, + parcelBanList :: [(String,Maybe Int)], + parcelPassList :: [(String,Maybe Int)] + } deriving (Show) + +defaultRegions :: String -> [((Int,Int),Region)] +defaultRegions owner = [ + ((0,0), Region { regionName = "Region_0_0", regionFlags = 0, + regionParcels = [Parcel "parcel_0" "default parcel" (0,256,0,256) owner 0xffffffff [] []] }) + ] + +data Script = Script { scriptImage :: !ScriptImage, + scriptActive :: Bool, + scriptPermissions :: M.Map String Int, + scriptLastPerm :: Maybe String, + scriptStartTick :: Int, + scriptLastResetTick :: Int, + scriptEventQueue :: [Event], + scriptStartParameter :: Int, + scriptCollisionFilter :: !(String,String,Bool), + scriptTargetIndex :: !Int, + scriptPositionTargets :: !(IM.IntMap ((Float,Float,Float), Float)), + scriptRotationTargets :: !(IM.IntMap ((Float,Float,Float,Float), Float)) } deriving (Show) + +mkScript img = Script { scriptImage = img, + scriptActive = True, + scriptPermissions = M.empty, + scriptLastPerm = Nothing, + scriptStartTick = 0, + scriptLastResetTick = 0, + scriptEventQueue = [Event "state_entry" [] M.empty], + scriptStartParameter = 0, + scriptCollisionFilter = ("",nullKey,True), + scriptTargetIndex = 0, + scriptPositionTargets = IM.empty, + scriptRotationTargets = IM.empty } + +worldFromFullWorldDef worldBuilder fwd lib scripts = + do let primMap = mkPrimMap (fullWorldDefPrims fwd) + primMap' <- checkObjects primMap (fullWorldDefObjects fwd) -- prove all the prims in all the objects exists + let activeScripts = + concat (map (\ prim -> map + (\ item -> ((primKey prim, fst $ inventoryItemNameKey $ inventoryItemIdentification item), + invScriptLibId $ inventoryItemData item)) (filter isInvScriptItem $ primInventory prim)) (M.elems primMap')) + (activatedScripts,log) <- runWriterT (activateScripts activeScripts scripts primMap') + return $ worldBuilder (fullWorldDefSliceSize fwd) + (fullWorldDefMaxTime fwd) + [] lib scripts + (M.fromList $ mkAvatarLookup (fullWorldDefAvatars fwd)) + (mkObjectMap (fullWorldDefObjects fwd)) + primMap' + (M.fromList activatedScripts) + (M.fromList (fullWorldDefRegions fwd)) + (fullWorldDefInitialKeyIndex fwd) + (fullWorldDefWebHandling fwd) + (fullWorldDefEventHandler fwd) + log + +fctx :: MonadError String m => String -> Either String a -> m a +fctx s (Left s') = throwError s +fctx _ (Right v) = return v + +maybe2Either Nothing = Left "failed" +maybe2Either (Just v) = Right v + +mkPrimMap prims = M.fromList [(primKey p, p) | p <- prims] + --let tuples = map (\ p -> (primKey p, p)) prims in M.fromList tuples +mkObjectMap objects = M.fromList [ (p, o) | o@(LSLObject { primKeys = (p:_) }) <- objects ] +mkAvatarLookup avatars = [ (avatarKey a,a) | a <- avatars] + +checkObject primMap o = + foldM checkPrim primMap (primKeys o) + where root = head (primKeys o) + checkPrim m k = + case M.lookup k m of + Nothing -> fail ("prim " ++ k ++ " not found in definition") + Just prim -> + return (if (k == root) then m + else M.insert k (prim { primParent = Just root }) m) + +checkObjects primMap os = foldM checkObject primMap os + +activateScripts scriptIdInfo compiledScripts primMap = + mapM (activateScript compiledScripts primMap) scriptIdInfo >>= (\ ms -> return [ s | Just s <- ms ]) + +activateScript scripts primMap (k@(primKey,invName),(scriptID)) = + do let script = case lookup scriptID scripts of + Nothing -> fail "script not found" + Just v -> v + prim <- (lift . fctx ("looking up prim " ++ primKey ++ " failed")) (mlookup primKey primMap) + when (isNothing (findByInvName invName (primInventory prim))) $ fail (invName ++ " doesn't exist in prim " ++ primKey) + case script of + Left (_,s) -> tell [("script \"" ++ invName ++ "\" in prim " ++ primKey ++ " failed to activate because of error: " ++ s)] + >> return Nothing + Right code -> return $ Just (k,mkScript $ initLSLScript code) + +newKey xref = do + (m,i) <- lift SM.get + let k = mkKey i + let m' = case xref of + Nothing -> m + Just v -> M.insert v k m + lift $ SM.put (m',i+1) + return k + +findRealKey k = lift SM.get >>= mlookup k . fst + +--worldElement :: ElemAcceptor KeyManagerM FullWorldDef +worldElement = + let f (Elem _ _ contents) = do + (maxTime, c1) <- findValue "maxTime" (elementsOnly contents) + (handler, c2) <- findOptionalElement (simpleElement "simEventHandler") c1 + (sliceSizeStr, c3) <- findSimple "sliceSize" c2 + (avatars,c4) <- findElement avatarsElement c3 + (prims,c5) <- findElement primsElement c4 + (objects,[]) <- findElement objectsElement c5 + sliceSize <- readM sliceSizeStr + (m,keyIndex) <- lift SM.get + let webHandling = if isNothing handler then WebHandlingByDoingNothing else WebHandlingByFunction + return $ (FullWorldDef maxTime sliceSize webHandling handler objects prims avatars (defaultRegions "") keyIndex) + in ElemAcceptor "world-def" f + +activeScriptsElement :: ElemAcceptor KeyManagerM [((String,String),String)] +activeScriptsElement = elementList "scripts" activeScriptElement + +activeScriptElement :: ElemAcceptor KeyManagerM ((String,String),String) +activeScriptElement = ElemAcceptor "script" $ + \ (Elem _ _ contents) -> do + (primKey,c1) <- findSimple "primKey" (elementsOnly contents) + realPrimKey <- findRealKey primKey + (scriptName, c2) <- findSimple "scriptName" c1 + (scriptId, []) <- findSimple "scriptId" c2 + return $ ((realPrimKey,scriptName), scriptId) + +objectsElement :: ElemAcceptor KeyManagerM [LSLObject] +objectsElement = elementList "objects" objectElement + +objectElement :: ElemAcceptor KeyManagerM LSLObject +objectElement = ElemAcceptor "object" $ + \ (Elem _ _ contents) -> do + (position,c) <- findOrDefault (0,0,0) (vecAcceptor "position") (elementsOnly contents) + (primKeys,[]) <- findElement (elementList "primKeys" (simpleElement "string")) c + --(m,i) <- lift SM.get + realPrimKeys <- mapM findRealKey primKeys + return $ LSLObject realPrimKeys (defaultDynamics { objectPosition = position }) + +primsElement :: ElemAcceptor KeyManagerM [Prim] +primsElement = elementList "prims" primElement + +primElement :: ElemAcceptor KeyManagerM Prim +primElement = ElemAcceptor "prim" $ + \ (Elem _ _ contents) -> do + (name,c1) <- findSimple "name" (elementsOnly contents) + (key,c2) <- findSimple "key" c1 + realKey <- newKey (Just key) + (description, c3) <- findSimpleOrDefault "" "description" c2 + (scripts,c4) <- findElement (elementList "scripts" (scriptAcceptor "script")) c3 + (owner,c5) <- findSimpleOrDefault "" "owner" c4 + realOwner <- findRealKey owner + (position,c6) <- findOrDefault (128.0,128.0,0.0) (vecAcceptor "position") c5 + (eulerRotation,c7) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "rotation") c6 + (scale,c8) <- findOrDefault (1.0,1.0,1.0) (vecAcceptor "scale") c7 + (faces,c9) <- findOrDefault (replicate 6 defaultFace) (elementList "faces" (faceAcceptor "face")) c8 + (flexibility,c10) <- findOptionalElement (flexibilityAcceptor "flexibility") c9 + (material,c11) <- findValueOrDefault 0 "material" c10 + (status,c12) <- findValueOrDefault 0x0e "status" c11 + (light,c13) <- findOptionalElement (lightAcceptor "light") c12 + (tempOnRez, c14) <- findValueOrDefault False "tempOnRez" c13 + (typeInfo, c15) <- findOrDefault basicBox (primTypeAcceptor "typeInfo") c14 + (permissions, c16) <- findOrDefault [0] (elementList "permissions" (valueAcceptor "int")) c15 + (dropAllowed,c17) <- findValueOrDefault False "dropAllowed" c16 + (inventory,[]) <- findOrDefault [] (elementListWith "inventory" acceptInventoryItem) c17 + return $ Prim { primName = name, + primKey = realKey, + primParent = Nothing, + primDescription = description, + primInventory = scripts ++ inventory, + primOwner = realOwner, + primGroup = Nothing, + primCreator = realOwner, + primPosition = position, + primRotation = rotationsToQuaternion P123 eulerRotation, + primScale = scale, + primFaces = faces, + primFlexibility = flexibility, + primMaterial = material, + primStatus = status, + primVehicleFlags = 0, + primLight = light, + primTempOnRez = tempOnRez, + primTypeInfo = typeInfo, + primPermissions = permissions, + primAllowInventoryDrop = dropAllowed, + primSitTarget = Nothing , + primSittingAvatar = Nothing, + primPendingEmails = [], + primPassTouches = False, + primPassCollisions = False, + primPayInfo = (-2, -2, -2, -2, -2), + primAttachment = Nothing, + primRemoteScriptAccessPin = 0 } + +acceptInventoryItem e = matchChoice (map (uncurry mkInventoryItemAcceptor) + [("notecardItem",acceptNotecardData), + ("textureItem", acceptTextureData), + ("bodyPartItem", acceptBodyPartData), + ("clothingItem", acceptClothingData), + ("gestureItem", acceptGestureData), + ("soundItem", acceptSoundData), + ("animationItem", acceptAnimationData), + ("inventoryObjectItem", acceptInventoryObjectData), + ("landmarkItem", acceptLandmarkData) + ]) e + +acceptNotecardData contents = do + (lines,c1) <- findOrDefault [] (elementList "lines" (simpleElement "string")) contents + return (InvNotecard lines,c1) + +acceptTextureData contents = return (InvTexture,contents) +acceptBodyPartData contents = return (InvBodyPart,contents) +acceptClothingData contents = return (InvClothing,contents) +acceptGestureData contents = return (InvGesture,contents) +acceptSoundData contents = do + (duration,c1) <- findValue "duration" contents + return (InvSound duration,c1) +acceptAnimationData contents = do + (duration,c1) <- findValue "duration" contents + return (InvAnimation (if duration == 0 then Nothing else Just duration),c1) +acceptInventoryObjectData contents = do + (prims,c1) <- findElement primsElement contents + return (InvObject prims,c1) + +acceptLandmarkData contents = do + (region,c1) <- findElement (regionAcceptor "region") contents + (position, c2) <- findElement (vecAcceptor "position") c1 + return (InvLandmark (region,position), c2) + +mkInventoryItemAcceptor s f = ElemAcceptor s $ + \ (Elem _ _ contents) -> do + let c0 = elementsOnly contents + (name,c1) <- findSimple "name" c0 + key <- newKey Nothing + (creator,c2) <- findSimple "creator" c1 + realCreator <- findRealKey creator + (itemData,[]) <- f c2 + return $ InventoryItem (InventoryItemIdentification (name, key)) (InventoryInfo creator defaultInventoryPermissions) + itemData + +scriptAcceptor s = ElemAcceptor s $ + \ (Elem _ _ contents) -> do + let c0 = elementsOnly contents + (scriptName, c1) <- findSimple "scriptName" c0 + (scriptId, []) <- findSimple "scriptId" c1 + k <- newKey Nothing + return $ scriptInventoryItem scriptName k scriptId + +faceAcceptor s = ElemAcceptor s $ + \ (Elem _ _ contents) -> do + let c0 = elementsOnly contents + (alpha,c1) <- findValueOrDefault 0.0 "alpha" c0 + (color,c2) <- findOrDefault (1.0,1.0,1.0) (vecAcceptor "color") c1 + (shininess, c3) <- findValueOrDefault 0 "shininess" c2 + (bumpiness, c4) <- findValueOrDefault 0 "bumpiness" c3 + (fullbright, c5) <- findValueOrDefault False "fullbright" c4 + (textureMode, c6) <- findValueOrDefault 0 "textureMode" c5 + (textureInfo, []) <- findOrDefault defaultTextureInfo (textureInfoAcceptor "textureInfo") c6 + return $ PrimFace { + faceAlpha = alpha, + faceColor = color, + faceShininess = shininess, + faceBumpiness = bumpiness, + faceFullbright = fullbright, + faceTextureMode = textureMode, + faceTextureInfo = textureInfo + } + +textureInfoAcceptor s = ElemAcceptor s $ + \ (Elem _ _ contents) -> do + let c0 = elementsOnly contents + (name,c1) <- findSimpleOrDefault "" "name" c0 + (repeats,c2) <- findOrDefault (1.0,1.0,1.0) (vecAcceptor "repeats") c1 + (offsets,c3) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "offsets") c2 + (rotation,[]) <- findValueOrDefault 0.0 "rotation" c3 + return $ TextureInfo { + textureKey = name, + textureRepeats = repeats, + textureOffsets = offsets, + textureRotation = rotation + } + +flexibilityAcceptor s = ElemAcceptor s $ + \ (Elem _ _ contents) -> do + let c0 = elementsOnly contents + (softness,c1) <- findValueOrDefault 0 "softness" c0 + (gravity,c2) <- findValueOrDefault 1.0 "gravity" c1 + (friction,c3) <- findValueOrDefault 0.0 "friction" c2 + (wind,c4) <- findValueOrDefault 0.0 "wind" c3 + (tension,c5) <- findValueOrDefault 1.0 "tension" c4 + (force, []) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "force") c5 + return $ Flexibility { + flexSoftness = softness, + flexGravity = gravity, + flexFriction = friction, + flexWind = wind, + flexTension = tension, + flexForce = force + } + +lightAcceptor s = ElemAcceptor s $ + \ (Elem _ _ contents) -> do + let c0 = elementsOnly contents + (color,c1) <- findOrDefault (1.0,1.0,1.0) (vecAcceptor "color") c0 + (intensity,c2) <- findValueOrDefault 1.0 "intensity" c1 + (radius,c3) <- findValueOrDefault 10.0 "radius" c2 + (falloff,[]) <- findValueOrDefault 1.0 "falloff" c3 + return $ LightInfo { + lightColor = color, + lightIntensity = intensity, + lightRadius = radius, + lightFalloff = falloff + } + +primTypeAcceptor s = ElemAcceptor s $ + \ (Elem _ _ contents) -> do + let c0 = elementsOnly contents + (version, c1) <- findValueOrDefault 9 "version" c0 + (typeCode, c2) <- findValueOrDefault 0 "typeCode" c1 + (holeshape, c3) <- findValueOrDefault 0 "holeshape" c2 + (cut, c4) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "cut") c3 + (twist, c5) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "twist") c4 + (holesize, c6) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "holesize") c5 + (topshear, c7) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "topshear") c6 + (hollow, c8) <- findValueOrDefault 0.0 "hollow" c7 + (taper, c9) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "taper") c8 + (advancedCut, c10) <- findOrDefault (0.0,0.0,0.0) (vecAcceptor "advancedCut") c9 + (radiusOffset, c11) <- findValueOrDefault 0.0 "radiusOffset" c10 + (revolutions, c12) <- findValueOrDefault 0.0 "revolutions" c11 + (skew, c13) <- findValueOrDefault 0.0 "skew" c12 + (sculptTexture, c14) <- findOptionalElement (simpleElement "sculptTexture") c13 + (sculptType, []) <- findValueOrDefault 0 "sculptType" c14 + return $ PrimType { + primVersion = version, -- 1 or 9 + primTypeCode = typeCode, + primHoleshape = holeshape, + primCut = cut, + primTwist = twist, + primHolesize = holesize, + primTopshear = topshear, + primHollow = hollow, + primTaper = taper, + primAdvancedCut = advancedCut, + primRadiusOffset = radiusOffset, + primRevolutions = revolutions, + primSkew = skew, + primSculptTexture = sculptTexture, + primSculptType = sculptType + } + +avatarsElement :: ElemAcceptor KeyManagerM [Avatar] +avatarsElement = elementList "avatars" avatarElement + +avatarElement :: ElemAcceptor KeyManagerM Avatar +avatarElement = ElemAcceptor "avatar" $ + \ (Elem _ _ contents) -> do + (name,c2) <- findSimple "name" (elementsOnly contents) + realKey <- newKey (Just name) + (x,c3) <- findValue "xPos" c2 + (y,c4) <- findValue "yPos" c3 + (z,c5) <- findValue "zPos" c4 + (handlerName,_) <- findOptionalElement (simpleElement "avatarEventHandler") c5 + let initialHandler = fmap (flip (,) []) handlerName + return $ (defaultAvatar realKey) { avatarName = name, + avatarPosition = (x,y,z), + avatarCameraPosition = (x,y,z), + avatarEventHandler = initialHandler } + +vecAcceptor s = ElemAcceptor s $ + \ (Elem _ _ contents) -> do + (x,c1) <- findValue "x" (elementsOnly contents) + (y,c2) <- findValue "y" c1 + (z,[]) <- findValue "z" c2 + return $ (x,y,z) + +rotAcceptor s = ElemAcceptor s $ + \ (Elem _ _ contents) -> do + (x,c1) <- findValue "x" (elementsOnly contents) + (y,c2) <- findValue "y" c1 + (z,c3) <- findValue "z" c2 + (s,[]) <- findValue "s" c3 + return $ (x,y,z,s) + +regionAcceptor s = ElemAcceptor s $ + \ (Elem _ _ contents) -> do + (x,c1) <- findValue "x" (elementsOnly contents) + (y,[]) <- findValue "y" (c1) + return $ (x,y)
+ src/LslPlus.hs view
@@ -0,0 +1,35 @@+module Main where + +import qualified Language.Lsl.Internal.MetaData as MetaData +import qualified Language.Lsl.Internal.Compiler as Compiler +import qualified Language.Lsl.Internal.ExpressionHandler as ExpressionHandler +import qualified Language.Lsl.Internal.SimMetaData as SimMetaData +import qualified Language.Lsl.Internal.SystemTester as SystemTester +import qualified Language.Lsl.Internal.UnitTester as UnitTester + +import Control.Monad +import IO +import System +import System.Exit + +version="0.1.1" +usage progName = "Usage: " ++ progName ++ " [Version|MetaData|Compiler|ExpressionHandler|SimMetaData|SystemTester|UnitTester]" +main = do + progName <- getProgName + args <- getArgs + when (length args /= 1) $ do + hPutStrLn stderr "Invalid number of command line arguments" + hPutStrLn stderr (usage progName) + exitFailure + case head args of + "Version" -> putStrLn version + "MetaData" -> MetaData.printMeta + "Compiler" -> Compiler.main0 + "ExpressionHandler" -> ExpressionHandler.validateExpression stdin stdout + "SimMetaData" -> SimMetaData.printSimMeta + "SystemTester" -> SystemTester.testSystem + "UnitTester" -> UnitTester.main2 + val -> do + hPutStrLn stderr ("Invalid argument: " ++ val) + hPutStrLn stderr (usage progName) + exitFailure