diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Redistribution and use in source and binary forms, with or without modification, are permitted +provided that the following conditions are met: + + 1. Redistributions of source code must retain the above copyright notice, this list of + conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright notice, this list of + conditions and the following disclaimer in the documentation and/or other materials provided + with the distribution. + 3. The name of the author may not be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, +BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Language/Lsl/Parse.hs b/Language/Lsl/Parse.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Parse.hs @@ -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 . and . 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 + diff --git a/Language/Lsl/QQ.hs b/Language/Lsl/QQ.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/QQ.hs @@ -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 diff --git a/Language/Lsl/Render.hs b/Language/Lsl/Render.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Render.hs @@ -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 diff --git a/Language/Lsl/Sim.hs b/Language/Lsl/Sim.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Sim.hs @@ -0,0 +1,3697 @@ +{-# 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 ', 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 ( lift $ logFromScript info ("llGetAnimation: no such avatar: " ++ ak) >> return "" + Just av | avatarRegion av /= rp -> lift $ logFromScript info ("llGetAnimationList: avatar no in sim") >> return "" + | otherwise -> return "Standing" -- TODO: real animation state + continueWith (SVal nm) + +llStartAnimation info@(ScriptInfo _ _ sid pk _) [SVal anim] = + do avKey <- getPermittedAvKey info "llStartAnimation" cPermissionTriggerAnimation + case avKey of + Nothing -> return () + Just ak -> do + avatars <- lift getWorldAvatars + av <- mlookup ak avatars + let anims = avatarActiveAnimations av + now <- lift getTick + result <- findAnimation pk anim + case result of + Just (key,mduration) -> do + let anims' = updateAnims anims now mduration key + lift $ setWorldAvatars (M.insert ak (av { avatarActiveAnimations = anims' }) avatars) + Nothing -> lift $ logFromScript info ("llStartAnimation: animation not found - " ++ anim) + where updateAnims anims now mduration key = + (expire,key):[(t,k) | (t,k) <- anims, (maybe True ( invName item == anim) primAnims of + Just item -> do + return $ Just (snd $ inventoryItemNameKey $ inventoryItemIdentification item, invAnimationDuration $ inventoryItemData item) + Nothing -> + case find (\ (name,_,_) -> name == anim) builtInAnimations of + Just (_,key,mduration) -> return $ Just (key,mduration) + Nothing -> return Nothing + +llStopAnimation info@(ScriptInfo _ _ sid pk _) [SVal anim] = + do avKey <- getPermittedAvKey info "llStartAnimation" cPermissionTriggerAnimation + case avKey of + Nothing -> return () + Just ak -> do + avatars <- lift getWorldAvatars + av <- mlookup ak avatars + let anims = avatarActiveAnimations av + result <- findAnimation pk anim + case result of + Just (key,_) -> do + case find (\ (_,k) -> k == key) anims of + Nothing -> lift $ logFromScript info "llStopAnimation: animation not active" + Just _ -> do + let anims' = [(expire,k) | (expire,k) <- anims, k /= key] + lift $ setWorldAvatars $ M.insert ak (av { avatarActiveAnimations = anims' }) avatars + Nothing -> lift $ logFromScript info ("llStopAnimation: animation not found - " ++ anim) + continueWith VoidVal + +llSetClickAction info [IVal action] = + lift $ (if action `elem` cClickActions then logFromScript info "llSetClickAction: setting click action" + else logFromScript info "llSetClickAction: invalid click action") >> continueWith VoidVal +------------------------------------------------------------------------------- +-- XML RPC related functions +llCloseRemoteDataChannel info@(ScriptInfo _ _ sn pk _) [KVal key] = + do -- according to LSL wiki this function has no effect, + -- so we'll just log a message indicating whether or not the passed in key is valid + (lookupScriptFromChan key) <||> throwError "key not an open channel" + return () + continueWith VoidVal + +llOpenRemoteDataChannel info@(ScriptInfo _ _ sn pk _) [] = + do key <- lookupDataChannel (pk,sn) <||> lift newKey + insertScriptChannelPair (pk,sn) key + lift $ logFromScript info ("pushing remote data channel to script") + lift $ pushDeferredScriptEvent (Event "remote_data" [llcRemoteDataChannel, KVal key, KVal nullKey, SVal "", IVal 0, SVal ""] M.empty) pk sn 0 + continueWith VoidVal + +llSendRemoteData info [KVal channel, SVal dest, IVal idata, SVal sdata] = + do -- according to LSL Wiki, this function doesn't do anything... but we'll check + -- for a valid channel and log a message. + lookupScriptFromChan channel <||> throwError "key not an open channel" + lift newKey >>= continueWith . KVal + +llRemoteDataReply info@(ScriptInfo _ _ _ _ mevent) [KVal channel, KVal messageId, SVal sdata, IVal idata] = + do Just event <- return mevent + when (eventName event /= "remote_data") $ throwError "no effect unless called within remote_data handler" + let m = eventInfo event + (KVal k) <- mlookup "requestKey" m <||> throwError ("problem: invalid or mistyped request key in event") + lift $ putWorldEvent 0 (XMLReplyEvent k channel messageId sdata idata) + lift $ logFromScript info ("llRemoteDataReply: (" ++ show channel ++ "," ++ show messageId ++ "," ++ show sdata ++ "," ++ + show idata ++ ")") + continueWith VoidVal + +llRemoteDataSetRegion info [] = lift $ logFromScript info "llRemoteDataSetRegion: this function has no effect" >> continueWith VoidVal +------------------------------------------------------------------------------- + +llDialog info@(ScriptInfo _ _ _ pk _) [KVal ak, SVal message, LVal buttons, IVal channel] = + do when (length message > 512) $ doErr "message too long, must be less than 512 characters" + when (null message) $ doErr "must supply a message" + when (not $ all (==LLString) $ map typeOfLSLValue buttons) $ doErr "button list must contain only strings" + let buttons' = take 12 $ map ( \ (SVal s) -> s) buttons + when (any ((24 <) . length) buttons') $ doErr "Button Labels cannot have more that 24 characters" + when (any null buttons') $ doErr "all buttons must have label strings" + (lift getWorldAvatars >>= mlookup ak) <||> throwError ("no such agent/avatar - " ++ ak) + lift $ putWorldEvent 0 (DialogEvent ak message buttons' channel pk) -- deprecated! + lift $ putWorldEvent 0 (AvatarInputEvent ak (AvatarDialog message buttons' channel pk)) + continueWith VoidVal + where doErr msg = (lift $ putChat (Just 20) pk cDebugChannel ("llDialog: " ++ msg)) >> throwError msg +------------------------------------------------------------------------------- +-- old (deprecated) functions for visual effects + +llMakeExplosion info _ = lift $ logFromScript info "llMakeExplosion: deprecated" >> continueWith VoidVal +llMakeSmoke info _ = lift $ logFromScript info "llMakeSmoke: deprecated" >> continueWith VoidVal +llMakeFire info _ = lift $ logFromScript info "llMakeFire: deprecated" >> continueWith VoidVal +llMakeFountain info _ = lift $ logFromScript info "llMakeFountain: deprecated" >> continueWith VoidVal + +-------------------------------------------------------------------------------- +llTakeControls info@(ScriptInfo {scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [IVal controls, IVal accept, IVal pass] = + do allScripts <- lift getWorldScripts + script <- mlookup (pk,sn) allScripts + case scriptLastPerm script of + Nothing -> lift $ logFromScript info "no persmission to take controls from any agent" + Just ak -> do + av <- getWorldAvatar ak + maybe (throwError $ "no permission to take controls from " ++ avatarName av) + (\ perms -> if perms .&. cPermissionTakeControls /= 0 + then when (accept /= 0) $ lift $ setWorldAvatar ak (av { avatarControlListener = Just acl }) + else (throwError $ "no permission to take controls from " ++ avatarName av)) + (M.lookup ak $ scriptPermissions script) + where acl = AvatarControlListener { avatarControlListenerMask = controls, avatarControlListenerScript = (pk,sn) } + continueWith VoidVal +-------------------------------------------------------------------------------- + +llVolumeDetect info@(ScriptInfo { scriptInfoObjectKey = oid }) [IVal i] = + do obj <- getObject oid + lift $ setObject oid (obj { objectDynamics = (objectDynamics obj) { objectVolumeDetect = i /= 0 }}) + continueWith VoidVal + +llCollisionFilter info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn }) [SVal name, KVal k, IVal i] = + do allScripts <- lift getWorldScripts + script <- mlookup (pk,sn) allScripts + lift $ setWorldScripts (M.insert (pk,sn) (script { scriptCollisionFilter = (name,k, i /= 0) }) allScripts) + continueWith VoidVal + +llTarget info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [VVal x y z, FVal range] = + do allScripts <- lift getWorldScripts + script <- mlookup (pk,sn) allScripts + let index = scriptTargetIndex script + let script' = script {scriptTargetIndex = index + 1, + scriptPositionTargets = IM.insert index ((x,y,z),range) (scriptPositionTargets script) + } + lift $ setWorldScripts (M.insert (pk,sn) script' allScripts) + continueWith $ IVal index + +llTargetRemove info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [IVal tnumber] = + do allScripts <- lift getWorldScripts + script <- mlookup (pk,sn) allScripts + let script' = script { scriptPositionTargets = IM.delete tnumber (scriptPositionTargets script) } + lift $ setWorldScripts (M.insert (pk,sn) script' allScripts) + continueWith VoidVal + +llRotTarget info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [RVal x y z s, FVal err] = + do allScripts <- lift getWorldScripts + script <- mlookup (pk,sn) allScripts + let index = scriptTargetIndex script + let script' = script { scriptTargetIndex = index + 1, + scriptRotationTargets = IM.insert index ((x,y,z,s),err) (scriptRotationTargets script) + } + lift $ setWorldScripts (M.insert (pk,sn) script' allScripts) + continueWith VoidVal + +llRotTargetRemove info@(ScriptInfo { scriptInfoPrimKey = pk, scriptInfoScriptName = sn}) [IVal tnumber] = + do allScripts <- lift getWorldScripts + script <- mlookup (pk,sn) allScripts + let script' = script { scriptRotationTargets = IM.delete tnumber (scriptRotationTargets script) } + lift $ setWorldScripts (M.insert (pk,sn) script' allScripts) + continueWith VoidVal + +-------------------------------------------------------------------------------- +llGround info [VVal _ _ _] = continueWith (FVal 0) -- the world is flat! +llGroundContour info [VVal _ _ _] = continueWith (VVal 1 0 0) -- could be any vector +llGroundNormal info [VVal _ _ _] = continueWith (VVal 0 0 1) -- straight up! +llGroundSlope info [VVal _ _ _] = continueWith (VVal 0 1 0) +-------------------------------------------------------------------------------- +llGetSunDirection info [] = lift $ do + az <- getTick >>= return . (*(pi/7200)) . ticksToDuration + let el = 80 * pi + continueWith $ vec2VVal (sin az * cos el, sin el, cos az * cos el) + +-------------------------------------------------------------------------------- +llLoadURL info [KVal ak, SVal msg, SVal url] = do + getWorldAvatar ak + lift $ putWorldEvent 0 (AvatarInputEvent ak (AvatarLoadURL msg url)) + continueWith VoidVal + +llMapDestination info [SVal simName, (VVal x y z), (VVal _ _ _)] = do + case mevent of + Nothing -> do + attachment <- getPrimAttachment oid + case attachment of + Nothing -> lift $ logFromScript info ("prim neither attached nor touched, so call to llMapDestination is not valid") + Just (Attachment { attachmentKey = ak }) -> putIt ak + Just (Event "touch" _ m) -> + case M.lookup "key_0" m of + Just (SVal ak) -> putIt ak + _ -> throwError "invalid touch event!" + continueWith VoidVal + where oid = scriptInfoObjectKey info + mevent = scriptInfoCurrentEvent info + putIt ak = lift $ putWorldEvent 0 (AvatarInputEvent ak (AvatarMapDestination simName (x,y,z))) +-------------------------------------------------------------------------------- +continueWith val = return (EvalIncomplete,val) + +defaultPredefs :: Monad m => M.Map String (PredefFunc m) +defaultPredefs = M.fromList $ map (\(x,y) -> (x, defaultPredef x y)) [ + ("llAddToLandBanList",llAddToLandBanList), + ("llAddToLandPassList",llAddToLandPassList), + ("llAdjustSoundVolume",llAdjustSoundVolume), + ("llAllowInventoryDrop",llAllowInventoryDrop), + ("llApplyImpulse",llApplyImpulse), + ("llApplyRotationalImpulse", llApplyRotationalImpulse), + ("llAttachToAvatar",llAttachToAvatar), + ("llAvatarOnSitTarget",llAvatarOnSitTarget), + ("llBreakAllLinks",llBreakAllLinks), + ("llBreakLink",llBreakLink), + ("llClearCameraParams",llClearCameraParams), + ("llCloseRemoteDataChannel",llCloseRemoteDataChannel), + ("llCloud",llCloud), + ("llCollisionFilter", llCollisionFilter), + ("llCollisionSound",llCollisionSound), + ("llCollisionSprite",llCollisionSprite), + ("llCreateLink",llCreateLink), + ("llDetachFromAvatar", llDetachFromAvatar), + ("llDetectedGrab",llDetectedGrab), + ("llDetectedGroup",llDetectedGroup), + ("llDetectedKey", llDetectedKey), + ("llDetectedLinkNumber", llDetectedLinkNumber), + ("llDetectedName", llDetectedName), + ("llDetectedOwner", llDetectedOwner), + ("llDetectedPos", llDetectedPos), + ("llDetectedRot", llDetectedRot), + ("llDetectedType", llDetectedType), + ("llDetectedVel", llDetectedVel), + ("llDialog", llDialog), + ("llDie",llDie), + ("llEjectFromLand",llEjectFromLand), + ("llEmail",llEmail), + ("llFrand",llFrand), + ("llGetAccel",llGetAccel), + ("llGetAgentInfo",llGetAgentInfo), + ("llGetAgentSize",llGetAgentSize), + ("llGetAlpha",llGetAlpha), + ("llGetAndResetTime", llGetAndResetTime), + ("llGetAnimation", llGetAnimation), + ("llGetAnimationList",llGetAnimationList), + ("llGetAttached",llGetAttached), + ("llGetBoundingBox",llGetBoundingBox), + ("llGetCameraPos",llGetCameraPos), + ("llGetCameraRot",llGetCameraRot), + ("llGetColor",llGetColor), + ("llGetCreator",llGetCreator), + ("llGetDate",llGetDate), + ("llGetForce", llGetForce), + ("llGetGeometricCenter",llGetGeometricCenter), + ("llGetGMTclock",llGetGMTclock), + ("llGetInventoryCreator",llGetInventoryCreator), + ("llGetInventoryKey",llGetInventoryKey), + ("llGetInventoryName",llGetInventoryName), + ("llGetInventoryNumber",llGetInventoryNumber), + ("llGetInventoryPermMask", llGetInventoryPermMask), + ("llGetInventoryType",llGetInventoryType), + ("llGetKey",llGetKey), + ("llGetLocalPos",llGetLocalPos), + ("llGetNextEmail",llGetNextEmail), + ("llGetNumberOfPrims",llGetNumberOfPrims), + ("llGetNumberOfSides",llGetNumberOfSides), + ("llGetLinkKey",llGetLinkKey), + ("llGetLinkName",llGetLinkName), + ("llGetLinkNumber", llGetLinkNumber), + ("llGetLocalRot", llGetLocalRot), + ("llGetLandOwnerAt", llGetLandOwnerAt), + ("llGetMass",llGetMass), + ("llGetNotecardLine", llGetNotecardLine), + ("llGetNumberOfNotecardLines",llGetNumberOfNotecardLines), + ("llGetObjectDesc", llGetObjectDesc), + ("llGetObjectDetails", llGetObjectDetails), + ("llGetObjectMass", llGetObjectMass), + ("llGetObjectName", llGetObjectName), + ("llGetObjectPermMask", llGetObjectPermMask), + ("llGetObjectPrimCount",llGetObjectPrimCount), + ("llGetOmega",llGetOmega), + ("llGetOwner", llGetOwner), + ("llGetOwnerKey",llGetOwnerKey), + ("llGetParcelFlags", llGetParcelFlags), + ("llGetParcelDetails", llGetParcelDetails), + ("llGetPermissions",llGetPermissions), + ("llGetPermissionsKey",llGetPermissionsKey), + ("llGetPos", llGetPos), + ("llGetPrimitiveParams", llGetPrimitiveParams), + ("llGetRegionCorner", llGetRegionCorner), + ("llGetRegionFlags", llGetRegionFlags), + ("llGetRegionFPS", llGetRegionFPS), + ("llGetRegionName", llGetRegionName), + ("llGetRegionTimeDilation", llGetRegionTimeDilation), + ("llGetRot",llGetRot), + ("llGetRootPosition",llGetRootPosition), + ("llGetRootRotation",llGetRootRotation), + ("llGetScale", llGetScale), + ("llGetScriptName", llGetScriptName), + ("llGetScriptState", llGetScriptState), + ("llGetSimulatorHostname", llGetSimulatorHostname), + ("llGetStartParameter",llGetStartParameter), + ("llGetStatus",llGetStatus), + ("llGetSunDirection",llGetSunDirection), + ("llGetTexture", llGetTexture), + ("llGetTextureOffset", llGetTextureOffset), + ("llGetTextureRot", llGetTextureRot), + ("llGetTextureScale", llGetTextureScale), + ("llGetTime",llGetTime), + ("llGetTimeOfDay",llGetTimeOfDay), + ("llGetTimestamp",llGetTimestamp), + ("llGetTorque",llGetTorque), + ("llGetUnixTime",llGetUnixTime), + ("llGetWallclock",llGetWallclock), + ("llGetVel",llGetVel), + ("llGiveInventory", llGiveInventory), + ("llGiveMoney",llGiveMoney), + ("llGround", llGround), + ("llGroundContour", llGroundContour), + ("llGroundNormal", llGroundNormal), + ("llGroundRepel",llGroundRepel), + ("llGroundSlope",llGroundSlope), + ("llHTTPRequest",llHTTPRequest), + ("llInstantMessage",llInstantMessage), + ("llKey2Name", llKey2Name), + ("llListRandomize",llListRandomize), + ("llListen", llListen), + ("llListenControl",llListenControl), + ("llListenRemove",llListenRemove), + ("llLoadURL",llLoadURL), + ("llLookAt", llLookAt), + ("llLoopSound",llLoopSound), + ("llLoopSoundSlave",llLoopSoundSlave), + ("llLoopSoundMaster", llLoopSoundMaster), + ("llMakeExplosion",llMakeExplosion), + ("llMakeFire",llMakeFire), + ("llMakeFountain",llMakeFountain), + ("llMakeSmoke",llMakeSmoke), + ("llMapDestination", llMapDestination), + ("llMessageLinked", llMessageLinked), + ("llMoveToTarget", llMoveToTarget), + ("llOffsetTexture", llOffsetTexture), + ("llOpenRemoteDataChannel", llOpenRemoteDataChannel), + ("llOverMyLand", llOverMyLand), + ("llOwnerSay", llOwnerSay), + ("llPassCollisions", llPassCollisions), + ("llPassTouches", llPassTouches), + ("llPlaySound", llPlaySound), + ("llPlaySoundSlave", llPlaySoundSlave), + ("llPointAt",llPointAt), + ("llPreloadSound", llPreloadSound), + ("llRefreshPrimURL", llRefreshPrimURL), + ("llRegionSay", llRegionSay), + ("llReleaseCamera", llReleaseCamera), + ("llRemoteDataReply", llRemoteDataReply), + ("llRemoteDataSetRegion", llRemoteDataSetRegion), + ("llRemoteLoadScript", llRemoteLoadScript), + ("llRemoveFromLandPassList",llRemoveFromLandPassList), + ("llRemoveFromLandBanList",llRemoveFromLandBanList), + ("llRemoveInventory",llRemoveInventory), + ("llRemoveVehicleFlags",llRemoveVehicleFlags), + ("llRequestAgentData", llRequestAgentData), + ("llRequestInventoryData",llRequestInventoryData), + ("llRequestPermissions",llRequestPermissions), + ("llRequestSimulatorData",llRequestSimulatorData), + ("llResetLandPassList",llResetLandPassList), + ("llResetLandBanList",llResetLandBanList), + ("llResetOtherScript",llResetOtherScript), + ("llResetScript",llResetScript), + ("llResetTime",llResetTime), + ("llRezAtRoot",llRezAtRoot), + ("llRezObject",llRezObject), + ("llRotLookAt",llRotLookAt), + ("llRotTarget",llRotTarget), + ("llRotTargetRemove",llRotTargetRemove), + ("llRotateTexture", llRotateTexture), + ("llSameGroup", llSameGroup), + ("llSay",llSay), + ("llScaleTexture", llScaleTexture), + ("llSensor",llSensor), + ("llSensorRemove",llSensorRemove), + ("llSensorRepeat",llSensorRepeat), + ("llSendRemoteData",llSendRemoteData), + ("llSetAlpha", llSetAlpha), + ("llSetBuoyancy", llSetBuoyancy), + ("llSetClickAction", llSetClickAction), + ("llSetColor", llSetColor), + ("llSetForce", llSetForce), + ("llSetForceAndTorque", llSetForceAndTorque), + ("llSetHoverHeight", llSetHoverHeight), + ("llSetLinkAlpha",llSetLinkAlpha), + ("llSetLinkColor",llSetLinkColor), + ("llSetLinkPrimitiveParams",llSetLinkPrimitiveParams), + ("llSetLinkTexture",llSetLinkTexture), + ("llSetLocalRot",llSetLocalRot), + ("llSetObjectName",llSetObjectName), + ("llSetObjectDesc",llSetObjectDesc), + ("llSetParcelMusicURL",llSetParcelMusicURL), + ("llSetPayPrice",llSetPayPrice), + ("llSetPos",llSetPos), + ("llSetPrimitiveParams",llSetPrimitiveParams), + ("llSetPrimURL",llSetPrimURL), + ("llSetRemoteScriptAccessPin", llSetRemoteScriptAccessPin), + ("llSetRot",llSetRot), + ("llSetScale",llSetScale), + ("llSetScriptState",llSetScriptState), + ("llSetSoundQueueing",llSetSoundQueueing), + ("llSetSoundRadius",llSetSoundRadius), + ("llSetSitText",llSetSitText), + ("llSetStatus",llSetStatus), + ("llSetText",llSetText), + ("llSetTexture",llSetTexture), + ("llSetTorque",llSetTorque), + ("llSetTouchText",llSetTouchText), + ("llSetVehicleFlags",llSetVehicleFlags), + ("llSitTarget",llSitTarget), + ("llShout",llShout), + ("llSleep", llSleep), + ("llSetTimerEvent",llSetTimerEvent), + ("llSound",llSound), + ("llSoundPreload", llSoundPreload), + ("llStartAnimation", llStartAnimation), + ("llStopAnimation", llStopAnimation), + ("llStopHover",llStopHover), + ("llStopLookAt",llStopLookAt), + ("llStopMoveToTarget", llStopMoveToTarget), + ("llStopPointAt", llStopPointAt), + ("llStopSound",llStopSound), + ("llTakeCamera",llTakeCamera), + ("llTakeControls",llTakeControls), + ("llTarget",llTarget), + ("llTargetRemove",llTargetRemove), + ("llTeleportAgentHome",llTeleportAgentHome), + ("llTriggerSound",llTriggerSound), + ("llTriggerSoundLimited",llTriggerSoundLimited), + ("llUnSit",llUnSit), + ("llVolumeDetect", llVolumeDetect), + ("llWhisper",llWhisper), + ("llWind",llWind), + ("llWater",llWater) + ] ++ map (\ (n,f) -> (n, defaultPredef n (\ i args -> lift $ f i args))) internalLLFuncs + +allFuncs = (map (\ (name,_,_) -> name) funcSigs) +implementedFuncs = (map fst $ M.toList (defaultPredefs::(M.Map String (PredefFunc Maybe)))) +unimplementedFuncs = S.toList (S.difference (S.fromList allFuncs) (S.fromList implementedFuncs)) + +--------------------------------------------------------------------------------------------------- +logFromScript :: Monad m => ScriptInfo -> 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 + } diff --git a/Language/Lsl/Syntax.hs b/Language/Lsl/Syntax.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/Syntax.hs @@ -0,0 +1,961 @@ +{-# 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) diff --git a/Language/Lsl/UnitTest.hs b/Language/Lsl/UnitTest.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/UnitTest.hs @@ -0,0 +1,72 @@ +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) } diff --git a/Language/Lsl/UnitTestEnv.hs b/Language/Lsl/UnitTestEnv.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/UnitTestEnv.hs @@ -0,0 +1,268 @@ +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') + diff --git a/Language/Lsl/WorldDef.hs b/Language/Lsl/WorldDef.hs new file mode 100644 --- /dev/null +++ b/Language/Lsl/WorldDef.hs @@ -0,0 +1,817 @@ +{-# 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) diff --git a/LslPlus.cabal b/LslPlus.cabal new file mode 100644 --- /dev/null +++ b/LslPlus.cabal @@ -0,0 +1,38 @@ +Name: LslPlus +version: 0.1.0 +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, + which works in cooperation with the LSL Plus Eclipse plugin (the executable is not + much use standalone). It also provides a library, which includes a parser and + corresponding quasiquoter, a unit test framework for LSL, and a simulator for running + scripts. +Cabal-Version: >= 1.5 +Homepage: http:/lslplus.sourceforge.net/ +License: BSD3 +License-file: LICENSE +Category: Language +Copyright: Copyright (c) Robert Greayer 2008. +Author: Robert Greayer +Maintainer: robgreayer@yahoo.com +Stability: experimental +Build-Type: Simple +Tested-With: GHC ==6.10.1 + +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, + 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 + 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 +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: . + Ghc-Options: -fwarn-unused-imports + diff --git a/LslPlus.hs b/LslPlus.hs new file mode 100644 --- /dev/null +++ b/LslPlus.hs @@ -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.0" +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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain +