import System.Environment import System.IO import System.Info import Data.Array import Data.Char import Data.List import Data.Maybe import Data.String import Control.Monad (when) import qualified Data.Set as Set import qualified Data.Map as Map engineVersion = "iogii engine 1.1.4" data Value = L [Value] | S !Integer deriving (Eq, Ord, Read) ls a = L $ map S a lls a = L $ map ls a llls a = L $ map lls a ll a = L $ map L a getS (S x) = x getL (L a) = a getLL a = map getL (getL a) getLS a = map getS (getL a) getLLS a = map getLS (getL a) getLLLS a = map getLLS (getL a) valueShow "int" (S a) = show a valueShow "char" (S a) = show $ myChr a valueShow "[char]" v = show $ map myChr $ getLS v valueShow "[]" _ = "[]" valueShow "[empty]" _ = "[]" valueShow ('[':innerType) (L a) = "[" ++ intercalate "," (map (valueShow $ init innerType) a) ++ "]" zeroFor "char" = S 32 zeroFor ('[':_) = L [] zeroFor _ = S 0 -- int and unknown type truthyFor "char" = (truthyChar . getS) truthyFor "int" = (truthyInt . getS) truthyFor ('[':_) = (truthyList . getL) truthyFor _ = (truthyEmpty . getS) -- unknown type elemT typeStr = tail $ init typeStr -- "remove []" -- op, arg inds, vec level, result type data Instruction = Data Value String | Op String [Int] Int String deriving Read getType (Data _ resultType) = resultType getType (Op _ _ _ resultType) = resultType seqList :: [a] -> b -> b seqList a b = foldr seq b a -- the use of maybe is to avoid a space leak (they will never be Nothing). By getting the weak head normal form of a Maybe Value we cause its args to be looked up from the graph without evaluating the actual value yet. Without this all values of the iogii graph would need to be kept because the graph would not be fully generated at the time of computing values, so therefore it would not know if no more edges point to a value. interpretAll :: [Instruction] -> String -> [String] -> String -> [Value] interpretAll instructions hsStdin hsArgs iogiiVersion = seqList safeAllValues allValues where instructionsA = listArray (0, length instructions -1 ) instructions safeAllValues = map interpret instructions allValues = map fromJust safeAllValues allValuesA = listArray (0, length allValues - 1) (map Just allValues) (input,autoSelectedOutput) = autoChoose hsStdin hsArgs (rawInput,rawSelectedOutput) = rawChoose hsStdin hsArgs (rawLineInput,rawLineSelectedOutput) = rawLineChoose hsStdin hsArgs interpret :: Instruction -> Maybe Value interpret (Data v resultType) = Just v interpret (Op op argInds vecLevel resultType) = seqList safeArgs $ Just $ case length argInds of 0 -> f0 1 | op == "_id" -> arg1 1 -> exec1 f1 vecLevel arg1 2 | op == "rawInputSelector" -> args !! rawSelectedOutput 2 | op == "rawLineInputSelector" -> args !! rawLineSelectedOutput 2 -> exec2 f2 vecLevel arg1 arg2 3 -> exec3 f3 vecLevel arg1 arg2 arg3 8 | op == "autoInputSelector" -> args !! autoSelectedOutput n -> error $ "unknown op" ++ show n ++ " " ++ op where safeArgs = map (allValuesA !) argInds args = map fromJust safeArgs aType = iterate elemT (getType $ instructionsA ! (head argInds)) !! vecLevel bType = iterate elemT (getType $ instructionsA ! (argInds !! 1)) !! vecLevel arg1 = head args arg2 = head $ tail args arg3 = head $ tail $ tail args f0 = case op of "nil" -> L $ iogNil "version" -> ls $ iogVersion $ iogiiVersion ++ "\n" ++ engineVersion "wholes" -> ls $ iogWholes "input" -> input "inputEmpty" -> L $ iogInputEmpty "rawInput" -> rawInput "rawLineInput" -> rawLineInput otherwise -> error $ "unknown op0: " ++ op f1 = case op of "abs" -> \a -> S $ iogAbs (getS a) "bits" -> \a -> ls $ iogBits (getS a) "charClass" -> \a -> ls $ iogCharClass (getLS a) "chr" -> \a -> S $ iogChr (getS a) "concat" -> \a -> L $ iogConcat (getLL a) "consDefault" -> \a -> L $ iogConsDefaultZero (zeroFor $ elemT aType) (getL a) "countTo" -> \a -> ls $ iogCountTo (getS a) "digits" -> \a -> ls $ iogDigits (getS a) "error" -> \a -> ls $ iogErrorL (getLS a) "head" -> \a -> iogHeadZero (zeroFor $ elemT aType) (getL a) "init" -> \a -> L $ iogInit (getL a) "isFirst" -> \a -> ls $ iogIsFirst (getL a) "just" -> \a -> L $ iogJust ( a) "last" -> \a -> iogLastZero (zeroFor $ elemT aType) (getL a) "len" -> \a -> S $ iogLen (getL a) "lines" -> \a -> lls $ iogLines (getLS a) "lowercase" -> \a -> S $ iogLowercase (getS a) "negate" -> \a -> S $ iogNegate (getS a) "not" -> \a -> S $ iogNotTruthyA0 (truthyFor aType) ( a) "ord" -> \a -> S $ iogOrd (getS a) "padDefault" -> \a -> L $ iogPadDefaultZero (zeroFor $ elemT aType) (getL a) "powOf10" -> \a -> S $ iogPowOf10 (getS a) "powOf2" -> \a -> S $ iogPowOf2 (getS a) "pred" -> \a -> S $ iogPred (getS a) "prod" -> \a -> S $ iogProd (getLS a) "rangeBegin" -> \a -> ls $ iogRangeBegin (getS a) "rangeTo" -> \a -> ls $ iogRangeToZero (getS $ zeroFor aType) (getS a) "read" -> \a -> S $ iogRead (getLS a) "readAll" -> \a -> ls $ iogReadAll (getLS a) "repeat" -> \a -> L $ iogRepeat ( a) "reverse" -> \a -> L $ iogReverse (getL a) "show" -> \a -> ls $ map myOrd $ valueShow aType a "sqrt" -> \a -> S $ iogSqrt (getS a) "str" -> \a -> ls $ iogStr (getS a) "strip" -> \a -> ls $ iogStrip (getLS a) "succ" -> \a -> S $ iogSucc (getS a) "sum" -> \a -> S $ iogSum (getLS a) "tail" -> \a -> L $ iogTail (getL a) "transpose" -> \a -> ll $ iogTransposeZero (zeroFor $ elemT $ elemT aType) (getLL a) "type" -> \a -> ls $ map myOrd aType "undigits" -> \a -> S $ iogUndigits (getLS a) "unlines" -> \a -> ls $ iogUnlines (getLLS a) "unwords" -> \a -> ls $ iogUnwords (getLLS a) "uppercase" -> \a -> S $ iogUppercase (getS a) "words" -> \a -> lls $ iogWords (getLS a) otherwise -> error $ "unknown op1: " ++ op f2 = case op of "add" -> \a b -> S $ iogAdd (getS a) (getS b) "append" -> \a b -> L $ iogAppend (getL a) (getL b) "charSubtraction" -> \a b -> S $ iogCharSubtraction (getS a) (getS b) "chunkWhen" -> \a b -> ll $ iogChunkWhenTruthyB1 ((truthyFor $ elemT bType)) (getL a) (getL b) "cons" -> \a b -> L $ iogCons (getL a) ( b) "cutAny" -> \a b -> lls $ iogCutAny (getLS a) (getLLLS b) "div" -> \a b -> S $ iogDiv (getS a) (getS b) "drop" -> \a b -> L $ iogDrop (getL a) (getS b) "dropUntilAfterAnySubstring" -> \a b -> ls $ iogDropUntilAfterAnySubstring (getLS a) (getLLS b) "dropUntilAfterSubstring" -> \a b -> ls $ iogDropUntilAfterSubstring (getLS a) (getLS b) "equal" -> \a b -> S $ iogEqual ( a) ( b) "filter" -> \a b -> L $ iogFilterTruthyB1 (truthyFor $ elemT bType) (getL a) (getL b) "fromBase" -> \a b -> S $ iogFromBase (getLS a) (getS b) "getAnySubstring" -> \a b -> ls $ iogGetAnySubstring (getLS a) (getLLS b) "get" -> \a b -> iogGetZero (zeroFor $ elemT aType) (getL a) (getS b) "getSubstring" -> \a b -> ls $ iogGetSubstring (getLS a) (getLS b) "indices" -> \a b -> ls $ iogIndices (getL a) ( b) "isCharClass" -> \a b -> S $ iogIsCharClass (getS a) (getLS b) "join" -> \a b -> ls $ iogJoin (getLLS a) (getLLS b) "joinM" -> \a b -> ls $ iogJoinM (getLS a) (getLLS b) "keepUntilAnySubstring" -> \a b -> ls $ iogKeepUntilAnySubstring (getLS a) (getLLS b) "keepUntilSubstring" -> \a b -> ls $ iogKeepUntilSubstring (getLS a) (getLS b) "lessThan" -> \a b -> S $ iogLessThan ( a) ( b) "max" -> \a b -> iogMax ( a) ( b) "min" -> \a b -> iogMin ( a) ( b) "mod" -> \a b -> S $ iogMod (getS a) (getS b) "mult" -> \a b -> S $ iogMult (getS a) (getS b) "pad" -> \a b -> L $ iogPad (getL a) ( b) "pow" -> \a b -> S $ iogPow (getS a) (getS b) "replicate" -> \a b -> ls $ iogReplicate (getLS a) (getS b) "reshape" -> \a b -> ll $ iogReshape (getL a) (getLS b) "rightJustify" -> \a b -> ls $ iogRightJustify (getLS a) (getS b) "scanAny" -> \a b -> lls $ iogScanAny (getLS a) (getLLLS b) "setDiff" -> \a b -> L $ iogSetDiff (getL a) (getL b) "sortBy" -> \a b -> L $ iogSortBy (getL a) (getL b) "split" -> \a b -> lls $ iogSplit (getLS a) (getLS b) "splitKeepEmpties" -> \a b -> lls $ iogSplitKeepEmpties (getLS a) (getLLS b) "sub" -> \a b -> S $ iogSub (getS a) (getS b) "take" -> \a b -> L $ iogTake (getL a) (getS b) "takeWhile" -> \a b -> L $ iogTakeWhileTruthyB1 (truthyFor $ elemT bType) (getL a) (getL b) "toBase" -> \a b -> ls $ iogToBase (getS a) (getS b) otherwise -> error $ "unknown op2: " ++ op f3 = case op of "ifElse" -> \a b c -> iogIfElseTruthyA0 (truthyFor aType) ( a) ( b) ( c) otherwise -> error $ "unknown op3: " ++ op rawChoose :: String -> [String] -> (Value, Int) rawChoose hsStdin hsArgs = if null hsArgs then (ls $ map myOrd hsStdin, 0) else (lls $ map (map myOrd) hsArgs, 1) rawLineChoose :: String -> [String] -> (Value, Int) rawLineChoose hsStdin hsArgs = if null hsArgs then (lls $ iogLines $ map myOrd hsStdin, 0) else (llls $ map iogLines $ map (map myOrd) hsArgs, 1) autoChoose :: String -> [String] -> (Value, Int) autoChoose hsStdin hsArgs | null hsArgs && null stdinLines = (L [], inputEmpty) | onlyNums = case nums of [a] -> intMatrixSelector a _ | all ((==1) . length) nums -> intMatrixSelector $ map head nums | all (all ((==1) . length)) nums -> intMatrixSelector $ map (map head) nums | otherwise -> (llls nums, inputLLLInt) | otherwise = strMatrixSelector $ map (map (map myOrd)) inputs where stdinLines = lines hsStdin inputs = if null hsArgs then [stdinLines] else map lines hsArgs inputInt = 0 inputLInt = 1 inputLLInt = 2 inputLLLInt = 3 inputStr = 4 inputLStr = 5 inputLLStr = 6 inputEmpty = 7 nums = map (map readAll) inputs nonNums = zipWith (\lines numsl -> zipWith iogSplitKeepEmpties lines (map (map show) numsl)) inputs nums isSep s = s == "," || s == ", " || s == " " numLine cut = head cut == "" && all isSep (tail (if null (last cut) && length cut > 1 then init cut else cut)) onlyNums = not (null (concat $ concat nums)) && all (all numLine) nonNums intMatrixSelector [[a]] = (S a,inputInt) intMatrixSelector [a] = (ls a,inputLInt) intMatrixSelector a | all ((==1) . length) a = (ls (map head a), inputLInt) intMatrixSelector a = (lls a, inputLLInt) strMatrixSelector [[a]] = (ls a,inputStr) strMatrixSelector [a] = (lls a,inputLStr) strMatrixSelector a | all ((==1) . length) a = (lls (map head a), inputLStr) strMatrixSelector a = (llls a, inputLLStr) exec3 :: (Value -> Value -> Value -> Value) -> Int -> Value -> Value -> Value -> Value exec3 f vecLevel = iterate (\f a b c -> L $ zipWith3 f (getL a) (getL b) (getL c)) f !! vecLevel exec2 :: (Value -> Value -> Value) -> Int -> Value -> Value -> Value exec2 f vecLevel = iterate (\f a b -> L $ zipWith f (getL a) (getL b)) f !! vecLevel exec1 :: (Value -> Value) -> Int -> Value -> Value exec1 f vecLevel = iterate (\f a -> L $ map f (getL a)) f !! vecLevel main=do hSetBuffering stdout NoBuffering -- only really needed so that all stuff is printed before possible errors are thrown in fuzz testing, makes output a bit slower args <- getArgs case args of (astFile:hsArgs) -> do astContents <- readFile astFile let astLines = lines astContents let iogiiVersion = head astLines let isBytes = isInfixOf "encoding=ISO-8859-1" iogiiVersion when isBytes $ do hSetEncoding stdin char8 hSetEncoding stdout char8 hsStdin <- getContents let toChar = if isBytes then myChr . flip mod 256 else myChr let instructions = map read (tail astLines) :: [Instruction] let allValues = interpretAll instructions hsStdin hsArgs iogiiVersion putStr $ map toChar $ getLS $ last $ allValues _ -> putStrLn "Usage: engine *" ------------- iogii function definitions -------------- myChr :: Integer -> Char myChr i = chr $ fromIntegral i myOrd :: Char -> Integer myOrd c = fromIntegral $ ord c bool2i :: Bool -> Integer bool2i b = if b then 1 else 0 falseChars = Set.fromList [0,9,10,11,12,13,32] truthyChar :: Integer -> Bool truthyChar = not . (flip Set.member falseChars) truthyList :: Ord a => [a] -> Bool truthyList = (not . null) truthyInt = (/= 0) truthyEmpty = (flip seq (undefined::Bool)) readAll :: String -> [Integer] readAll xs = if num == [] then [] else sign * (read num :: Integer) : readAll afterNum where (beforeNum,atNum) = span (not . isDigit) xs (num,afterNum) = span isDigit atNum negatives = takeWhile (== '-') (reverse beforeNum) sign = (-1) ^ length negatives iogUnwords :: [[Integer]] -> [Integer] iogUnwords = intercalate [32] iogUnlines :: [[Integer]] -> [Integer] iogUnlines = concatMap (++[10]) iogLines [] = [] -- copied from GHC but with integers instead of chars iogLines s = cons (case break (== 10) s of (l, s') -> (l, case s' of [] -> [] _:s'' -> iogLines s'')) where cons ~(h, t) = h : t iogError msg = error $ "\x1b[31mERROR: \x1b[0m" ++ msg iogErrorL msg = error $ map myChr msg -- int ops iogAdd = (+) iogSub = (-) iogCharSubtraction = (-) iogMult 0 _ = 0 -- for laziness iogMult a b = a*b iogDiv a b = if b == 0 then 0 else a `div` b iogMod 0 _ = 0 -- for laziness iogMod a 0 = a iogMod a b = a `mod` b iogPow a b | b == 0 = 1 -- for laziness | b < 0 && a == 0 = 0 | b < 0 = 1 `div` pow | otherwise = pow where pow = a^(abs b) iogNegate x = -x iogAbs = abs iogCountTo x = [1..x] iogWholes = [0..] iogSum = sum :: [Integer] -> Integer iogSucc = (+1) iogPred x = x-1 -- char ops iogCharRange a b = [a..b] iogRead = iogHeadZero 0 . iogReadAll iogReadAll x = readAll (map myChr x) iogOrd = id iogChr = id iogStr = (map myOrd) . show :: Integer -> [Integer] iogStrip = f . f where f = reverse . dropWhile (not . truthyChar) :: [Integer] -> [Integer] iogReplicate a b = concat $ (replicate . fromIntegral) b a iogJoin a b = if null a then [] else head a ++ concat (zipWith (++) b (tail a)) iogSplit a b = filter (not . null) $ iogSplitKeepEmpties a (repeat b) iogSplitKeepEmpties a b | null a || null b = [a] | otherwise = maybe ((head a : head rhs) : tail rhs) (\remainder -> [] : iogSplitKeepEmpties remainder (tail b)) (stripPrefix (head b) a) where rhs = iogSplitKeepEmpties (tail a) b iogCutAny a b | null a || null b = [a] | otherwise = maybe ((head a : head rhs) : tail rhs) (\match -> [] : iogCutAny (drop (length match) a) (tail b)) (find (flip isPrefixOf a) (head b)) where rhs = iogCutAny (tail a) b iogScanAny a b | null a || null b = [] | otherwise = maybe (iogScanAny (tail a) b) (\match -> match : iogScanAny (drop (length match) a) (tail b)) (find (flip isPrefixOf a) (head b)) where substrInd _ [] = 0 substrInd needle haystack | isPrefixOf needle haystack = 0 | otherwise = 1 + substrInd needle (tail haystack) iogDropUntilAfterSubstring a b = drop (substrInd b a + length b) a iogKeepUntilSubstring a b = take (substrInd b a) a iogGetSubstring a b = take (length b) $ drop (substrInd b a) a anySubstrInd _ [] = (0, []) anySubstrInd needles haystack = case find (flip isPrefixOf haystack) needles of Just needle -> (0, needle) Nothing -> let (ind, match) = anySubstrInd needles (tail haystack) in (ind+1, match) iogDropUntilAfterAnySubstring a b = drop (pos + length match) a where (pos, match) = anySubstrInd b a iogKeepUntilAnySubstring a b = take pos a where (pos, match) = anySubstrInd b a iogGetAnySubstring a b = take (length match) $ drop pos a where (pos, match) = anySubstrInd b a charClasses = map (Set.fromList) charClassesLists charClassesLists = map (map myOrd) [ ['a'..'z'], ['A'..'Z'], ['0'..'9'], [' '..chr 126] \\ (['a'..'z']++['A'..'Z']++['0'..'9']++" \n"), "\n " ] iogCharClass a = concat $ charClass a (replicate (length charClasses) False) where charClass [] _ = [] charClass (a:as) used = let is = [i | i <- [0..length charClasses - 1], Set.member a (charClasses !! i)] i = head is in if null is || used !! i then charClass as used else (charClassesLists !! i) : charClass as (markUsed used i) markUsed used i = take i used ++ [True] ++ drop (i + 1) used iogIsCharClass a b = case find (Set.member a) charClasses of Just clazz -> bool2i $ any (flip Set.member clazz) b Nothing -> 0 iogRightJustify a b = replicate (fromInteger b - length a) 32 ++ a -- generic ops iogTake = flip (take . fromIntegral) iogDrop = flip (drop . fromIntegral) iogJust = (:[]) iogCons = flip (:) iogNil = [] iogAppend = (++) iogReverse = reverse iogNotTruthyA0 truthyFn x = 1 - bool2i (truthyFn x) iogRepeat = repeat iogTakeWhileTruthyB1 truthyFn a b = iogTakeWhileHelper a (map truthyFn b) where iogTakeWhileHelper [] _ = [] iogTakeWhileHelper _ [] = [] iogTakeWhileHelper (a:as) (b:bs) | b = a : iogTakeWhileHelper as bs | otherwise = [] iogGetZero zero a b = if b < 0 || null rest then zero else head rest where rest = (drop . fromIntegral) b a iogHeadZero zero a = if null a then zero else head a iogTail a = if null a then [] else tail a iogInit a = if null a then [] else init a iogLastZero zero a = if null a then zero else last a iogConsDefaultZero zero a = zero : a iogTransposeZero zero a = takeWhile (not . null) $ map (map $ iogHeadZero zero) $ map rstrip $ iterate (map iogTail) a where rstrip [] = [] rstrip (h:t) | null h && null rest = [] | otherwise = h : rest where rest = rstrip t iogLen = fromIntegral . length iogSortBy a b = map fst $ sortOn snd (zip a b) iogConcat :: [[a]] -> [a] iogConcat = concat iogFilterTruthyB1 truthyFn = (catMaybes .) . zipWith (\ai bi->if truthyFn bi then Just ai else Nothing ) iogSetDiff :: Ord a => [a] -> [a] -> [a] iogSetDiff xs ys = go xs (foldl' (\m x -> Map.insertWith (+) x 1 m) Map.empty ys) where go :: (Ord a) => [a] -> Map.Map a Int -> [a] go [] _ = [] go (x:xs) m = case Map.lookup x m of Just n | n > 0 -> go xs (Map.insert x (n-1) m) _ -> x : go xs m iogIfElseTruthyA0 truthyFn a b c = if truthyFn a then b else c iogPadDefaultZero zero a = iogPad a zero iogEqual a b = bool2i (a == b) iogLessThan a b = bool2i (a < b) iogIndices a b = map toInteger (elemIndices b a) iogReshape a b | null b = [] | n>0 && null a = [] | n <= 0 = [] : (iogReshape a $ tail b) | otherwise = (take . fromIntegral) n a : if null d then [] else iogReshape (tail d) (tail b) where n = head b d = (drop . fromIntegral) (n-1) a iogIsFirst :: Ord a => [a] -> [Integer] iogIsFirst a = zipWith ((bool2i .) . (not .) . Set.member) a sets where sets = Set.empty : zipWith Set.insert a sets iogChunkWhenTruthyB1 truhtyFn a b = chunkWhenHelper a (map truhtyFn b) chunkWhenHelper a b | null a = [[]] | otherwise = (head a : if truthy then head rest else []) : (if truthy then tail rest else rest) where rest = chunkWhenHelper (tail a) (iogTail b) truthy = null b || head b -- low rank overrides iogUppercase a = if a >= myOrd('a') && a <= myOrd('z') then a-32 else a iogLowercase a = if a >= myOrd('A') && a <= myOrd('Z') then a+32 else a iogWords a = filter (not . null) $ map (filter truthyChar) $ chunkWhenHelper a (map truthyChar a) iogDigits a = if a == 0 then [0] else iogToBase a 10 iogUndigits a = iogFromBase (concat (map iogDigits a)) 10 iogPowOf2 = iogPow 2 iogBits = toBase 2 iogToBase a b = reverse $ toBase b a toBase b a = if b==0 then [a] else toBaseHelper (abs a) where sign = if a > 0 then 1 else -1 toBaseHelper a | a == 0 = [] | otherwise = digit : toBaseHelper ((a-digit*sign)`div`b) where digit = (a `mod` b)*sign iogFromBase a b = foldl' (\acc x -> acc * b + x) 0 a iogRangeBegin a = [a..] iogRangeToZero zero a = [zero..a-1] iogSqrt x | x < 0 = iogError "negative square root" | x == 0 = 0 | otherwise = sqrtGuess x x sqrtGuess guess x = case ((x `div` guess) + guess) `div` 2 of r | r>=guess -> guess | otherwise -> sqrtGuess r x iogMin a b = min b a -- (haskell evaluation order is backwards from what you expect) iogMax a b = max b a iogPowOf10 = iogPow 10 iogProd = foldr iogMult 1 -- internal ops iogPad :: [a] -> a -> [a] iogPad a b = (if null a then b else head a) : iogPad (iogTail a) b iogZeroZero zero a = zero iogZeromZero = iogZeroZero -- intuitive overloads iogJoinM a = iogJoin (map iogJust a) -- special ops iogDel = undefined iogVersion v = map myOrd $ v ++ ", " ++ compilerName ++ ": " ++ show compilerVersion iogType ts a = map myOrd $ ts iogShow coerceFn a = map myOrd $ show $ coerceFn a iogInputEmpty = []