From 0a48ed023ea65d75851ba2a4151100602695a2fd Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Thu, 22 Oct 2015 14:05:21 +1100 Subject: Cleaning up source a bit --- sieve/euler.scm | 16 ++++++++++------ sieve/sundaram.scm | 16 ++++++++-------- sort/gnome.hs | 22 ++++++++++++++++++++++ sort/gnomesort.hs | 19 ------------------- sort/merge.hs | 22 ++++++++++++++++++++++ sort/mergesort.hs | 19 ------------------- sort/pancake.hs | 33 +++++++++++++++++++++++++++++++++ sort/pancakesort.hs | 30 ------------------------------ sort/quick.hs | 15 +++++++++++++++ sort/quicksort.hs | 12 ------------ sort/strand.hs | 28 ++++++++++++++++++++++++++++ sort/strandsort.hs | 25 ------------------------- 12 files changed, 138 insertions(+), 119 deletions(-) create mode 100644 sort/gnome.hs delete mode 100644 sort/gnomesort.hs create mode 100644 sort/merge.hs delete mode 100644 sort/mergesort.hs create mode 100644 sort/pancake.hs delete mode 100644 sort/pancakesort.hs create mode 100644 sort/quick.hs delete mode 100644 sort/quicksort.hs create mode 100644 sort/strand.hs delete mode 100644 sort/strandsort.hs diff --git a/sieve/euler.scm b/sieve/euler.scm index b3ba946..ac23a94 100644 --- a/sieve/euler.scm +++ b/sieve/euler.scm @@ -16,17 +16,21 @@ -(define-stream (sub-merge x y) - (if (eq? (stream-car x) (stream-car y)) - (sub-merge (stream-cdr x) (stream-cdr y)) - (stream-cons (stream-car x) (sub-merge (stream-cdr x) y)))) +(define-stream (stream-ordered-diff xstrm ystrm) + (stream-match xstrm (() '()) ((x . xs) + (stream-match ystrm (() xstrm) ((y . ys) + (cond ((< x y) (stream-cons x (stream-ordered-diff xs ystrm))) + ((> x y) (stream-ordered-diff xstrm ys)) + (else (stream-ordered-diff xs ys)))))))) + (define-stream (sieve input) (stream-cons (stream-car input) - (sieve (sub-merge (stream-cdr input) - (stream-map ((curry *) (stream-car input)) input))))) + (sieve (stream-ordered-diff + (stream-cdr input) + (stream-map ((curry *) (stream-car input)) input))))) diff --git a/sieve/sundaram.scm b/sieve/sundaram.scm index 457efb8..384bc3d 100644 --- a/sieve/sundaram.scm +++ b/sieve/sundaram.scm @@ -19,9 +19,9 @@ (define-stream (stream-ordered-diff xstrm ystrm) (stream-match xstrm (() '()) ((x . xs) (stream-match ystrm (() xstrm) ((y . ys) - (if (eq? x y) - (stream-ordered-diff xs ys) - (stream-cons x (stream-ordered-diff xs ystrm)))))))) + (cond ((< x y) (stream-cons x (stream-ordered-diff xs ystrm))) + ((> x y) (stream-ordered-diff xstrm ys)) + (else (stream-ordered-diff xs ys)))))))) @@ -30,7 +30,7 @@ (stream-match ystrm (() xstrm) ((y . ys) (cond ((< x y) (stream-cons x (stream-merge xs ystrm))) ((> x y) (stream-cons y (stream-merge xstrm ys))) - ((eq? x y) (stream-cons x (stream-merge xs ys))))))))) + (else (stream-cons x (stream-merge xs ys))))))))) @@ -48,11 +48,11 @@ (define ij-stream (stream-let loop ((n 1) (strm (i-stream 1))) - (let* ((cutoff ((curry >) (stream-car (i-stream n)))) - (next (+ n 1)) + (let* ((next (+ n 1)) + (cutoff ((curry >) (stream-car (i-stream next)))) (available (stream-take-while cutoff strm)) - (remainder (stream-drop-while cutoff strm))) - (stream-append available (loop next (stream-merge remainder (i-stream next))))))) + (remaining (stream-drop-while cutoff strm))) + (stream-append available (loop next (stream-merge remaining (i-stream next))))))) diff --git a/sort/gnome.hs b/sort/gnome.hs new file mode 100644 index 0000000..e43b05a --- /dev/null +++ b/sort/gnome.hs @@ -0,0 +1,22 @@ +module Gnome ( + gnomeSort + ) where + + + +gnomeSort :: Ord a => [a] -> [a] +gnomeSort list = doGnomeSort list 1 + + + +doGnomeSort :: Ord a => [a] -> Int -> [a] +doGnomeSort list pos | pos >= length list = list +doGnomeSort list pos = + if (list !! pos) >= (list !! (pos - 1)) + then doGnomeSort list (pos + 1) + else let list' = (take (pos - 1) list) ++ [list !! pos] ++ + [list !! (pos - 1)] ++ (drop (pos + 1) list) + pos' = if pos > 1 then pos - 1 else pos + in doGnomeSort list' pos' + + diff --git a/sort/gnomesort.hs b/sort/gnomesort.hs deleted file mode 100644 index 2a9b9ce..0000000 --- a/sort/gnomesort.hs +++ /dev/null @@ -1,19 +0,0 @@ - - - -gnomeSort :: Ord a => [a] -> [a] -gnomeSort list = doGnomeSort list 1 - - - -doGnomeSort :: Ord a => [a] -> Int -> [a] -doGnomeSort list pos | pos >= length list = list -doGnomeSort list pos = - if (list !! pos) >= (list !! (pos - 1)) - then doGnomeSort list (pos + 1) - else let list' = (take (pos - 1) list) ++ [list !! pos] ++ - [list !! (pos - 1)] ++ (drop (pos + 1) list) - pos' = if pos > 1 then pos - 1 else pos - in doGnomeSort list' pos' - - diff --git a/sort/merge.hs b/sort/merge.hs new file mode 100644 index 0000000..71dd999 --- /dev/null +++ b/sort/merge.hs @@ -0,0 +1,22 @@ +module Merge ( + mergeSort + ) where + + + +mergeSort :: Ord a => [a] -> [a] +mergeSort x | length x <= 1 = x +mergeSort x = + let n = (length x) `div` 2 + left = mergeSort (take n x) + right = mergeSort (drop n x) + in merge left right + + + +merge :: Ord a => [a] -> [a] -> [a] +merge [] y = y +merge x [] = x +merge (x:xs) (y:ys) = if x <= y then x:(merge xs (y:ys)) else y:(merge (x:xs) ys) + + diff --git a/sort/mergesort.hs b/sort/mergesort.hs deleted file mode 100644 index 5c140b3..0000000 --- a/sort/mergesort.hs +++ /dev/null @@ -1,19 +0,0 @@ - - - -mergeSort :: Ord a => [a] -> [a] -mergeSort x | length x <= 1 = x -mergeSort x = - let n = (length x) `div` 2 - left = mergeSort (take n x) - right = mergeSort (drop n x) - in merge left right - - - -merge :: Ord a => [a] -> [a] -> [a] -merge [] y = y -merge x [] = x -merge (x:xs) (y:ys) = if x <= y then x:(merge xs (y:ys)) else y:(merge (x:xs) ys) - - diff --git a/sort/pancake.hs b/sort/pancake.hs new file mode 100644 index 0000000..2bfdb4a --- /dev/null +++ b/sort/pancake.hs @@ -0,0 +1,33 @@ +module Pancake ( + pancakeSort + ) where + + + +pancakeSort :: Ord a => [a] -> [a] +pancakeSort [] = [] +pancakeSort cakeStack = + let selectedCake = indexOfLargest cakeStack + cakeStack' = (doFlip (length cakeStack)) . (doFlip selectedCake) $ cakeStack + in (pancakeSort (init cakeStack')) ++ [last cakeStack'] + + + +indexOfLargest :: Ord a => [a] -> Int +indexOfLargest (x:xs) = + let f m i j y = if length y == 0 + then i + else if (head y) > m + then f (head y) j (j+1) (tail y) + else f m i (j+1) (tail y) + in f x 0 1 xs + + + +doFlip :: Int -> [a] -> [a] +doFlip depth list = + let prefix = take (depth + 1) list + rest = drop (depth + 1) list + in (reverse prefix) ++ rest + + diff --git a/sort/pancakesort.hs b/sort/pancakesort.hs deleted file mode 100644 index 30993ba..0000000 --- a/sort/pancakesort.hs +++ /dev/null @@ -1,30 +0,0 @@ - - - -pancakeSort :: Ord a => [a] -> [a] -pancakeSort [] = [] -pancakeSort cakeStack = - let selectedCake = indexOfLargest cakeStack - cakeStack' = (doFlip (length cakeStack)) . (doFlip selectedCake) $ cakeStack - in (pancakeSort (init cakeStack')) ++ [last cakeStack'] - - - -indexOfLargest :: Ord a => [a] -> Int -indexOfLargest (x:xs) = - let f m i j y = if length y == 0 - then i - else if (head y) > m - then f (head y) j (j+1) (tail y) - else f m i (j+1) (tail y) - in f x 0 1 xs - - - -doFlip :: Int -> [a] -> [a] -doFlip depth list = - let prefix = take (depth + 1) list - rest = drop (depth + 1) list - in (reverse prefix) ++ rest - - diff --git a/sort/quick.hs b/sort/quick.hs new file mode 100644 index 0000000..44efd81 --- /dev/null +++ b/sort/quick.hs @@ -0,0 +1,15 @@ +module Quick ( + quickSort + ) where + + + +quickSort :: Ord a => [a] -> [a] +quickSort [] = [] +quickSort (x:xs) = + let less = [ a | a <- xs, a < x ] + equal = [ b | b <- (x:xs), b == x ] + greater = [ c | c <- xs, c > x ] + in quickSort less ++ equal ++ quickSort greater + + diff --git a/sort/quicksort.hs b/sort/quicksort.hs deleted file mode 100644 index 78330f3..0000000 --- a/sort/quicksort.hs +++ /dev/null @@ -1,12 +0,0 @@ - - - -quickSort :: Ord a => [a] -> [a] -quickSort [] = [] -quickSort (x:xs) = - let less = [ a | a <- xs, a < x ] - equal = [ b | b <- (x:xs), b == x ] - greater = [ c | c <- xs, c > x ] - in quickSort less ++ equal ++ quickSort greater - - diff --git a/sort/strand.hs b/sort/strand.hs new file mode 100644 index 0000000..856f75a --- /dev/null +++ b/sort/strand.hs @@ -0,0 +1,28 @@ +module Strand ( + strandSort + ) where + + + +strandSort :: Ord a => [a] -> [a] +strandSort list = doStrandSort list [] [] [] + + + +doStrandSort :: Ord a => [a] -> [a] -> [a] -> [a] -> [a] +doStrandSort [] [] [] result = result +doStrandSort [] sublist unsorted result = doStrandSort unsorted [] [] (merge (reverse sublist) result) +doStrandSort input [] unsorted result = doStrandSort (tail input) [head input] unsorted result +doStrandSort input sublist unsorted result = + if (head input) >= (head sublist) + then doStrandSort (tail input) ((head input):sublist) unsorted result + else doStrandSort (tail input) sublist ((head input):unsorted) result + + + +merge :: Ord a => [a] -> [a] -> [a] +merge [] y = y +merge x [] = x +merge (x:xs) (y:ys) = if x <= y then x:(merge xs (y:ys)) else y:(merge (x:xs) ys) + + diff --git a/sort/strandsort.hs b/sort/strandsort.hs deleted file mode 100644 index 8226b79..0000000 --- a/sort/strandsort.hs +++ /dev/null @@ -1,25 +0,0 @@ - - - -strandSort :: Ord a => [a] -> [a] -strandSort list = doStrandSort list [] [] [] - - - -doStrandSort :: Ord a => [a] -> [a] -> [a] -> [a] -> [a] -doStrandSort [] [] [] result = result -doStrandSort [] sublist unsorted result = doStrandSort unsorted [] [] (merge (reverse sublist) result) -doStrandSort input [] unsorted result = doStrandSort (tail input) [head input] unsorted result -doStrandSort input sublist unsorted result = - if (head input) >= (head sublist) - then doStrandSort (tail input) ((head input):sublist) unsorted result - else doStrandSort (tail input) sublist ((head input):unsorted) result - - - -merge :: Ord a => [a] -> [a] -> [a] -merge [] y = y -merge x [] = x -merge (x:xs) (y:ys) = if x <= y then x:(merge xs (y:ys)) else y:(merge (x:xs) ys) - - -- cgit