{-
 *  SAD / Alice / Intro -- subparser for introductors in ForTheL texts
 *  Copyright (C) 2001-2004  SAD Development Team (see ../README)
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License along
 *  with this program; if not, write to the Free Software Foundation, Inc.,
 *  59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 -}

module Intro (introduce) where

import Control.Monad (when,unless,mzero,liftM,liftM2)
import Data.Char (isAlpha,isAlphaNum,toUpper)

import Text
import Parser
import State
import Phrase

-- Introduction of primary expressions

introduce =
  do  let intr  = ver_intr -|- adj_intr -|- fun_intr
              -|- ntn_intr -|- prf_intr -|- inf_intr
      l <- getLin; char '['; (int@(Trm _ vs), fm) <- intr; char ']'
      unless (nodups vs) $ lfail l "duplicate variables in pattern"
      let undotte (Var ('.':v)) = Var v; undotte f = mapF undotte f
      let f = undotte fm; err = wf vs f in
                  if null err then return (int, f) else lfail l err

ver_intr  = do  (pat, vs) <- ver_patt; let ex = Trm (get_name pat)
                fm <- opt ex (char '@' >> prd_alias vs); let np = smp pat
                setState $ \ s -> s { ver_expr = (pat, fm) : ver_expr s }
                unless (null np) $ setState
                    $ \ s -> s { m_ver_expr = (np, fm) : m_ver_expr s }
                return (ex vs, fm vs)

adj_intr  = do  (pat, vs) <- adj_patt; let ex = Trm ('i':'s': get_name pat)
                fm <- opt ex (char '@' >> prd_alias vs); let np = smp pat
                setState $ \ s -> s { adj_expr = (pat, fm) : adj_expr s }
                unless (null np) $ setState
                    $ \ s -> s { m_adj_expr = (np, fm) : m_adj_expr s }
                when (null $ tail vs) $ setState
                    $ \ s -> s { un_adj_expr = (pat, fm) : un_adj_expr s }
                unless (null np) $ when (null $ tail $ tail vs) $ setState
                    $ \ s -> s { m_un_adj_expr = (np, fm) : m_un_adj_expr s }
                return (ex vs, fm vs)

fun_intr  = do  (pat, vs) <- fun_patt; let ex = Trm (get_name pat)
                fm <- opt ex (char '@' >> fun_alias vs); let np = unp pat
                setState $ \ s -> s { fun_expr = (pat, fm) : fun_expr s }
                unless (null np) $ setState
                    $ \ s -> s { un_fun_expr = (np, fm) : un_fun_expr s }
                return (ex vs, fm vs)

ntn_intr  = do  (pat, vs) <- ntn_patt; let ex = Trm ('a': get_name pat)
                fm <- opt ex (char '@' >> ntn_alias vs); let np = unp pat
                setState $ \ s -> s { ntn_expr = (pat, fm) : ntn_expr s }
                unless (null np) $ setState
                    $ \ s -> s { un_ntn_expr = (np, fm) : un_ntn_expr s }
                nvs <- liftM (:vs) hidden; return (ex nvs, fm nvs)

prf_intr  = do  pt@(pat, vs) <- unp_patt -|- prf_patt -|- smb_patt; char '@'
                f <- ppr pt -|- pfn pt; return (Trm (get_name pat) vs, f)
  where
    ppr (pat, vs) = do  fm <- prd_alias vs; setState
                          $ \ s -> s { ppr_expr = (pat, fm) : ppr_expr s }
                        return $ fm vs

    pfn (pat@[Sm _, Vr], vs) =
                    do  fm <- fun_alias vs; setState
                          $ \ s -> s { ufn_expr = (pat, fm) : ufn_expr s }
                        return $ fm vs

    pfn (pat, vs) = do  fm <- fun_alias vs; setState $ if (last pat == Vr)
                          then \ s -> s { lfn_expr = (pat, fm) : lfn_expr s }
                          else \ s -> s { cfn_expr = (pat, fm) : cfn_expr s }
                        return $ fm vs

inf_intr  = do  v <- var; (pat, us) <- smb_patt; char '@'
                let vs = v:us ; pt = (pat, vs)
                f <- ipr pt -|- ifn pt; return (Trm (get_name pat) vs, f)
  where
    ipr (pat, vs) = do  fm <- prd_alias vs; setState
                          $ \ s -> s { ipr_expr = (pat, fm) : ipr_expr s }
                        when (head vs `elem` decl [] (fm vs)) $ setState
                          $ \ s -> s { int_expr = (pat, fm) : int_expr s }
                        return $ fm vs

    ifn (pat, vs) = do  fm <- fun_alias vs; setState $ if (last pat == Vr)
                          then \ s -> s { ifn_expr = (pat, fm) : ifn_expr s }
                          else \ s -> s { rfn_expr = (pat, fm) : rfn_expr s }
                        return $ fm vs

-- Pattern parsing

ver_patt  = do  v@(Var w) <- var; hd <- opt [] read_head
                when (w == "a" || w == "A") mzero
                (ls, vs) <- read_tail; let nls = hd ++ ls
                when (null nls) mzero; return (nls, v:vs)

adj_patt  = do  v <- var; is; hd <- opt [] read_head
                (ls, vs) <- read_tail; let nls = hd ++ ls
                when (null nls) mzero; return (nls, v:vs)

fun_patt  = do  the; hd <- read_head; (ls, vs) <- read_tail
                return (hd ++ ls, vs)

ntn_patt  = do  an; hd <- read_head; (ls, vs) <- read_tail
                return (hd ++ (Nm:ls), vs)

read_head = do  l <- read_lex; opt [l] ( do m <- read_lex; return [l,m] )

read_tail = opt ([], []) $ do l <- read_lex; v <- var
                              (ls, vs) <- read_tail
                              return (l:Vr:ls, v:vs)

unp_patt  = do  l <- lexem wf_slx; (ls, vs) <- unp_tail; return (Sm l : ls, vs)
  where unp_tail  = opt ([], []) $ do v <- var; return ([Vr], [v])

prf_patt  = do  l <- lexem wf_slx; char '('; v <- var; (ls, vs) <- (u1 -|- u2)
                return (Sm l : Sm "(" : Vr : ls, v:vs)
  where
    u1  = char ',' >> do  v <- var; (ls, vs) <- (u1 -|- u2)
                          return (Sm "," : Vr : ls, v:vs)
    u2  = char ')' >> return ([Sm ")"], [])

smb_patt  = u1
  where
    u1  = do  l <- slx; (ls, vs) <- opt ([], []) u2; return (Sm l : ls, vs)
    u2  = do  v <- var; (ls, vs) <- opt ([], []) u1; return (Vr : ls, v:vs)
    slx = liftM2 (:) (charOf_ op_chars) (slx -|- space [])
      -|- liftM2 (:) (char_ '\\') (lexem wf_slx)


-- Introduction of aliases

prd_alias vs  = do  f <- statement; return $ reenum f vs

ntn_alias vs  = do  (q, g) <- isa_atom; f <- dig [zHole] g
                    return $ reenum (substH f q) (zHole:vs)

fun_alias vs  = do  (_, t) <- fo_term; return $ reenum t vs

reenum f vs   = permute (dotte f) (map dotte vs)
  where
    permute f (v:vs) (t:ts) = permute (subst t v f) vs ts
    permute f _ _ = f

    dotte (Var v) = Var ('.':v)
    dotte f       = mapF dotte f


-- Service stuff

get_name ((Wd ((c:cs):_)):ls) = toUpper c : cs ++ get_name ls
get_name ((Sm s):_:ls) = chcode s ++ '_' : get_name ls
get_name ((Sm s):_) = chcode s
get_name (_:ls) = get_name ls
get_name [] = ""

smp p = if (bi_patt p) then np p else []
  where
    bi_patt (Wd _ : Wd _ : Vr : t) = not (and_patt t)
    bi_patt (_ : t)         = bi_patt t
    bi_patt _               = False

    and_patt (Wd l : _) = "and" `elem` l
    and_patt _          = False

    np (w1 : w2 : _ : Vr : t)  = (w1 : w2 : t)
    np (w1 : _ : Vr : t)       = (w1 : t)

unp p = if (of_patt p) then np p else []
  where
    of_patt (Wd l : Vr : t) = "of" `elem` l && not (and_patt t)
    of_patt (_ : t)         = of_patt t
    of_patt _               = False

    and_patt (Wd l : _) = "and" `elem` l
    and_patt _          = False

    np (w1 : w2 : Nm : _ : Vr : t)  = (w1 : w2 : Nm : t)
    np (w1 : Nm : _ : Vr : t)       = (w1 : Nm : t)
    np (w1 : w2 : _ : Vr : t)       = (w1 : w2 : Nm : t)
    np (w1 : _ : Vr : t)            = (w1 : Nm : t)

read_lex  = liftM Wd real
  where
    real  = liftM2 (:) (lexem wf_lex) (opt [] $ char '/' >> real)

lexem wfl = do  l <- readWord; if (wfl l) then space l
                  else fail ("invalid lexem " ++ show l)

wf_lex l  = and (map isAlpha l) && wf_com l
wf_slx l  = and (map isAlphaNum l) && wf_com l
wf_com l  = not (wf_var l) && l `notElem` ["a", "an", "the", "is", "are", "be"]


op_chars = "`~!@$%^&*()-+=[]{}:'\"<>/?\\|;,0123456789"

chcode = concatMap chc
  where
    chc '`' = "bq" ; chc '~'  = "tl" ; chc '!' = "ex"
    chc '@' = "at" ; chc '$'  = "dl" ; chc '%' = "pc"
    chc '^' = "cf" ; chc '&'  = "et" ; chc '*' = "as"
    chc '(' = "lp" ; chc ')'  = "rp" ; chc '-' = "mn"
    chc '+' = "pl" ; chc '='  = "eq" ; chc '[' = "lb"
    chc ']' = "rb" ; chc '{'  = "lc" ; chc '}' = "rc"
    chc ':' = "cl" ; chc '\'' = "qt" ; chc '"' = "dq"
    chc '<' = "ls" ; chc '>'  = "gt" ; chc '/' = "sl"
    chc '?' = "qu" ; chc '\\' = "bs" ; chc '|' = "br"
    chc ';' = "sc" ; chc ','  = "cm" ; chc '0' = "zr"
    chc '1' = "on" ; chc '2'  = "tw" ; chc '3' = "th"
    chc '4' = "fr" ; chc '5'  = "fv" ; chc '6' = "sx"
    chc '7' = "sv" ; chc '8'  = "ei" ; chc '9' = "nn"
    chc c   = [c]

