├── .gitignore
├── README.md
├── annotations
    └── trees.org
└── src
    ├── Nat
        ├── lte
        │   └── mul_right_only.kind
        └── min
        │   └── both.kind
    ├── Tree.kind
    ├── seq.hvm
    └── structs.hvm


/.gitignore:
--------------------------------------------------------------------------------
1 | src/.cache/*


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # functional structures
2 | 
3 | just a simples repo to record some annotations and implementations (and some proofs) of common data structures (trees, lists, vectors, maps...) presented in the book [Functional Algorithms Verified](https://functional-algorithms-verified.org/).
4 | 
5 | most of them are in [kind](https://github.com/kind-lang/Kind), so i recomend checking it out.


--------------------------------------------------------------------------------
/annotations/trees.org:
--------------------------------------------------------------------------------
  1 | #+title: trees
  2 | #+author: @o-santi
  3 | #+PROPERTY: header-args:kind :tangle ../src/Tree.kind :mkdirp yes
  4 | 
  5 | * basics
  6 | we will consider any tree to being binary for now..
  7 | 
  8 | after we study binary trees a bit we can go forward to non-binary ones.
  9 | 
 10 | the most basic binary tree has the following type:
 11 | #+begin_src kind
 12 | type Tree<A: Type>{
 13 |   nil
 14 |   node(
 15 |     left: Tree<A>
 16 |     val: A
 17 |     right: Tree<A>
 18 |   )
 19 | }
 20 | #+end_src
 21 | 
 22 | this means that an element of type =Tree= can be constructed in either of the two of the following ways:
 23 | - the simple element =Tree.nil=
 24 | - an object =Tree.node= that holds 2 Trees and a value
 25 | 
 26 | since a tree can actually hold anything (just like a list), we can make it dependent on a type, so that all values on the node are of that type.
 27 | 
 28 | also notice that the type =Tree.nil= represents the empty tree (just like =List.nil= represents the empty list) and it doesnt need to depend on anything.
 29 | 
 30 | the most basic tree is of the form =<nil, T, nil>=, so we can implement a function that returns it (so that we do not need to repeat it later)
 31 | #+begin_src kind
 32 | Tree.leaf<A: Type>(x: A): Tree<A>
 33 |   Tree.node!(
 34 |     Tree.nil!
 35 |     x
 36 |     Tree.nil!
 37 |   )
 38 | #+end_src
 39 | 
 40 | notice that =Tree.nil= is actually a function of the type =A -> Tree<A>=, so we need to give it the argument (even though it doesnt use it). because of that, we can use the ! to tell kind to infer the type and check it (a *very* cool feature).
 41 | 
 42 | with this we can implement a simple tree:
 43 | 
 44 | #+begin_src kind
 45 | my_tree: Tree<Nat>
 46 |   Tree.node!(
 47 |     Tree.leaf!(1)
 48 |     2
 49 |     Tree.leaf!(3)
 50 |   )
 51 | #+end_src
 52 | 
 53 | we can then implement =Tree.map=, which takes a tree and a function, and returns a new tree with that function applied to each element:
 54 | 
 55 | #+begin_src kind
 56 | Tree.map<T: Type, K: Type>(tree: Tree<T>, f: T -> K): Tree<K>
 57 |   case tree{
 58 |     nil:
 59 |       Tree.nil!
 60 |     node:
 61 |       Tree.node<K>(
 62 | 	  Tree.map!!(tree.left, f)
 63 | 	  f(tree.val)
 64 | 	  Tree.map!!(tree.right, f)
 65 |       ) :: Tree<K>
 66 |   }
 67 | #+end_src
 68 | that is, just return nil on nil and map the function to the left and to the right. pretty simple right?
 69 | 
 70 | we can test it by evaluating for example:
 71 | #+begin_src kind
 72 | Tree: Tree<Nat>
 73 |   Tree.map!!(
 74 | 	my_tree
 75 | 	(x) x + x // the same as lambda (x): x + x
 76 |   ) 
 77 | #+end_src
 78 | i specially named the term =tree= so that we can run it (the same as the file name). kind is a bit fidgety with file names so i avoid getting in its way
 79 | 
 80 | we can then run this test doing the following:
 81 | #+begin_src bash
 82 | kind Tree --run
 83 | #+end_src
 84 | 
 85 | and we see that indeed it returned the tree times two:
 86 | #+begin_src bash
 87 | { _: 'Tree.node',
 88 |   left:
 89 |    { _: 'Tree.node',
 90 |      left: { _: 'Tree.nil' },
 91 |      val: 2n,
 92 |      right: { _: 'Tree.nil' } },
 93 |   val: 4n,
 94 |   right:
 95 |    { _: 'Tree.node',
 96 |      left: { _: 'Tree.nil' },
 97 |      val: 6n,
 98 |      right: { _: 'Tree.nil' } } }
 99 | #+end_src
100 | 
101 | we can also implement the traversal functions =in_order=, =pre_order= and =post_order=, which simply transform a Tree into a list:
102 | #+begin_src kind
103 | Tree.in_order<A: Type>(tree: Tree<A>): List<A>
104 |   case tree{
105 |     nil:
106 |       List.nil!
107 |     node:
108 |       List.concat!(
109 | 	  Tree.in_order!(tree.left),
110 |         tree.val & Tree.in_order!(tree.right)
111 | 	) 
112 |   }
113 |   
114 | Tree.pre_order<A: Type>(tree: Tree<A>): List<A>
115 |   case tree{
116 |     nil:
117 |       List.nil!
118 |     node:
119 |       tree.val & List.concat!(
120 |         Tree.pre_order!(tree.left)
121 |         Tree.pre_order!(tree.right)
122 | 	)
123 |   }
124 | Tree.post_order<A: Type>(tree: Tree<A>): List<A>
125 |   case tree{
126 |     nil:
127 |       List.nil!
128 |     node:
129 |       List.concat!(
130 |         Tree.post_order!(tree.left)
131 |         List.concat!(
132 | 	    Tree.post_order!(tree.right)
133 | 	    [tree.val]
134 | 	  )
135 |       )
136 |   }
137 | #+end_src
138 | notice that the infix =&= operator is just syntatic sugar for =List.cons=. since =List.cons= accepts a val and a list, we can only use if we are inserting =tree.val= to the left of another list. otherwise, we need to use =List.concat= to concatenate two lists.
139 | 
140 | we can also implement the size function:
141 | #+begin_src kind
142 | Tree.size<A: Type>(tree: Tree<A>): Nat
143 |   case tree {
144 |     nil:
145 | 	1
146 |     node:
147 |       1 + Tree.size!(tree.left) + Tree.size!(tree.right)
148 |   }
149 | #+end_src
150 | and the two height functions:
151 | #+begin_src kind
152 | Tree.height<A: Type>(tree: Tree<A>): Nat
153 |   // "normal height"
154 |   case tree {
155 |     nil:
156 |       0
157 |     node:
158 |       1 + Nat.max(Tree.height!(tree.left), Tree.height!(tree.right))
159 |   }
160 | Tree.min_height<A: Type>(tree: Tree<A>): Nat
161 |   // "normal height"
162 |   case tree {
163 |     nil:
164 |       0
165 |     node:
166 |       1 + Nat.min(Tree.height!(tree.left), Tree.height!(tree.right))
167 |   }
168 | #+end_src
169 | 
170 | 
171 | 
172 | * completeness
173 | we can check to see if a tree is complete (that is, all leaves have the same distance from the root) with the following function:
174 | #+begin_src kind
175 | Tree.complete<A: Type>(tree: Tree<A>): Bool
176 |   case tree {
177 |     nil: true
178 |     node:
179 |       Tree.complete!(tree.left) &&
180 |       Tree.complete!(tree.right) &&
181 |       Nat.eql(Tree.height!(tree.left), Tree.height!(tree.right))
182 |   }
183 | #+end_src
184 | 
185 | #+begin_src kind
186 | full_tree_max_height<A:Type>(
187 | 	tree: Tree<A>
188 | 	H: Tree.complete<A>(tree) == true
189 | ): Nat.eql(Tree.height!(tree), Tree.min_height!(tree))
190 |   ?cu
191 | 				   
192 | #+end_src
193 | 


--------------------------------------------------------------------------------
/src/Nat/lte/mul_right_only.kind:
--------------------------------------------------------------------------------
 1 | Nat.lte.mul_right_only(
 2 |   a: Nat
 3 |   b: Nat
 4 |   c: Nat
 5 |   H1: Nat.lte(a, b) == true
 6 |   H2: Nat.lte(1, c) == true
 7 | ): Nat.lte(a, Nat.mul(b, c)) == true
 8 |   let lemma = Nat.Order.mul.left(1, c, b, H2) // b * 1 <= b * c
 9 |   let lemma2 = lemma :: rewrite X in (Nat.lte(X, b*c) == true) with Nat.mul.one_right(b) // b = b * 1
10 |   Nat.Order.chain(a, b, b*c, H1, lemma2) 
11 | 
12 | 


--------------------------------------------------------------------------------
/src/Nat/min/both.kind:
--------------------------------------------------------------------------------
 1 | Nat.min.both(a: Nat, b: Nat, c: Nat, H1: Nat.lte(a, c) == true): Nat.lte(Nat.min(a, b), c) == true
 2 |   case a with H1 {
 3 |     zero: refl
 4 |     succ:
 5 |       case b {
 6 |         zero: refl
 7 | 	succ:
 8 | 	  case c with H1 {
 9 | 	    zero: H1 // or H2
10 | 	    succ:
11 | 	      Nat.min.both(a.pred, b.pred, c.pred, H1)
12 | 	  }!
13 |       }!
14 |   }!
15 | 
16 | 
17 | 
18 | 


--------------------------------------------------------------------------------
/src/Tree.kind:
--------------------------------------------------------------------------------
  1 | type Tree<A: Type>{
  2 |   nil
  3 |   node(
  4 |     left: Tree<A>
  5 |     val: A
  6 |     right: Tree<A>
  7 |   )
  8 | }
  9 | 
 10 | Tree.leaf<A: Type>(x: A): Tree<A>
 11 |   Tree.node!(
 12 |     Tree.nil!
 13 |     x
 14 |     Tree.nil!
 15 |   )
 16 | 
 17 | my_tree: Tree<Nat>
 18 |   Tree.node!(
 19 |     Tree.leaf!(1)
 20 |     2
 21 |     Tree.leaf!(3)
 22 |   )
 23 | 
 24 | Tree.map<T: Type, K: Type>(tree: Tree<T>, f: T -> K): Tree<K>
 25 |   case tree{
 26 |     nil:
 27 |       Tree.nil!
 28 |     node:
 29 |       Tree.node<K>(
 30 | 	  Tree.map!!(tree.left, f)
 31 | 	  f(tree.val)
 32 | 	  Tree.map!!(tree.right, f)
 33 |       ) :: Tree<K>
 34 |   }
 35 | 
 36 | Tree: Tree<Nat>
 37 |   Tree.map!!(
 38 | 	my_tree
 39 | 	(x) x + x // the same as lambda (x): x + x
 40 |   )
 41 | 
 42 | Tree.in_order<A: Type>(tree: Tree<A>): List<A>
 43 |   case tree{
 44 |     nil:
 45 |       List.nil!
 46 |     node:
 47 |       List.concat!(
 48 | 	  Tree.in_order!(tree.left),
 49 |         tree.val & Tree.in_order!(tree.right)
 50 | 	) 
 51 |   }
 52 |   
 53 | Tree.pre_order<A: Type>(tree: Tree<A>): List<A>
 54 |   case tree{
 55 |     nil:
 56 |       List.nil!
 57 |     node:
 58 |       tree.val & List.concat!(
 59 |         Tree.pre_order!(tree.left)
 60 |         Tree.pre_order!(tree.right)
 61 | 	)
 62 |   }
 63 | Tree.post_order<A: Type>(tree: Tree<A>): List<A>
 64 |   case tree{
 65 |     nil:
 66 |       List.nil!
 67 |     node:
 68 |       List.concat!(
 69 |         Tree.post_order!(tree.left)
 70 |         List.concat!(
 71 | 	    Tree.post_order!(tree.right)
 72 | 	    [tree.val]
 73 | 	  )
 74 |       )
 75 |   }
 76 | 
 77 | Tree.size<A: Type>(tree: Tree<A>): Nat
 78 |   case tree {
 79 |     nil:
 80 | 	1
 81 |     node:
 82 |       Tree.size!(tree.left) + Tree.size!(tree.right)
 83 |   }
 84 | 
 85 | Tree.height<A: Type>(tree: Tree<A>): Nat
 86 |   // "normal height"
 87 |   case tree {
 88 |     nil:
 89 |       0
 90 |     node:
 91 |       1 + Nat.max(Tree.height!(tree.left), Tree.height!(tree.right))
 92 |   }
 93 | Tree.min_height<A: Type>(tree: Tree<A>): Nat
 94 |   // "normal height"
 95 |   case tree {
 96 |     nil:
 97 |       0
 98 |     node:
 99 |       1 + Nat.min(Tree.height!(tree.left), Tree.height!(tree.right))
100 |   }
101 | 
102 | Tree.complete<A: Type>(tree: Tree<A>): Bool
103 |   case tree {
104 |     nil: true
105 |     node:
106 |       Tree.complete!(tree.left) &&
107 |       Tree.complete!(tree.right) &&
108 |       Nat.eql(Tree.height!(tree.left), Tree.height!(tree.right))
109 |   }
110 | 
111 | // full_tree_max_height<A:Type>(
112 | // 	tree: Tree<A>
113 | // 	H: Tree.complete<A>(tree) == true
114 | // ): Nat.eql(Tree.height!(tree), Tree.min_height!(tree)) == true
115 | //   case tree with H {
116 | //     nil: refl
117 | //     node:
118 | //       let min = Tree.min_height!(tree)
119 | //       let max = Tree.height!(tree)
120 | //       Nat.eql(min, max) == true
121 | //   }!
122 | 
123 | size_height<A: Type>(
124 |   t: Tree<A>
125 | ): Nat.lte(Tree.size!(t), Nat.pow(2, Tree.height!(t))) == true
126 |   case t {
127 |     nil: refl
128 |     node:
129 |       case (Nat.lte(Tree.height!(t.left),Tree.height!(t.right))){
130 |         true:
131 | 	  let size = Tree.size!(t.left) + Tree.size!(t.right)
132 | 	  ?true
133 | 
134 | 	false: ?cu2
135 |       }!
136 |   }!
137 | 
138 | 
139 | 
140 | 
141 | 
142 | 


--------------------------------------------------------------------------------
/src/seq.hvm:
--------------------------------------------------------------------------------
  1 | // == Sequences in HVM ==
  2 | 
  3 | // Finger Trees are a very cool and interesting structure
  4 | // because they provide fast access on both ends;
  5 | // and these sequences are a specialization of Finger Trees
  6 | // specifically when you use the monoid of Natural numbers with sum.
  7 | 
  8 | // Sequences provide the following operations in O(1) amortized:
  9 | // - head
 10 | // - tail
 11 | // - last
 12 | // - init
 13 | // - push_front
 14 | // - push_back
 15 | // and some others like length and view.
 16 | // besides those, concatenation takes O(log(# of elements of smaller tree))
 17 | // and spliting a tree by some predicate (monoids!) is also efficient,
 18 | // taking O(log(n)). still, dont trust my implementation of concat, as
 19 | // i dont think it is very efficient (specially reduces)
 20 | 
 21 | // since trees specialize measures to size, this means
 22 | // we can access the nth element of the structure in relatively cheap time
 23 | 
 24 | // this still has a lot of bugs and dumb code. and it has zero type notation,
 25 | // as i still dont know exactly how kind 2 wants me to do it
 26 | 
 27 | 
 28 | (Range 0 xs) = xs
 29 | (Range n xs) =
 30 |   let m = (- n 1)
 31 |   (Range m (Cons m xs))
 32 | 
 33 | (Pair.get (Pair x y) fn) = (fn x y)
 34 | (Split.get (Split l x r) fn) = (fn l x r)
 35 | (View.get (View (Cons elem tail)) fn) = (fn elem tail)
 36 | // of course i will completely ignore the cases where View returns Nil (empty tree)
 37 | // and there is absolutely nothing that could go wrong here /s
 38 | 
 39 | (Foldr f Nil z)         = z
 40 | (Foldr f (Cons x xs) z) = (f x (Foldr f xs z))
 41 | 
 42 | (Foldl f Nil z)         = z
 43 | (Foldl f (Cons x xs) z) = (Foldl f xs (f z x))
 44 | 
 45 | (Reducer f Nil z) = z
 46 | (Reducer f (Cons x xs) z) = (Foldr f (Cons x xs) z)
 47 | 
 48 | (Reducel f Nil z) = z
 49 | (Reducel f (Cons x xs) z) = (Foldl f (Cons x xs) z)
 50 | 
 51 | // TODO: linearize reduce (remove f's duplication (monads!))
 52 | (Reducer f (One a) z) = (f z a)
 53 | (Reducer f (Two a b) z) = (f (f z b) a)
 54 | (Reducer f (Three a b c) z) = (f (f (f z c) b) a)
 55 | (Reducer f (Four a b c d) z) = (f (f (f (f z d) c) b) a)
 56 | 
 57 | (Reducer f (Node2 _ a b)   z) = (f (f z b) a)
 58 | (Reducer f (Node3 _ a b c) z) = (f (f (f z c) b) a)
 59 | 
 60 | (Reducer f Empty          z) = z
 61 | (Reducer f (Single  x)    z) = (f z x)
 62 | (Reducer f (Deep _ pr m sf) z) =
 63 |   let right  = (Reducer f sf z)
 64 |   let middle = (Reducer λsλe(Reducer f e s) m right)
 65 |   (Reducer f pr middle)
 66 |   
 67 | (Reducer f Nil z) = z
 68 | (Reducer f (Cons x xs) z) = (Foldr f (Cons x xs) z)
 69 | 
 70 | (Reducel f Empty          z) = z
 71 | (Reducel f (Single x)     z) = (f x z)
 72 | (Reducel f (Deep _ pr m sf) z) =
 73 |   let left  = (Reducel f pr z)
 74 |   let middle = (Reducel λsλe(Reducel f e s) m left)
 75 |   (Reducel f sf middle)
 76 | 
 77 | (Reducel f (Node2 _ a b)    z) = (f (f z a) b)
 78 | (Reducel f (Node3 _ a b c)  z) = (f (f (f z a) b) c)
 79 | 
 80 | (Reducel f (One a) z) = (f z a)
 81 | (Reducel f (Two a b) z) = (f (f z a) b)
 82 | (Reducel f (Three a b c) z) = (f (f (f z a) b) c)
 83 | (Reducel f (Four a b c d) z) = (f (f (f (f z a) b) c) d)
 84 | 
 85 | 
 86 | // function that returns a special kind of cons list
 87 | // of the type (Cons V (FingerTree V)), that is:
 88 | // it uses the same Nil and Cons constructors (maybe i should give them new names)
 89 | // but the tails are always well-formed Finger trees
 90 | // This is very useful for element deletion in a persistent way
 91 | (FTree.viewl Empty) = (View Nil)
 92 | (FTree.viewl (Single x)) = (View (Cons x Empty))
 93 | (FTree.viewl (Deep c pr m sf)) = (View (Cons (FTree.digit.head pr) (FTree.deepl (FTree.digit.tail pr) m sf)))
 94 | 
 95 | // same function but for right side
 96 | (FTree.viewr Empty) = (View Nil)
 97 | (FTree.viewr (Single x)) = (View (Cons x Empty))
 98 | (FTree.viewr (Deep c pr m sf)) = (View (Cons (FTree.digit.last sf) (FTree.deepr pr m (FTree.digit.but_last sf))))
 99 | 
100 | // helper function to keep the middle recursive tree behaved
101 | (FTree.deepl Nothing   m sf) =
102 |   let m_view = (FTree.viewl m)
103 |   (FTree.deepl.1 m_view sf)
104 | 
105 | (FTree.deepl.1 (View Nil) sf) = (FTree.digit.to_tree sf)
106 | (FTree.deepl.1 (View (Cons a new_m)) sf) = (Deep.go (FTree.node.to_digit a) new_m sf)
107 | 
108 | (FTree.deepl pr m sf) = (Deep.go pr m sf)
109 | 
110 | (FTree.deepr pr m Nothing) =
111 |   let m_view = (FTree.viewr m)
112 |   (FTree.deepr.1 pr m_view)
113 | 
114 | (FTree.deepr.1 pr (View Nil)) = (FTree.digit.to_tree pr)
115 | (FTree.deepr.1 pr (View (Cons a new_m))) = (Deep.go pr new_m (FTree.node.to_digit a))
116 |   
117 | (FTree.deepr pr m sf) = (Deep.go pr m sf)
118 | 
119 | // insert an element at the left-most position of a tree
120 | (FTree.push_left Empty a) = (Single a)
121 | (FTree.push_left (Single b) a) = (Deep.go (One a) Empty (One b))
122 | (FTree.push_left (Deep _ pr m sf) a) = (FTree.push_left.1 pr m sf a)
123 | 
124 | (FTree.push_left.1 (Four b c d e) m sf a) =
125 |   (Deep.go (Two a b) (FTree.push_left m (Node3.go c d e)) sf)
126 | 
127 | (FTree.push_left.1 pr m sf a) =
128 |   (Deep.go (FTree.digit.snoc a pr) m sf)
129 |   
130 | // insert an element at the right-most position of a tree
131 | (FTree.push_right Empty a) = (Single a)
132 | (FTree.push_right (Single b) a) = (Deep.go (One b) Empty (One a))
133 | (FTree.push_right (Deep _ pr m (Four e d c b)) a) =
134 |   (Deep.go pr (FTree.push_right m (Node3.go e d c)) (Two b a))
135 | (FTree.push_right (Deep _ pr m sf) a) =
136 |   (Deep.go pr m (FTree.digit.cons a sf))
137 | 
138 | // some helper functions for digits
139 | // you can think of them as fixed sized lists, ranging from 1 to 4 elements in size
140 | 
141 | (FTree.digit.cons a Nothing) = (One a)
142 | (FTree.digit.cons a (One b)) = (Two b a)
143 | (FTree.digit.cons a (Two b c)) = (Three b c a)
144 | (FTree.digit.cons a (Three b c d)) = (Four b c d a)
145 | 
146 | (FTree.digit.snoc a Nothing) = (One a)
147 | (FTree.digit.snoc a (One b)) = (Two a b)
148 | (FTree.digit.snoc a (Two b c)) = (Three a b c)
149 | (FTree.digit.snoc a (Three b c d)) = (Four a b c d)
150 | 
151 | (FTree.digit.head (One a))        = a
152 | (FTree.digit.head (Two a _))      = a
153 | (FTree.digit.head (Three a _ _))  = a
154 | (FTree.digit.head (Four a _ _ _)) = a
155 | 
156 | (FTree.digit.tail (One _))        = Nothing
157 | (FTree.digit.tail (Two _ b))      = (One b)
158 | (FTree.digit.tail (Three _ b c))  = (Two b c)
159 | (FTree.digit.tail (Four _ b c d)) = (Three b c d)
160 | 
161 | // i think this is called init?
162 | // i've seen something like this somewhere
163 | (FTree.digit.but_last (One _))    = Nothing
164 | (FTree.digit.but_last (Two a _))  = (One a)
165 | (FTree.digit.but_last (Three a b _)) = (Two a b)
166 | (FTree.digit.but_last (Four a b c _)) = (Three a b c)
167 | 
168 | (FTree.digit.last (One a))        = a
169 | (FTree.digit.last (Two _ a))      = a
170 | (FTree.digit.last (Three _ _ a))  = a
171 | (FTree.digit.last (Four _ _ _ a)) = a
172 | 
173 | // converts a digit to a tree (useful in FTree.deep)
174 | (FTree.digit.to_tree Nothing) = Empty
175 | (FTree.digit.to_tree (One a)) = (Single a)
176 | (FTree.digit.to_tree (Two a b)) = (Deep.go (One a) Empty (One b))
177 | (FTree.digit.to_tree (Three a b c)) = (Deep.go (One a) Empty (Two b c))
178 | (FTree.digit.to_tree (Four a b c d)) = (Deep.go (One a) Empty (Three b c d))
179 | 
180 | (FTree.node.to_digit (Node2 _ a b)) = (Two a b)
181 | (FTree.node.to_digit (Node3 _ a b c)) = (Three a b c)
182 | 
183 | // just helper easy functions
184 | (FTree.headl tree) = (View.get (FTree.viewl tree) λelemλtail (elem))
185 | (FTree.headr tree) = (View.get (FTree.viewr tree) λelemλtail (elem))
186 | (FTree.taill tree) = (View.get (FTree.viewl tree) λelemλtail (tail))
187 | (FTree.tailr tree) = (View.get (FTree.viewr tree) λelemλtail (tail))
188 | 
189 | // this mess is all the functions used in FTree.split
190 | // and FTree.split.tree
191 | 
192 | // FTree.split receives a tree and a predicate function
193 | // and splits the tree when the predicate turns from false to true
194 | 
195 | // FTree.split.tree is the main function, and returns a 3-uple (Split left x right)
196 | // where x is the first element that the predicate turns true, and left and right are
197 | // well-formed finger trees
198 | (FTree.split.digit pred i (One a)) = (Split Nothing a Nothing)
199 | (FTree.split.digit pred i (Two a b)) =
200 |   (Pair.get (Measure a) λa_measureλa_cache
201 |   (FTree.split.digit.1 (pred (+ i a_measure)) pred (+i a_measure) a_cache (One b)))
202 | 
203 | (FTree.split.digit pred i (Three a b c)) =
204 |   (Pair.get (Measure a) λa_measureλa_cache
205 |   (FTree.split.digit.1 (pred (+ i a_measure)) pred (+i a_measure) a_cache (Two b c)))
206 | 
207 | (FTree.split.digit pred i (Four a b c d)) =
208 |   (Pair.get (Measure a) λa_measureλa_cache
209 |   (FTree.split.digit.1 (pred (+ i a_measure)) pred (+i a_measure) a_cache (Three b c d)))
210 | 
211 | (FTree.split.digit.1 1 pred i a tail) = (Split Nothing a tail)
212 | (FTree.split.digit.1 0 pred i a tail) =
213 |   (Split.get (FTree.split.digit pred i tail) λlλxλr
214 |   (Split (FTree.digit.snoc a l) x r))
215 | 
216 | 
217 | (FTree.split pred Empty) = (Pair Empty Empty)
218 | (FTree.split pred xs) =
219 |   (Pair.get (Measure xs) λxs_measureλxs_cache
220 |   (FTree.split.1 pred (pred xs_measure) xs_cache))
221 | 
222 | (FTree.split.1 pred 1 xs) = (Split.go (FTree.split.tree pred 0 xs))
223 | (FTree.split.1 pred 0 xs) = (Pair xs Empty)
224 | 
225 | (Split.go (Split l x r)) = (Pair l (FTree.push_left r x))
226 | 
227 | 
228 | 
229 | (FTree.split.tree pred i (Single x)) = (Split Empty x Empty)
230 | (FTree.split.tree pred i (Deep c pr m sf)) =
231 |   (Pair.get (Measure pr) λpr_measureλpr_cache
232 |   (FTree.split.tree.1 (pred (+ i pr_measure)) pred (+ i pr_measure) (Deep c pr_cache m sf)))
233 | 
234 | (FTree.split.tree.1 1 pred i (Deep c pr m sf)) =
235 |   (Split.get (FTree.split.digit pred i pr) λlλxλr
236 |   (Split (FTree.digit.to_tree l) x (FTree.deepl r m sf)))
237 | 
238 | (FTree.split.tree.1 0 pred i (Deep c pr m sf)) =
239 |   (Pair.get (Measure m) λm_measureλm_cache
240 |   (FTree.split.tree.2 (pred (+ i m_measure)) pred i (+ i m_measure) (Deep c pr m_cache sf)))
241 |   
242 | (FTree.split.tree.2 1 pred vpr vm (Deep c pr m sf)) =
243 |   (Split.get (FTree.split.tree pred vpr m) λmlλxsλmr
244 |   (Pair.get  (Measure ml)                  λml_measureλml_cache
245 |   (Split.get (FTree.split.digit pred (+ vpr ml_measure) (FTree.node.to_digit xs)) λlλxλr
246 |   (Split (FTree.deepr pr ml_cache l) x (FTree.deepl r mr sf)))))
247 | 
248 | (FTree.split.tree.2 0 pred vpr vm (Deep c pr m sf)) =
249 |   (Split.get (FTree.split.digit pred vm sf) λlλxλr
250 |   (Split (FTree.deepr pr m l) x (FTree.digit.to_tree r)))
251 | 
252 | // TODO: figure a way that is not completely stupid of implementing concat :D
253 | 
254 | // (FTree.app3 Empty ds xs) = (Reducer λtreeλelem(FTree.push_left  tree elem) ds xs)
255 | // (FTree.app3 xs ds Empty) = (Reducel λtreeλelem(FTree.push_right tree elem) ds xs)
256 | 
257 | // (FTree.app3 (Single x) ds xs) = (FTree.push_left (Reducer λtreeλelem(FTree.push_left tree elem) xs ds) x)
258 | // (FTree.app3 xs ds (Single x)) = (FTree.push_left (Reducer λtreeλelem(FTree.push_left tree elem) xs ds) x)
259 | 
260 | // (FTree.app3 (Deep c1 pr1 m1 sf1) ds (Deep c2 pr2 m2 sf2)) =
261 | //   let nodes   = (FTree.nodes (FTree.digit.concat (FTree.digit.concat sf1 ds) pr2))
262 | //   let new_mid = (FTree.app3 m1 nodes m2)
263 | //   (Deep.go pr1 new_mid sf2)
264 | 
265 | // (FTree.nodes (Cons a (Cons b Nil))) = (Node2 a b)
266 | // (FTree.nodes (Cons a (Cons b (Cons c tail)))) = (FTree.nodes.1 a b c tail)
267 | 
268 | // (FTree.nodes.1 a b c Nil) = (Node3 a b c)
269 | // (FTree.nodes.1 a b c (Cons d Nil)) = (Cons (Node2 a b) (Cons (Node2 c d) Nil))
270 | // (FTree.nodes.1 a b c tail) = (Cons (Node3 a b c) (FTree.nodes tail))
271 | 
272 | // functions that measure the finger trees
273 | // all of these have been specialized to Sequences (specifically, the binary
274 | // operation has been substituted by + and the identity element is 0).
275 | (Node2.go a b) = 
276 |   (Pair.get (Measure a) λa_measureλa_cache
277 |   (Pair.get (Measure b) λb_measureλb_cache
278 |   (Node2 (+ a_measure b_measure) a_cache b_cache)))
279 |   
280 | (Node3.go a b c) =
281 |   (Pair.get (Measure a) λa_measureλa_cache
282 |   (Pair.get (Measure b) λb_measureλb_cache
283 |   (Pair.get (Measure c) λc_measureλc_cache
284 |   (Node3 (+ (+ a_measure b_measure) c_measure) a_cache b_cache c_cache))))
285 | 
286 | (Deep.go pr m sf) =
287 |   (Pair.get (Measure pr) λpr_measureλpr_cache
288 |   (Pair.get (Measure  m) λm_measure λm_cache
289 |   (Pair.get (Measure sf) λsf_measureλsf_cache
290 |   (Deep (+ (+ pr_measure m_measure) sf_measure) pr_cache m_cache sf_cache))))
291 | 
292 | (Measure (Node2 v a b))    = (Pair v (Node2 v a b))
293 | (Measure (Node3 v a b c))  = (Pair v (Node3 v a b c))
294 | (Measure (Deep v pr m sf)) = (Pair v (Deep v pr m sf))
295 | (Measure Empty)            = (Pair 0 Empty)
296 | (Measure (Single x)) =
297 |   (Pair.get (Measure x) λx_measureλx_cache
298 |   (Pair x_measure (Single x_cache)))
299 | 
300 | (Measure (One a)) =
301 |   (Pair.get (Measure a) λa_measureλa_cache
302 |   (Pair a_measure (One a_cache)))
303 | 
304 | (Measure (Two a b)) =
305 |   (Pair.get (Measure a) λa_measureλa_cache
306 |   (Pair.get (Measure b) λb_measureλb_cache
307 |   (Pair (+ a_measure b_measure) (Two a_cache b_cache))))
308 | 
309 | (Measure (Three a b c)) =
310 |   (Pair.get (Measure a) λa_measureλa_cache
311 |   (Pair.get (Measure b) λb_measureλb_cache
312 |   (Pair.get (Measure c) λc_measureλc_cache
313 |   (Pair (+ a_measure (+ b_measure c_measure)) (Three a_cache b_cache c_cache)))))
314 | 
315 | (Measure (Four a b c d)) =
316 |   (Pair.get (Measure a) λa_measureλa_cache
317 |   (Pair.get (Measure b) λb_measureλb_cache
318 |   (Pair.get (Measure c) λc_measureλc_cache
319 |   (Pair.get (Measure d) λd_measureλd_cache
320 |   (Pair (+ a_measure (+ b_measure (+ c_measure d_measure))) (Four a_cache b_cache c_cache d_cache))))))
321 | 
322 | // if none of the above matches...
323 | (Measure x) = (Pair 1 x)
324 | 
325 | // some small helper functions for sequences
326 | // all of them are implemented in terms of the ones shown above.
327 | (Seq.new) = Empty
328 | 
329 | (Seq.push_front seq x) = (FTree.push_left seq x)
330 | (Seq.push_back  seq x) = (FTree.push_right seq x)
331 | (Seq.to_list     tree) = (Reducer λtailλx(Cons x tail) tree Nil)
332 | 
333 | (Seq.from_list list)   = (Seq.from_list.1 list Empty)
334 | (Seq.from_list.1 Nil tree)         = tree
335 | (Seq.from_list.1 (Cons x xs) tree) = (Seq.from_list.1 xs (FTree.push_right tree x))
336 | 
337 | (Seq.head seq) = (FTree.headl seq)
338 | (Seq.last seq) = (FTree.headr seq)
339 | (Seq.tail seq) = (FTree.taill seq)
340 | (Seq.init seq) = (FTree.tailr seq) // first n-1 elements, like an inversed tail
341 | 
342 | (Seq.length seq) = (Pair.get (Measure seq) λlenλ_ len)
343 | 
344 | (Seq.split_at seq i) = (FTree.split λk(< k i) 0 seq)
345 | (Seq.nth seq n) = (Split.get (FTree.split.tree λk(< n k) 0 seq) λ_λxλ_(x))
346 | (Seq.takeUntil seq predicate) = (Pair.get (FTree.split predicate seq) λfstλsnd (fst))
347 | (Seq.dropUntil seq predicate) = (Pair.get (FTree.split predicate seq) λfstλsnd (snd))
348 | 
349 | (Main n) =
350 |   let inserts = (Range n Nil)
351 |   let seq = (Seq.from_list inserts)
352 |   // transforma a lista [1, 2...n] em uma sequência
353 |   // e depois pega o enésimo elemento
354 |   (Seq.length seq)
355 | 
356 | // branch : quadratic fix
357 | // n         # of rewrites
358 | //       1          15
359 | //      10         192 (x 12.8)
360 | //     100       2 095 (x 10.91)
361 | //   1 000      21 406 (x 10.21)
362 | //  10 000     214 875 (x 10.03)
363 | // 100 000   2 149 850 (x 10.005)
364 | 
365 | // branch : master
366 | // n             # of rewrites
367 | //       1          19         
368 | //      10         270 (x 14.21)
369 | //     100       5 211 (x 19.30)
370 | //   1 000      84 135 (x 16.14)
371 | //  10 000   1 208 638 (x 14.36)
372 | // 100 000  15 386 318 (x 12.73)
373 | 
374 | // after rewrite with pairs (and without fold)
375 | // n               # of rewrites
376 | //       1          10         
377 | //      10         396 (x 39.60)
378 | //     100       5 662 (x 14.57)
379 | //   1 000      60 694 (x 10.71)
380 | //  10 000     613 919 (x 10.11)
381 | // 100 000   6 148 694 (x 10.01)
382 | 
383 | 


--------------------------------------------------------------------------------
/src/structs.hvm:
--------------------------------------------------------------------------------
  1 | // Author: Leonardo Santiago (@o-santi)
  2 | 
  3 | // ===============================
  4 | // The following equations are general functions
  5 | // that are sometimes needed to implement algorithms
  6 | // ================================
  7 | 
  8 | (IfElse 1 then else) = then
  9 | (IfElse 0 then else) = else
 10 | 
 11 | (Not 1) = 0
 12 | (Not 0) = 1
 13 | 
 14 | (<= a b) = (Not (> a b))
 15 | (>= a b) = (Not (< a b))
 16 | 
 17 | 
 18 | (Max a b) = (IfElse (> a b) a b)
 19 | (Min a b) = (IfElse (> a b) b a)
 20 | 
 21 | (Range 0 xs) = xs
 22 | (Range n xs) =
 23 |   let m = (- n 1)
 24 |   (Range m (Cons m xs))
 25 | 
 26 | (Head Nil) = Nil
 27 | (Head (Cons x xs)) = x
 28 | 
 29 | (Tail Nil) = Nil
 30 | (Tail (Cons x xs)) = xs
 31 | 
 32 | (ReverseGo Nil ys) = ys
 33 | (ReverseGo (Cons x xs) ys) = (ReverseGo xs (Cons x ys))
 34 | 
 35 | (Randoms s 0) = (Nil)
 36 | (Randoms s l) = (Cons s (Randoms (% (+ (* s 1664525) 1013904223) 101) (- l 1)))
 37 | 
 38 | (Reverse list) = (ReverseGo list Nil)
 39 | 
 40 | (Append x Nil) = (Cons x Nil)
 41 | (Append x (Cons y ys)) = (Cons y (Append x ys))
 42 | 
 43 | // joins two lists
 44 | 
 45 | (Concat Nil ys)         = ys
 46 | (Concat (Cons x xs) ys) = (Cons x (Concat xs ys)) 
 47 | // (Concat (Cons x xs) ys)  = (Concat.Fold λk(Cons x k) ys xs)
 48 | 
 49 | // (Concat.Fold f z Nil)    = (f z)
 50 | // (Concat.Fold f z (Cons x xs)) = (Concat.Fold λk(f (Cons x k)) z xs)
 51 | 
 52 | (Filter f Nil) = Nil
 53 | (Filter f (Cons x xs)) =
 54 |   (IfElse (f x)
 55 |     (Cons x (Filter f xs))
 56 |     (Filter f xs))
 57 | 
 58 | // list length
 59 | 
 60 | (Length Nil) = 0
 61 | (Length (Cons x xs)) = (+ 1 (Length xs))
 62 | 
 63 | 
 64 | // Map
 65 | 
 66 | (Map f Nil)         = Nil
 67 | (Map f (Cons x xs)) = (Cons (f x) (Map f xs))
 68 | 
 69 | // Fold
 70 | // actually its foldl
 71 | // but for now it wont make any difference
 72 | 
 73 | (Foldl f Nil z)         = z
 74 | (Foldl f (Cons x xs) z) = (Foldl f xs (f z x))
 75 | 
 76 | (Foldr f Nil z)         = z
 77 | (Foldr f (Cons x xs) z) = (f x (Foldr f xs z))
 78 | 
 79 | Sum = λxλy(+ x y)
 80 | 
 81 | Mul = λxλy(* x y)
 82 | 
 83 | // Take
 84 | 
 85 | (Take 0 list) = Nil
 86 | (Take n (Cons x xs)) = (Cons x (Take (- n 1) xs))
 87 | 
 88 | // Drop
 89 | 
 90 | (Drop 0 list) = list
 91 | (Drop n (Cons x xs)) = (Drop (- n 1) xs) 
 92 | 
 93 | // Case
 94 | // this is the best i've thought yet
 95 | // it expects that `match` is a function that receives all it's args
 96 | // in the order given bellow
 97 | 
 98 | (Case (Nil)      fst_match snd_match) = (fst_match)
 99 | (Case (Cons a b) fst_match snd_match) = (snd_match a b)
100 | 
101 | // i dont exactly know how to generalize this without actually
102 | // writing all constructors by hand
103 | 
104 | // idk how to do this?
105 | // iterate through cases?
106 | // try each one?
107 | // how to back track?
108 | 
109 | 
110 | // =============================================================
111 | // List sorting algorithms
112 | // the following algorithms are presented in the book
113 | // Functional Algorithms Verified
114 | // ===========================================================
115 | 
116 | // Insertion sort
117 | 
118 | (Insort x Nil) = (Cons x Nil)
119 | (Insort x (Cons y ys)) =
120 |   (IfElse (< x y)
121 |     (Cons x (Cons y ys))
122 |     (Cons y (Insort x ys)))
123 | 
124 | (ISort Nil) = Nil
125 | (ISort (Cons x xs)) = (Insort x (ISort xs))
126 | 
127 | // Quicksort
128 | // this is very bad
129 | // and i mean very bad
130 | // i still dont quite know why, but i will leave it as is for now
131 | 
132 | (Quicksort Nil) = Nil
133 | (Quicksort (Cons x xs)) =
134 |   let antes = (Quicksort (Filter λy(< y x) xs))
135 |   let depois = (Quicksort (Filter λy(>= y x) xs))
136 |   (Concat antes (Cons x depois))
137 | 
138 | // Topdown Merge sort
139 | 
140 | (Merge xs Nil) = xs
141 | (Merge Nil ys) = ys
142 | (Merge (Cons x xs) (Cons y ys)) =
143 |   (IfElse (<= x y)
144 |    	  (Cons x (Merge xs (Cons y ys)))
145 |           (Cons y (Merge (Cons x xs) ys)))
146 | 
147 | (MSort xs) =
148 |   let n = (Length xs)
149 |   (IfElse (<= n 1)
150 |     xs
151 |     (Merge (MSort (Take (>> n 1) xs))
152 |            (MSort (Drop (>> n 1) xs)))) 
153 | 
154 | // Bottom up Merge Sort
155 | // Like top-down merge but recursively joins sets of lists
156 | // until only one is left
157 | // this version is implemented in Functional Algorithms Verified
158 | 
159 | (Merge_adj Nil) = Nil
160 | (Merge_adj (Cons x Nil)) = (Cons x Nil)
161 | (Merge_adj (Cons xs (Cons ys zs))) = (Cons (Merge xs ys) (Merge_adj zs))
162 | 
163 | (Merge_all Nil) = Nil
164 | (Merge_all (Cons x Nil)) = x
165 | (Merge_all xs)  = (Merge_all (Merge_adj xs))
166 | 
167 | (BotMSort xs) = (Merge_all (Map λx(Cons x Nil) xs))
168 | 
169 | // Natural Merge sort
170 | // like bottom-up but efficient for small length aswell
171 | // it will try to split the list into ascending and descending
172 | // runs of elements
173 | 
174 | (Runs Nil) = Nil
175 | (Runs (Cons x Nil)) = (Cons (Cons x Nil) Nil)
176 | (Runs (Cons a (Cons b xs))) =
177 |   (IfElse (< b a)
178 | 	  (Desc b (Cons a Nil) xs)
179 | 	  (Asc  b λk(Cons a k) xs))  // function that inserts `a` to a new list
180 | // notice that ascending needs to append an item at the end
181 | // and append is O(n) so it would end up making Asc O(n^2)
182 | // to solve that we could use Cons and then reverse at the end
183 | // but what i ended up doing (as the book did)
184 | // is using  encoding for lists, make an "element" be a function that inserts
185 | // an element into a list.
186 | // so [a] -> @k (Cons a k)
187 | // and when we want to force it into a list we simply apply it to Nil
188 | 
189 | (Asc a as Nil) = (Cons (as (Cons a Nil)) Nil) 
190 | (Asc a as (Cons b bs)) =
191 |   (IfElse (>= b a)
192 | 	  (Asc b λk(as (Cons a k)) bs)
193 | 	  (Cons (as (Cons a Nil)) (Runs (Cons b bs))))
194 | 
195 | (Desc a as Nil) = (Cons a as)
196 | (Desc a as (Cons b bs)) =
197 |   (IfElse (< b a)
198 | 	  (Desc b (Cons a as) bs)
199 | 	  (Cons (Cons a as) (Runs (Cons b bs))))
200 | 
201 | (NatMSort list) = (Merge_all (Runs list))
202 | 
203 | 
204 | // Comparison with random n = 1000 
205 | // Bot   =   2 066 614 rewrites
206 | // Top   =   2 170 831 rewrites 
207 | // Nat   =   3 215 566 rewrites (x1.5 ish?)
208 | // QSort =   7 350 273 rewrites (x3.5 ish?) 
209 | // ISort = 227 146 635 rewrites (x100)
210 | 
211 | // Insertion is obviously worse because of O(n^2)
212 | // but i do think quicksort can be better (and i just did it poorly)
213 | // of course, it was not written to use naturally use the parallelization and stuff like that of hvm
214 | 
215 | // =============================
216 | // Queues
217 | // type Queue<T> {
218 | //   F : List
219 | //   R : List
220 | //   S : List
221 | // }
222 | // in functional languages, queues are implemented as
223 | // 2 lists: one for the front F, and one for the tail R (in reverse)
224 | // alongside with the order in which they should be evaluated 
225 | // append is done by Consing to R, and removal
226 | // is done with a little bit of black magic
227 | // it is the first appearance of Amortized analysis in this file.
228 | //
229 | // we should maintain it in such a way that
230 | // F is only Nil when R is also Nil
231 | // if F is Nil and R is not Nil, we must transfer R to F (in reverse)
232 | // and we do this transfering process in Balance
233 | 
234 | (Queue.front (Q Nil        _ _)) = Nil
235 | (Queue.front (Q (Cons x f) _ _)) = x
236 | 
237 | (Queue.push_back  (Q f r s) x)        = (Queue.balance f (Cons x r) s)
238 | (Queue.push_front (Q f r s) x)        = (Q (Cons x f) r (Cons x s))
239 | (Queue.pop_front  (Q Nil _ _))        = Nil
240 | (Queue.pop_front  (Q (Cons x f) r s)) = (Queue.balance f r s) 
241 | (Queue.pop_back   (Q _ Nil _))        = Nil
242 | (Queue.pop_back   (Q f (Cons x r) s)) = (Queue.balance f r s)
243 | 
244 | // in the case that there are more elements in
245 | // R than F, we append R reversed to F and set R to Nil 
246 | (Queue.balance f r (Cons x s))        = (Q f r s)
247 | (Queue.balance f r s) =
248 |   let new_f = (Rotate f r Nil)
249 |   (Q new_f Nil new_f)
250 | 
251 | //initialize an empty Queue
252 | (Queue.empty) = (Q Nil Nil Nil)
253 | 
254 | (Rotate Nil (Cons y _) a) = (Cons y a)
255 | (Rotate (Cons x f) (Cons y r) a) = (Cons x (Rotate f r (Cons y a))) 
256 | 
257 | // ==============================
258 | // Trees
259 | // type Tree<T> {
260 | //   Empty
261 | //   Node(l: Tree<t>,x:T, r:Tree<T>)
262 | // }
263 | //
264 | // bellow are some generic functions
265 | // related to trees
266 | // ==============================
267 | 
268 | (IsEmpty Empty)        = 1
269 | (IsEmpty (Node _ _ _)) = 0
270 | 
271 | (MapTree f Empty) = Empty
272 | (MapTree f (Node l x r)) = (Node (MapTree f l) (f x) (MapTree f r))
273 | 
274 | (Size (Empty)) = 0
275 | (Size (Node l x r)) = (+ 1 (+ (Size l) (Size r)))
276 | 
277 | (Height (Empty)) = 0
278 | (Height (Node l x r)) = (+ 1 (Max (Height l) (Height r)))
279 | 
280 | (MinHeight (Empty)) = 0
281 | (MinHeight (Node l x r)) = (+ 1 (Min (Height l) (Height r)))
282 | 
283 | // |========================|
284 | // BST - Binary search trees
285 | // insertion, membership, deletion
286 | // |========================|
287 | 
288 | // Following the book, i will use a little shortcut to compare 2 elements
289 | // called (Compare a b) that will take the 3 paths for the comparison as argument.
290 | 
291 | (Compare a b less equal bigger) =
292 |   (IfElse (< a b)
293 |     less
294 |     (IfElse (> a b)
295 |       bigger
296 |       equal))
297 | 
298 | // Membership in a BST
299 | (IsIn _ (Empty))      = 0 // False
300 | (IsIn a (Node l x r)) =
301 |   (Compare a x
302 |     (IsIn a l)  // if a < x then check in left branch
303 |     1           // a == x -> True, 'cuz a is equal to an elem in the tree
304 |     (IsIn a r)) // if a > x then check in right branch
305 |     
306 | // Insertion
307 | 
308 | (Insert a (Empty)) = (Single a)
309 | (Insert a (Node l x r)) =
310 |   (Compare a x
311 |     (Node (Insert a l) x r) // if a < x then insert in left
312 |     (Node l x r) // if a == x just insert in place 
313 |     (Node l x (Insert a r))) // if a > x then insert in right
314 | 
315 | // note that this makes so that a tree cannot have multiple equal elements 
316 | 
317 | (Delete a (Empty)) = Empty
318 | (Delete a (Node l x r)) =
319 |   (Compare a x
320 |     (Node (Delete a l) x r)
321 |     (IfElse (IsEmpty r)
322 |       l
323 |       (Join l r)) // join the two branches (excluding a)
324 |     (Node l x (Delete a r)))
325 | 
326 | (Join t (Empty)) = t
327 | (Join (Empty) t) = t
328 | (Join (Node t1 a t2) (Node t3 b t4)) =
329 |   (Join.1 t1 t4 a b (Join t2 t3))
330 |     
331 | (Join.1 t1 t4 a b (Empty)) = (Node t1 a (Node Empty b t4))
332 | (Join.1 t1 t4 a b (Node u2 x u3)) = (Node (Node t1 a u2) x (Node u3 b t4))
333 | 
334 | 
335 | // this is basically a complete implementation of maps
336 | // the problem is that insertion into that map
337 | // does not necessarily preserve balance
338 | // meaning that maybe Height(Tree) > Log(Size(Tree))
339 | // which defeats the purpose of implementing Trees for fast lookup.
340 | 
341 | // now we will see some special trees that preserve balance
342 | 
343 | // |===========================|
344 | // 2-3 Trees
345 | //
346 | // an example of a data type that preserves balance of the tree
347 | // these are of the type
348 | // type Tree23<T> {
349 | //   Empty
350 | //   Node(l: Tree23, a: T, r: Tree23)
351 | //   Node(l: Tree23, a: T, m: Tree23, b: T, r: Tree23)
352 | //  }
353 | // where you can build a node with 3 children.
354 | // |===========================|
355 | 
356 | // we will use the afore-defined function to normal BST's
357 | // forget about type safety and such things like that for a second
358 | (IsIn x (Node l a m b r)) =
359 |   (Compare x a
360 |     (IsIn x l)
361 |     1 // true
362 |     (Compare x b
363 |       (IsIn x m)
364 |       1 // true
365 |       (IsIn x r)))
366 | 
367 | (TreeI (Success  t)) = t
368 | (TreeI (Overflow l a r)) = (Node l a r)
369 | 
370 | (Insert23 x t) = (TreeI (Insert23.Go x t)) 
371 | 
372 | (Insert23.Go x (Empty)) = (Overflow Empty x Empty)
373 | //(Insert23.Go x (Node l a r)) =
374 | //(Compare x a
375 | //      (
376 | 
377 | 
378 | // |==============================|
379 | // Red Black Trees
380 | //
381 | // type RBTree {
382 | //   Empty
383 | //   Red(l, a, r)
384 | //   Black(l, a, r)
385 | // }
386 | // |==============================|
387 | 
388 | (Paint (Black) (Red l a r)) = (Black l a r)
389 | (Paint (Black) (Black l a r)) = (Black l a r)
390 | 
391 | (InsertRB x t) = (Paint Black (InsertRB.Go x t))
392 | 
393 | (InsertRB.Go x (Empty)) = (Red Empty x Empty)
394 | (InsertRB.Go x (Black l a r)) = 
395 |   (Compare x a
396 |     (Balance  (InsertRB.Go x l) a r)
397 |     (Black l a r)
398 |     (Balance l a (InsertRB.Go x r)))
399 | 
400 | (InsertRB.Go x (Red l a r)) = 
401 |   (Compare x a
402 |     (Red (InsertRB.Go x l) a r)
403 |     (Red l a r)
404 |     (Red l a (InsertRB.Go x r)))
405 |  
406 | (Balance (Red (Red t1 a t2) b t3) c t4) = (Red (Black t1 a t2) b (Black t3 c t4))
407 | (Balance t1 a (Red (Red t2 b t3) c t4)) = (Red (Black t1 a t2) b (Black t3 c t4))
408 | (Balance (Red t1 a (Red t2 b t3)) c t4) = (Red (Black t1 a t2) b (Black t3 c t4))
409 | (Balance t1 a (Red t2 b (Red t3 c t4))) = (Red (Black t1 a t2) b (Black t3 c t4))
410 | (Balance t1 a t2)  = (Black t1 a t2)
411 | 
412 | (FoldWith f z Nil) = z
413 | (FoldWith f z (Cons x xs)) = (FoldWith f (f x z) xs)
414 | 
415 | (Height (Red l _ r)) = (+ 1 (Max (Height l) (Height r)))
416 | (Height (Black l _ r)) = (+ 1 (Max (Height l) (Height r)))
417 | 
418 | (IsIn _ (Empty)) = 0 // false
419 | (IsIn x (Red l a r)) =
420 |   (Compare x a
421 |     (IsIn x l)
422 |     1
423 |     (IsIn x r))
424 |     
425 | (IsIn x (Black l a r)) =
426 |   (Compare x a
427 |     (IsIn x l)
428 |     1
429 |     (IsIn x r))
430 | 
431 | // ========================================
432 | // Finger Trees
433 | 
434 | // type FTree<T> {
435 | //   Empty
436 | //   Single(a: T)
437 | //   Deep(Digit<T>(a:T), FTree<T>(Node<T>(a: T)), Digit<T>(a: T))
438 | // }
439 | // type Digit<T> {
440 | //   One(a: T)
441 | //   Two(a: T, a:T)
442 | //   Three(a: T, a:T, a:T)
443 | //   Four(a: T, a:T, a: T)
444 | // }
445 | // basically overpowered 2-3 threes
446 | 
447 | // ==========================================|
448 | 
449 | (Reducer f (One a) z) = (f z a)
450 | (Reducer f (Two a b) z) = (f (f z b) a)
451 | (Reducer f (Three a b c) z) = (f (f (f z c) b) a)
452 | (Reducer f (Four a b c d) z) = (f (f (f (f z d) c) b) a)
453 | 
454 | (Reducer f (Node2 a b)   z) = (f (f z b))
455 | (Reducer f (Node3 a b c) z) = (f (f (f z c) b) a)
456 | 
457 | (Reducer f Empty          z) = z
458 | (Reducer f (Single x)     z) = (f x z)
459 | (Reducer f (Deep pr m sf) z) =
460 |   let right  = (Reducer f sf z)
461 |   let middle = (Reducer λsλe(Reducer f e s) m right)
462 |   (Reducer f pr middle)
463 |   
464 | (Reducer f Nil z) = z
465 | (Reducer f (Cons x xs) z) = (Foldr f (Cons x xs) z)
466 | 
467 | (Reducel f Empty          z) = z
468 | (Reducel f (Single x)     z) = (f x z)
469 | (Reducel f (Deep pr m sf) z) =
470 |   let left  = (Reducel f pr z)
471 |   let middle = (Reducel λsλe(Reducel f e s) m left)
472 |   (Reducel f sf middle)
473 | 
474 | (Reducel f (Node2 a b)    z) = (f (f z a) b)
475 | (Reducel f (Node3 a b c)  z) = (f (f (f z a) b) c)
476 | 
477 | (Reducel f (One a) z) = (f z a)
478 | (Reducel f (Two a b) z) = (f (f z a) b)
479 | (Reducel f (Three a b c) z) = (f (f (f z a) b) c)
480 | (Reducel f (Four a b c d) z) = (f (f (f (f z a) b) c) d)
481 | 
482 | (FTree.push_left Empty a) = (Single a)
483 | (FTree.push_left (Single b) a) = (Deep (One a) Empty (One b))
484 | (FTree.push_left (Deep (Four b c d e) m sf) a) =
485 |   (Deep (Two a b) (FTree.push_left m (Node3 c d e)) sf)
486 | (FTree.push_left (Deep pr m sf) a) =
487 |   (Deep (FTree.digit.snoc a pr) m sf)
488 | 
489 | (FTree.push_right Empty a) = (Single a)
490 | (FTree.push_right (Single b) a) = (Deep (One b) Empty (One a))
491 | (FTree.push_right (Deep pr m (Four e d c b)) a) =
492 |   (Deep pr (FTree.push_right m (Node3 e d c)) (Two b a))
493 | (FTree.push_right (Deep pr m sf) a) =
494 |   (Deep pr m (FTree.digit.cons a sf))
495 | 
496 | (FTree.to_tree list) = (Reducer λelemλstruct(FTree.push_left struct elem) list Empty)  
497 | 
498 | (FTree.digit.snoc a (One b)) = (Two a b)
499 | (FTree.digit.snoc a (Two b c)) = (Three a b c)
500 | (FTree.digit.snoc a (Three b c d)) = (Four a b c d)
501 | 
502 | (FTree.digit.cons a (One b)) = (Two b a)
503 | (FTree.digit.cons a (Two b c)) = (Three b c a)
504 | (FTree.digit.cons a (Three b c d)) = (Four b c d a)
505 | 
506 | 
507 | 
508 | // to make concat work, i need to write the FTree.nodes function
509 | // but it has a lot of cases and i think it is not only very boring but very error-prone
510 | // so im still thinking about how to do this
511 | // (FTree.glue Empty xs right) = (Reducer λsλe(FTree.push_left  e s) right xs)
512 | // (FTree.glue left  xs Empty) = (Reducel λsλe(FTree.push_right e s) left  xs)
513 | // (FTree.glue (Single x) xs right) = (FTree.push_left  (Reducer λsλe(FTree.push_left  e s) xs right) x)
514 | // (FTree.glue left xs (Single x))  = (FTree.push_right (Reducel λsλe(FTree.push_right e s) xs left ) x)
515 | // (FTree.glue (Deep pr_1 m_1 sf_1) ts (Deep pr_2 m_2 sf_2)) =
516 | //   let glue_middle = (FTree.glue m_1 (FTree.nodes (Concat sf_1 (Concat ts pr_2))) m_2)
517 | //   (Deep pr_1 glue_middle sf_2)
518 | 
519 | // (Concat (One a) b) = (FTree.digit.cons a b)
520 | // (Concat (Two a b) c) = (FTree.digit.cons 
521 | 
522 | // (FTree.nodes (One a) b) = (Cons (Node2 a b) Nil)
523 | 
524 | 
525 | (FTree.concat first second) = (FTree.glue first Nil second)
526 | 
527 | 
528 | (Main n) =
529 |   let inserts = (Range n Nil)
530 |   let ftree = (FTree.to_tree inserts)
531 |   (FTree.concat ftree ftree)
532 | 


--------------------------------------------------------------------------------