fork(3) download
copy 
  1. import Data.Time
  2. import Data.List
  3. import Data.Function
  4.  
  5. data NodeList = NodeList 
  6.     { nlRoot  :: [Int]
  7.     , nlLength :: Int
  8.     , nlSum    :: Int }
  9.     deriving (Show)
  10.  
  11. map1 _ q []    = q
  12. map1 f q (x:xs)  = f x : map1 f q xs
  13.  
  14. makeSums :: [Int] -> Int -> [NodeList] -> [NodeList]
  15. makeSums [] _  acc         = acc    
  16. makeSums (x:xs) maxlen acc = makeSums xs maxlen $ addNodeList $ map1 addNode acc $ filter lessLen acc
  17.     where addNodeList y = (NodeList [x] 1 x) : y
  18.           addNode (NodeList root len sum) = NodeList (x:root) (len+1) (sum+x) 
  19.           lessLen y = nlLength y < maxlen
  20.  
  21. makePairs :: [NodeList] -> [([Int], [Int])] -> [([Int], [Int])]
  22. makePairs [] acc     = acc
  23. makePairs (x:xs) acc = makePairs xs $ (++) acc $ map pairNodes $ filter sameSum xs 
  24.     where sameSum y = nlSum x == (nlSum y)
  25.           pairNodes y = (nlRoot x, nlRoot y)
  26.  
  27. solve3 :: [Int] -> Int -> [([Int], [Int])]
  28. solve3 nums maxlen = makePairs (makeSums nums maxlen []) []
  29.  
  30. makePairs4 :: [NodeList] -> [([Int], [Int])] -> [([Int], [Int])]
  31. makePairs4 [] acc     = acc
  32. makePairs4 (x:xs) acc = makePairs4 xs $ map1 pairNodes acc $ takeWhile sameSum xs 
  33.     where sameSum y = nlSum x == (nlSum y)
  34.           pairNodes y = (nlRoot x, nlRoot y)
  35.  
  36. solve4 :: [Int] -> Int -> [([Int], [Int])]
  37. solve4 nums maxlen = makePairs4 (sortBy (compare `on` nlSum) (makeSums nums maxlen [])) []
  38.  
  39. solve1 nums maxlen = nub $ concat $ concatMap (mkPair . map snd) $ filter noOne $
  40.                     groupBy ((==) `on` fst) $ sortBy (compare `on` fst) $ 
  41.                     map (\a -> (sum a,a)) $
  42.                     filter ((<=maxlen).length) $ tail $ subsequences nums
  43.     where noOne [x] = False
  44.           noOne _ = True
  45.           mkPair [x,y] = [[(x,y)]]
  46.           mkPair (x:xs) = map ((,)x) xs : mkPair xs
  47.  
  48. solve2 nums maxlen = concat $ concatMap (mkPair . map snd) $ filter noOne $
  49.                     groupBy ((==) `on` fst) $ sortBy (compare `on` fst) $ 
  50.                     map (\a -> (sum a,a)) $
  51.                     filter ((<=maxlen).length) $ tail $ subsequences nums
  52.     where noOne [x] = False
  53.           noOne _ = True
  54.           mkPair [x,y] = [[(x,y)]]
  55.           mkPair (x:xs) = map ((,)x) xs : mkPair xs
  56.  
  57. bench f nums maxlen title = do
  58.        begT <- getCurrentTime
  59.        print $ last $ f nums maxlen
  60.        endT <- getCurrentTime
  61.        print $ show (diffUTCTime endT begT) ++ "  " ++ title 
  62.  
  63. test m = do
  64. 	--bench solve1 [1..m] (m `div` 2) "with nub"
  65. 	bench solve2 [1..m] (m `div` 2) "without nub"
  66. 	--bench solve3 [1..m] (m `div` 2) "without sort filter"
  67. 	bench solve4 [1..m] (m `div` 2) "with sort takeWhile"
  68.  
  69. main:: IO () 
  70. main = test 14
Success #stdin #stdout 0.21s 8320KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
([7,8,10,11,12,13,14],[6,9,10,11,12,13,14])
"0.083884s  without nub"
([3],[2,1])
"0.133114s  with sort takeWhile"
https://ideone.com/bCfybQ
language:
Haskell (ghc 8.4.4)
created:
10 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!