Commit 67b2af08 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Add a test for #2902

parent 8792fd6c
......@@ -15,3 +15,14 @@ T3736:
# platforms), but we don't currently.
ALLOC1=`$(call runT3736,1)`; ALLOC2=`$(call runT3736,2)`; if [ "$$ALLOC1" -gt 100 ] && [ "$$ALLOC1" -eq "$$ALLOC2" ]; then echo Match; else echo "Mismatch: $$ALLOC1 $$ALLOC2"; fi
.PHONY: T2902
T2902:
$(RM) -f T2902_A T2902_B
$(RM) -f T2902_A.hi T2902_B.hi
$(RM) -f T2902_A.o T2902_B.o
$(RM) -f T2902_A_PairingSum.hi T2902_B_PairingSum.hi T2902_Sum.hi
$(RM) -f T2902_A_PairingSum.o T2902_B_PairingSum.o T2902_Sum.o
'$(TEST_HC)' -v0 -O --make T2902_A -rtsopts
'$(TEST_HC)' -v0 -O --make T2902_B -rtsopts
BAA=`./T2902_A +RTS -t --machine-readable 2>&1 | grep '"bytes allocated"' | sed -e 's/.*, "//' -e 's/")//'`; BAB=`./T2902_B +RTS -t --machine-readable 2>&1 | grep '"bytes allocated"' | sed -e 's/.*, "//' -e 's/")//'`; [ "$$BAA" = "" ] && echo 'T2902_A: No "bytes allocated"'; [ "$$BAA" = "$$BAB" ] || echo 'T2902: Mismatch in "bytes allocated"'
{-# LANGUAGE UnicodeSyntax #-}
module Main (main) where
import T2902_A_PairingSum
f :: Int -> PSum Int Int
f n = unions $ fmap g [1..n]
where
g m = unions $ fmap fromList
[ zip [m..n] $ repeat 1
, zip [m,2+m..n] $ repeat 2
, zip [m,3+m..n] $ repeat 3
]
main IO ()
main = print $ take 20 $ toList $ f 20
{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, FlexibleInstances #-}
module T2902_A_PairingSum (Sum(..), PSum) where
import T2902_Sum
data PSum a b = Empty | Tree a b [(PSum a b)]
instance (Ord a, Num b) Sum PSum a b where
insert = insertX
union = unionX
unions = unionsX
extractMin = extractMinX
fromList = fromListX
toList = toListX
insertX (Ord a, Num b) a b PSum a b PSum a b
insertX v r = unionX $ Tree v r []
unionX (Ord a, Num b) PSum a b PSum a b PSum a b
unionX x Empty = x
unionX Empty x = x
unionX x@(Tree v r xs) y@(Tree w s ys) =
case compare v w of
LT Tree v r (y:xs)
GT Tree w s (x:ys)
EQ case r + s of
0 z
t insertX v t z
where z = unionX (unionsX xs) (unionsX ys)
unionsX (Ord a, Num b) [PSum a b] PSum a b
unionsX [] = Empty
unionsX [x] = x
unionsX (x : y : zs) = unionX (unionX x y) (unionsX zs)
extractMinX (Ord a, Num b) PSum a b ((a,b), PSum a b)
extractMinX Empty = undefined
extractMinX (Tree v r xs) = ((v,r), unionsX xs)
fromListX (Ord a, Num b) [(a,b)] PSum a b
fromListX [] = Empty
fromListX ((v,r):xs) = insertX v r $ fromListX xs
toListX (Ord a, Num b) PSum a b [(a,b)]
toListX Empty = []
toListX x = let (y, z) = extractMinX x in y : toListX z
{-# LANGUAGE UnicodeSyntax #-}
module Main (main) where
import T2902_B_PairingSum
f :: Int -> PSum Int Int
f n = unions $ fmap g [1..n]
where
g m = unions $ fmap fromList
[ zip [m..n] $ repeat 1
, zip [m,2+m..n] $ repeat 2
, zip [m,3+m..n] $ repeat 3
]
main IO ()
main = print $ take 20 $ toList $ f 20
{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, FlexibleInstances #-}
module T2902_B_PairingSum (Sum(..), PSum) where
import T2902_Sum
data PSum a b = Empty | Tree a b [PSum a b]
instance (Ord a, Num b) Sum PSum a b where
insert v r = union $ Tree v r []
union x Empty = x
union Empty x = x
union x@(Tree v r xs) y@(Tree w s ys) =
case compare v w of
LT Tree v r (y:xs)
GT Tree w s (x:ys)
EQ case r + s of
0 z
t insert v t z
where z = union (unions xs) (unions ys)
unions [] = Empty
unions [x] = x
unions (x : y : zs) = union (union x y) (unions zs)
extractMin Empty = undefined
extractMin (Tree v r xs) = ((v,r), unions xs)
fromList [] = Empty
fromList ((v,r):xs) = insert v r $ fromList xs
toList Empty = []
toList x = let (y, z) = extractMin x in y : toList z
{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses #-}
module T2902_Sum (Sum(..)) where
class Sum c a b where
insert a b c a b c a b
union c a b c a b c a b
unions [c a b] c a b
extractMin c a b ((a,b), c a b)
fromList [(a,b)] c a b
toList c a b [(a,b)]
......@@ -89,3 +89,15 @@ test('MethSharing',
],
compile_and_run,
['-O'])
test('T2902',
[normal,
extra_clean(['T2902_A', 'T2902_B',
'T2902_A.hi', 'T2902_B.hi',
'T2902_A.o', 'T2902_B.o',
'T2902_A_PairingSum.hi', 'T2902_B_PairingSum.hi',
'T2902_A_PairingSum.o', 'T2902_B_PairingSum.o',
'T2902_Sum.hi',
'T2902_Sum.o'])],
run_command,
['$MAKE -s --no-print-directory T2902'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment