@@ -12,7 +12,6 @@ as SML/NJ to get nice trees.
1212-}
1313
1414import Control.Arrow (second)
15−import Data.Function (on)
1615import qualified Data.List as List
1716import qualified Data.Map as Map
1817import qualified Data.Set as Set
@@ -144,37 +143,23 @@ toDecisionTree variantDict rawBranches =
144143 Nothing ->
145144 let
146145 path =
147− smallDefaults branches
146+ pickPath variantDict branches
148147
149− relevantTests =
150− testsAtPath path branches
148+ (edges, fallback) =
149+ gatherEdges variantDict branches path
151150
152− allRawEdges =
153− map (edgesFor path branches) relevantTests
154−
155− (rawEdges, unexplored) =
156− if isComplete variantDict relevantTests then
157− ( init allRawEdges
158− , snd (last allRawEdges)
159− )
160−
161− else
162− ( allRawEdges
163− , filter (isIrrelevantTo path) branches
164− )
165−
166− edges =
167− map (second (toDecisionTree variantDict)) rawEdges
151+ decisionEdges =
152+ map (second (toDecisionTree variantDict)) edges
168153 in
169− case (edges, unexplored) of
154+ case (decisionEdges, fallback) of
170155 ([(_tag, decisionTree)], []) ->
171156 decisionTree
172157
173158 (_, []) ->
174− Decision path edges Nothing
159+ Decision path decisionEdges Nothing
175160
176161 (_, _) ->
177− Decision path edges (Just (toDecisionTree variantDict unexplored))
162+ Decision path decisionEdges (Just (toDecisionTree variantDict fallback))
178163
179164
180165isComplete :: VariantDict -> [Test] -> Bool
@@ -283,6 +268,28 @@ getSubstitution (path, A.A _ pattern) =
283268 Nothing
284269
285270
271+-- GATHER OUTGOING EDGES
272+
273+gatherEdges :: VariantDict -> [Branch] -> Path -> ([(Test, [Branch])], [Branch])
274+gatherEdges variantDict branches path =
275+ let
276+ relevantTests =
277+ testsAtPath path branches
278+
279+ allRawEdges =
280+ map (edgesFor path branches) relevantTests
281+ in
282+ if isComplete variantDict relevantTests then
283+ ( init allRawEdges
284+ , snd (last allRawEdges)
285+ )
286+
287+ else
288+ ( allRawEdges
289+ , filter (isIrrelevantTo path) branches
290+ )
291+
292+
286293-- FIND RELEVANT TESTS
287294
288295testsAtPath :: Path -> [Branch] -> [Test]
@@ -420,18 +427,20 @@ needsTests (A.A _ pattern) =
420427 True
421428
422429
423−-- PATH PICKING HEURISTICS
430+-- PICK A PATH
424431
425−smallDefaults :: [Branch] -> Path
426−smallDefaults branches =
432+pickPath :: VariantDict -> [Branch] -> Path
433+pickPath variantDict branches =
427434 let
428435 allPaths =
429436 Maybe.mapMaybe isChoicePath (concatMap _patterns branches)
430−
431− weightedPaths =
432− map (\path -> (path, length (filter (isIrrelevantTo path) branches))) allPaths
433437 in
434− fst (List.minimumBy (compare `on` snd) weightedPaths)
438+ case bests (addWeights (smallDefaults branches) allPaths) of
439+ [path] ->
440+ path
441+
442+ tiedPaths ->
443+ head (bests (addWeights (smallBranchingFactor variantDict branches) tiedPaths))
435444
436445
437446isChoicePath :: (Path, CPattern) -> Maybe Path
@@ -442,4 +451,38 @@ isChoicePath (path, pattern) =
442451 Nothing
443452
444453
445−-- smallBranchingFactor :: [Branch] -> Path
454+addWeights :: (Path -> Int) -> [Path] -> [(Path, Int)]
455+addWeights toWeight paths =
456+ map (\path -> (path, toWeight path)) paths
457+
458+
459+bests :: [(Path, Int)] -> [Path]
460+bests ((path,weight):weightedPaths) =
461+ let
462+ gatherMinimum acc@(minWeight, paths) (path, weight) =
463+ if weight == minWeight then
464+ (minWeight, path : paths)
465+
466+ else if weight < minWeight then
467+ (weight, [path])
468+
469+ else
470+ acc
471+ in
472+ snd (List.foldl' gatherMinimum (weight, [path]) weightedPaths)
473+
474+
475+-- PATH PICKING HEURISTICS
476+
477+smallDefaults :: [Branch] -> Path -> Int
478+smallDefaults branches path =
479+ length (filter (isIrrelevantTo path) branches)
480+
481+
482+smallBranchingFactor :: VariantDict -> [Branch] -> Path -> Int
483+smallBranchingFactor variantDict branches path =
484+ let
485+ (edges, fallback) =
486+ gatherEdges variantDict branches path
487+ in
488+ length edges + (if null fallback then 0 else 1)