fun_mergesort.hs

{-# LANGUAGE DeriveFunctor #-}

module Main where

-- see https://jtobin.io/sorting-with-style

import           Control.Arrow         ((***))
import           Data.Function         ((&))

import           Data.Functor.Foldable (hylo)
import           Data.List.Ordered     (merge)


-- Implementation 1

mergesort' :: Ord a => [a] -> [a]
mergesort' = hylo folder unfolder

data Tree a r = Empty
    | Leaf a
    | Branch (r,r)
    deriving Functor

unfolder :: [a] -> Tree a [a]
unfolder []  = Empty
unfolder [x] = Leaf x
unfolder xs  = Branch (partition xs)

folder :: Ord a => Tree a [a] -> [a]
folder Empty = []
folder (Leaf x) = [x]
folder (Branch (l,r)) = merge l r

-- Implementation 2

mergesort :: Ord a => [a] -> [a]
mergesort []  = []
mergesort [a] = [a]
mergesort as  = as & merge' . (mergesort *** mergesort) . partition

merge' :: Ord a => ([a], [a]) -> [a]
merge' (as, []) = as
merge' ([], bs) = bs
merge' (as@(a:as'), bs@(b:bs'))
  | a <= b    = a : merge' (as', bs)
  | otherwise = b : merge' (as, bs')

partition :: [a] -> ([a], [a])
partition xs = go ([],[]) xs
  where
    go p []         = p
    go (l,r) (a:as) = go (r, a:l) as


-- Testing!

main :: IO ()
main = do
  print $ mergesort  $ reverse $ [1..10] ++ [2..13]
  print $ mergesort' $ reverse $ [1..10] ++ [2..13]