-- Implementation of Quowong Liu's esoteric language "conser" in Haskell 98.
-- Version 0.0. Copyright 2002 Ben Rudiak-Gould. Released under the GPL.
import List
import Char
main = interact conser
conser = decodeOutput . run . compile . functionSplit . tokenize
{-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
data Pair = Pair Set Set deriving (Eq, Show)
type Set = [Pair]
{-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
opCar = '<'
opCdr = '>'
opOpen = '('
opClose = ')'
opCons = ','
opXn = '&'
opDiff = '!'
opIs = '='
opEnd = '.'
operators = [opCar,opCdr,opOpen,opClose,opCons,opXn,opDiff,opIs,opEnd]
comment = '"'
{-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
tokenize :: String -> [String]
tokenize [] = []
tokenize (ch:rest) =
if isSpace ch then
tokenize rest
else if ch `elem` operators then
([ch] : tokenize rest)
else if ch == comment then
tokenize (tail (dropWhile (/= comment) rest))
else
let (token,rest2) = break (\ch -> (isSpace ch) || (ch `elem` operators) || (ch == comment)) rest
in ((ch : token) : tokenize rest2)
{-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
type AssocList a b = [(a,b)]
type StringAssoc b = AssocList String b
assoclistLookup :: Eq a => AssocList a b -> a -> Maybe b
assoclistLookup al key =
case find ((== key) . fst) al of
Nothing -> Nothing
Just (key,value) -> Just value
assoclistMap :: (a->b->c) -> AssocList a b -> AssocList a c
assoclistMap f [] = []
assoclistMap f ((k,v):kvs) = (k,f k v) : assoclistMap f kvs
{-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
type RawFunction = ([String],[String]) -- params, code
type CompiledFunction = [Pair]->Set
{-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
parseFatal func msg =
error ("In function '" ++ func ++ "': " ++ msg)
{-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
functionSplit :: [String] -> StringAssoc RawFunction
functionSplit [] = []
functionSplit (name:rest) =
let (params,is_body) = span (/= [opIs]) rest in
if null is_body then
parseFatal name "no '=' found before end of file"
else
let (body,rest) = span (/= [opEnd]) (tail is_body) in
if null rest then
parseFatal name "no ':' found before end of file"
else
(name,(params,body)) : functionSplit (tail rest)
{-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
compile :: StringAssoc RawFunction -> StringAssoc CompiledFunction
compile funcs =
let compiledFuncs = assoclistMap (\k v -> (encode compiledFuncs (parse funcs k v))) funcs
in compiledFuncs
{-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
run :: StringAssoc CompiledFunction -> Set
run compiledFuncs =
case assoclistLookup compiledFuncs "main" of
Nothing -> error "No main function"
Just f -> f []
{-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
decodeOutput :: Set -> String
decodeOutput [] = ""
decodeOutput (x:[]) = decodeOutputPair x
decodeOutput (x:xs) = (decodeOutputPair x) ++ " " ++ (decodeOutput xs)
decodeOutputPair (Pair x y) = "(" ++ (decodeOutput x) ++ "," ++ (decodeOutput y) ++ ")"
{-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
data CExpr = CArgRef Int
| CFuncall String [CExpr]
| CUnion [CExpr]
| CIntersect CExpr CExpr
| CDifference CExpr CExpr
| CCons CExpr CExpr
| CCar CExpr
| CCdr CExpr
deriving Show
{-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
parse :: StringAssoc RawFunction -> String -> RawFunction -> CExpr
parse funcs name (params,body) =
let (ast, remainingInput) = parseTerm funcs name params body in
case remainingInput of
[] -> ast
x:xs -> parseFatal name ("unexpected token '" ++ x ++ "' after end of function")
parseTerm :: StringAssoc RawFunction -> String -> [String] -> [String] -> (CExpr, [String])
parseTerm funcs name params [] = parseFatal name "unexpected end of function (expected a term)"
parseTerm funcs name params (x:xs) =
-- (...)
if x == [opOpen] then
parseParenthesized funcs name params xs
-- car and cdr
else if x == [opCar] then
let (ast, remainingInput) = parseTerm funcs name params xs in
(CCar ast, remainingInput)
else if x == [opCdr] then
let (ast, remainingInput) = parseTerm funcs name params xs in
(CCdr ast, remainingInput)
-- reference to formal parameter
else case elemIndex x params of
Just i -> (CArgRef i, xs)
Nothing ->
-- reference to function
case assoclistLookup funcs x of
Just f -> parseFuncall funcs name params x (length (fst f)) xs
Nothing -> parseFatal name ("unexpected token '" ++ x ++ "' (expected a term)")
parseParenthesized funcs name params input =
let (union1, input2) = parseUnion funcs name params input in
case input2 of
[] -> parseFatal name "Unexpected end of function in parenthesized expression"
(x:xs) ->
if x == [opClose] then
(union1, xs)
else if x `elem` [[opCons],[opXn],[opDiff]] then
let (union2, input3) = parseUnion funcs name params xs in
if null input3 || head input3 /= [opClose] then
parseFatal name "missing ')' after cons/intersect/difference operation"
else
(if x == [opCons] then CCons union1 union2
else if x == [opXn] then CIntersect union1 union2
else {-if x == [opDiff] then-} CDifference union1 union2
, tail input3)
else
parseFatal name "missing ')' after union operation"
parseFuncall funcs name params subname numArgs input =
let (args, remainingInput) = parseMultiTerm funcs name params input numArgs
in (CFuncall subname args, remainingInput)
parseMultiTerm funcs name params input 0 = ([], input)
parseMultiTerm funcs name params input n =
let (firstTerm, input2) = parseTerm funcs name params input
(remainingTerms, input3) = parseMultiTerm funcs name params input2 (n-1)
in (firstTerm:remainingTerms, input3)
parseUnion funcs name params [] = (CUnion [], [])
parseUnion funcs name params input@(x:xs) =
if x `elem` [[opClose],[opCons],[opXn],[opDiff]] then
(CUnion [], input)
else
let (firstTerm, input2) = parseTerm funcs name params input
(CUnion remainingTerms, input3) = parseUnion funcs name params input2
in (CUnion (firstTerm:remainingTerms), input3)
{-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
encode :: StringAssoc CompiledFunction -> CExpr -> CompiledFunction
encode funcs (CArgRef n) = \args -> [args !! n]
encode funcs (CFuncall name subargs) = \args ->
let Just func = assoclistLookup funcs name
compiledArgs = map (($ args).(encode funcs)) subargs
in foldl union [] (map func (multiCartesianProduct compiledArgs))
encode funcs (CUnion []) = \args -> []
encode funcs (CUnion (x:xs)) = \args ->
union (encode funcs x args) (encode funcs (CUnion xs) args)
encode funcs (CIntersect s t) = \args ->
intersect (encode funcs s args) (encode funcs t args)
encode funcs (CDifference s t) = \args ->
(encode funcs s args) \\ (encode funcs t args)
encode funcs (CCons s t) = \args ->
[Pair (encode funcs s args) (encode funcs t args)]
encode funcs (CCar s) = \args->
foldl union [] (map car (encode funcs s args))
where car (Pair p q) = p
encode funcs (CCdr s) = \args->
foldl union [] (map cdr (encode funcs s args))
where cdr (Pair p q) = q
{-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
cartesianProduct :: [a] -> [[a]] -> [[a]]
cartesianProduct [] _ = []
cartesianProduct _ [] = []
cartesianProduct (x:xs) ys =
(map (x:) ys) ++ (cartesianProduct xs ys)
multiCartesianProduct = foldr cartesianProduct [[]]
(
geocities.com/qpliu)