Sorting

In 1998, Lex Augusteijn published a now-classic paper entitled "Sorting Morphisms", where he redefined common sorting algorithms in terms of their recursion patterns. In this article we revisit his work, implementing functions for quickSort, mergeSort, heapSort, etc. as morphisms on Lists, Trees and other Algebraic Data Structures.

Basic Data Structures

 data Bool =   False | True ;
 data List =  Cons x y | Nil ;
 data Pair = Pair x y;
 data Either = Right b | Left a;

 False:
 *combi T0 2 [ 1,2 ]
 True:
 *combi T0 2 [ 0,2 ]
 Cons:
 *combi T2 3 [ 3,0,1 ]
 Nil:
 *combi T0 2 [ 0,2 ]
 Pair:
 *combi T2 2 [ 2,0,1 ]
 Right:
 *combi T0 2 [ 2,0 ]
 Left:
 *combi T0 2 [ 1,0 ]

Auxiliary Functions

 put x = out (extern 0x10a1fafa) x;
 
 put:
 EXT 279051002
 *OUT
 
 printlist xs = xs (True) (\h t -> put h (printlist t));
  printlist:
 link printlist_r
 combi T0 2 [ 0,2 ]
 *combi T2 2 [ 2,0,1 ]
 printlist_r:
 link printlist
 link put
 *combi T5 3 [ 0,2,1,3 ]

 printEither e = e (\x -> put x) (\x -> x (\f s -> printlist f));
 printEither:
 link printEither_r
 link put
 *combi T2 2 [ 2,0,1 ]
 printEither_l_r:
 *link put
 printEither_r:
 link printEither_r_r
 *combi T0 1 [ 1,0 ]
 printEither_r_r:
 link printlist
 *combi T0 2 [ 0,1 ]

 compose f g x = f (g x);
 compose:
 *combi T1 2 [ 0,1,2 ]

 id x = x;
 id:
 *combi T0 1 [ 0,1 ]
 
 fix f = f (fix f);
 fix:
 link fix
 *combi T1 1 [ 1,0,1 ]

 range n m = (< n m) Nil (Cons n ( range (- n  1) m ));
 range:
 link range#1
 link range#2
 *combi T44 3 [ 0,2,3,1,2,3 ] 
 range#1:
 link range#1#1
 *combi T14 4 [ 4,1,0,1,2 ]
 range#1#1:
 addi -1
 link range
 *combi T1 2 [ 0,1,2 ]
 range#2:
 combi T0 2 [ 0,2 ]
 lt 
 *combi T7 3 [ 0,2,3,1 ]

List Catamorphism

 list_cata a f = Fix (\n ls -> ls a (\x l -> f x (n l)));
 test_cata = list_cata 0 + l4;

List Anamorphism

 list_ana a = fix (\n u -> (a u) (\l -> Nil) (\r -> r (\x l -> Cons x (n l))));
 count = list_ana destruct_count;
 destruct_count n = (== 0 n) (Left Nil) (Right (Pair n (- n 1))); 

List Hylomorphism

 list_hylo1 a c = compose (list cata c) (list_ana a);
 prod = list_cata 1 *;
 factorial1 = compose prod count;

 list_hylo d a f = fix (\n u -> (d u) 
                              (\l -> a)
                              (\r -> r (\x l -> f x (n  l))));
 fac = list_hylo destruct_count 1 *;

Insertion Sort

 insertion_sort l = list_cata Nil insert l;
 insert x ls = ls (Cons x Nil) (\a l -> (< x a) (Cons x (Cons a l)) (Cons a (insert x l)) );

Bubble Sort

 bubble_sort l = selection_sort bubble l;
 bubble ls = ls (Nil) (\x l -> l (Pair x Nil) (\h t -> (bubble l) (\y m -> (< x y) (Pair x (Cons y m)) (Pair y (Cons x m)))));

 bubble2 ls = ls Nil (\x l -> list_cata (Pair x Nil) bub l);
 bub x ps = ps (\y l -> (< x y) (Pair x (Cons y l)) (Pair y (Cons x l)));
 bubble_sort2 l = selection_sort bubble2 l;
 

Leaf Trees

 data LeafTree = Split l r | Leaf x;
 t1 = Split (Split (Leaf 1)
                   (Leaf 2))
            (Split (Leaf 3)
                   (Leaf 4)); 
 tree_sum1 t = t (\x -> x) (\l r -> + (tree_sum l) (tree_sum r));
 

 leaftree_cata fl fs = fix (\n t -> t (\x -> fl x) (\l r -> fs (n l) (n r)));
 tree_sum = leaftree_cata id +;

Fibonacci Tree

 fib_tree1 n = (< n 2) (Leaf 1) 
                    (Branch (fib_tree (- n 1)) (fib_tree (- n 2)));
 leaftree_ana d = fix (\n t -> (d t) (\l -> Leaf l) (\p -> p (\l r -> Split (n l) (n r)))); 

 fib_tree = leaftree_ana destruct_fib;
 destruct_fib n = (< n 2) (Left 1) (Right (Pair (- n 1) (- n 2) ));

 leaftree_hylo d fl fs = fix (\n t -> ( (d t) (\left -> fl left)
                                          (\right -> right (\l r -> fs (n l) (n r) ))));
 fib = leaftree_hylo destruct_fib id +;

Merge Sort

 merge_sort l = l Nil (\h t -> leaftree_hylo select single merge l);

 single x = Cons x Nil;

 merge lx ly = lx ly (\x xs -> ly lx (\y ys ->  (< x y) (Cons x (merge xs (Cons y ys)))
                                                      (Cons y (merge (Cons x xs) ys))));
                                                   
 select l = l (Nil) (\h t -> t (Left h) (\hh tt -> Right (split l )));

 split = list_cata (Pair Nil Nil) (\x p -> p (\l r -> Pair r (Cons x l)));
 test = printEither (select l2);

Binary Trees

 data BinTree = Branch x l r | Tip;
 data Trio = Trio x l r;

 bintree_cata a f = fix (\n t -> t a (\x l r -> f x (n l) (n r)));

 bintree_ana d = fix (\n t -> (d t) (\l -> Tip) (\r -> r (\x l r -> Branch x (n l) (n r) ) ));

 bintree_hylo d a f = Fix (\n t -> (d t) (\l -> a) (\r -> r (\x l r -> f x (n l) (n r))));

Quick Sort

 quick_sort l = bintree_hylo split2 Nil join l;

 split2 ls = ls (Left Nil)
             (\x l -> (partition (> x) l) (\s g -> Right (Trio x s g)));

 partition p =  foldr (select2 p) (Pair Nil Nil);

 join x l r = concat l (Cons x r);

 concat xs ys = xs ys (\h t -> Cons h (concat t ys));

 select2 p x ps = ps (\ts fs -> p x (Pair (Cons x ts) fs) (Pair ts (Cons x fs)));

 foldr f z ls = ls (z) (\h t -> f h (foldr f z t));

Heap Sort

 heap2list l = list_ana (\t -> t (Left Nil) (\x l r -> Right (Pair x (combine l r))) ) l;

 combine t k = t k (\x l r -> k t (\y s v -> (< x y) (Branch x l (combine r k)) (Branch y (combine t s) v ) ));

 list2heap l = bintree_ana decompose l;

 decompose l = l (Left Nil) (\h t -> Right (bubbles l));

 bubbles ls = ls Nil (\x l -> list_cata (Trio x Nil Nil) bubs l);

 bubs x tr = tr (\y l r -> < x y (Trio x (Cons y r) l) (Trio y (Cons x r) l )); 

 heap_sort l = heap2list (list2heap l); 

Paramorphism

 list_para = fix (\n a f ls -> ls a (\x l -> f x l (n a f l)));

 insertion_sort2 l = list_cata Nil insert2 l;

 insert2 x = list_para (Cons x Nil) (\a l rec ->  (< x a) (Cons x (Cons a l)) (Cons a rec));

 remove2 x = list_para Nil (\y l rec -> (== x y) l (Cons y rec));