Merge pull request #59 from inariksit/gftest

(gftest) Fixes/additions when comparing against older version

src/tools/gftest/Grammar.hs

@@ -935,6 +935,7 @@ hasConcrString gr str =
 type Context = String
 type LinTree = ((Lang,Context),(Lang,String),(Lang,String),(Lang,String))
 data Comparison = Comparison { funTree :: String, linTree :: [LinTree] }
+
 instance Show Comparison where
   show c = unlines $ funTree c : map showLinTree (linTree c)
 
@@ -945,27 +946,28 @@ showLinTree :: LinTree -> String
 showLinTree ((an,hl),(l1,t1),(l2,t2),(_l,[])) = unlines ["", an++hl, l1++t1, l2++t2]
 showLinTree ((an,hl),(l1,t1),(l2,t2),(l3,t3)) = unlines ["", an++hl, l1++t1, l2++t2, l3++t3]
 
-compareTree :: Grammar -> Grammar -> [Grammar] -> Tree -> Comparison
-compareTree gr oldgr transgr t = Comparison {
+compareTree :: Grammar -> Grammar -> [Grammar] -> Cat -> Tree -> Comparison
+compareTree gr oldgr transgr startcat t = Comparison {
   funTree = "* " ++ show t
 , linTree = [ ( ("** ",hl), (langName gr,newLin), (langName oldgr, oldLin), transLin )
             | ctx <- ctxs
             , let hl = show (ctx dummyHole)
+            , let newLin = linearize gr (ctx t)
+            , let oldLin = linearize oldgr (ctx t)
             , let transLin = case transgr of
                               []  -> ("","")
                               g:_ -> (langName g, linearize g (ctx t))
-            , let newLin = linearize gr (ctx t)
-            , let oldLin = linearize oldgr (ctx t)
-            , newLin /= oldLin ] }
+            , newLin /= oldLin
+            ] }
  where
   w    = top t
   c    = snd (ctyp w)
-  cs   = [ coe 
+  cs   = c:[ coe
            | (cat,coe) <- coercions gr
            , c == cat ]
   ctxs = concat
          [ contextsFor gr sc cat
-         | sc <- ccats gr (startCat gr)
+         | sc <- ccats gr startcat
          , cat <- cs ] 
   langName gr = concrLang gr ++ "> "
 
@@ -1081,7 +1083,7 @@ bestTrees fun gr cats =
   bestExamples fun gr $ take 200 -- change this to something else if too slow
   [ featIthVec gr cats size i
   | all (`S.member` nonEmptyCats gr) cats
-  , size <- [0..10]
+  , size <- [0..20]
   , let card = featCardVec gr cats size 
   , i <- [0..card-1]
   ]

src/tools/gftest/Main.hs

@@ -114,8 +114,12 @@ main = do
          where
           s    = top t
           c    = snd (ctyp s)
-          ctxs = concat [ contextsFor gr sc c
-                      | sc <- ccats gr startcat ]
+          cs   = c:[ coe
+                   | (cat,coe) <- coercions gr
+                   , c == cat ]
+          ctxs = concat [ contextsFor gr sc cat
+                        | sc <- ccats gr startcat
+                        , cat <- cs ]
 
         output = -- Print to stdout or write to a file
          if write_to_file args 
@@ -149,9 +153,9 @@ main = do
     -- Test a tree
     let trees = case tree args of
          [] -> []
-         ts -> lines ts
+         ts -> [ readTree gr t | t <- lines ts ]
     output $
-      unlines [ testTree' (readTree gr tree) 1 | tree <- trees ]
+      unlines [ testTree' tree 1 | tree <- trees ]
 
     -- Test a function
     let substrs xs = filter (/="*") $ groupBy (\a b -> a/='*' && b/='*') xs
@@ -368,7 +372,7 @@ main = do
                       | funName <- funs -- comes from command line arg -f
                       , let fs@(s:_) = lookupSymbol gr funName
                       , let cat = snd $ Grammar.typ s ]
-            fromTb  = [ (cat,[tree]) | tree <- treebank'
+            fromTb  = [ (cat,[tree]) | tree <- treebank'++trees
                       , let (CC (Just cat) _) = ccatOf tree ]
 
             treesToTest =
@@ -381,25 +385,18 @@ main = do
               writeFile file ""
               putStrLn "Testing functions in… "
               diff <- concat `fmap`
-                sequence [ do let cs = [ compareTree grammar otherGrammar grTrans t
-                                       | t <- trees ]
+                sequence [ do let cs = [ compareTree grammar otherGrammar grTrans startcat t
+                                       | t <- ttrees ]
                               putStr $ cat ++ "                \r"
                               -- prevent lazy evaluation; make printout accurate
                               appendFile ("/tmp/"++file) (unwords $ map show cs)
-                              return cs
-                         | (cat,trees) <- treesToTest ]
-              let relevantDiff = go [] [] diff where
-                    go res seen [] = res
-                    go res seen (Comparison f ls:cs) = 
-                      if null uniqLs then go res seen cs
-                        else go (Comparison f uniqLs:res) (uniqLs++seen) cs
-                       where uniqLs = deleteFirstsBy ctxEq ls seen
-                             ctxEq (a,_,_,_) (b,_,_,_) = a==b
-                  shorterTree c1 c2 = length (funTree c1) `compare` length (funTree c2)
+                              return [ c | c@(Comparison f (x:xs)) <- cs ]
+                         | (cat,ttrees) <- treesToTest ]
+
+              let shorterTree c1 c2 = length (funTree c1) `compare` length (funTree c2)
               writeFile file $ unlines
                 [ show comp 
-                | comp <- sortBy shorterTree relevantDiff ]
-
+                | comp <- sortBy shorterTree diff ]
             
         writeLinFile (langName ++ "-lin-diff.org") gr ogr
         putStrLn $ "Created file " ++ (langName ++ "-lin-diff.org")