Подпоследовательности с одинаковыми суммами

data NodeList = NodeList 
    { nlRoot  :: [Int]
    , nlLength :: Int
    , nlSum    :: Int }
    deriving (Show)
 
makeSums :: [Int] -> Int -> [NodeList] -> [NodeList]
makeSums [] _  acc         = acc    
makeSums (x:xs) maxlen acc = makeSums xs maxlen $ addNodeList $ (++) acc $ map addNode $ 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 $ filter sameSum xs 
    where sameSum y = nlSum x == (nlSum y)
          pairNodes y = (nlRoot x, nlRoot y)
 
solve :: [Int] -> Int -> [([Int], [Int])]
solve nums maxlen = makePairs (makeSums nums maxlen []) []
    
main = do 
  print $ solve [1,2,3,4] 3

import Data.Time
import Data.List
import Data.Function
 
solve nums maxlen = nub $ concat $ concatMap (mkPair . map snd) $ filter noOne $
                    groupBy ((==) `on` fst) $ sortBy (compare `on` fst) $ 
                    map (\a -> (sum a,a)) $
                    filter ((<=maxlen).length) $ tail $ subsequences nums
    where noOne [x] = False
          noOne _ = True
          mkPair [x,y] = [[(x,y)]]
          mkPair (x:xs) = map ((,)x) xs : mkPair xs
          
main:: IO () 
main = do
       begT <- getCurrentTime
       print $ solve [1,2,3,4,5,6] 4
       endT <- getCurrentTime
       print $ diffUTCTime endT begT

import Data.Time
import Data.List
import Data.Function
 
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
 
makePairs4 :: [NodeList] -> [([Int], [Int])] -> [([Int], [Int])]
makePairs4 [] acc     = acc
makePairs4 (x:xs) acc = makePairs4 xs $ map1 pairNodes acc $ takeWhile sameSum xs 
    where sameSum y = nlSum x == (nlSum y)
          pairNodes y = (nlRoot x, nlRoot y)
    
solve4 :: [Int] -> Int -> [([Int], [Int])]
solve4 nums maxlen = makePairs4 (sortBy (compare `on` nlSum) (makeSums nums maxlen [])) []