kfm/to-hen
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

optimality-theory: add exercise test case

Browse Source
This commit is contained in:
Kierán Meinhardt
2025-05-10 10:13:05 +02:00
parent 5cf8ab0629
commit 394e5769da
1 changed files with 31 additions and 20 deletions
Download Patch File Download Diff File Expand all files Collapse all files

19
optimality-theory/Learning.hs
View File

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