Functional coverage tree: Difference between revisions
→{{header|Haskell}}: Added a Haskell draft.
(→Python: Functional: Comments and space for legibility) |
(→{{header|Haskell}}: Added a Haskell draft.) |
||
Line 342:
the top level coverage would increase by 0.016667 to 0.425833
</pre>
=={{header|Haskell}}==
Using a function from a text outline to an updated text outline.
The raw table (supplied in the task description) is read in from a text file, parsed to tree structure, and updated by two traversals (one bottom-up and one top down) before being serialised back to a completed outline text, with an additional 'Share of Residue' column:
{{Trans|Python}}
<lang haskell>{-# LANGUAGE OverloadedStrings #-}
import qualified Data.Text.Read as T
import qualified Data.Text.IO as T
import qualified Data.Text as T
import Control.Arrow ((&&&), first)
import Numeric (showFFloat)
import Data.Bool (bool)
import Data.Tree
data Coverage = Coverage
{ name :: T.Text
, weight :: Float
, coverage :: Float
, share :: Float
} deriving (Eq, Show)
-- TEST ---------------------------------------------------
main :: IO ()
main =
T.readFile "coverageOutline.txt" >>= (T.putStrLn . updatedCoverageOutline)
-- UPDATED COVERAGE OUTLINE -------------------------------
updatedCoverageOutline :: T.Text -> T.Text
updatedCoverageOutline s =
let delimiter = "|"
indentedLines = T.lines s
titles = init $ columnNames delimiter (head indentedLines)
in T.unlines
[ titleLine (titles ++ ["SHARE OF RESIDUE"])
, indentedLinesFromTree " " showCoverage $
withResidueShares 1.0 $
foldTree
weightedCoverage
((partialRecord . fmap T.strip . T.splitOn delimiter) <$>
head (outlineParse (tail indentedLines)))
]
-- WEIGHTED COVERAGE AND SHARES OF REMAINING WORK ---------
weightedCoverage :: Coverage -> Forest Coverage -> Tree Coverage
weightedCoverage x xs =
let cws = (coverage &&& weight) <$> (rootLabel <$> xs)
totalWeight = foldr ((+) . snd) 0 cws
in Node
(x
{ coverage =
foldr (\(c, w) a -> (c * w) + a) (coverage x) cws /
bool 1 totalWeight (0 < totalWeight)
})
xs
withResidueShares :: Float -> Tree Coverage -> Tree Coverage
withResidueShares shareOfTotal tree =
let go fraction node =
let forest = subForest node
cws = (coverage &&& weight) <$> (rootLabel <$> forest)
weights = snd <$> cws
weightTotal = sum weights
nodeRoot = rootLabel node
in Node
(nodeRoot
{ share = fraction * (1 - coverage nodeRoot)
})
(zipWith go (((fraction *) . (/ weightTotal)) <$> weights) forest)
in go shareOfTotal tree
-- OUTLINE PARSE ------------------------------------------
outlineParse :: [T.Text] -> [Tree T.Text]
outlineParse = forestFromLineIndents . indentLevelsFromLines
forestFromLineIndents :: [(Int, T.Text)] -> [Tree T.Text]
forestFromLineIndents pairs =
let go [] = []
go ((n, s):xs) =
let (firstTreeLines, rest) = span ((n <) . fst) xs
in Node s (go firstTreeLines) : go rest
in go pairs
indentLevelsFromLines :: [T.Text] -> [(Int, T.Text)]
indentLevelsFromLines xs =
let pairs = T.span (' ' ==) <$> xs
indentUnit =
foldr
(\x a ->
let w = (T.length . fst) x
in bool a w (w < a && 0 < w))
(maxBound :: Int)
pairs
in first (flip div indentUnit . T.length) <$> pairs
partialRecord :: [T.Text] -> Coverage
partialRecord xs =
let [name, weightText, coverageText] = take 3 (xs ++ repeat "")
in Coverage
{ name = name
, weight = defaultOrRead 1.0 weightText
, coverage = defaultOrRead 0.0 coverageText
, share = 0.0
}
columnNames :: T.Text -> T.Text -> [T.Text]
columnNames delimiter = fmap T.strip . T.splitOn delimiter
defaultOrRead :: Float -> T.Text -> Float
defaultOrRead n txt = either (const n) fst $ T.rational txt
-- SERIALISATION OF TREE TO TABULATED OUTLINE -------------
indentedLinesFromTree :: T.Text -> (T.Text -> a -> T.Text) -> Tree a -> T.Text
indentedLinesFromTree tab showRoot tree =
let go indent node =
showRoot indent (rootLabel node) :
(subForest node >>= go (T.append tab indent))
in T.unlines $ go "" tree
showCoverage :: T.Text -> Coverage -> T.Text
showCoverage indent x =
T.intercalate
"| "
(T.justifyLeft 31 ' ' (T.append indent (name x)) :
T.justifyLeft 9 ' ' (T.pack (showN 0 (weight x))) :
((T.justifyLeft 9 ' ' . T.pack . showN 4) <$> ([coverage, share] <*> [x])))
titleLine :: [T.Text] -> T.Text
titleLine = T.intercalate "| " . zipWith (`T.justifyLeft` ' ') [31, 9, 9, 9]
justifyRight :: Int -> a -> [a] -> [a]
justifyRight n c = (drop . length) <*> (replicate n c ++)
showN :: Int -> Float -> String
showN p n = justifyRight 7 ' ' (showFFloat (Just p) n "")
-- GENERIC ------------------------------------------------
foldTree :: (a -> [b] -> b) -> Tree a -> b
foldTree f = go
where
go (Node x ts) = f x (map go ts)</lang>
{{Out}}
<pre>NAME_HIERARCHY | WEIGHT | COVERAGE | SHARE OF RESIDUE
cleaning | 1 | 0.4092 | 0.5908
house1 | 40 | 0.3312 | 0.2675
bedrooms | 1 | 0.2500 | 0.0375
bathrooms | 1 | 0.5000 | 0.0250
bathroom1 | 1 | 0.5000 | 0.0083
bathroom2 | 1 | 0.0000 | 0.0167
outside_lavatory | 1 | 1.0000 | 0.0000
attic | 1 | 0.7500 | 0.0125
kitchen | 1 | 0.1000 | 0.0450
living_rooms | 1 | 0.2500 | 0.0375
lounge | 1 | 0.0000 | 0.0125
dining_room | 1 | 0.0000 | 0.0125
conservatory | 1 | 0.0000 | 0.0125
playroom | 1 | 1.0000 | 0.0000
basement | 1 | 0.0000 | 0.0500
garage | 1 | 0.0000 | 0.0500
garden | 1 | 0.8000 | 0.0100
house2 | 60 | 0.4611 | 0.3233
upstairs | 1 | 0.1500 | 0.1700
bedrooms | 1 | 0.0000 | 0.0500
suite_1 | 1 | 0.0000 | 0.0125
suite_2 | 1 | 0.0000 | 0.0125
bedroom_3 | 1 | 0.0000 | 0.0125
bedroom_4 | 1 | 0.0000 | 0.0125
bathroom | 1 | 0.0000 | 0.0500
toilet | 1 | 0.0000 | 0.0500
attics | 1 | 0.6000 | 0.0200
groundfloor | 1 | 0.3167 | 0.1367
kitchen | 1 | 0.0000 | 0.0333
living_rooms | 1 | 0.0000 | 0.0333
lounge | 1 | 0.0000 | 0.0083
dining_room | 1 | 0.0000 | 0.0083
conservatory | 1 | 0.0000 | 0.0083
playroom | 1 | 0.0000 | 0.0083
wet_room_&_toilet | 1 | 0.0000 | 0.0333
garage | 1 | 0.0000 | 0.0333
garden | 1 | 0.9000 | 0.0033
hot_tub_suite | 1 | 1.0000 | 0.0000
basement | 1 | 0.9167 | 0.0167
cellars | 1 | 1.0000 | 0.0000
wine_cellar | 1 | 1.0000 | 0.0000
cinema | 1 | 0.7500 | 0.0167 </pre>
=={{header|J}}==
| |||