GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-27 13:32:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

"Committed_by_peb"

Browse Source
This commit is contained in:
peb
2005-04-11 12:57:45 +00:00
parent f6273f7033
commit ac00f77dad
81 changed files with 7080 additions and 181 deletions
Download Patch File Download Diff File Expand all files Collapse all files

67
src/GF/Data/BacktrackM.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/03/29 11:17:54 $
-- > CVS $Date: 2005/04/11 13:52:49 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.2 $
-- > CVS $Revision: 1.3 $
--
-- Backtracking state monad, with r\/o environment
-----------------------------------------------------------------------------
@@ -19,7 +19,6 @@ module GF.Data.BacktrackM ( -- * the backtracking state monad
failure,
(|||),
-- * handling the state & environment
readEnv,
readState,
writeState,
-- * monad specific utilities
@@ -37,53 +36,51 @@ import Monad
-- * controlling the monad
failure :: BacktrackM e s a
(|||) :: BacktrackM e s a -> BacktrackM e s a -> BacktrackM e s a
failure :: BacktrackM s a
(|||) :: BacktrackM s a -> BacktrackM s a -> BacktrackM s a
instance MonadPlus (BacktrackM e s) where
instance MonadPlus (BacktrackM s) where
mzero = failure
mplus = (|||)
-- * handling the state & environment
readEnv :: BacktrackM e s e
readState :: BacktrackM e s s
writeState :: s -> BacktrackM e s ()
readState :: BacktrackM s s
writeState :: s -> BacktrackM s ()
-- * monad specific utilities
-- * specific functions on the backtracking monad
member :: [a] -> BacktrackM e s a
member :: [a] -> BacktrackM s a
member = msum . map return
-- * running the monad
runBM :: BacktrackM e s a -> e -> s -> [(s, a)]
runBM :: BacktrackM s a -> s -> [(s, a)]
solutions :: BacktrackM e s a -> e -> s -> [a]
solutions bm e s = map snd $ runBM bm e s
solutions :: BacktrackM s a -> s -> [a]
solutions bm = map snd . runBM bm
finalStates :: BacktrackM e s () -> e -> s -> [s]
finalStates bm e s = map fst $ runBM bm e s
finalStates :: BacktrackM s () -> s -> [s]
finalStates bm = map fst . runBM bm
{-
----------------------------------------------------------------------
-- implementation as lists of successes
newtype BacktrackM e s a = BM (e -> s -> [(s, a)])
newtype BacktrackM s a = BM (s -> [(s, a)])
runBM (BM m) = m
readEnv = BM (\e s -> [(s, e)])
readState = BM (\e s -> [(s, s)])
writeState s = BM (\e _ -> [(s, ())])
readState = BM (\s -> [(s, s)])
writeState s = BM (\_ -> [(s, ())])
failure = BM (\e s -> [])
BM m ||| BM n = BM (\e s -> m e s ++ n e s)
failure = BM (\s -> [])
BM m ||| BM n = BM (\s -> m s ++ n s)
instance Monad (BacktrackM e s) where
return a = BM (\e s -> [(s, a)])
BM m >>= k = BM (\e s -> concat [ n e s' | (s', a) <- m e s, let BM n = k a ])
instance Monad (BacktrackM s) where
return a = BM (\s -> [(s, a)])
BM m >>= k = BM (\s -> concat [ n s' | (s', a) <- m s, let BM n = k a ])
fail _ = failure
-}
@@ -105,19 +102,17 @@ runB (B m) = m (:) []
-- BacktrackM = state monad transformer over the backtracking monad
newtype BacktrackM e s a = BM (e -> s -> Backtr (s, a))
newtype BacktrackM s a = BM (s -> Backtr (s, a))
runBM (BM m) e s = runB (m e s)
runBM (BM m) s = runB (m s)
readEnv = BM (\e s -> return (s, e))
readState = BM (\e s -> return (s, s))
writeState s = BM (\e _ -> return (s, ()))
readState = BM (\s -> return (s, s))
writeState s = BM (\_ -> return (s, ()))
failure = BM (\e s -> failureB)
BM m ||| BM n = BM (\e s -> m e s |||| n e s)
failure = BM (\s -> failureB)
BM m ||| BM n = BM (\s -> m s |||| n s)
instance Monad (BacktrackM e s) where
return a = BM (\e s -> return (s, a))
BM m >>= k = BM (\e s -> do (s', a) <- m e s
unBM (k a) e s')
instance Monad (BacktrackM s) where
return a = BM (\s -> return (s, a))
BM m >>= k = BM (\s -> do (s', a) <- m s ; unBM (k a) s')
where unBM (BM m) = m

117
src/GF/Data/GeneralDeduction.hs Normal file
View File

@@ -0,0 +1,117 @@
----------------------------------------------------------------------
-- |
-- Maintainer : Peter Ljunglöf
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/11 13:52:51 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.1 $
--
-- Simple implementation of deductive chart parsing
-----------------------------------------------------------------------------
module GF.NewParsing.GeneralChart
(-- * Type definition
ParseChart,
-- * Main functions
chartLookup,
buildChart, buildChartM,
-- * Probably not needed
emptyChart,
chartMember,
chartInsert, chartInsertM,
chartList,
addToChart, addToChartM
) where
-- import Trace
import GF.Data.RedBlackSet
import Monad (foldM)
----------------------------------------------------------------------
-- main functions
chartLookup :: (Ord item, Ord key) => ParseChart item key -> key -> [item]
chartList :: (Ord item, Ord key) => ParseChart item key -> [item]
buildChart :: (Ord item, Ord key) =>
(item -> key) -- ^ key lookup function
-> [ParseChart item key -> item -> [item]] -- ^ list of inference rules as functions
-- from triggering items to lists of items
-> [item] -- ^ initial chart
-> ParseChart item key -- ^ final chart
buildChartM :: (Ord item, Ord key) =>
(item -> [key]) -- ^ many-valued key lookup function
-> [ParseChart item key -> item -> [item]] -- ^ list of inference rules as functions
-- from triggering items to lists of items
-> [item] -- ^ initial chart
-> ParseChart item key -- ^ final chart
buildChart keyof rules axioms = addItems axioms emptyChart
where addItems [] = id
addItems (item:items) = addItems items . addItem item
-- addItem item | trace ("+ "++show item++"\n") False = undefined
addItem item = addToChart item (keyof item)
(\chart -> foldr (consequence item) chart rules)
consequence item rule chart = addItems (rule chart item) chart
buildChartM keysof rules axioms = addItems axioms emptyChart
where addItems [] = id
addItems (item:items) = addItems items . addItem item
-- addItem item | trace ("+ "++show item++"\n") False = undefined
addItem item = addToChartM item (keysof item)
(\chart -> foldr (consequence item) chart rules)
consequence item rule chart = addItems (rule chart item) chart
-- probably not needed
emptyChart :: (Ord item, Ord key) => ParseChart item key
chartMember :: (Ord item, Ord key) => ParseChart item key
-> item -> key -> Bool
chartInsert :: (Ord item, Ord key) => ParseChart item key
-> item -> key -> Maybe (ParseChart item key)
chartInsertM :: (Ord item, Ord key) => ParseChart item key
-> item -> [key] -> Maybe (ParseChart item key)
addToChart :: (Ord item, Ord key) => item -> key
-> (ParseChart item key -> ParseChart item key)
-> ParseChart item key -> ParseChart item key
addToChart item keys after chart = maybe chart after (chartInsert chart item keys)
addToChartM :: (Ord item, Ord key) => item -> [key]
-> (ParseChart item key -> ParseChart item key)
-> ParseChart item key -> ParseChart item key
addToChartM item keys after chart = maybe chart after (chartInsertM chart item keys)
--------------------------------------------------------------------------------
-- key charts as red/black trees
newtype ParseChart item key = KC (RedBlackMap key item)
deriving Show
emptyChart = KC rbmEmpty
chartMember (KC tree) item key = rbmElem key item tree
chartLookup (KC tree) key = rbmLookup key tree
chartList (KC tree) = concatMap snd (rbmList tree)
chartInsert (KC tree) item key = fmap KC (rbmInsert key item tree)
chartInsertM (KC tree) item keys = fmap KC (foldM insertItem tree keys)
where insertItem tree key = rbmInsert key item tree
--------------------------------------------------------------------------------}
{--------------------------------------------------------------------------------
-- key charts as unsorted association lists -- OBSOLETE!
newtype Chart item key = SC [(key, item)]
emptyChart = SC []
chartMember (SC chart) item key = (key,item) `elem` chart
chartInsert (SC chart) item key = if (key,item) `elem` chart then Nothing else Just (SC ((key,item):chart))
chartLookup (SC chart) key = [ item | (key',item) <- chart, key == key' ]
chartList (SC chart) = map snd chart
--------------------------------------------------------------------------------}

64
src/GF/Data/IncrementalDeduction.hs Normal file
View File

@@ -0,0 +1,64 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/11 13:52:51 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.1 $
--
-- Implementation of /incremental/ deductive parsing,
-- i.e. parsing one word at the time.
-----------------------------------------------------------------------------
module GF.NewParsing.IncrementalChart
(-- * Type definitions
IncrementalChart,
-- * Functions
chartLookup,
buildChart,
chartList
) where
import Array
import GF.Data.SortedList
import GF.Data.Assoc
----------------------------------------------------------------------
-- main functions
chartLookup :: (Ord item, Ord key) =>
IncrementalChart item key
-> Int -> key -> SList item
buildChart :: (Ord item, Ord key) =>
(item -> key) -- ^ key lookup function
-> (Int -> item -> SList item) -- ^ all inference rules for position k, collected
-> (Int -> SList item) -- ^ all axioms for position k, collected
-> (Int, Int) -- ^ input bounds
-> IncrementalChart item key
chartList :: (Ord item, Ord key) =>
IncrementalChart item key -- ^ the final chart
-> (Int -> item -> edge) -- ^ function building an edge from
-- the position and the item
-> [edge]
type IncrementalChart item key = Array Int (Assoc key (SList item))
----------
chartLookup chart k key = (chart ! k) ? key
buildChart keyof rules axioms bounds = finalChartArray
where buildState k = limit (rules k) $ axioms k
finalChartList = map buildState [fst bounds .. snd bounds]
finalChartArray = listArray bounds $ map stateAssoc finalChartList
stateAssoc state = accumAssoc id [ (keyof item, item) | item <- state ]
chartList chart combine = [ combine k item |
(k, state) <- assocs chart,
item <- concatMap snd $ aAssocs state ]

61
src/GF/Data/SortedList.hs
View File

@@ -1,13 +1,12 @@
----------------------------------------------------------------------
-- |
-- Module : SortedList
-- Maintainer : Peter Ljunglöf
-- Stability : stable
-- Portability : portable
--
-- > CVS $Date: 2005/03/21 14:17:39 $
-- > CVS $Date: 2005/04/11 13:52:49 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.1 $
-- > CVS $Revision: 1.2 $
--
-- Sets as sorted lists
--
@@ -18,29 +17,37 @@
-- * /O(n^2)/ fixed point iteration
-----------------------------------------------------------------------------
module GF.Data.SortedList ( SList,
nubsort, union,
(<++>), (<\\>), (<**>),
limit,
hasCommonElements, subset,
groupPairs, groupUnion
) where
module GF.Data.SortedList
( -- * type declarations
SList, SMap,
-- * set operations
nubsort, union,
(<++>), (<\\>), (<**>),
limit,
hasCommonElements, subset,
-- * map operations
groupPairs, groupUnion,
unionMap, mergeMap
) where
import List (groupBy)
import GF.Data.Utilities (split, foldMerge)
-- | The list must be sorted and contain no duplicates.
type SList a = [a]
-- | Group a set of key-value pairs into
-- a set of unique keys with sets of values
groupPairs :: Ord a => SList (a, b) -> SList (a, SList b)
-- | A sorted map also has unique keys,
-- i.e. 'map fst m :: SList a', if 'm :: SMap a b'
type SMap a b = SList (a, b)
-- | Group a set of key-value pairs into a sorted map
groupPairs :: Ord a => SList (a, b) -> SMap a (SList b)
groupPairs = map mapFst . groupBy eqFst
where mapFst as = (fst (head as), map snd as)
eqFst a b = fst a == fst b
-- | Group a set of key-(sets-of-values) pairs into
-- a set of unique keys with sets of values
groupUnion :: (Ord a, Ord b) => SList (a, SList b) -> SList (a, SList b)
-- | Group a set of key-(sets-of-values) pairs into a sorted map
groupUnion :: (Ord a, Ord b) => SList (a, SList b) -> SMap a (SList b)
groupUnion = map unionSnd . groupPairs
where unionSnd (a, bs) = (a, union bs)
@@ -57,13 +64,25 @@ xs `subset` ys = null (xs <\\> ys)
nubsort :: Ord a => [a] -> SList a
nubsort = union . map return
-- | the union of a list of sorted maps
unionMap :: Ord a => (b -> b -> b)
-> [SMap a b] -> SMap a b
unionMap plus = foldMerge (mergeMap plus) []
-- | merging two sorted maps
mergeMap :: Ord a => (b -> b -> b)
-> SMap a b -> SMap a b -> SMap a b
mergeMap plus [] abs = abs
mergeMap plus abs [] = abs
mergeMap plus abs@(ab@(a,bs):abs') cds@(cd@(c,ds):cds')
= case compare a c of
EQ -> (a, plus bs ds) : mergeMap plus abs' cds'
LT -> ab : mergeMap plus abs' cds
GT -> cd : mergeMap plus abs cds'
-- | The union of a list of sets
union :: Ord a => [SList a] -> SList a
union [] = []
union [as] = as
union abs = let (as, bs) = split abs in union as <++> union bs
where split (a:b:abs) = let (as, bs) = split abs in (a:as, b:bs)
split as = (as, [])
union = foldMerge (<++>) []
-- | The union of two sets
(<++>) :: Ord a => SList a -> SList a -> SList a

53
src/GF/Data/Utilities.hs Normal file
View File

@@ -0,0 +1,53 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/11 13:52:49 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.1 $
--
-- Basic functions not in the standard libraries
-----------------------------------------------------------------------------
module GF.Data.Utilities where
-- * functions on lists
sameLength :: [a] -> [a] -> Bool
sameLength [] [] = True
sameLength (_:xs) (_:ys) = sameLength xs ys
sameLength _ _ = False
lookupList :: Eq a => a -> [(a, b)] -> [b]
lookupList a [] = []
lookupList a (p:ps) | a == fst p = snd p : lookupList a ps
| otherwise = lookupList a ps
split :: [a] -> ([a], [a])
split (x : y : as) = (x:xs, y:ys)
where (xs, ys) = split as
split as = (as, [])
splitBy :: (a -> Bool) -> [a] -> ([a], [a])
splitBy p [] = ([], [])
splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys)
where (xs, ys) = splitBy p as
foldMerge :: (a -> a -> a) -> a -> [a] -> a
foldMerge merge zero = fm
where fm [] = zero
fm [a] = a
fm abs = let (as, bs) = split abs in fm as `merge` fm bs
-- * functions on pairs
mapFst :: (a -> a') -> (a, b) -> (a', b)
mapFst f (a, b) = (f a, b)
mapSnd :: (b -> b') -> (a, b) -> (a, b')
mapSnd f (a, b) = (a, f b)