optimality-theory: add exercise test case

optimality-theory/Learning.hs

@@ -13,6 +13,7 @@ import Data.Ord (comparing)
 import Data.Set (Set, delete, empty, fromList, insert, member, singleton, toAscList, union)
 import Data.String (IsString (..))
 import Data.Text (Text, pack, unpack)
+import Debug.Trace
 
 newtype Grammar = Grammar {strata :: [Set Constraint]}
   deriving (Eq)
@@ -42,12 +43,16 @@ data MarkDataPair = MarkDataPair
   { loserMarks :: Set Constraint,
     winnerMarks :: Set Constraint
   }
+  deriving (Show)
 
 demoteWith :: MarkDataPair -> Grammar -> Grammar
 demoteWith markDataPair grammar =
+  trace ("\nexamining " ++ show markDataPair) $
     let highestRankedLoser = minimumBy (comparing (`rankIn` grammar)) (loserMarks markDataPair)
-   in foldr
+     in trace ("highest ranked loser: " ++ show highestRankedLoser) $
+          foldr
             ( \winner g ->
+                trace ("grammar: " ++ show g) $
                 if (highestRankedLoser `dominates` winner) grammar
                   then g
                   else demoteBelow winner highestRankedLoser g
@@ -57,6 +62,7 @@ demoteWith markDataPair grammar =
 
 demoteBelow :: Constraint -> Constraint -> Grammar -> Grammar
 demoteBelow a b grammar =
+  trace ("demoting " ++ show a ++ " below " ++ show b) $
     let rankB = fromJust $ b `rankIn` grammar
         strataWithoutA = map (delete a) (strata grammar)
      in grammar
@@ -78,9 +84,8 @@ learnFrom pairs g = go g (cycle pairs)
             then g
             else go g' ps
 
-initialGrammar, resultGrammar :: Grammar
-initialGrammar = singleStratumFrom markData
-resultGrammar = learnFrom markData initialGrammar
+hierarchyFrom :: [MarkDataPair] -> Grammar
+hierarchyFrom = learnFrom <*> singleStratumFrom
 
 markData :: [MarkDataPair]
 markData =
@@ -89,3 +94,9 @@ markData =
     MarkDataPair {loserMarks = ["All-Ft-L", "Leftmost", "Parse-Syl"], winnerMarks = ["All-Ft-R", "Rightmost"]},
     MarkDataPair {loserMarks = ["All-Ft-L", "Ft-Bin"], winnerMarks = ["Parse-Syl"]}
   ]
+
+markData' :: [MarkDataPair]
+markData' =
+  [ MarkDataPair {loserMarks = ["Mid"], winnerMarks = ["Low"]},
+    MarkDataPair {loserMarks = ["Top", "Low"], winnerMarks = ["Mid"]}
+  ]