From 0606de738e0d934b45f39f1bbe34ed1defde478a Mon Sep 17 00:00:00 2001 From: krasimir Date: Tue, 21 Oct 2008 14:30:36 +0000 Subject: efficient and nicer implementation for literal categories --- src/PGF/Data.hs | 1 + src/PGF/Parsing/FCFG/Incremental.hs | 90 +++++++++++++++++-------------------- src/PGF/Raw/Convert.hs | 6 ++- 3 files changed, 45 insertions(+), 52 deletions(-) (limited to 'src/PGF') diff --git a/src/PGF/Data.hs b/src/PGF/Data.hs index 8ee95c579..31b267a17 100644 --- a/src/PGF/Data.hs +++ b/src/PGF/Data.hs @@ -70,6 +70,7 @@ type FIndex = Int type FPointPos = Int data FSymbol = FSymCat {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex + | FSymLit {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex | FSymTok Tokn deriving (Eq,Ord,Show) type Profile = [Int] diff --git a/src/PGF/Parsing/FCFG/Incremental.hs b/src/PGF/Parsing/FCFG/Incremental.hs index 99d734f40..bd95ec34e 100644 --- a/src/PGF/Parsing/FCFG/Incremental.hs +++ b/src/PGF/Parsing/FCFG/Incremental.hs @@ -44,48 +44,27 @@ initState pinfo (DTyp _ start _) = -- is consumed and the current position shifted by one. nextState :: ParseState -> String -> Maybe ParseState nextState (State pinfo chart items) t = - let (items1,chart1) = process add (sequences pinfo) (functions pinfo) (Set.toList items) Set.empty chart - (items2,chart2) = addConst pinfo (AK fcatString 0) (Lit (LStr t)) t items1 chart1 - (items3,chart3) = case reads t of {[(n,"")] -> addConst pinfo (AK fcatInt 0) (Lit (LInt n)) t items2 chart2; - _ -> (items2,chart2)} - (items4,chart4) = case reads t of {[(d,"")] -> addConst pinfo (AK fcatFloat 0) (Lit (LFlt d)) t items3 chart3; - _ -> (items3,chart3)} - (items5,chart5) = addConst pinfo (AK fcatVar 0) (Var (mkCId t)) t items4 chart4 - chart6 = chart5{ active =emptyAC - , actives=active chart5 : actives chart5 + let (items1,chart1) = process (Just t) add (sequences pinfo) (functions pinfo) (Set.toList items) Set.empty chart + chart2 = chart1{ active =emptyAC + , actives=active chart1 : actives chart1 , passive=emptyPC - , offset =offset chart5+1 + , offset =offset chart1+1 } - in if Set.null items5 + in if Set.null items1 then Nothing - else Just (State pinfo chart6 items5) + else Just (State pinfo chart2 items1) where add (KS tok) item set | tok == t = Set.insert item set | otherwise = set -addConst :: ParserInfo -> ActiveKey -> Tree -> String -> Set.Set Active -> Chart -> (Set.Set Active,Chart) -addConst pinfo key const s items chart = - case lookupAC key (active chart) of - Nothing -> (items,chart) - Just set -> let fid = nextId chart - - items1 = Set.fold (\(Active j ppos funid seqid args key) -> - let FSymCat d _ = unsafeAt (unsafeAt (sequences pinfo) seqid) ppos - in Set.insert (Active j (ppos+1) funid seqid (updateAt d fid args) key)) items set - - chart1 = chart{forest =IntMap.insert fid (Set.singleton (FConst const s)) (forest chart) - ,nextId =nextId chart+1 - } - in (items1,chart1) - -- | If the next token is not known but only its prefix (possible empty prefix) -- then the 'getCompletions' function can be used to calculate the possible -- next words and the consequent states. This is used for word completions in -- the GF interpreter. getCompletions :: ParseState -> String -> Map.Map String ParseState getCompletions (State pinfo chart items) w = - let (map',chart1) = process add (sequences pinfo) (functions pinfo) (Set.toList items) Map.empty chart + let (map',chart1) = process Nothing add (sequences pinfo) (functions pinfo) (Set.toList items) Map.empty chart chart2 = chart1{ active =emptyAC , actives=active chart1 : actives chart1 , passive=emptyPC @@ -100,7 +79,7 @@ getCompletions (State pinfo chart items) w = extractExps :: ParseState -> Type -> [Tree] extractExps (State pinfo chart items) (DTyp _ start _) = exps where - (_,st) = process (\_ _ -> id) (sequences pinfo) (functions pinfo) (Set.toList items) () chart + (_,st) = process Nothing (\_ _ -> id) (sequences pinfo) (functions pinfo) (Set.toList items) () chart exps = nubsort $ do cat <- fromMaybe [] (Map.lookup start (startCats pinfo)) @@ -142,8 +121,8 @@ extractExps (State pinfo chart items) (DTyp _ start _) = exps _B = mkCId "_B" _V = mkCId "_V" -process fn !seqs !funs [] acc chart = (acc,chart) -process fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) acc chart +process mbt fn !seqs !funs [] acc chart = (acc,chart) +process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) acc chart | inRange (bounds lin) ppos = case unsafeAt lin ppos of FSymCat d r -> let !fid = args !! d @@ -155,17 +134,23 @@ process fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) acc ch items3 = foldForest (\funid args items -> Active k 0 funid (rhs funid r) args key : items) (\_ _ items -> items) items2 fid (forest chart) - acc2 = if fid < 0 -- literal category - then foldForest (\funid args acc -> acc) - (\lit s acc -> fn (KS s) (Active j (ppos+1) funid seqid args key0) acc) - acc fid (forest chart) - else acc in case lookupAC key (active chart) of - Nothing -> process fn seqs funs items3 acc2 chart{active=insertAC key (Set.singleton item) (active chart)} - Just set | Set.member item set -> process fn seqs funs items acc chart - | otherwise -> process fn seqs funs items2 acc2 chart{active=insertAC key (Set.insert item set) (active chart)} + Nothing -> process mbt fn seqs funs items3 acc chart{active=insertAC key (Set.singleton item) (active chart)} + Just set | Set.member item set -> process mbt fn seqs funs items acc chart + | otherwise -> process mbt fn seqs funs items2 acc chart{active=insertAC key (Set.insert item set) (active chart)} FSymTok tok -> let !acc' = fn tok (Active j (ppos+1) funid seqid args key0) acc - in process fn seqs funs items acc' chart + in process mbt fn seqs funs items acc' chart + FSymLit d r -> let !fid = args !! d + in case [t | set <- IntMap.lookup fid (forest chart), FConst _ t <- Set.toList set] of + (tok:_) -> let !acc' = fn (KS tok) (Active j (ppos+1) funid seqid args key0) acc + in process mbt fn seqs funs items acc' chart + [] -> case litCatMatch fid mbt of + Just (t,lit) -> let fid' = nextId chart + !acc' = fn (KS t) (Active j (ppos+1) funid seqid (updateAt d fid' args) key0) acc + in process mbt fn seqs funs items acc' chart{forest=IntMap.insert fid' (Set.singleton (FConst lit t)) (forest chart) + ,nextId=nextId chart+1 + } + Nothing -> process mbt fn seqs funs items acc chart | otherwise = case lookupPC (mkPK key0 j) (passive chart) of Nothing -> let fid = nextId chart @@ -175,12 +160,12 @@ process fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) acc ch Just set -> Set.fold (\(Active j' ppos funid seqid args keyc) -> let FSymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos in (:) (Active j' (ppos+1) funid seqid (updateAt d fid args) keyc)) items set - in process fn seqs funs items2 acc chart{passive=insertPC (mkPK key0 j) fid (passive chart) - ,forest =IntMap.insert fid (Set.singleton (FApply funid args)) (forest chart) - ,nextId =nextId chart+1 - } + in process mbt fn seqs funs items2 acc chart{passive=insertPC (mkPK key0 j) fid (passive chart) + ,forest =IntMap.insert fid (Set.singleton (FApply funid args)) (forest chart) + ,nextId =nextId chart+1 + } Just id -> let items2 = [Active k 0 funid (rhs funid r) args (AK id r) | r <- labelsAC id (active chart)] ++ items - in process fn seqs funs items2 acc chart{forest = IntMap.insertWith Set.union id (Set.singleton (FApply funid args)) (forest chart)} + in process mbt fn seqs funs items2 acc chart{forest = IntMap.insertWith Set.union id (Set.singleton (FApply funid args)) (forest chart)} where !lin = unsafeAt seqs seqid !k = offset chart @@ -190,15 +175,20 @@ process fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) acc ch rhs funid lbl = unsafeAt lins lbl where FFun _ _ lins = unsafeAt funs funid - - lit2tok (LStr t) = KS t - lit2tok (LInt n) = KS (show n) - lit2tok (LFlt d) = KS (show d) - + updateAt :: Int -> a -> [a] -> [a] updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs] +litCatMatch fcat (Just t) + | fcat == fcatString = Just (t,Lit (LStr t)) + | fcat == fcatInt = case reads t of {[(n,"")] -> Just (t,Lit (LInt n)); + _ -> Nothing } + | fcat == fcatFloat = case reads t of {[(d,"")] -> Just (t,Lit (LFlt d)); + _ -> Nothing } + | fcat == fcatVar = Just (t,Var (mkCId t)) +litCatMatch _ _ = Nothing + ---------------------------------------------------------------- -- Active Chart diff --git a/src/PGF/Raw/Convert.hs b/src/PGF/Raw/Convert.hs index d202ff8dd..85799a3a2 100644 --- a/src/PGF/Raw/Convert.hs +++ b/src/PGF/Raw/Convert.hs @@ -102,7 +102,8 @@ toPInfo [App "functions" fs, App "sequences" ss, App "productions" ps,App "categ toProduction (App "C" [fcat]) = FCoerce (expToInt fcat) toSymbol :: RExp -> FSymbol -toSymbol (App "P" [n,l]) = FSymCat (expToInt n) (expToInt l) +toSymbol (App "P" [n,l]) = FSymCat (expToInt n) (expToInt l) +toSymbol (App "PL" [n,l]) = FSymLit (expToInt n) (expToInt l) toSymbol (App "KP" (d:alts)) = FSymTok (toKP d alts) toSymbol (AStr t) = FSymTok (KS t) @@ -239,7 +240,8 @@ fromFFun (FFun fun prof lins) = App (prCId fun) [App "P" (map fromProfile prof), daughter n = App "_A" [intToExp n] fromSymbol :: FSymbol -> RExp -fromSymbol (FSymCat n l) = App "P" [intToExp n, intToExp l] +fromSymbol (FSymCat n l) = App "P" [intToExp n, intToExp l] +fromSymbol (FSymLit n l) = App "PL" [intToExp n, intToExp l] fromSymbol (FSymTok t) = fromTokn t fromFSeq :: FSeq -> RExp -- cgit v1.2.3