graph: Add ingredient mergingHEADmaster

2 files changed, 91 insertions, 6 deletions

diff --git a/src/exe/Main.lhs b/src/exe/Main.lhs
index dc360fd..ae663ad 100644
--- a/src/exe/Main.lhs
+++ b/src/exe/Main.lhs
@@ -8,7 +8,7 @@ User interface
 > import Data.List (intercalate)
 >
 > import Codec.Pesto.Parse (parse, Instruction (Ingredient), Quantity (..))
-> import Codec.Pesto.Graph (extract, toGraph, firstNodeId, resolveReferences)
+> import Codec.Pesto.Graph (extract, toGraph, firstNodeId, resolveReferences, extractIngredients, mergeQuantity)
 > import Codec.Pesto.Lint (lint, extractMetadata, Metadata(..), LintResult (LintResult))
 > import Codec.Pesto.Serialize (serialize)
 
@@ -87,10 +87,10 @@ ingredients
 Extract ingredients and print them in CSV format. This does not take
 alternatives into account yet.
 
-> runIngredients stream = mapM_ (putStrLn . csvQty) $ reverse $ foldl getIngredient [] stream
+> runIngredients stream = mapM_ (putStrLn . csvQty) $ ingredients
 > 	where
-> 		getIngredient xs (_, Ingredient q) = q:xs
-> 		getIngredient xs _ = xs
+> 		(nodes, _) = streamToGraph stream
+> 		ingredients = mergeQuantity $ extractIngredients nodes
 
 > printMeta (_, (key, MetaStr value)) = putStrLn $ key ++ "=" ++ value
 > printMeta (_, (key, MetaQty q)) = putStrLn $ key ++ "=" ++ csvQty q
diff --git a/src/lib/Codec/Pesto/Graph.lhs b/src/lib/Codec/Pesto/Graph.lhs
index 43142b6..5628ec3 100644
--- a/src/lib/Codec/Pesto/Graph.lhs
+++ b/src/lib/Codec/Pesto/Graph.lhs
@@ -16,6 +16,8 @@ Language semantics
 > 	, resolveReferences
 > 	, test
 > 	, extract
+> 	, extractIngredients
+> 	, mergeQuantity
 > 	, NodeId
 > 	, Node
 > 	, Nodes
@@ -23,8 +25,9 @@ Language semantics
 > 	, Edges
 > 	) where
 > import Data.Char (toLower)
-> import Data.List (sort, nub)
+> import Data.List (sort, nub, sortOn)
 > import Test.HUnit hiding (test, Node)
+> import Data.Ratio ((%), Ratio)
 >
 > import Codec.Pesto.Parse hiding (test)
 
@@ -264,6 +267,76 @@ results with the same name). They are permitted at this stage, but rejected
 > 	, cmpGraphRef "|foobar *foobar >foobar *foobar" [(0, 1), (0, 3), (2, 1), (2, 3)]
 > 	]
 
+Quantities
+++++++++++
+
+.. Does not really fit here. Move?
+
+Lists of quantities, for instance for a shopping basket, can be extracted and merged.
+
+> extractIngredients :: [Node Instruction] -> [Quantity]
+> extractIngredients nodes = foldl f [] nodes
+> 	where
+> 		f xs (_, Ingredient q) = q:xs
+> 		f xs _ = xs
+
+> mergeQuantity :: [Quantity] -> [Quantity]
+> mergeQuantity ingredients = reverse $ foldl foldQty [] sortedIngredients
+> 	where
+> 		sortedIngredients = sortOn sortKey ingredients
+> 		sortKey (Quantity _ b c) = (c, b)
+> 		foldQty ((Quantity (Exact (AmountRatio prevAmount)) prevUnit prevObject):xs)
+> 				(Quantity (Exact (AmountRatio qamount)) qunit qobject)
+> 				| prevObject == qobject && prevUnit == qunit
+> 				= (Quantity (Exact (AmountRatio (prevAmount + qamount))) qunit qobject):xs
+> 		foldQty ((Quantity (Exact (AmountStr "")) prevUnit prevObject):xs)
+> 				(Quantity (Exact (AmountStr "")) qunit qobject)
+> 				| prevObject == qobject && prevUnit == qunit
+> 				= (Quantity (Exact (AmountStr "")) qunit qobject):xs
+> 		foldQty xs x = x:xs
+
+> testQuantity :: [Test]
+> testQuantity = [
+
+Quantities are merged when their objects and units match.
+
+> 	  cmpMerge [
+> 			  exactRatioQuantity (1%1) "kg" "apples"
+> 			, exactRatioQuantity (2%1) "kg" "apples"
+> 			, exactRatioQuantity (1%2) "" "bananas"
+> 			, exactRatioQuantity (3%4) "" "bananas"
+> 			, exactRatioQuantity (5%1) "" "peas"
+> 			, exactRatioQuantity (200%1) "g" "peas"
+> 			]
+> 			[
+> 			  exactRatioQuantity (3%1) "kg" "apples"
+> 			, exactRatioQuantity (5%4) "" "bananas"
+> 			, exactRatioQuantity (5%1) "" "peas"
+> 			, exactRatioQuantity (200%1) "g" "peas"
+> 			]
+
+Objects without any quantity can also be merged.
+
+> 	, cmpMerge [
+> 			  strQuantity "apples"
+> 			, strQuantity "apples"
+> 			]
+> 			[ strQuantity "apples" ]
+
+The merged quantities are sorted.
+
+> 	, cmpMerge [
+> 			  strQuantity "b"
+> 			, strQuantity "c"
+> 			, strQuantity "a"
+> 			]
+> 			[
+> 			  strQuantity "a"
+> 			, strQuantity "b"
+> 			, strQuantity "c"
+> 			]
+> 	]
+
 Appendix
 ++++++++
 
@@ -295,7 +368,19 @@ Get all nodes with edges pointing towards nodeid
 > outgoingEdges edges nodeid = filter ((==) nodeid . fst) edges
 > outgoingNodes nodes edges nodeid = map ((!!) nodes . snd) $ outgoingEdges edges nodeid
 
-> test = ["graph" ~: testGraph, "ref" ~: testRef, "extract" ~: testExtract]
+> test = [
+> 	  "graph" ~: testGraph
+> 	, "ref" ~: testRef
+> 	, "extract" ~: testExtract
+> 	, "quantity" ~: testQuantity
+> 	]
+
+> cmpMerge value expected = (mergeQuantity value) ~?= expected
+> strQuantity = Quantity (Exact (AmountStr "")) ""
+> exactRatioQuantity :: Ratio Integer -> Unit -> Object -> Quantity
+> exactRatioQuantity qamount qunit qobject =
+> 	Quantity (Exact (AmountRatio qamount)) qunit qobject
+
 
 > third (_, _, x) = x