Quicksort.hs

{-# LANGUAGE LinearTypes #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- Uncomment the line below to observe the generated (optimised) Core. It will
-- land in a file named “Quicksort.dump-simpl”
-- {-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all -dsuppress-uniques #-}

-- | This module implements quicksort with mutable arrays from linear-base
module Simple.Quicksort where

import Data.Array.Mutable.Linear (Array)
import qualified Data.Array.Mutable.Linear as Array
import Data.Unrestricted.Linear
import GHC.Stack
import Prelude.Linear hiding (partition)

-- # Quicksort
-------------------------------------------------------------------------------

quicksortUsingList :: (Ord a) => [a] -> [a]
quicksortUsingList [] = []
quicksortUsingList (x : xs) = quicksortUsingList ltx ++ x : quicksortUsingList gex
  where
    ltx = [y | y <- xs, y < x]
    gex = [y | y <- xs, y >= x]

quicksortUsingArray :: (Ord a) => [a] -> [a]
quicksortUsingArray xs = unur $ Array.fromList xs $ Array.toList . quicksortArray

quicksortArray :: (Ord a) => Array a %1 -> Array a
quicksortArray arr =
  Array.size arr
    & \(Ur len, arr1) -> go 0 (len - 1) arr1

go :: (Ord a) => Int -> Int -> Array a %1 -> Array a
go lo hi arr
  | lo >= hi = arr
  | otherwise =
      Array.read arr lo
        & \(Ur pivot, arr1) ->
          partition arr1 pivot lo hi
            & \(arr2, Ur ix) ->
              swap arr2 lo ix
                & \arr3 ->
                  go lo (ix - 1) arr3
                    & \arr4 -> go (ix + 1) hi arr4

-- | @partition arr pivot lo hi = (arr', Ur ix)@ such that
-- @arr'[i] <= pivot@ for @lo <= i <= ix@,
-- @arr'[j] > pivot@ for @ix < j <= hi@,
-- @arr'[k] = arr[k]@ for @k < lo@ and @k > hi@, and
-- @arr'@ is a permutation of @arr@.
partition :: (Ord a) => Array a %1 -> a -> Int -> Int -> (Array a, Ur Int)
partition arr pivot lo hi
  | (hi < lo) = (arr, Ur (lo - 1))
  | otherwise =
      Array.read arr lo
        & \(Ur lVal, arr1) ->
          Array.read arr1 hi
            & \(Ur rVal, arr2) -> case (lVal <= pivot, pivot < rVal) of
              (True, True) -> partition arr2 pivot (lo + 1) (hi - 1)
              (True, False) -> partition arr2 pivot (lo + 1) hi
              (False, True) -> partition arr2 pivot lo (hi - 1)
              (False, False) ->
                swap arr2 lo hi
                  & \arr3 -> partition arr3 pivot (lo + 1) (hi - 1)

-- | @swap a i j@ exchanges the positions of values at @i@ and @j@ of @a@.
swap :: (HasCallStack) => Array a %1 -> Int -> Int -> Array a
swap arr i j =
  Array.read arr i
    & \(Ur ival, arr1) ->
      Array.read arr1 j
        & \(Ur jval, arr2) -> (Array.set i jval . Array.set j ival) arr2