import Data.List (sortBy)
import Data.Time (getCurrentTime, diffUTCTime)
import Data.Function (on)

data NodeList = NodeList 
    { nlRoot  :: [Int]
    , nlLength :: Int
    , nlSum    :: Int }
    deriving (Show)
    
map1 _ q []    = q
map1 f q (x:xs)  = f x : map1 f q xs
 
makeSums :: [Int] -> Int -> [NodeList] -> [NodeList]
makeSums [] _  acc         = acc    
makeSums (x:xs) maxlen acc = makeSums xs maxlen $ addNodeList $ map1 addNode acc $ filter lessLen acc
	where addNodeList y = (NodeList [x] 1 x) : y
	      addNode (NodeList root len sum) = NodeList (x:root) (len+1) (sum+x)
	      lessLen y = nlLength y < maxlen
 
makePairs :: [NodeList] -> [([Int], [Int])] -> [([Int], [Int])]
makePairs [] acc     = acc
makePairs (x:xs) acc = makePairs xs $ (++) acc $ map pairNodes $ takeWhile sameSum xs 
    where sameSum y = nlSum x == (nlSum y)
          pairNodes y = (nlRoot x, nlRoot y)
           
 
solve :: [Int] -> Int -> [([Int], [Int])]
solve nums maxlen = makePairs (sortBy compareNodes (makeSums nums maxlen [])) []
	where compareNodes x y = compare (nlSum x) (nlSum y)

makePairs1 [] acc     = acc
makePairs1 (x:xs) acc = makePairs1 xs $ map1 pairNodes acc $ takeWhile sameSum xs
    where sameSum y = nlSum x == (nlSum y)
          pairNodes y = (nlRoot x, nlRoot y)

solve1 nums maxlen = do
	let a1 = makeSums nums maxlen []
	let a2 = sortBy (compare `on` nlSum) a1
	let a3 = makePairs1 a2 []
	a3

bench f nums maxlen title = do
       begT <- getCurrentTime
       print $ take 1 $ reverse $ f nums maxlen
       endT <- getCurrentTime
       print $ (++) "solve1   " $ show (diffUTCTime endT begT) 
       
test m = bench solve1 [1..m] (m `div` 2) ""   

main = test 10 --print $ solve1 [1..4] 3