git.iko.soy/elk
on master help sign in
improve heuristics for decision trees
d3c72d1Evan Czaplicki
src/Optimize/Patterns/DecisionTree.hs+74−31
compare with master
unifiedsplit
@@ -12,7 +12,6 @@ as SML/NJ to get nice trees.
12-}
12-}
13
13
14import Control.Arrow (second)
14import Control.Arrow (second)
15−import Data.Function (on)
16import qualified Data.List as List
15import qualified Data.List as List
17import qualified Data.Map as Map
16import qualified Data.Map as Map
18import qualified Data.Set as Set
17import qualified Data.Set as Set
@@ -144,37 +143,23 @@ toDecisionTree variantDict rawBranches =
144 Nothing ->
143 Nothing ->
145 let
144 let
146 path =
145 path =
147− smallDefaults branches
146+ pickPath variantDict branches
148
147
149− relevantTests =
148+ (edges, fallback) =
150− testsAtPath path branches
149+ gatherEdges variantDict branches path
151
150
152− allRawEdges =
151+ decisionEdges =
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
152+ map (second (toDecisionTree variantDict)) edges
168 in
153 in
169− case (edges, unexplored) of
154+ case (decisionEdges, fallback) of
170 ([(_tag, decisionTree)], []) ->
155 ([(_tag, decisionTree)], []) ->
171 decisionTree
156 decisionTree
172
157
173 (_, []) ->
158 (_, []) ->
174− Decision path edges Nothing
159+ Decision path decisionEdges Nothing
175
160
176 (_, _) ->
161 (_, _) ->
177− Decision path edges (Just (toDecisionTree variantDict unexplored))
162+ Decision path decisionEdges (Just (toDecisionTree variantDict fallback))
178
163
179
164
180isComplete :: VariantDict -> [Test] -> Bool
165isComplete :: VariantDict -> [Test] -> Bool
@@ -283,6 +268,28 @@ getSubstitution (path, A.A _ pattern) =
283 Nothing
268 Nothing
284
269
285
270
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+
286-- FIND RELEVANT TESTS
293-- FIND RELEVANT TESTS
287
294
288testsAtPath :: Path -> [Branch] -> [Test]
295testsAtPath :: Path -> [Branch] -> [Test]
@@ -420,18 +427,20 @@ needsTests (A.A _ pattern) =
420 True
427 True
421
428
422
429
423−-- PATH PICKING HEURISTICS
430+-- PICK A PATH
424
431
425−smallDefaults :: [Branch] -> Path
432+pickPath :: VariantDict -> [Branch] -> Path
426−smallDefaults branches =
433+pickPath variantDict branches =
427 let
434 let
428 allPaths =
435 allPaths =
429 Maybe.mapMaybe isChoicePath (concatMap _patterns branches)
436 Maybe.mapMaybe isChoicePath (concatMap _patterns branches)
430−
431− weightedPaths =
432− map (\path -> (path, length (filter (isIrrelevantTo path) branches))) allPaths
433 in
437 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))
435
444
436
445
437isChoicePath :: (Path, CPattern) -> Maybe Path
446isChoicePath :: (Path, CPattern) -> Maybe Path
@@ -442,4 +451,38 @@ isChoicePath (path, pattern) =
442 Nothing
451 Nothing
443
452
444
453
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+
445−-- smallBranchingFactor :: [Branch] -> Path
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)