LslPlus-0.1.1: Language/Lsl/Internal/InternalLLFuncs.hs
{-
The 'Internal Functions' of LSL are not a formal grouping of functions, but by my definition
are all the functions that -
* do not affect the SL environment in any way. I.e. they don't communicate information
'outside' the script in any way.
* do not have any state. Call them with the same arguments, and they will return the same
result, each and every time.
Note that this notion of affecting the SL environment excludes cetain types of effects:
* time usage. All actions within a script take time, and this indirectly affects the
SL environment.
* energy cost. SL has a notion of the 'energy' of an object that sometimes comes into
play. These functions may affect that energy, but that has no impact on the results
of the functions themselves.
Note that a couple of functions that don't affect the SL environment don't fall into
my category of 'internal' because they are not stateless. Those functions are
* llFrand: each time you call this function it returns a different number, even if
you pass the exact same argument. SL completely hides the seed and sequence generator
from the script.
* llRandomizeList. Essentially the same issue as for llFrand.
To implement these functions, either the execution model for the script must hava some
storage set aside for the state of the pseudo-random number generator, or the 'world
state' must contain this state. I've chosen to make this part of the 'world state'
so the execution model doesn't know anything about the pseudo random number generator.
Not that anybody was wondering...
So this module implements the functions that are left, and my assumption is that these
implementations would be used regardless of how the SL 'world' the scripts run in is
modelled. Thus, the operation of all other LSL predefined functions is specific to
the implementation of the 'world', but these are not.
-}
module Language.Lsl.Internal.InternalLLFuncs(
-- String Functions
llStringLength,
llGetSubString,
llDeleteSubString,
llInsertString,
llParseString2List,
llParseStringKeepNulls,
llToUpper,
llToLower,
llSubStringIndex,
llEscapeURL,
llUnescapeURL,
llIntegerToBase64,
llBase64ToInteger,
llBase64ToString,
llStringToBase64,
llStringTrim,
llXorBase64Strings,
llXorBase64StringsCorrect,
-- Math functions
llCos,
llSin,
llAcos,
llAsin,
llSqrt,
llFabs,
llLog,
llLog10,
llTan,
llAtan2,
llAbs,
llCeil,
llFloor,
llRound,
llPow,
llModPow,
llListStatistics,
-- Math Vector/Rotation
llAngleBetween,
llEuler2Rot,
llAxisAngle2Rot,
llRot2Angle,
llRot2Axis,
llAxes2Rot,
llRot2Fwd,
llRot2Left,
llRot2Up,
llRot2Euler,
llRotBetween,
llVecMag,
llVecDist,
llVecNorm,
-- List functions
llGetListLength,
llList2List,
llDeleteSubList,
llDumpList2String,
llListFindList,
llListInsertList,
llListReplaceList,
llList2ListStrided,
llListSort,
llGetListEntryType,
llList2Float,
llList2Integer,
llList2Key,
llList2Rot,
llList2String,
llList2Vector,
llList2CSV,
llCSV2List,
internalLLFuncs,
internalLLFuncNames
) where
import Language.Lsl.Internal.Util(Permutation3(..),axisAngleToRotation,cut,dist3d,elemAtM,
filtMap,fromInt,indexOf,mag3d,mag3d2,matrixToQuaternion,quaternionToMatrix,
quaternionToRotations,rotationBetween,rotationsToQuaternion)
import Language.Lsl.Internal.Type(LSLType(..),LSLValue(..),lslValString,parseFloat,parseInt,rot2RVal,toSVal,typeOfLSLValue,vVal2Vec)
import Language.Lsl.Internal.Evaluation(EvalResult(..))
import Language.Lsl.Internal.Constants(findConstVal)
import Data.List(elemIndex,find,foldl',intersperse,isPrefixOf,sort)
import Data.Char(toLower,toUpper)
import Data.Bits((.|.),(.&.),shiftL,shiftR,xor)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Digest.Pure.MD5 as MD5
import qualified Data.ByteString.UTF8 as UTF8
import Network.URI(escapeURIChar,unEscapeString)
internalLLFuncNames :: [String]
internalLLFuncNames = map fst (internalLLFuncs :: [(String, a -> [LSLValue] -> Maybe (EvalResult,LSLValue))])
internalLLFuncs :: (Monad m) => [(String, a -> [LSLValue] -> m (EvalResult,LSLValue))]
internalLLFuncs = [
("llAbs",llAbs),
("llAcos",llAcos),
("llAngleBetween",llAngleBetween),
("llAsin",llAsin),
("llAtan2",llAtan2),
("llAxes2Rot",llAxes2Rot),
("llAxisAngle2Rot",llAxisAngle2Rot),
("llBase64ToInteger",llBase64ToInteger),
("llBase64ToString",llBase64ToString),
("llCeil",llCeil),
("llCos",llCos),
("llCSV2List",llCSV2List),
("llDeleteSubList",llDeleteSubList),
("llDeleteSubString",llDeleteSubString),
("llDumpList2String",llDumpList2String),
("llEscapeURL",llEscapeURL),
("llEuler2Rot",llEuler2Rot),
("llFabs",llFabs),
("llFloor",llFloor),
("llGetListEntryType",llGetListEntryType),
("llGetListLength",llGetListLength),
("llGetSubString",llGetSubString),
("llInsertString",llInsertString),
("llIntegerToBase64",llIntegerToBase64),
("llList2CSV",llList2CSV),
("llList2Float",llList2Float),
("llList2Integer",llList2Integer),
("llList2Key",llList2Key),
("llList2List",llList2List),
("llList2ListStrided",llList2ListStrided),
("llList2Rot",llList2Rot),
("llList2String",llList2String),
("llList2Vector",llList2Vector),
("llListFindList",llListFindList),
("llListInsertList",llListInsertList),
("llListReplaceList",llListReplaceList),
("llListSort",llListSort),
("llListStatistics",llListStatistics),
("llLog",llLog),
("llLog10",llLog10),
("llMD5String",llMD5String),
("llModPow",llModPow),
("llParseString2List",llParseString2List),
("llParseStringKeepNulls",llParseStringKeepNulls),
("llPow",llPow),
("llRot2Angle",llRot2Angle),
("llRot2Axis",llRot2Axis),
("llRotBetween",llRotBetween),
("llRot2Euler",llRot2Euler),
("llRot2Fwd",llRot2Fwd),
("llRot2Left",llRot2Left),
("llRot2Up",llRot2Up),
("llRound",llRound),
("llSin",llSin),
("llSqrt",llSqrt),
("llStringLength",llStringLength),
("llStringToBase64",llStringToBase64),
("llStringTrim", llStringTrim),
("llSubStringIndex",llSubStringIndex),
("llTan",llTan),
("llToLower",llToLower),
("llToUpper",llToUpper),
("llUnescapeURL",llUnescapeURL),
("llVecDist",llVecDist),
("llVecMag",llVecMag),
("llVecNorm",llVecNorm),
("llXorBase64Strings",llXorBase64Strings),
("llXorBase64StringsCorrect", llXorBase64StringsCorrect)]
continueWith x = return (EvalIncomplete,x)
-- String Functions
llStringLength _ [SVal s] = continueWith $ IVal (length s)
llGetSubString _ [SVal source, IVal start, IVal end] = continueWith $ SVal (subList source start end)
llDeleteSubString _ [SVal source, IVal start, IVal end] = continueWith $ SVal (deleteSubList source start end)
llInsertString _ [SVal dst, IVal pos, SVal src] =
-- TODO: wiki says this function does not support negative indices...
-- how does it deal with out of range indices?
let (x,y) = splitAt pos dst in continueWith $ SVal $ x ++ src ++ y
separate :: Eq a => [a] -> [[a]] -> [[a]] -> [a] -> Bool -> [[a]]
separate [] _ _ accum keepNulls = if keepNulls || length accum > 0 then [reverse accum] else []
separate l seps spacers accum keepNulls =
case find ((flip isPrefixOf) l) seps of
Nothing ->
case find ((flip isPrefixOf) l) spacers of
Nothing -> let rest = tail l in separate rest seps spacers (head l:accum) keepNulls
Just p -> let rest = drop (length p) l in
if accum == [] && not keepNulls then
p:(separate rest seps spacers [] keepNulls)
else (reverse accum):p:(separate rest seps spacers [] keepNulls)
Just p -> let rest = drop (length p) l in
if accum == [] && not keepNulls then
separate rest seps spacers [] keepNulls
else (reverse accum):(separate rest seps spacers [] keepNulls)
llStringTrim _ [SVal string, trimType ] =
let trimEnd = reverse . dropWhile (==' ') . reverse
trimBegin = dropWhile (==' ')
trimBoth = trimBegin . trimEnd in
continueWith $ SVal $ (case trimType of
tt | Just tt == findConstVal "STRING_TRIM_HEAD" -> trimBegin
| Just tt == findConstVal "STRING_TRIM_TAIL" -> trimEnd
| Just tt == findConstVal "STRING_TRIM" -> trimBoth
| otherwise -> id) string
llParseString2List _ [SVal string, LVal separators, LVal spacers] =
continueWith $ LVal $ map SVal $ separate string (map lslValString separators) (map lslValString spacers) [] False
llParseStringKeepNulls _ [SVal string, LVal separators, LVal spacers] =
continueWith $ LVal $ map SVal $ separate string (map lslValString separators) (map lslValString spacers) [] True
llToUpper _ [SVal string] = continueWith $ SVal $ map toUpper string
llToLower _ [SVal string] = continueWith $ SVal $ map toLower string
llSubStringIndex _ [SVal source, SVal pattern] = continueWith $ IVal $
case indexOf pattern source of
Nothing -> (-1)
Just i -> i
unescapedChars = ['A'..'Z'] ++ ['0'..'9'] ++ ['a'..'z']
escapeURL "" n = ""
escapeURL (c:cs) n =
let s = escapeURIChar (`elem` unescapedChars) c
len = length s
in if len > n then "" else s ++ escapeURL cs (n - len)
maxResult = 254::Int
llEscapeURL _ [SVal string] =
continueWith $ SVal $ escapeURL string maxResult
llUnescapeURL _ [SVal string] =
continueWith $ SVal $ take maxResult $ unEscapeString string
llMD5String _ [SVal string, IVal nonce] =
continueWith $ SVal $ (show . MD5.md5 . L.pack . B.unpack . UTF8.fromString) (string ++ ":" ++ show nonce)
-- Math functions
unaryToLL :: (Monad m) => (Float -> Float) -> [LSLValue] -> m (EvalResult,LSLValue)
unaryToLL f [FVal v] = continueWith $ FVal (f v)
llCos _ = unaryToLL cos
llSin _ = unaryToLL sin
llAcos _ = unaryToLL acos
llAsin _ = unaryToLL asin
llSqrt _ = unaryToLL sqrt
llFabs _ = unaryToLL abs
llLog _ = unaryToLL log
llLog10 _ = unaryToLL (logBase 10)
llTan _ = unaryToLL tan
llAtan2 _ [FVal x,FVal y] = continueWith $ FVal (atan2 x y)
llAbs _ [IVal i] = continueWith $ IVal (abs i)
llCeil _ [FVal f] = continueWith $ IVal (ceiling f)
llFloor _ [FVal f] = continueWith $ IVal (floor f)
llRound _ [FVal f] = continueWith $ IVal (round f)
-- llRand is not an 'internal' function, in the sense that it
-- is not stateless, like the other 'internal' functions.
-- this is because of its seed, and current position in
-- the sequence.
llPow _ [FVal base, FVal exp] = continueWith $ FVal (base ** exp)
llModPow _ [IVal base, IVal exp, IVal modulus] = continueWith $ IVal (modpow base exp modulus)
modpow a b c | b < 0 = 0
| otherwise =
let b' = (if b > 0xFFFF then 0xFFFF else b)
pow _ 0 = 1 `mod` c
pow x n = (let p' = pow x (n `div` 2) in ((if odd n then (x *) else id) (p' * p')) `mod` c)
in pow (a `mod` c) b'
-- should use a map for this, but have been using lists for everything, so will stick with it...
statFuncs :: [(Int, [Float] -> Float)]
statFuncs = map (\(Just (IVal op), f) -> (op,f)) [
(findConstVal "LIST_STAT_RANGE", listStatRange),
(findConstVal "LIST_STAT_MAX", listStatMax),
(findConstVal "LIST_STAT_MIN", listStatMin),
(findConstVal "LIST_STAT_MEAN", listStatMean),
(findConstVal "LIST_STAT_MEDIAN", listStatMedian),
(findConstVal "LIST_STAT_STD_DEV", listStatStdDev),
(findConstVal "LIST_STAT_SUM", sum),
(findConstVal "LIST_STAT_SUM_SQUARES", sum . map (\x -> x * x )),
(findConstVal "LIST_STAT_NUM_COUNT", fromInt . length),
(findConstVal "LIST_STAT_GEOMETRIC_MEAN", listStatGeometricMean)]
toF :: LSLValue -> Maybe Float
toF (IVal i) = Just (fromInt i)
toF (FVal f) = Just f
toF _ = Nothing
fvals list = filtMap toF list
llListStatistics _ [IVal operation,LVal list] =
case lookup operation statFuncs of
Nothing -> continueWith $ FVal 0 -- this seems to be what lsl does...
Just f -> continueWith $ FVal (f $ fvals list)
listStatRange l = listStatMax l - listStatMin l
listStatMax [] = 0.0
listStatMax l = foldl1 max l
listStatMin [] = 0.0
listStatMin l = foldl1 min l
listStatMean l = sum l / fromInt (length l)
listStatMedian [] = 0.0
listStatMedian l =
let l' = sort l
n = length l
in if odd n then l' !! (n `div` 2) else ((l' !! (n `div` 2)) + (l' !! (n `div` 2 - 1))) / 2.0
listStatStdDev l =
let mean = listStatMean l in
sqrt $ listStatMean $ map ((**2.0).(mean-)) l
listStatSumSquares l = sum $ map (**2.0) l
listStatGeometricMean l = product l ** (1.0 / fromInt (length l))
llRot2Angle _ [RVal _ _ _ w] = continueWith $ FVal (2.0 * acos w)
llRot2Axis _ [RVal x y z w] =
let sinVal = sqrt (1.0 - w*w)
v = if sinVal == 0.0 then VVal 0.0 0.0 0.0
else VVal (x/sinVal) (y/sinVal) (z/sinVal) in
continueWith $ v
llAxisAngle2Rot _ [vval@(VVal x y z), FVal r] = return (axisAngleToRotation (vVal2Vec vval) r) >>= continueWith . rot2RVal
llAxes2Rot _ [VVal xf yf zf, VVal xl yl zl, VVal xu yu zu] =
let (x,y,z,s) = matrixToQuaternion ((xf,xl,xu),(yf,yl,yu),(zf,zl,zu)) in
continueWith $ RVal x y z s
llRot2Fwd _ [RVal x y z s] =
let ((x,_,_),(y,_,_),(z,_,_)) = quaternionToMatrix (x,y,z,s) in
continueWith $ VVal x y z
llRot2Left _ [RVal x y z s] =
let ((_,x,_),(_,y,_),(_,z,_)) = quaternionToMatrix (x,y,z,s) in
continueWith $ VVal x y z
llRot2Up _ [RVal x y z s] =
let ((_,_,x),(_,_,y),(_,_,z)) = quaternionToMatrix (x,y,z,s) in
continueWith $ VVal x y z
llRot2Euler _ [RVal x y z s] =
let (x',y',z') = quaternionToRotations P123 False (x,y,z,s)
in continueWith $ VVal x' y' z'
llEuler2Rot _ [VVal x y z] =
let (x',y',z',s) = rotationsToQuaternion P123 (x,y,z)
in continueWith $ RVal x' y' z' s
llRotBetween n [v0@(VVal x1 y1 z1),v1@(VVal x2 y2 z2)] = return (rotationBetween (vVal2Vec v0) (vVal2Vec v1)) >>= continueWith . rot2RVal
llAngleBetween _ [RVal aX aY aZ aS,RVal bX bY bZ bS] =
continueWith $ FVal $ 2 * acos ((aX * bX + aY * bY + aZ * bZ + aS * bS)
/ sqrt ((aX^2 + aY^2 + aZ^2 + aS^2) *
(bX^2 + bY^2 + bZ^2 + bS^2)))
llVecMag _ [v@(VVal x y z)] =
continueWith $ FVal $ mag3d (vVal2Vec v)
llVecDist _ [v1@(VVal x1 y1 z1),v2@(VVal x2 y2 z2)] =
continueWith $ FVal $ dist3d (vVal2Vec v1) (vVal2Vec v2)
llVecNorm _ [v@(VVal x y z)] =
let mag2 = mag3d2 (vVal2Vec v) in
continueWith $ if mag2 == 0.0 then VVal 0.0 0.0 0.0
else let mag = sqrt mag2 in
VVal (x/mag) (y/mag) (z/mag)
-- List Functions
--llGetListLength Gets the number of elements in a list
llGetListLength _ [LVal list] = continueWith $ IVal (length list)
llList2List _ [LVal source, IVal start, IVal end] = continueWith $ LVal (subList source start end)
llDeleteSubList _ [LVal source, IVal start, IVal end] = continueWith $ LVal (deleteSubList source start end)
llDumpList2String _ [LVal list, SVal sep] =
continueWith $ SVal $ concat $ intersperse sep (map lslValString list)
deleteSubList source start end =
let n = length source
s = convertIndex n start
e = convertIndex n end
in if s <= e then take s source ++ drop (e + 1) source
else drop (e + 1) $ take s source
subList source start end =
let n = length source
s = convertIndex n start
e = convertIndex n end
in
if s <= e then take (e - s + 1) $ drop s source
else take (e+1) source ++ drop s source
convertIndex length index = if index < 0 then length + index else index
-- llCSV2List Converts comma-separated values (CSV) to a list
-- llList2CSV Converts a list to comma-separated values (CSV)
llCSV2List _ [SVal s] =
continueWith $ LVal $ map SVal (lslCsvToList [] s)
llList2CSV _ [LVal l] =
continueWith $ SVal $ concat (intersperse "," (map lslValToString l))
lslValToString (VVal x y z) = "<" ++ (show x) ++ "," ++ (show y) ++ "," ++ (show z) ++ ">"
lslValToString (RVal x y z s) = "<" ++ (show x) ++ "," ++ (show y) ++ "," ++ (show z) ++ "," ++ (show s) ++ ">"
lslValToString (SVal s) = s
lslValToString (KVal k) = k
lslValToString (IVal i) = show i
lslValToString (FVal f) = show f
lslCsvToList partial [] = [reverse partial]
lslCsvToList partial (',':rst) = (reverse partial) : (lslCsvToList [] rst)
lslCsvToList partial ('<':rst) = bracketPattern 0 ('<':partial) rst
lslCsvToList partial (x:rst) = lslCsvToList (x:partial) rst
bracketPattern 0 partial ('>':rst) = lslCsvToList ('>':partial) rst
bracketPattern n partial ('>':rst) = bracketPattern (n-1) ('>':partial) rst
bracketPattern n partial ('<':rst) = bracketPattern (n+1) ('<':partial) rst
bracketPattern n partial (x:rst) = bracketPattern n (x:partial) rst
bracketPattern n partial [] = lslCsvToList partial []
llListFindList _ [LVal source, LVal pattern] = continueWith $ IVal $
case indexOf pattern source of
Nothing -> (-1)
Just i -> i
llListInsertList _ [LVal dst, LVal src, IVal pos] =
let (x,y) = splitAt pos dst in continueWith $ LVal $ x ++ src ++ y
-- TODO: does SL handle start > end?
llListReplaceList _ [LVal dst, LVal src, IVal start, IVal end] =
let n = length src
s = convertIndex n start
e = convertIndex n end
(x,y) = cut s (e+1) dst in continueWith $ LVal $ x ++ src ++ y
-- llList2ListStrided Extracts a subset of a strided list
-- TODO: assumes this works like llList2List, but first extracting every nth elem
llList2ListStrided _ [LVal src, IVal start, IVal end, IVal stride] =
let start' = (start `div` stride) + (if start `mod` stride /= 0 then 1 else 0)
end' = (end `div` stride)
stridedSrc = filtMap (\ (x,y) -> if x `mod` stride == 0 then Just y else Nothing) $ zip [0..] src
in
continueWith $ LVal $ subList stridedSrc start' end'
strideList l stride =
if length l <= stride || stride <= 1 then [l] else (take stride l):(strideList (drop stride l) stride)
llListSort _ [LVal list, IVal stride, IVal ascending] =
let Just (IVal true) = findConstVal "TRUE" -- this will crash if true isn't defined...
-- according to the documentation for this function
-- ascending must EQUAL the constant TRUE, or sort
-- will be descending (which is odd)
direction = if ascending == true then id else reverse
in continueWith $ LVal $
concat (direction $ sort $ strideList list stride)
typeCodes = map (\ (t,Just v) -> (t,v)) [
(LLInteger, findConstVal "TYPE_INTEGER"),
(LLFloat, findConstVal "TYPE_FLOAT"),
(LLString, findConstVal "TYPE_STRING"),
(LLKey, findConstVal "TYPE_KEY"),
(LLVector, findConstVal "TYPE_VECTOR"),
(LLRot, findConstVal "TYPE_ROTATION")]
invalidType = let Just v = findConstVal "TYPE_INVALID" in v
-- TODO: might this function work with negative indices? assuming no.
llGetListEntryType _ [LVal l, IVal index] =
continueWith $
if index < 0 || index >= length l then invalidType
else let Just v = lookup (typeOfLSLValue $ l !! index) typeCodes in v
llList2Float _ [LVal l, IVal index] =
continueWith $ FVal $
case elemAtM index l of
Just (SVal s) -> parseFloat s
Just (IVal i) -> fromInt i
Just (FVal f) -> f
_ -> 0.0
llList2Integer _ [LVal l, IVal index] =
continueWith $ IVal $
case elemAtM index l of
Just (SVal s) -> parseInt s
Just (IVal i) -> i
Just (FVal f) -> truncate f
_ -> 0
llList2Key _ [LVal l, IVal index] =
continueWith $
case elemAtM index l of
Just v -> let (SVal v') = toSVal v in KVal v'
_ -> let (Just (SVal v)) = findConstVal "NULL_KEY" in KVal v
llList2Rot _ [LVal l, IVal index] =
continueWith $ case elemAtM index l of
Just r@(RVal _ _ _ _) -> r
_ -> let (Just r) = findConstVal "ZERO_ROTATION" in r
llList2String _ [LVal l, IVal index] =
continueWith $
case elemAtM index l of
Nothing -> SVal ""
Just v -> toSVal v
llList2Vector _ [LVal l, IVal index] =
continueWith $ case elemAtM index l of
Just v@(VVal _ _ _) -> v
_ -> let (Just v) = findConstVal "ZERO_VECTOR" in v
base64chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
llIntegerToBase64 _ [IVal i] =
let digit1 = 63 .&. (i `shiftR` 26)
digit2 = 63 .&. (i `shiftR` 20)
digit3 = 63 .&. (i `shiftR` 14)
digit4 = 63 .&. (i `shiftR` 8)
digit5 = 63 .&. (i `shiftR` 2)
digit6 = 63 .&. (i `shiftR` (-4))
in continueWith $ SVal $ map (base64chars !!) [digit1,digit2,digit3,digit4,digit5,digit6] ++ "=="
charToBits :: Char -> Int
charToBits c = case elemIndex c base64chars of
Nothing -> 0
Just i -> i
llBase64ToInteger _ [SVal s] =
let n = length s
s' = if n >= 8 then s else (s ++ (replicate (6 - n) 'A'))
charToBits c = case elemIndex c base64chars of
Nothing -> 0
Just i -> i
in continueWith $ IVal $ foldl' (.|.) 0 $ zipWith (shiftL) (map charToBits (take 6 s')) [26,20..]
slPrintable :: String
slPrintable = map toEnum (10:[32..127])
mkPrintable c = if c `elem` slPrintable then c else '?'
-- some valid cases
decodeB64 :: String -> String
decodeB64 [] = []
decodeB64 (x:y:'=':'=':[]) =
let (c1,c2,_) = decodeQuartet(charToBits x,charToBits y,0,0) in [c1]
decodeB64 (x:y:z:'=':[]) =
let (c1,c2,_) = decodeQuartet(charToBits x,charToBits y,charToBits z,0) in [c1,c2]
decodeB64 (w:x:y:z:rest) =
let (c1,c2,c3) = decodeQuartet(charToBits w,charToBits x,charToBits y,charToBits z) in
(c1:c2:c3:(decodeB64 rest))
-- some invalid ones
decodeB64 (x:[]) =
let (c1,_,_) = decodeQuartet(charToBits x,0,0,0) in [c1]
decodeB64 (x:y:[]) =
let (c1,_,_) = decodeQuartet(charToBits x,charToBits y,0,0) in [c1]
decodeB64 (x:y:z:[]) =
let (c1,c2,_) = decodeQuartet(charToBits x,charToBits y,charToBits z,0) in [c1]
decodeQuartet :: (Int,Int,Int,Int) -> (Char,Char,Char)
decodeQuartet (w,x,y,z) =
let c1 = (w `shiftL` 2) .|. (x `shiftR` 4)
c2 = ((x `shiftL` 4) .|. (y `shiftR` 2)) .&. 255
c3 = ((y `shiftL` 6) .|. z) .&. 255
in (toEnum c1,toEnum c2, toEnum c3)
stripPadChars ('=':'=':[]) = []
stripPadChars ('=':[]) = []
stripPadChars [] = []
stripPadChars (x:xs) = x:(stripPadChars xs)
llXorBase64Strings _ [SVal s1, SVal s2] =
let i1 = map charToBits $ stripPadChars s1
i2 = map charToBits $ stripPadChars s2
n = length i2
i3 = zipWith (\ v i -> v `xor` (i2 !! (i `mod` n))) i1 [0..]
in continueWith $ SVal $ map (base64chars !!) i3
-- test strings s1 = YWJjZGVm, s2 = eHl6 => GRsZHBwc
-- s1 = YWJjZGVm, s2 = eHl6dw== => GRsZEx0f
-- s1 = YWJjZGVm, s2 = eHl6d3h5 => GRsZEx0f
--trace1 v = trace (show v) v
llXorBase64StringsCorrect _ [SVal s1, SVal s2] =
let s1' = map fromEnum $ decodeB64 s1
s2' = map fromEnum $ decodeB64 s2
n = length s2'
s3 = zipWith (\ v i -> v `xor` (s2' !! (i `mod` n))) s1' [0..]
in continueWith $ SVal $ encodeB64 (map toEnum s3)
llBase64ToString _ [SVal s] = continueWith $ SVal $ map mkPrintable $ decodeB64 s
llStringToBase64 _ [SVal s] =
let s' = (encodeB64 s) in
continueWith $ SVal s'
encodeB64 [] = []
encodeB64 [x] = encode1 x
encodeB64 [x,y] = encode2 (x,y)
encodeB64 (x:y:z:rest) = encode3 (x,y,z) ++ (encodeB64 rest)
encode3 :: (Char,Char,Char) -> [Char]
encode3 (c1,c2,c3) =
let b1 = ((fromEnum c1) `shiftR` 2) .&. 63
b2 = (((fromEnum c1) `shiftL` 4) .|. ((fromEnum c2) `shiftR` 4)) .&. 63
b3 = (((fromEnum c2) `shiftL` 2) .|. ((fromEnum c3) `shiftR` 6)) .&. 63
b4 = (fromEnum c3) .&. 63
in [base64chars !! b1,base64chars !! b2,base64chars !! b3,base64chars !! b4]
encode2 :: (Char,Char) -> [Char]
encode2 (c1,c2) =
let b1 = ((fromEnum c1) `shiftR` 2) .&. 63
b2 = (((fromEnum c1) `shiftL` 4) .|. ((fromEnum c2) `shiftR` 4)) .&. 63
b3 = ((fromEnum c2) `shiftL` 2) .&. 63
in [base64chars !! b1,base64chars !! b2,base64chars !! b3,'=']
encode1 :: Char -> [Char]
encode1 c1 =
let b1 = ((fromEnum c1) `shiftR` 2) .&. 63
b2 = ((fromEnum c1) `shiftL` 4) .&. 63
in [base64chars !! b1,base64chars !! b2,'=','=']