1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 |
------------------------------------------------------------------------------ --- A collection of useful functions for sorting and comparing --- characters, strings, and lists. --- --- @author Michael Hanus --- @version April 2016 --- @category algorithm ------------------------------------------------------------------------------ {-# OPTIONS_CYMAKE -Wno-overlapping #-} module Sort( sort, sortBy, sorted, sortedBy , permSort, permSortBy, insertionSort, insertionSortBy , quickSort, quickSortBy, mergeSort, mergeSortBy , cmpChar, cmpList, cmpString , leqChar, leqCharIgnoreCase, leqList , leqString, leqStringIgnoreCase, leqLexGerman ) where import Char import Test.Prop --- The default sorting operation, mergeSort, with standard ordering `<=`. sort :: Ord a => [a] -> [a] sort = sortBy (<=) -- Postcondition: input and output lists have same length and output is sorted. sort'post :: Ord a => [a] -> [a] -> Bool sort'post xs ys = length xs == length ys && sorted ys -- Specification via permutation sort: sort'spec :: Ord a => [a] -> [a] sort'spec xs = permSort xs --- The default sorting operation: mergeSort sortBy :: (a -> a -> Bool) -> [a] -> [a] sortBy = mergeSortBy --- `sorted xs` is satisfied if the elements `xs` are in ascending order. sorted :: Ord a => [a] -> Bool sorted = sortedBy (<=) --- `sortedBy leq xs` is satisfied if all adjacent elements of the list `xs` --- satisfy the ordering predicate `leq`. sortedBy :: (a -> a -> Bool) -> [a] -> Bool sortedBy _ [] = True sortedBy _ [_] = True sortedBy leq (x:y:ys) = leq x y && sortedBy leq (y:ys) ------------------------------------------------------------------------------ --- Permutation sort with standard ordering `<=`. --- Sorts a list by finding a sorted permutation --- of the input. This is not a usable way to sort a list but it can be used --- as a specification of other sorting algorithms. permSort :: Ord a => [a] -> [a] permSort = permSortBy (<=) --- Permutation sort with ordering as first parameter. --- Sorts a list by finding a sorted permutation --- of the input. This is not a usable way to sort a list but it can be used --- as a specification of other sorting algorithms. permSortBy :: Eq a => (a -> a -> Bool) -> [a] -> [a] permSortBy leq xs | sortedBy leq ys = ys where ys = perm xs --- Computes a permutation of a list. perm :: [a] -> [a] perm [] = [] perm (x:xs) = insert (perm xs) where insert ys = x : ys insert (y:ys) = y : insert ys ------------------------------------------------------------------------------ --- Insertion sort with standard ordering `<=`. --- The list is sorted by repeated sorted insertion of the elements --- into the already sorted part of the list. insertionSort :: Ord a => [a] -> [a] insertionSort = insertionSortBy (<=) -- Postcondition: input and output lists have same length and output is sorted. insertionSort'post :: Ord a => [a] -> [a] -> Bool insertionSort'post xs ys = length xs == length ys && sorted ys -- Specification via permutation sort: insertionSort'spec :: Ord a => [a] -> [a] insertionSort'spec = permSort --- Insertion sort with ordering as first parameter. --- The list is sorted by repeated sorted insertion of the elements --- into the already sorted part of the list. insertionSortBy :: (a -> a -> Bool) -> [a] -> [a] insertionSortBy _ [] = [] insertionSortBy leq (x:xs) = insert (insertionSortBy leq xs) where insert [] = [x] insert zs@(y:ys) | leq x y = x : zs | otherwise = y : insert ys ------------------------------------------------------------------------------ --- Quicksort with standard ordering `<=`. --- The classical quicksort algorithm on lists. quickSort :: Ord a => [a] -> [a] quickSort = quickSortBy (<=) -- Postcondition: input and output lists have same length and output is sorted. quickSort'post :: Ord a => [a] -> [a] -> Bool quickSort'post xs ys = length xs == length ys && sorted ys -- Specification via permutation sort: quickSort'spec :: Ord a => [a] -> [a] quickSort'spec = permSort --- Quicksort with ordering as first parameter. --- The classical quicksort algorithm on lists. quickSortBy :: (a -> a -> Bool) -> [a] -> [a] quickSortBy _ [] = [] quickSortBy leq (x:xs) = let (l,r) = split x xs in quickSortBy leq l ++ (x : quickSortBy leq r) where split _ [] = ([],[]) split e (y:ys) | leq y e = (y:l,r) | otherwise = (l,y:r) where (l,r) = split e ys ------------------------------------------------------------------------------ --- Bottom-up mergesort with standard ordering `<=`. mergeSort :: Ord a => [a] -> [a] mergeSort = mergeSortBy (<=) -- Postcondition: input and output lists have same length and output is sorted. mergeSort'post :: Ord a => [a] -> [a] -> Bool mergeSort'post xs ys = length xs == length ys && sorted ys -- Specification via permutation sort: mergeSort'spec :: Ord a => [a] -> [a] mergeSort'spec = permSort --- Bottom-up mergesort with ordering as first parameter. mergeSortBy :: (a -> a -> Bool) -> [a] -> [a] mergeSortBy leq zs = mergeLists (genRuns zs) where -- generate runs of length 2: genRuns [] = [] genRuns [x] = [[x]] genRuns (x1:x2:xs) | leq x1 x2 = [x1,x2] : genRuns xs | otherwise = [x2,x1] : genRuns xs -- merge the runs: mergeLists [] = [] mergeLists [x] = x mergeLists (x1:x2:xs) = mergeLists (merge leq x1 x2 : mergePairs xs) mergePairs [] = [] mergePairs [x] = [x] mergePairs (x1:x2:xs) = merge leq x1 x2 : mergePairs xs --- Merges two lists with respect to an ordering predicate. merge :: (a -> a -> Bool) -> [a] -> [a] -> [a] merge _ [] ys = ys merge _ (x:xs) [] = x : xs merge leq (x:xs) (y:ys) | leq x y = x : merge leq xs (y:ys) | otherwise = y : merge leq (x:xs) ys ------------------------------------------------------------------------------ -- Comparing lists, characters and strings --- Less-or-equal on lists. leqList :: Eq a => (a -> a -> Bool) -> [a] -> [a] -> Bool leqList _ [] _ = True leqList _ (_:_) [] = False leqList leq (x:xs) (y:ys) | x == y = leqList leq xs ys | otherwise = leq x y --- Comparison of lists. cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering cmpList _ [] [] = EQ cmpList _ [] (_:_) = LT cmpList _ (_:_) [] = GT cmpList cmp (x:xs) (y:ys) | cmp x y == EQ = cmpList cmp xs ys | otherwise = cmp x y --- Less-or-equal on characters (deprecated, use 'Prelude.<='). leqChar :: Char -> Char -> Bool leqChar = (<=) --- Comparison of characters (deprecated, use 'Prelude.compare'). cmpChar :: Char -> Char -> Ordering cmpChar = compare --- Less-or-equal on characters ignoring case considerations. leqCharIgnoreCase :: Char -> Char -> Bool leqCharIgnoreCase c1 c2 = (toUpper c1) <= (toUpper c2) --- Less-or-equal on strings (deprecated, use 'Prelude.<='). leqString :: String -> String -> Bool leqString = (<=) --- Comparison of strings (deprecated, use 'Prelude.compare'). cmpString :: String -> String -> Ordering cmpString = compare --- Less-or-equal on strings ignoring case considerations. leqStringIgnoreCase :: String -> String -> Bool leqStringIgnoreCase = leqList leqCharIgnoreCase --- Lexicographical ordering on German strings. --- Thus, upper/lowercase are not distinguished and Umlauts are sorted --- as vocals. leqLexGerman :: String -> String -> Bool leqLexGerman [] _ = True leqLexGerman (_:_) [] = False leqLexGerman (x:xs) (y:ys) | x' == y' = leqLexGerman xs ys | otherwise = x' < y' where x' = glex (ord x) y' = glex (ord y) -- map umlauts to vocals and make everything lowercase: glex o | o >= ord 'A' && o <= ord 'Z' = o + (ord 'a' - ord 'A') | o == 228 = ord 'a' | o == 246 = ord 'o' | o == 252 = ord 'u' | o == 196 = ord 'a' | o == 214 = ord 'o' | o == 220 = ord 'u' | o == 223 = ord 's' | otherwise = o -- end module Sort |