-- 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 [[]]