embedded haskelle example: query

5 files changed, 219 insertions, 0 deletions

diff --git a/examples/query/Database.gf b/examples/query/Database.gf
new file mode 100644
index 000000000..2385b8670
--- /dev/null
+++ b/examples/query/Database.gf
@@ -0,0 +1,45 @@
+-- abstract syntax of a small arithmetic query language
+
+abstract Database = {
+
+cat 
+  Query ; S ; Q ; NP ; CN ; PN ; A1 ; A2 ;
+
+fun 
+  QueryS : S -> Query ; 
+  QueryQ : Q -> Query ;
+
+  PredA1  : NP -> A1 -> S ;
+
+  WhichA1 : CN -> A1 -> Q ;
+  WhichA2 : CN -> NP -> A2 -> Q ;
+
+  ComplA2 : A2 -> NP -> A1 ;
+  UseInt  : Int -> NP ;
+
+  Every   : CN -> NP ;
+  Some    : CN -> NP ;
+
+-- lexicon
+
+  Number : CN ;
+  Even,Odd,Prime : A1 ;
+  Equal,Greater,Smaller,Divisible  : A2 ;
+
+-- replies
+
+cat Answer ; ListInt ;
+
+fun
+  Yes,No : Answer ;
+  None : Answer ;
+  List : ListInt -> Answer ;
+  One : Int -> ListInt ;
+  Cons : Int -> ListInt -> ListInt ;
+
+-- general moves
+fun
+  Quit : Query ;
+  Bye : Answer ;
+
+}
diff --git a/examples/query/DatabaseEng.gf b/examples/query/DatabaseEng.gf
new file mode 100644
index 000000000..6af490678
--- /dev/null
+++ b/examples/query/DatabaseEng.gf
@@ -0,0 +1,52 @@
+--# -path=.:prelude
+
+concrete DatabaseEng of Database = open Prelude in {
+
+-- english query language
+
+flags lexer=literals ; unlexer=text ;
+
+-- concrete syntax; greatly simplified - just for test purposes
+
+lin 
+  QueryS s = s ;
+  QueryQ q = q ;
+
+  PredA1 np a = prefixSS "is" (cc2 np a) ;
+
+  WhichA1 n a = ss ("which" ++ n.s ++ "are" ++ a.s) ;
+  WhichA2 n q a = ss ("which" ++ n.s ++ "are" ++ q.s ++ a.s) ;
+
+  ComplA2     = cc2 ;
+
+  Every A  = ss ("every" ++ A.s) ;
+  Some A   = ss ("some" ++ A.s) ;
+  UseInt n = n ;
+
+  Number = ss "numbers" ;
+
+  Even   = ss "even" ;
+  Odd    = ss "odd" ;
+  Prime  = ss "prime" ;
+  Equal  = ss ("equal" ++ "to") ;
+  Greater = ss ("greater" ++ "than") ;
+  Smaller = ss ("smaller" ++ "than") ;
+  Divisible = ss ("divisible" ++ "by") ;
+ 
+-- replies
+
+lin
+  Yes = ss "yes" ;
+  No = ss "no" ;
+
+  None = ss "none" ;
+  List xs = xs ;
+  One n = n ;
+  Cons = cc2 ;
+
+-- general moves
+
+lin 
+  Quit = ss "quit" ;
+  Bye = ss "bye" ;
+}
diff --git a/examples/query/Makefile b/examples/query/Makefile
new file mode 100644
index 000000000..08ab63ae1
--- /dev/null
+++ b/examples/query/Makefile
@@ -0,0 +1,15 @@
+#GF=/users/mdstud/ltec06/GF
+GF=/home/aarne/GF
+
+all:
+	make gf ; make ghc
+ghc:
+	ghc -fglasgow-exts --make UseDatabase.hs -o query ; strip query
+gf:
+	echo "pg -printer=haskell | wf GSyntax.hs ;; pm | wf database.gfcm" | gf DatabaseEng.gf
+link:
+	ln -s $(GF)/src/GF
+	ln -s $(GF)/src/Transfer
+#	export GF_LIB_PATH=$(GF)/lib
+clean:
+	rm *.hi *.o
diff --git a/examples/query/README b/examples/query/README
new file mode 100644
index 000000000..e1ce93098
--- /dev/null
+++ b/examples/query/README
@@ -0,0 +1,22 @@
+Aarne Ranta 6/5/2004; revised 10/5/2005 for GF 2.2, 21/4/2006 for GF 2.5.
+
+An example of database query system for Lab 2 of language technology course.
+
+To compile:
+
+  Create a link to GF sources, by
+
+      make link
+
+  Create the file GSyntax.hs and the executable query
+
+      make
+
+To run:
+
+      ./query
+
+Examples:
+
+      is 4567 prime
+      which numbers are prime
diff --git a/examples/query/UseDatabase.hs b/examples/query/UseDatabase.hs
new file mode 100644
index 000000000..cf90ae2a4
--- /dev/null
+++ b/examples/query/UseDatabase.hs
@@ -0,0 +1,85 @@
+module Main where
+
+import GSyntax
+import GF.Embed.EmbedAPI
+
+import GF.Infra.UseIO
+
+-- to compile: make
+
+main :: IO ()
+main = do
+  gr <- file2grammar "database.gfcm"
+  loop gr
+
+loop :: MultiGrammar -> IO ()
+loop gr = do
+  putStrFlush "> "
+  s <- getLine
+  let ts = parse gr "DatabaseEng" "Query" s
+  case ts of
+    [t] -> case fg t of
+      GQuit -> putStrLnFlush (linearize gr "DatabaseEng" (gf GBye)) >> return ()
+      t'    -> case reply t' of
+         Left r   -> (putStrLnFlush $ linearize gr "DatabaseEng" $ gf r) >> loop gr
+         Right xs -> print xs >> loop gr 
+    []  -> putStrLnFlush "no parse" >> loop gr
+    _   -> do 
+      putStrLnFlush "ambiguous parse:" 
+----      mapM_ (putStrLn . prGFTree) ts
+      loop gr
+
+-- the question-answer relation
+
+reply :: GQuery -> Either GAnswer [Ent]
+reply (GQueryS s) = Left $ if (iS s) then GYes else GNo 
+reply (GQueryQ q) = case iQ q of
+  [] -> Left GNone
+  xs -> Right xs
+{- much less efficient:
+  xs -> GList $ list xs
+ where
+   list [x] = GOne (GInt (show x))
+   list (x:xs) = GCons (GInt (show x)) (list xs)
+-}
+
+-- denotational semantics
+
+type Ent = Integer
+type Prop = Bool
+
+domain :: [Ent]
+domain = [0..10000] ---
+
+primes = sieve (drop 2 domain) where
+  sieve (p:x) = p : sieve [ n | n <- x, n `mod` p > 0 ]
+  sieve [] = []
+
+iS :: GS -> Prop
+iS (GPredA1 np ap) = iNP np (iA1 ap)
+
+iQ :: GQ -> [Ent]
+iQ (GWhichA1 cn a) = [e | e <- iCN cn, iA1 a e]
+iQ (GWhichA2 cn np a) = [e | e <- iCN cn, iNP np (\x -> iA2 a x e)]
+
+iA1 :: GA1 -> Ent -> Prop
+iA1 (GComplA2 f q) = iNP q . iA2 f
+iA1 GEven = even
+iA1 GOdd = odd
+iA1 GPrime = flip elem primes
+
+iA2 :: GA2 -> Ent -> Ent -> Prop
+iA2 GEqual = (==)
+iA2 GGreater = (>)
+iA2 GSmaller = (<)
+iA2 GDivisible = \x y -> y /= 0 && mod x y == 0
+
+
+iCN :: GCN -> [Ent]
+iCN GNumber = domain
+
+iNP :: GNP -> (Ent -> Prop) -> Prop
+iNP (GEvery cn) p = all p (iCN cn)
+iNP (GSome cn) p = any p (iCN cn)
+iNP (GUseInt (GInt n)) p = p n
+