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

51
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,29 +43,34 @@ 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 =
let highestRankedLoser = minimumBy (comparing (`rankIn` grammar)) (loserMarks markDataPair) trace ("\nexamining " ++ show markDataPair) $
in foldr let highestRankedLoser = minimumBy (comparing (`rankIn` grammar)) (loserMarks markDataPair)
( \winner g -> in trace ("highest ranked loser: " ++ show highestRankedLoser) $
if (highestRankedLoser `dominates` winner) grammar foldr
then g ( \winner g ->
else demoteBelow winner highestRankedLoser g trace ("grammar: " ++ show g) $
) if (highestRankedLoser `dominates` winner) grammar
grammar then g
(winnerMarks markDataPair) else demoteBelow winner highestRankedLoser g
)
grammar
(winnerMarks markDataPair)
demoteBelow :: Constraint -> Constraint -> Grammar -> Grammar demoteBelow :: Constraint -> Constraint -> Grammar -> Grammar
demoteBelow a b grammar = demoteBelow a b grammar =
let rankB = fromJust $ b `rankIn` grammar trace ("demoting " ++ show a ++ " below " ++ show b) $
strataWithoutA = map (delete a) (strata grammar) let rankB = fromJust $ b `rankIn` grammar
in grammar strataWithoutA = map (delete a) (strata grammar)
{ strata = in grammar
case splitAt rankB strataWithoutA of { strata =
(before, bStratum : belowBStratum : after) -> before ++ bStratum : insert a belowBStratum : after case splitAt rankB strataWithoutA of
(before, [bStratum]) -> before ++ [bStratum, singleton a] (before, bStratum : belowBStratum : after) -> before ++ bStratum : insert a belowBStratum : after
} (before, [bStratum]) -> before ++ [bStratum, singleton a]
}
singleStratumFrom :: [MarkDataPair] -> Grammar singleStratumFrom :: [MarkDataPair] -> Grammar
singleStratumFrom pairs = Grammar [foldr (\p g -> loserMarks p `union` winnerMarks p `union` g) empty pairs] singleStratumFrom pairs = Grammar [foldr (\p g -> loserMarks p `union` winnerMarks p `union` g) empty pairs]
@@ -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"]}
]