1 ----------------------------------------------------------------------------
    2 -- |
    3 -- Module      :  Parser
    4 -- Copyright   :  (c) Masahiro Sakai 2007-2009
    5 -- License     :  BSD3-style (see LICENSE)
    6 -- 
    7 -- Maintainer:    masahiro.sakai@gmail.com
    8 -- Stability   :  experimental
    9 -- Portability :  non-portable
   10 
   11 {-# LANGUAGE TypeOperators #-}
   12 module Parser (parse, parseAny) where
   13 
   14 import Data.Char
   15 import Control.Monad
   16 import qualified Data.IntSet as IS
   17 
   18 import P
   19 
   20 -----------------------------------------------------------------------------
   21 -- パーサのコア部分
   22 
   23 type Token = String
   24 
   25 newtype Parser a
   26     = Parser
   27     { runParser :: Env -> State -> [Token] -> [(a, State, [Token])]
   28     }
   29 
   30 instance Monad Parser where
   31     return x = Parser $ \_ s ts -> [(x,s,ts)]
   32     m >>= f = Parser $ \env s ts ->
   33               do (v,s',ts') <- runParser m env s ts
   34                  runParser (f v) env s' ts'
   35 
   36 instance MonadPlus Parser where
   37     mzero = Parser $ \_ _ _ -> []
   38     mplus x y = Parser $ \env s ts ->
   39                 runParser x env s ts ++ runParser y env s ts
   40 
   41 infixr 0 <|>
   42 (<|>) :: Parser a -> Parser a -> Parser a
   43 (<|>) = mplus
   44 
   45 anyToken :: Parser Token
   46 anyToken = Parser g
   47     where g _ _ []     = []
   48           g _ s (t:ts) = [(t, s, ts)]
   49 
   50 lookAhead :: Parser Token
   51 lookAhead = Parser g
   52     where g _ _ []     = []
   53           g _ s (t:ts) = [(t, s, t:ts)]
   54 
   55 -----------------------------------------------------------------------------
   56 -- 環境
   57 
   58 data Env
   59     = Env
   60     { s3env :: S3Env
   61     }
   62 
   63 initialEnv :: Env
   64 initialEnv = Env{ s3env = initialS3Env }
   65 
   66 local :: (Env -> Env) -> Parser a -> Parser a
   67 local f (Parser g) = Parser g'
   68     where g' env s ts = g (f env) s ts
   69 
   70 ask :: Parser Env
   71 ask = Parser g
   72     where g env s ts = [(env,s,ts)]
   73 
   74 -----------------------------------------------------------------------------
   75 -- 状態
   76 
   77 data State
   78     = State
   79     { gensymState :: PronounNo
   80     , f10State    :: F10State
   81     }
   82 initialState :: State
   83 initialState = State{ gensymState = 0, f10State = initialF10State }
   84 
   85 get :: Parser State
   86 get = Parser g
   87     where g _ s xs = [(s,s,xs)]
   88 
   89 put :: State -> Parser ()
   90 put s = Parser g
   91     where g _ _ xs = [((),s,xs)]
   92 
   93 -----------------------------------------------------------------------------
   94 -- S3Env
   95 
   96 type S3Env = [(PronounNo,Gender)] -- S3規則で使うためのデータ
   97 initialS3Env :: S3Env
   98 initialS3Env = []
   99 
  100 localS3 :: (S3Env -> S3Env) -> Parser a -> Parser a
  101 localS3 f = local (\env@Env{ s3env = x } -> env{ s3env = f x })
  102 
  103 askS3 :: Parser S3Env
  104 askS3 = liftM s3env ask
  105 
  106 -----------------------------------------------------------------------------
  107 -- Counter
  108 
  109 gensym :: Parser PronounNo
  110 gensym =
  111     do s@State{ gensymState = i } <- get
  112        put s{ gensymState = i+1 }
  113        return i
  114 
  115 -----------------------------------------------------------------------------
  116 -- F10のための処理
  117 
  118 -- DVarStateみたいな名前にした方が良いか
  119 type F10Entry = (PronounNo, Gender, P T, IS.IntSet)
  120 type F10State = [F10Entry] -- F10で使うためのデータ
  121 initialF10State :: F10State
  122 initialF10State = []
  123 
  124 getF10State :: Parser F10State
  125 getF10State =
  126     do State{ f10State = s } <- get
  127        return s
  128 
  129 putF10State :: F10State -> Parser ()
  130 putF10State s =
  131     do x <- get
  132        put x{ f10State = s }
  133 
  134 asPronoun :: Gender -> P T -> Parser (P T)
  135 asPronoun g t =
  136     do n <- gensym
  137        s <- getF10State
  138        putF10State ((n,g,t,fvs t) : s)
  139        return (He n)
  140 
  141 mayF10s :: F10 c => Parser (P c) -> Parser (P c)
  142 mayF10s p = liftM fst $ mayF10s' $ p >>= \x -> return (x,())
  143 
  144 mayF10s' :: F10 c => Parser (P c, a) -> Parser (P c, a)
  145 mayF10s' p =
  146     do s <- getF10State
  147        putF10State []
  148        (x,a) <- localS3 ([(n,g) | (n,g,_,_)<-s]++) p
  149        x' <- introF10s x
  150        s' <- getF10State
  151        putF10State (s'++s)
  152        return (x',a)
  153 
  154 introF10 :: F10 c => P c -> Parser (P c)
  155 introF10 x =
  156     do (n, _, alpha, _) <- takeF10Entry
  157        return (F10 n alpha x)
  158 
  159 introF10s :: F10 c => P c -> Parser (P c)
  160 introF10s x = (introF10 x >>= introF10s) <|> return x
  161 
  162 -- F10に変換可能なエントリを取り出す
  163 takeF10Entry :: Parser F10Entry
  164 takeF10Entry =
  165     do s <- getF10State
  166        (e@(n,_,_,_), s') <- msum $ map return $ pick s
  167        noDanglingRef n
  168        putF10State s'
  169        return e
  170 
  171 pick :: [a] -> [(a,[a])]
  172 pick []     = []
  173 pick (x:xs) = (x,xs) : [(y,x:ys) | (y,ys) <- pick xs] 
  174 
  175 -- nへの参照が残っていないことを保障
  176 noDanglingRef :: PronounNo -> Parser ()
  177 noDanglingRef n =
  178     do s <- getF10State
  179        guard $ and [not (IS.member n vs) | (_,_,_,vs) <- s]
  180 
  181 -----------------------------------------------------------------------------
  182 -- パーサのユーティリティ
  183 
  184 token :: Token -> Parser Token
  185 token x =
  186     do y <- anyToken
  187        guard $ x==y
  188        return y
  189 
  190 many, many1 :: Parser a -> Parser [a]
  191 many p = many1 p <|> return []
  192 many1 p =
  193     do x  <- p
  194        xs <- many p
  195        return (x:xs)
  196 
  197 chainr1 :: Parser a -> Parser (a->a->a) -> Parser a
  198 chainr1 p q =
  199     do x <- p
  200        f <- do{ op <- q; y <- chainr1 p q; return (`op` y) } <|> return id
  201        return (f x)
  202 
  203 -----------------------------------------------------------------------------
  204 -- API
  205 
  206 parse :: String -> [P Sen]
  207 parse = parse' p_t
  208 
  209 parseAny :: String -> [PAny]
  210 parseAny s = concat $
  211   [ f p_Det, f (liftM fst p_CN), f p_IAV_T, f p_t_t, f p_t, f p_Adj, f p_PP
  212   , f p_IAV, f p_PP_T, f (p_T [Subject, Object]) ] ++
  213   [ concat [ f (p_IV x), f (p_TV x), f (p_IV__IV x), f (p_DTV x), f (p_IV_t x)
  214            , f (p_IV_Adj x)] | x <- vfs ]
  215   where
  216     f :: CatType a => Parser (P a) -> [PAny]
  217     f p = map PAny (parse' p s)
  218     vfs :: [VerbForm]
  219     vfs = [VFOrig, VFPastParticiple] ++ [f True | f <- [VFPresent, VFFuture, VFPerfect]]
  220     -- 否定形の動詞それ自体はPで表現できないのでパース出来ない
  221 
  222 parse' :: Parser (P a) -> String -> [P a]
  223 parse' p s = [x | (x, State{ f10State = [] }, []) <- runParser p initialEnv initialState ts]
  224     where ts = tokenize s
  225 
  226 tokenize :: String -> [Token]
  227 tokenize = expandAbbr . words . map toLower . filter ('.'/=)
  228 
  229 expandAbbr :: [String] -> [String]
  230 expandAbbr = concatMap f
  231     where f "doesn't" = ["does", "not"]
  232           f "won't"   = ["will", "not"]
  233           f "hasn't"  = ["has",  "not"]
  234           f "isn't"   = ["is",   "not"]
  235           f x = [x]
  236 
  237 -----------------------------------------------------------------------------
  238 -- 各範疇のパーサ
  239 
  240 p_Det :: Parser (P Det)
  241 p_Det =
  242     do x@(B _ s) <- s1_Det
  243        let x' = if s=="an" then B (cat :: Cat Det) "a" else x -- XXX
  244        -- FIXME: anの場合には次の語が母音で始まるかチェック
  245        return $ x'
  246 
  247 p_CN :: Parser (P CN, Gender)
  248 p_CN = mayF10s' $ -- S15
  249     do (zeta,g) <- s1_CN
  250        zeta <- s3s g zeta
  251        return (zeta,g)
  252 
  253 -- FIXME: 全ての組み合わせを網羅している?
  254 p_T :: [Case] -> Parser (P T)
  255 p_T cs = chainr1 (p <|> he_n cs) f9 -- S13
  256     where p = do (x,g) <- s1_T <|> s2
  257                  return x <|> asPronoun g x
  258 
  259 -- He_n
  260 he_n :: [Case] -> Parser (P T)
  261 he_n cs =
  262     do g <- mplus
  263             (if Subject `elem` cs
  264              then msum [ token "he"  >> return Masculine
  265                        , token "she" >> return Feminine
  266                        , token "it"  >> return Neuter
  267                        ]
  268              else mzero)
  269             (if Object `elem` cs
  270              then msum [ token "him" >> return Masculine
  271                        , token "her" >> return Feminine
  272                        , token "it"  >> return Neuter
  273                        ]
  274              else mzero)
  275        xs <- getF10State
  276        ys <- askS3
  277        let ns = [(n,g') | (n, g', _, _) <- xs] ++ ys
  278        msum [ return (He n) | (n,g') <- ns, g==g' ]
  279 
  280 -- FIXME: 全ての組み合わせを網羅している?
  281 p_IV :: VerbForm -> Parser (P IV)
  282 p_IV vf = mayF10s q -- S16
  283     where p = do x <- s1_IV vf
  284                       <|> s5 vf
  285                       <|> s7 vf 
  286                       <|> s8 vf
  287                       <|> s18 vf
  288                       <|> s19 vf
  289                       <|> s23 vf
  290                  liftM (foldl (flip F7) x) (many p_IAV) -- S10
  291           q = chainr1 p (f8 <|> f9) -- S12a, S12b
  292 
  293 p_TV :: VerbForm -> Parser (P TV)
  294 p_TV vf = s1_TV vf <|> s20 vf <|> s21 vf
  295 
  296 p_IAV_T :: Parser (P (IAV :/ T))
  297 p_IAV_T = s1_IAV_T
  298 
  299 p_IV__IV :: VerbForm -> Parser (P (IV :// IV))
  300 p_IV__IV = s1_IV__IV
  301 
  302 p_t_t :: Parser (P (Sen :/ Sen))
  303 p_t_t = s1_t_t
  304 
  305 -- FIXME: 全ての組み合わせを網羅している?
  306 p_t :: Parser (P Sen)
  307 p_t = mayF10s $ -- S14
  308       chainr1 (s9 <|> s4_or_s17) (f8 <|> f9) -- S11a, S11b
  309 
  310 p_IV_t :: VerbForm -> Parser (P (IV :/ Sen))
  311 p_IV_t = s1_IV_t
  312 
  313 p_IV_Adj :: VerbForm -> Parser (P (IV :/ Adj))
  314 p_IV_Adj vf = s1_IV_Adj vf
  315 
  316 p_Adj :: Parser (P Adj)
  317 p_Adj = s1_Adj <|> s25
  318 
  319 -- FIXME
  320 p_DTV :: VerbForm -> Parser (P DTV)
  321 p_DTV vf = mzero -- ???
  322 
  323 p_PP :: Parser (P PP)
  324 p_PP = s24
  325 
  326 p_IAV :: Parser (P IAV)
  327 p_IAV = s1_IAV <|> s6
  328 
  329 p_PP_T :: Parser (P (PP :/ T))
  330 p_PP_T = s1_PP_T
  331 
  332 -----------------------------------------------------------------------------
  333 -- 動詞の辞書
  334 
  335 -- (原形, 三人称単数現在形, 過去分詞)
  336 type VerbEntry = (String, String, String)
  337 
  338 verb_be :: VerbEntry
  339 verb_be = ("be", "is", "been")
  340 
  341 {-# INLINE regularVerb #-}
  342 regularVerb :: String -> VerbEntry
  343 regularVerb s = (s, present, past_participle)
  344     where
  345       rs = reverse s
  346       present =
  347           case rs of
  348           's':'s':_ -> s ++ "es"
  349           'h':'c':_ -> s ++ "es"
  350           'h':'s':_ -> s ++ "es"
  351           'x':_ -> s ++ "es"
  352           'y':s' -> reverse s' ++ "ies"
  353           _      -> s ++ "s"
  354       past_participle =
  355           case rs of
  356           'e':_  -> s ++ "d"
  357           'y':s' -> reverse s' ++ "ied"
  358           _      -> s ++ "ed"
  359 
  360 dict_IV :: [VerbEntry]
  361 dict_IV =
  362     [ regularVerb "walk"
  363     , regularVerb "talk"
  364     , regularVerb "change"
  365     , ("run",  "runs",  "ran")
  366     , ("rise", "rises", "rosen")
  367     ]
  368 
  369 dict_TV :: [VerbEntry]
  370 dict_TV =
  371     [ ("find", "finds", "found")
  372     , ("lose", "loses", "lost")
  373     , ("eat",  "eats",  "eaten")
  374     , ("seek", "seeks", "sought")
  375     , regularVerb "love"
  376     , regularVerb "date"
  377     --, "coneive" -- FIXME: conceiveの間違い?
  378     , verb_be
  379     ]
  380 
  381 dict_IV_t :: [VerbEntry]
  382 dict_IV_t =
  383     [ regularVerb "believe"
  384     , regularVerb "assert"
  385     ]
  386 
  387 dict_IV__IV :: [VerbEntry]
  388 dict_IV__IV =
  389     [ regularVerb "try"
  390     , regularVerb "wish"
  391     ]
  392 
  393 dict_IV_Adj :: [VerbEntry]
  394 dict_IV_Adj = [verb_be]
  395 
  396 -- DTVをTTVに変換することは出来るから、giveの範疇はDTVだろうな。多分。
  397 dict_DTV :: [VerbEntry]
  398 dict_DTV =
  399     [ ("give", "gives", "given")
  400     ]
  401 
  402 -----------------------------------------------------------------------------
  403 -- 動詞のパーサ
  404 
  405 data VerbForm
  406     = VFOrig           -- 原形
  407     | VFPastParticiple -- 過去分詞
  408     | VFPresent !Bool  -- 三人称単数現在形とその否定形
  409     | VFFuture  !Bool  -- 三人称単数未来系とその否定形
  410     | VFPerfect !Bool  -- 三人称単数現在完了系とその否定形
  411 
  412 {-# INLINE verbParser #-}
  413 verbParser :: CatType c => [VerbEntry] -> VerbForm -> Parser (P c)
  414 verbParser dict vf =
  415     do s <- verbParser' dict vf
  416        return (B cat s)
  417 
  418 -- FIXME: 後で整理する
  419 {-# INLINE verbParser' #-}
  420 verbParser' :: [VerbEntry] -> VerbForm -> Parser String
  421 verbParser' dict (VFPresent False) =
  422     mplus (do token "does"
  423               token "not"
  424               x <- verbParser' dict VFOrig
  425               guard (x/="be")
  426               return x)
  427           (do x <- verbParser' dict (VFPresent True)
  428               guard (x=="be")
  429               token "not"
  430               return x)
  431 verbParser' dict (VFFuture b) =
  432     do token "will"
  433        unless b $ token "not" >> return ()
  434        verbParser' dict VFOrig
  435 verbParser' dict (VFPerfect b) =
  436     do token "has"
  437        unless b $ token "not" >> return ()
  438        verbParser' dict VFPastParticiple
  439 verbParser' dict vf =
  440     do x <- anyToken
  441        msum [ return o
  442             | (o, present, pastparticiple) <- dict
  443             , case vf of
  444               VFOrig           -> o==x
  445               VFPastParticiple -> pastparticiple==x
  446               VFPresent True   -> present==x
  447               _ -> False -- shouldn't happen
  448             ]
  449 
  450 -----------------------------------------------------------------------------
  451 -- 名詞の辞書とパーサ
  452 
  453 data Case = Subject | Object deriving (Show,Eq,Ord)
  454 
  455 data Gender = Masculine | Feminine | Neuter deriving (Show,Eq,Ord)
  456 type NounEntry = (String, Gender)
  457 
  458 dict_T :: [NounEntry]
  459 dict_T =
  460     [ ("john"   , Masculine)
  461     , ("mary"   , Feminine)
  462     , ("bill"   , Masculine)
  463     , ("ninety" , Neuter)
  464     ]
  465 
  466 dict_CN :: [NounEntry]
  467 dict_CN =
  468     [ ("man"         , Masculine)
  469     , ("woman"       , Feminine)
  470     , ("park"        , Neuter)
  471     , ("fish"        , Neuter)
  472     , ("pen"         , Neuter)
  473     , ("unicorn"     , Neuter)
  474     , ("price"       , Neuter)
  475     , ("temperature" , Neuter)
  476     ]
  477 
  478 {-# INLINE nounParser #-}
  479 nounParser :: CatType c => [NounEntry] -> Parser (P c, Gender)
  480 nounParser dict =
  481     do x <- anyToken
  482        case lookup x dict of
  483          Nothing -> mzero
  484          Just g  -> return (B cat x, g)
  485 
  486 -----------------------------------------------------------------------------
  487 -- それ以外の基本表現の辞書とパーサ
  488 
  489 dict_IAV :: [String]
  490 dict_IAV = 
  491     [ "rapidly"
  492     , "slowly"
  493     , "voluntarily"
  494     , "allegedly"
  495     ]
  496 
  497 dict_t_t :: [String]
  498 dict_t_t = ["necessarily"]
  499 
  500 dict_IAV_T :: [String]
  501 dict_IAV_T = ["in", "about"]
  502 
  503 dict_Adj :: [String]
  504 dict_Adj = ["asleep"]
  505 
  506 dict_Det :: [String]
  507 dict_Det = ["a", "an", "the", "every", "no"]
  508 
  509 dict_PP_T :: [String]
  510 dict_PP_T = ["by"]
  511 
  512 {-# INLINE dictParser #-}
  513 dictParser :: CatType c => [String] -> Parser (P c)
  514 dictParser dict =
  515     do x <- anyToken
  516        guard $ x `elem` dict
  517        return $ B cat x
  518 
  519 -----------------------------------------------------------------------------
  520 -- 各統語規則のパーサ
  521 
  522 s1_IV :: VerbForm -> Parser (P IV)
  523 s1_IV = verbParser dict_IV
  524 
  525 s1_TV :: VerbForm -> Parser (P TV)
  526 s1_TV = verbParser dict_TV
  527 
  528 s1_IV_t :: VerbForm -> Parser (P (IV :/ Sen))
  529 s1_IV_t = verbParser dict_IV_t
  530 
  531 s1_IV__IV :: VerbForm -> Parser (P (IV :// IV))
  532 s1_IV__IV = verbParser dict_IV__IV
  533 
  534 s1_IV_Adj :: VerbForm -> Parser (P (IV :/ Adj))
  535 s1_IV_Adj = verbParser dict_IV_Adj
  536 
  537 s1_T :: Parser (P T, Gender)
  538 s1_T = nounParser dict_T
  539 
  540 s1_CN :: Parser (P CN, Gender)
  541 s1_CN = nounParser dict_CN
  542 
  543 s1_IAV :: Parser (P IAV)
  544 s1_IAV = dictParser dict_IAV
  545 
  546 s1_t_t :: Parser (P (Sen :/ Sen)) 
  547 s1_t_t = dictParser dict_t_t
  548 
  549 s1_IAV_T :: Parser (P (IAV :/ T))
  550 s1_IAV_T = dictParser dict_IAV_T
  551 
  552 s1_Adj :: Parser (P Adj)
  553 s1_Adj = dictParser dict_Adj
  554 
  555 s1_Det :: Parser (P Det)
  556 s1_Det = dictParser dict_Det
  557 
  558 s1_PP_T :: Parser (P (PP :/ T))
  559 s1_PP_T = dictParser dict_PP_T
  560 
  561 s2 :: Parser (P T, Gender)
  562 s2 =
  563     do delta <- p_Det
  564        -- w <- lookAhead
  565        (zeta,g) <- p_CN
  566        return (F2 delta zeta, g)
  567 
  568 s3s :: Gender -> P CN -> Parser (P CN)
  569 s3s g zeta = (s3_postfix g zeta >>= s3s g) <|> return zeta
  570 
  571 s3_postfix :: Gender -> P CN -> Parser (P CN)
  572 s3_postfix g zeta =
  573     do token "such"
  574        token "that"
  575        n <- gensym
  576        phi <- localS3 ((n,g):) p_t
  577        guard $ IS.member n (fvs phi) -- XXX: He n が現れていることを検査。
  578        noDanglingRef n -- nを参照している参照が残っていないことを保障
  579        return (F3 n zeta phi)
  580 
  581 s4_or_s17 :: Parser (P Sen)
  582 s4_or_s17 =
  583     do alpha <- p_T [Subject]
  584        msum [ do delta <- p_IV (VFPresent True)
  585                  return (F4 alpha delta) -- 三人称単数現在形 (S4)
  586             , do delta <- p_IV (VFPresent False) 
  587                  return (F11 alpha delta) -- 三人称単数現在の否定形 (S17)
  588             , do delta <- p_IV (VFFuture True)
  589                  return (F12 alpha delta) -- 三人称単数未来形 (S17)
  590             , do delta <- p_IV (VFFuture False)
  591                  return (F13 alpha delta) -- 三人称単数未来の否定形 (S17)
  592             , do delta <- p_IV (VFPerfect True)
  593                  return (F14 alpha delta) -- 三人称単数現在完了形 (S17)
  594             , do delta <- p_IV (VFPerfect False) 
  595                  return (F15 alpha delta) -- 三人称単数現在完了の否定形 (S17)
  596             ]
  597 
  598 s5 :: VerbForm -> Parser (P IV)
  599 s5 vf =
  600     do delta <- p_TV vf
  601        beta  <- p_T [Object]
  602        return (F5 delta beta)
  603 
  604 s6 :: Parser (P IAV)
  605 s6 =
  606     do delta <- p_IAV_T
  607        beta <- p_T [Object]
  608        return (F5 delta beta)
  609 
  610 s7 :: VerbForm -> Parser (P IV)
  611 s7 vf =
  612     do delta <- p_IV_t vf
  613        token "that"
  614        phi <- p_t
  615        return (F16 delta phi)
  616 
  617 s8 :: VerbForm -> Parser (P IV)
  618 s8 vf =
  619     do delta <- p_IV__IV vf
  620        token "to"
  621        beta <- p_IV VFOrig
  622        return (F17 delta beta)
  623 
  624 s9 :: Parser (P Sen)
  625 s9 =
  626     do delta <- p_t_t
  627        beta <- p_t
  628        return (F6 delta beta)
  629 
  630 -- S10 は他のパーサの中に組み込んでしまっている
  631 -- S11a, S11b, S12a, S12b, S13 は他のパーサの中に組み込んでしまっている
  632 -- S14, S15, S16 は他のパーサの中に組み込んでしまっている
  633 
  634 f8 :: F8 c => Parser (P c -> P c -> P c)
  635 f8 = token "and" >> return F8
  636 
  637 f9 :: F9 c => Parser (P c -> P c -> P c)
  638 f9 = token "or" >> return F9
  639 
  640 -- S17はS4のパーサの中に組み込んでしまっている
  641 
  642 -- 講義資料でF9と書いてある???
  643 s18 :: VerbForm -> Parser (P IV)
  644 s18 vf =
  645     do alpha <- p_IV_Adj vf
  646        beta <- p_Adj
  647        return (F6 alpha beta)
  648 
  649 s19 :: VerbForm -> Parser (P IV)
  650 s19 vf = liftM F19 (p_TV vf)
  651 
  652 -- FIXME: S20とS21のどちらかはTTVでは?
  653 -- S20の方か?
  654 
  655 -- ???: x が DTV ならば、x to him は TV
  656 s20 :: VerbForm -> Parser (P TV)
  657 s20 vf =
  658     do delta <- p_DTV vf
  659        token "to"
  660        beta <- p_T [Object]
  661        return (F20 delta beta)
  662 
  663 s21 :: VerbForm -> Parser (P TV)
  664 s21 vf =
  665     do delta <- p_DTV vf
  666        beta <- p_T [Object]
  667        return (F21 delta beta)
  668 
  669 -- FIXME: この規則はどこからも使われていないけど良いのだろうか?
  670 s22 :: VerbForm -> Parser (P TTV)
  671 s22 vf = liftM F22 (p_DTV vf)
  672 
  673 -- FIXME: αが-enならばというのは何を指している?
  674 -- δ が been, rosen, eaten であること?
  675 s23 :: VerbForm -> Parser (P IV)
  676 s23 vf =
  677     do verbParser' [verb_be] vf
  678        delta <- p_TV VFPastParticiple
  679        alpha <- p_PP
  680        return (F23 alpha delta)
  681 
  682 -- FIXME: αが-enならばというのは何を指している?
  683 -- β≠he_n の間違いか?
  684 s24 :: Parser (P PP)
  685 s24 =
  686     do alpha <- p_PP_T
  687        beta <- p_T [Object]
  688        return (F24 alpha beta)
  689 
  690 s25 :: Parser (P Adj)
  691 s25 =
  692     do delta <- p_TV VFPastParticiple
  693        return (F25 delta)
  694 
  695 -----------------------------------------------------------------------------
  696 
  697 -- He n で表される「自由変数」の集合
  698 fvs :: P c -> IS.IntSet
  699 fvs (B _ _)     = IS.empty
  700 fvs (He n)      = IS.singleton n
  701 fvs (F2 x y)    = IS.union (fvs x) (fvs y)
  702 fvs (F3 n x y)  = IS.delete n $ IS.union (fvs x) (fvs y)
  703 fvs (F4 x y)    = IS.union (fvs x) (fvs y)
  704 fvs (F5 x y)    = IS.union (fvs x) (fvs y)
  705 fvs (F6 x y)    = IS.union (fvs x) (fvs y)
  706 fvs (F7 x y)    = IS.union (fvs x) (fvs y)
  707 fvs (F8 x y)    = IS.union (fvs x) (fvs y)
  708 fvs (F9 x y)    = IS.union (fvs x) (fvs y)
  709 fvs (F10 n x y) = IS.delete n $ IS.union (fvs x) (fvs y)
  710 fvs (F11 x y)   = IS.union (fvs x) (fvs y)
  711 fvs (F12 x y)   = IS.union (fvs x) (fvs y)
  712 fvs (F13 x y)   = IS.union (fvs x) (fvs y)
  713 fvs (F14 x y)   = IS.union (fvs x) (fvs y)
  714 fvs (F15 x y)   = IS.union (fvs x) (fvs y)
  715 fvs (F16 x y)   = IS.union (fvs x) (fvs y)
  716 fvs (F17 x y)   = IS.union (fvs x) (fvs y)
  717 fvs (F19 x)     = fvs x
  718 fvs (F20 x y)   = IS.union (fvs x) (fvs y)
  719 fvs (F21 x y)   = IS.union (fvs x) (fvs y)
  720 fvs (F22 x)     = fvs x
  721 fvs (F23 x y)   = IS.union (fvs x) (fvs y)
  722 fvs (F24 x y)   = IS.union (fvs x) (fvs y)
  723 fvs (F25 x)     = fvs x