msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

efficient and nicer implementation for literal categories

Browse Source
This commit is contained in:
krasimir
2008-10-21 14:30:36 +00:00
parent 6633ae71f1
commit 0606de738e
6 changed files with 62 additions and 58 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
src/GF/Compile/GFCCtoJS.hs
View File

@@ -128,6 +128,7 @@ lins2js p ls = JS.EArray [JS.EArray [sym2js s | s <- Array.elems (sequences p Ar
sym2js :: FSymbol -> JS.Expr sym2js :: FSymbol -> JS.Expr
sym2js (FSymCat n l) = new "ArgProj" [JS.EInt n, JS.EInt l] sym2js (FSymCat n l) = new "ArgProj" [JS.EInt n, JS.EInt l]
sym2js (FSymLit n l) = new "ArgProj" [JS.EInt n, JS.EInt l]
sym2js (FSymTok (KS t)) = new "Terminal" [JS.EStr t] sym2js (FSymTok (KS t)) = new "Terminal" [JS.EStr t]
new :: String -> [JS.Expr] -> JS.Expr new :: String -> [JS.Expr] -> JS.Expr

9
src/GF/Compile/GeneratePMCFG.hs
View File

@@ -162,7 +162,10 @@ convertArg (C max) nr path lbl_path lin lins = do
convertArg (S _) nr path lbl_path lin lins = do convertArg (S _) nr path lbl_path lin lins = do
(_, args) <- readState (_, args) <- readState
let PFCat _ cat rcs tcs = args !! nr let PFCat _ cat rcs tcs = args !! nr
return ((lbl_path, FSymCat nr (index path rcs 0) : lin) : lins) l = index path rcs 0
sym | isLiteralCat cat = FSymLit nr l
| otherwise = FSymCat nr l
return ((lbl_path, sym : lin) : lins)
where where
index lbl' (lbl:lbls) idx index lbl' (lbl:lbls) idx
| lbl' == lbl = idx | lbl' == lbl = idx
@@ -257,7 +260,7 @@ expandHOAS abs_defs cnc_defs lincats env =
add_hoFun env (n,cat) = add_hoFun env (n,cat) =
let linRec = reverse $ let linRec = reverse $
[(l ,[FSymCat 0 i]) | (l,i) <- case arg of {PFCat _ _ rcs _ -> zip rcs [0..]}] ++ [(l ,[FSymCat 0 i]) | (l,i) <- case arg of {PFCat _ _ rcs _ -> zip rcs [0..]}] ++
[([],[FSymCat i 0]) | i <- [1..n]] [([],[FSymLit i 0]) | i <- [1..n]]
(env1,lins) = List.mapAccumL addFSeq env linRec (env1,lins) = List.mapAccumL addFSeq env linRec
newLinRec = mkArray lins newLinRec = mkArray lins
@@ -274,7 +277,7 @@ expandHOAS abs_defs cnc_defs lincats env =
-- add one PMCFG function for each high-order category: _V : Var -> Cat -- add one PMCFG function for each high-order category: _V : Var -> Cat
add_varFun env cat = add_varFun env cat =
let (env1,seqid) = addFSeq env ([],[FSymCat 0 0]) let (env1,seqid) = addFSeq env ([],[FSymLit 0 0])
lins = replicate (case res of {PFCat _ _ rcs _ -> length rcs}) seqid lins = replicate (case res of {PFCat _ _ rcs _ -> length rcs}) seqid
(env2,funid) = addFFun env1 (FFun _V [[0]] (mkArray lins)) (env2,funid) = addFFun env1 (FFun _V [[0]] (mkArray lins))
env3 = foldl (\env res -> addProduction env2 res (FApply funid [fcatVar])) env3 = foldl (\env res -> addProduction env2 res (FApply funid [fcatVar]))

13
src/GF/Speech/PGFToCFG.hs
View File

@@ -85,17 +85,24 @@ pgfToCFG pgf lang = mkCFG (prCId (lookStartCat pgf)) extCats (startRules ++ conc
mkRhs = map fsymbolToSymbol . Array.elems mkRhs = map fsymbolToSymbol . Array.elems
containsLiterals :: Array FPointPos FSymbol -> Bool containsLiterals :: Array FPointPos FSymbol -> Bool
containsLiterals row = any isLiteralFCat [args!!n | FSymCat n _ <- Array.elems row] containsLiterals row = any isLiteralFCat [args!!n | FSymCat n _ <- Array.elems row] ||
not (null [n | FSymLit n _ <- Array.elems row]) -- only this is needed for PMCFG.
-- The first line is for backward compat.
fsymbolToSymbol :: FSymbol -> CFSymbol fsymbolToSymbol :: FSymbol -> CFSymbol
fsymbolToSymbol (FSymCat n l) = NonTerminal (fcatToCat (args!!n) l) fsymbolToSymbol (FSymCat n l) = NonTerminal (fcatToCat (args!!n) l)
fsymbolToSymbol (FSymLit n l) = NonTerminal (fcatToCat (args!!n) l)
fsymbolToSymbol (FSymTok (KS t)) = Terminal t fsymbolToSymbol (FSymTok (KS t)) = Terminal t
fixProfile :: Array FPointPos FSymbol -> Profile -> Profile fixProfile :: Array FPointPos FSymbol -> Profile -> Profile
fixProfile row = concatMap positions fixProfile row = concatMap positions
where where
nts = zip [0..] [nt | nt@(FSymCat _ _) <- Array.elems row] nts = zip [0..] [j | nt <- Array.elems row, j <- getPos nt]
positions i = [k | (k,FSymCat j _) <- nts, j == i] positions i = [k | (k,j) <- nts, j == i]
getPos (FSymCat j _) = [j]
getPos (FSymLit j _) = [j]
getPos _ = []
profilesToTerm :: [Profile] -> CFTerm profilesToTerm :: [Profile] -> CFTerm
profilesToTerm ps = CFObj f (zipWith profileToTerm argTypes ps) profilesToTerm ps = CFObj f (zipWith profileToTerm argTypes ps)

1
src/PGF/Data.hs
View File

@@ -70,6 +70,7 @@ type FIndex = Int
type FPointPos = Int type FPointPos = Int
data FSymbol data FSymbol
= FSymCat {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex = FSymCat {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex
| FSymLit {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex
| FSymTok Tokn | FSymTok Tokn
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
type Profile = [Int] type Profile = [Int]

90
src/PGF/Parsing/FCFG/Incremental.hs
View File

@@ -44,48 +44,27 @@ initState pinfo (DTyp _ start _) =
-- is consumed and the current position shifted by one. -- is consumed and the current position shifted by one.
nextState :: ParseState -> String -> Maybe ParseState nextState :: ParseState -> String -> Maybe ParseState
nextState (State pinfo chart items) t = nextState (State pinfo chart items) t =
let (items1,chart1) = process add (sequences pinfo) (functions pinfo) (Set.toList items) Set.empty chart let (items1,chart1) = process (Just t) add (sequences pinfo) (functions pinfo) (Set.toList items) Set.empty chart
(items2,chart2) = addConst pinfo (AK fcatString 0) (Lit (LStr t)) t items1 chart1 chart2 = chart1{ active =emptyAC
(items3,chart3) = case reads t of {[(n,"")] -> addConst pinfo (AK fcatInt 0) (Lit (LInt n)) t items2 chart2; , actives=active chart1 : actives chart1
_ -> (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
, passive=emptyPC , passive=emptyPC
, offset =offset chart5+1 , offset =offset chart1+1
} }
in if Set.null items5 in if Set.null items1
then Nothing then Nothing
else Just (State pinfo chart6 items5) else Just (State pinfo chart2 items1)
where where
add (KS tok) item set add (KS tok) item set
| tok == t = Set.insert item set | tok == t = Set.insert item set
| otherwise = 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) -- | 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 -- then the 'getCompletions' function can be used to calculate the possible
-- next words and the consequent states. This is used for word completions in -- next words and the consequent states. This is used for word completions in
-- the GF interpreter. -- the GF interpreter.
getCompletions :: ParseState -> String -> Map.Map String ParseState getCompletions :: ParseState -> String -> Map.Map String ParseState
getCompletions (State pinfo chart items) w = 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 chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1 , actives=active chart1 : actives chart1
, passive=emptyPC , passive=emptyPC
@@ -100,7 +79,7 @@ getCompletions (State pinfo chart items) w =
extractExps :: ParseState -> Type -> [Tree] extractExps :: ParseState -> Type -> [Tree]
extractExps (State pinfo chart items) (DTyp _ start _) = exps extractExps (State pinfo chart items) (DTyp _ start _) = exps
where 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 exps = nubsort $ do
cat <- fromMaybe [] (Map.lookup start (startCats pinfo)) cat <- fromMaybe [] (Map.lookup start (startCats pinfo))
@@ -142,8 +121,8 @@ extractExps (State pinfo chart items) (DTyp _ start _) = exps
_B = mkCId "_B" _B = mkCId "_B"
_V = mkCId "_V" _V = mkCId "_V"
process fn !seqs !funs [] acc chart = (acc,chart) process mbt 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 (item@(Active j ppos funid seqid args key0):items) acc chart
| inRange (bounds lin) ppos = | inRange (bounds lin) ppos =
case unsafeAt lin ppos of case unsafeAt lin ppos of
FSymCat d r -> let !fid = args !! d 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) items3 = foldForest (\funid args items -> Active k 0 funid (rhs funid r) args key : items)
(\_ _ items -> items) (\_ _ items -> items)
items2 fid (forest chart) 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 in case lookupAC key (active chart) of
Nothing -> process fn seqs funs items3 acc2 chart{active=insertAC key (Set.singleton item) (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 fn seqs funs items acc chart Just set | Set.member item set -> process mbt fn seqs funs items acc chart
| otherwise -> process fn seqs funs items2 acc2 chart{active=insertAC key (Set.insert item set) (active 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 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 = | otherwise =
case lookupPC (mkPK key0 j) (passive chart) of case lookupPC (mkPK key0 j) (passive chart) of
Nothing -> let fid = nextId chart 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) -> Just set -> Set.fold (\(Active j' ppos funid seqid args keyc) ->
let FSymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos let FSymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos
in (:) (Active j' (ppos+1) funid seqid (updateAt d fid args) keyc)) items set 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) 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) ,forest =IntMap.insert fid (Set.singleton (FApply funid args)) (forest chart)
,nextId =nextId chart+1 ,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 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 where
!lin = unsafeAt seqs seqid !lin = unsafeAt seqs seqid
!k = offset chart !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 rhs funid lbl = unsafeAt lins lbl
where where
FFun _ _ lins = unsafeAt funs funid 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 :: Int -> a -> [a] -> [a]
updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs] 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 -- Active Chart

6
src/PGF/Raw/Convert.hs
View File

@@ -102,7 +102,8 @@ toPInfo [App "functions" fs, App "sequences" ss, App "productions" ps,App "categ
toProduction (App "C" [fcat]) = FCoerce (expToInt fcat) toProduction (App "C" [fcat]) = FCoerce (expToInt fcat)
toSymbol :: RExp -> FSymbol 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 (App "KP" (d:alts)) = FSymTok (toKP d alts)
toSymbol (AStr t) = FSymTok (KS t) 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] daughter n = App "_A" [intToExp n]
fromSymbol :: FSymbol -> RExp 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 fromSymbol (FSymTok t) = fromTokn t
fromFSeq :: FSeq -> RExp fromFSeq :: FSeq -> RExp