├── .gitignore ├── LICENSE ├── README.md ├── alist.ml ├── apply.ml ├── avl.ml ├── binomial_heap.ml ├── hashtable.ml ├── hlinearmap.ml ├── hlist.ml ├── htreemap.ml ├── leftist_heap.ml ├── lr_parser.ml ├── nat.ml ├── prime.ml └── safe_list.ml /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | # ocamlbuild working directory 12 | _build/ 13 | 14 | # ocamlbuild targets 15 | *.byte 16 | *.native 17 | 18 | # oasis generated files 19 | setup.data 20 | setup.log 21 | 22 | .swp 23 | .swo 24 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This repo contains some interesting GADT code pieces. Most codes are easy, but some are probably quite complicated to you. Few may be even at jaw-dropping level... 2 | 3 | GADT is used in the following way: 4 | 5 | 1. enforcing invariants at compile-time so implementation is correct by guarantee 6 | 7 | 2. more powerful data structure, e.g., heterogeneous list 8 | 9 | 3. maybe more... 10 | -------------------------------------------------------------------------------- /alist.ml: -------------------------------------------------------------------------------- 1 | (** type equality witness *) 2 | module Eq = struct 3 | type (_, _) t = Refl : ('a, 'a) t 4 | end 5 | 6 | module type KV = sig 7 | type 'a key 8 | type 'a value 9 | val equal : 'a key -> 'b key -> ('a, 'b) Eq.t option 10 | end 11 | 12 | module type AList = sig 13 | type 'a key 14 | type 'a value 15 | type t 16 | val empty : t 17 | val add : 'a key -> 'a value -> t -> t 18 | end 19 | 20 | module AssociationList (T : KV) : AList = struct 21 | 22 | include T 23 | 24 | type t = 25 | | Nil : t 26 | | Cons : 'a key * 'a value * t -> t 27 | 28 | let empty = Nil 29 | 30 | let add k v t = Cons (k, v, t) 31 | 32 | let cast : type a b. (a, b) Eq.t -> a value -> b value = fun Eq.Refl x -> x 33 | 34 | let rec find : type a. a key -> t -> a value option = fun k l -> 35 | match l with 36 | | Nil -> None 37 | | Cons (k', v, tl) -> 38 | match T.equal k' k with 39 | | None -> find k tl 40 | | Some eq -> Some (cast eq v) 41 | 42 | end 43 | 44 | -------------------------------------------------------------------------------- /apply.ml: -------------------------------------------------------------------------------- 1 | (* mainly by def, modified to be easier by me *) 2 | type (_, _) args = 3 | | Empty : ('a, 'a) args 4 | | Cons : 'c * ('a, 'b) args -> ('c -> 'a, 'b) args;; 5 | 6 | let l = Cons(false, Cons(1, Cons(2, Empty)));; 7 | 8 | let f x y z = if x then y else z;; 9 | 10 | let rec app : type a b. a -> (a, b) args -> b = 11 | fun f arg -> 12 | match arg with 13 | | Empty -> f 14 | | Cons(x, xs) -> app (f x) xs;; 15 | 16 | let g = app f l 17 | 18 | let h = app f (Cons(false, Empty)) 19 | 20 | let k = app f (Cons(false, Cons(1.2, Empty))) 21 | -------------------------------------------------------------------------------- /avl.ml: -------------------------------------------------------------------------------- 1 | (* AVL tree with invariants enforced by GADT *) 2 | 3 | type compare = LessThan | Equal | GreaterThan 4 | 5 | module RawAVLTree = struct 6 | 7 | type z = Z : z and 'n s = S : 'n -> 'n s 8 | 9 | (* Depths of branches of a AVL tree node differs at most by 1 *) 10 | type (_, _, _) diff = 11 | | Less : ('a, 'a s, 'a s) diff 12 | | Same : ('a, 'a, 'a) diff 13 | | More : ('a s, 'a, 'a s) diff 14 | 15 | (* each tree node has a diff that records left and right trees height 16 | difference *) 17 | type ('a, 'd) atree = 18 | | Empty : ('a, z) atree 19 | | Tree : ('a, 'm) atree * 'a * ('a, 'n) atree 20 | * ('m, 'n, 'o) diff -> ('a, 'o s) atree 21 | 22 | exception Empty_tree 23 | 24 | (* for insertion *) 25 | type ('a, _) pos_result = 26 | | PSameDepth : ('a, 'd) atree -> ('a, 'd) pos_result 27 | | Deeper : ('a, 'd s) atree -> ('a, 'd) pos_result 28 | 29 | (* for deletion *) 30 | type ('a, _) neg_result = 31 | | NSameDepth : ('a, 'd s) atree -> ('a, 'd s) neg_result 32 | | Shallower : ('a, 'd) atree -> ('a, 'd s) neg_result 33 | 34 | let is_empty : type d. ('a, d) atree -> bool = function 35 | | Empty -> true 36 | | _ -> false 37 | 38 | let rec member : type d. ('a -> 'a -> compare) -> 'a -> ('a, d) atree -> bool = 39 | fun cmp ele t -> 40 | match t with 41 | | Empty -> false 42 | | Tree (l, k, r, _) -> 43 | match cmp ele k with 44 | | LessThan -> member cmp ele l 45 | | Equal -> true 46 | | GreaterThan -> member cmp ele r 47 | 48 | let rec in_order_iter : type d. ('a -> unit) -> ('a, d) atree -> unit = 49 | fun iter t -> 50 | match t with 51 | | Empty -> () 52 | | Tree (l, k, r, _) -> 53 | in_order_iter iter l; 54 | iter k; 55 | in_order_iter iter r 56 | 57 | (* canonical AVL rotation algorithm now in GADT. Implementation 58 | is guaranteed to be correct thanks to GADT *) 59 | let rotate_left : type d. ('a, d) atree -> 'a -> ('a, d s s) atree -> ('a, d s s) pos_result = 60 | fun l v r -> 61 | let Tree (rl, rv, rr, diff) = r in 62 | match diff with 63 | | Less -> PSameDepth (Tree (Tree (l, v, rl, Same), rv, rr, Same)) 64 | | Same -> Deeper (Tree (Tree (l, v, rl, Less), rv, rr, More)) 65 | | More -> begin 66 | let Tree (rll, rlv, rlr, diffl) = rl in 67 | match diffl with 68 | | Less -> PSameDepth (Tree (Tree (l, v, rll, More), rlv, Tree (rlr, rv, rr, Same), Same)) 69 | | Same -> PSameDepth (Tree (Tree (l, v, rll, Same), rlv, Tree (rlr, rv, rr, Same), Same)) 70 | | More -> PSameDepth (Tree (Tree (l, v, rll, Same), rlv, Tree (rlr, rv, rr, Less), Same)) 71 | end 72 | 73 | let rotate_right : type d. ('a, d s s) atree -> 'a -> ('a, d) atree -> ('a, d s s) pos_result = 74 | fun l v r -> 75 | let Tree (ll, lv, lr, diff) = l in 76 | match diff with 77 | | More -> PSameDepth (Tree (ll, lv, (Tree (lr, v, r, Same)), Same)) 78 | | Same -> Deeper (Tree (ll, lv, (Tree (lr, v, r, More)), Less)) 79 | | Less -> begin 80 | let Tree (lrl, lrv, lrr, diffr) = lr in 81 | match diffr with 82 | | Less -> PSameDepth (Tree (Tree (ll, lv, lrl, More), lrv, Tree (lrr, v, r, Same), Same)) 83 | | Same -> PSameDepth (Tree (Tree (ll, lv, lrl, Same), lrv, Tree (lrr, v, r, Same), Same)) 84 | | More -> PSameDepth (Tree (Tree (ll, lv, lrl, Same), lrv, Tree (lrr, v, r, Less), Same)) 85 | end 86 | 87 | let rec insert : type d. ('a -> 'a -> compare) -> 'a -> ('a, d) atree -> ('a, d) pos_result = 88 | fun cmp v t -> 89 | match t with 90 | | Empty -> Deeper (Tree (Empty, v, Empty, Same)) 91 | | Tree (l, tv, r, diff) -> 92 | match cmp v tv with 93 | | LessThan -> begin 94 | match insert cmp v l with 95 | | Deeper t' -> begin 96 | match diff with 97 | | More -> rotate_right t' tv r 98 | | Same -> Deeper (Tree (t', tv, r, More)) 99 | | Less -> PSameDepth (Tree (t', tv, r, Same)) 100 | end 101 | | PSameDepth t' -> PSameDepth (Tree (t', v, r, diff)) 102 | end 103 | | Equal -> PSameDepth t 104 | | GreaterThan -> begin 105 | match insert cmp v r with 106 | | Deeper t' -> begin 107 | match diff with 108 | | Less -> rotate_left l tv t' 109 | | Same -> Deeper (Tree (l, tv, t', Less)) 110 | | More -> PSameDepth (Tree (l, tv, t', Same)) 111 | end 112 | | PSameDepth t' -> PSameDepth (Tree (l, tv, t', diff)) 113 | end 114 | 115 | let rec min_elt : type d. ('a, d) atree -> 'a = function 116 | | Empty -> raise Empty_tree 117 | | Tree (Empty, tv, _, _) -> tv 118 | | Tree (l, _, _, _) -> min_elt l 119 | 120 | let rec remove_min_elt : type d. ('a, d s) atree -> ('a, d s) neg_result = function 121 | | Tree (Empty, _, r, Less) -> Shallower r 122 | | Tree (l, tv, r, Less) -> begin 123 | match l with 124 | | Empty -> raise Empty_tree 125 | (* Weird, it seems that I have to manually write out this constructor! 126 | Try change the constructor below to wildcard and code won't type check *) 127 | | Tree _ -> 128 | let result = remove_min_elt l in 129 | match result with 130 | | NSameDepth t -> NSameDepth (Tree (t, tv, r, Less)) 131 | | Shallower t -> 132 | match rotate_left t tv r with 133 | | PSameDepth t' -> Shallower t' 134 | | Deeper t' -> NSameDepth t' 135 | end 136 | | Tree (l, tv, r, More) -> begin 137 | (* It is guranteed that ``l`` cannot be Empty because we already 138 | specified ``More`` in constructor. 139 | We only need to do one pattern matching below and compiler 140 | is smart enough to tell pattern matching is exhaustive *) 141 | match l with 142 | | Tree _ as l -> 143 | let result = remove_min_elt l in 144 | match result with 145 | | NSameDepth t -> NSameDepth (Tree (t, tv, r, More)) 146 | | Shallower t -> Shallower (Tree (t, tv, r, Same)) 147 | end 148 | | Tree (l, tv, r, Same) -> begin 149 | match l with 150 | | Empty -> raise Empty_tree 151 | | Tree _ as l -> 152 | let result = remove_min_elt l in 153 | match result with 154 | | NSameDepth t -> NSameDepth (Tree (t, tv, r, Same)) 155 | | Shallower t -> NSameDepth (Tree (t, tv, r, Less)) 156 | end 157 | 158 | let merge : type m n o. ('a, m) atree -> ('a, n) atree -> (m, n, o) diff -> ('a, o) pos_result = 159 | fun l r diff -> 160 | match l, r, diff with 161 | | Empty, Empty, Same -> PSameDepth Empty 162 | | Empty, _, Less -> PSameDepth r 163 | | _, Empty, More -> PSameDepth l 164 | | Tree _, Tree _, Same -> begin 165 | let e = min_elt r and result = remove_min_elt r in 166 | match result with 167 | | NSameDepth t -> Deeper (Tree (l, e, t, Same)) 168 | | Shallower t -> Deeper (Tree (l, e, t, More)) 169 | end 170 | | Tree _, Tree _, Less -> begin 171 | let e = min_elt r and result = remove_min_elt r in 172 | match result with 173 | | NSameDepth t -> Deeper (Tree (l, e, t, Less)) 174 | | Shallower t -> PSameDepth (Tree (l, e, t, Same)) 175 | end 176 | | Tree _, Tree _, More -> begin 177 | let e = min_elt r and result = remove_min_elt r in 178 | match result with 179 | | NSameDepth t -> Deeper (Tree (l, e, t, More)) 180 | | Shallower t -> rotate_right l e t 181 | end 182 | 183 | let pos_to_neg : type d. ('a, d) pos_result -> ('a, d s) neg_result = function 184 | | PSameDepth t -> Shallower t 185 | | Deeper t -> NSameDepth t 186 | 187 | let rec remove : type d. ('a -> 'a -> compare) -> 'a -> ('a, d) atree -> ('a, d) neg_result = 188 | fun cmp v t -> 189 | match t with 190 | | Empty -> raise Empty_tree 191 | | Tree (l, tv, r, diff) -> 192 | match cmp v tv with 193 | (* < *) 194 | | LessThan -> begin 195 | match remove cmp v l with 196 | | Shallower t -> begin 197 | match diff with 198 | | Less -> pos_to_neg (rotate_left t tv r) 199 | | Same -> NSameDepth (Tree (t, tv, r, Less)) 200 | | More -> Shallower (Tree (t, tv, r, Same)) 201 | end 202 | | NSameDepth t -> NSameDepth (Tree (t, tv, r, diff)) 203 | end 204 | (* = *) 205 | | Equal -> begin 206 | match merge l r diff with 207 | | PSameDepth t -> Shallower t 208 | | Deeper t -> NSameDepth t 209 | end 210 | (* > *) 211 | | GreaterThan -> begin 212 | match remove cmp v r with 213 | | Shallower t -> begin 214 | match diff with 215 | | Less -> Shallower (Tree (l, tv, t, Same)) 216 | | Same -> NSameDepth (Tree (l, tv, t, More)) 217 | | More -> pos_to_neg (rotate_right l tv t) 218 | end 219 | | NSameDepth t -> NSameDepth (Tree (l, tv, t, diff)) 220 | end 221 | 222 | end 223 | 224 | module type Set = sig 225 | type t 226 | type elem 227 | val empty : t 228 | val is_empty : t -> bool 229 | val member : elem -> t -> bool 230 | val insert : elem -> t -> t 231 | val remove : elem -> t -> t 232 | val iter : (elem -> unit) -> t -> unit 233 | end 234 | 235 | module Set (X : sig type t val compare : t -> t -> compare end) 236 | : Set with type elem := X.t = struct 237 | 238 | type t = T : (X.t, _) RawAVLTree.atree -> t 239 | 240 | type elem = X.t 241 | 242 | let empty = T (RawAVLTree.Empty) 243 | 244 | let is_empty (T t) = RawAVLTree.(is_empty t) 245 | 246 | let member e (T t) = RawAVLTree.(member X.compare e t) 247 | 248 | let insert e (T t) = RawAVLTree.( 249 | match insert X.compare e t with 250 | | PSameDepth t -> T t 251 | | Deeper t -> T t) 252 | 253 | let remove e (T t) = RawAVLTree.( 254 | match remove X.compare e t with 255 | | NSameDepth t -> T t 256 | | Shallower t -> T t) 257 | 258 | let iter f (T t) = RawAVLTree.(in_order_iter f t) 259 | 260 | end 261 | 262 | module IntCompare = struct 263 | type t = int 264 | let compare i j = 265 | match () with 266 | | _ when i < j -> LessThan 267 | | _ when i = j -> Equal 268 | | _ -> GreaterThan 269 | end 270 | 271 | module IntSet = Set(IntCompare) 272 | 273 | let () = 274 | let open IntSet in 275 | let add_list l s = List.fold_left (fun acc e -> insert e acc) s l in 276 | let remove_list l s = List.fold_left (fun acc e -> remove e acc) s l in 277 | let l1 = [1; 2; 3; 4; 5] and l2 = [1; 2; 3] in 278 | let s1 = add_list l1 empty in 279 | assert (member 1 s1); 280 | assert (member 2 s1); 281 | assert (member 3 s1); 282 | assert (member 4 s1); 283 | assert (member 5 s1); 284 | let s2 = remove_list l2 s1 in 285 | assert (not (member 1 s2)); 286 | assert (not (member 2 s2)); 287 | assert (not (member 3 s2)); 288 | assert (member 4 s2); 289 | assert (member 5 s2); 290 | 291 | -------------------------------------------------------------------------------- /binomial_heap.ml: -------------------------------------------------------------------------------- 1 | (* Binomial Heap with invariants enforced by GADT *) 2 | open Nat 3 | 4 | module type OrderedType = 5 | sig 6 | type t 7 | val compare: t -> t -> int 8 | end 9 | 10 | module type HEAP = sig 11 | type elt 12 | type t 13 | 14 | val empty : t 15 | val singleton : elt -> t 16 | val merge : t -> t -> t 17 | val insert : elt -> t -> t 18 | val find_min : t -> elt option 19 | val delete_min : t -> t option 20 | end 21 | 22 | module BinomialHeap (O : OrderedType) : HEAP with type elt = O.t = struct 23 | type elt = O.t 24 | 25 | (* shape enforced binomial tree *) 26 | type 'n tree = Node of elt * 'n tree_vector 27 | and _ tree_vector = 28 | | TNil : z tree_vector 29 | | TCons : 'n tree * 'n tree_vector -> 'n s tree_vector 30 | 31 | (* set of binomial trees *) 32 | type _ tree_opt_vector = 33 | | TONil : z tree_opt_vector 34 | | TOCons : 'n tree option * 'n tree_opt_vector -> 'n s tree_opt_vector 35 | 36 | (* binomial heap *) 37 | type t = T : 'n nat * 'n tree_opt_vector -> t 38 | 39 | let rec tree_opt_vector_of_tree_vector : type n. n tree_vector -> n tree_opt_vector = function 40 | | TNil -> TONil 41 | | TCons (t, tv) -> TOCons (Some t, tree_opt_vector_of_tree_vector tv) 42 | 43 | (* meld two same order trees keeping minimum heap property *) 44 | let merge_tree (Node (e1, ts1) as t1) (Node (e2, ts2) as t2) = 45 | if O.compare e1 e2 < 0 then Node (e1, TCons (t2, ts1)) 46 | else Node (e2, TCons (t1, ts2)) 47 | 48 | let rec merge_tree_opt_vector : type n. n tree_opt_vector -> n tree_opt_vector -> n tree_opt_vector * n tree option = fun tov1 tov2 -> 49 | match tov1, tov2 with 50 | | TONil, TONil -> (TONil, None) 51 | | TOCons (to1, tov1'), TOCons (to2, tov2') -> 52 | let (tov12, to3) = merge_tree_opt_vector tov1' tov2' in 53 | begin match to1, to2, to3 with 54 | | _, None, None -> (TOCons (to1, tov12), None) 55 | | None, _, None -> (TOCons (to2, tov12), None) 56 | | None, None, _ -> (TOCons (to3, tov12), None) 57 | | _, Some t2, Some t3 -> (TOCons (to1, tov12), Some (merge_tree t2 t3)) 58 | | Some t1, _, Some t3 -> (TOCons (to2, tov12), Some (merge_tree t1 t3)) 59 | | Some t1, Some t2, _ -> (TOCons (to3, tov12), Some (merge_tree t1 t2)) 60 | end 61 | 62 | let delete_min_tree_opt_vector_aux1 tov = function 63 | | None -> None 64 | | Some (Node (e, tv)) -> 65 | Some (e, fun () -> 66 | let (tov', to0) = merge_tree_opt_vector tov (tree_opt_vector_of_tree_vector tv) in 67 | TOCons (to0, tov')) 68 | 69 | let delete_min_tree_opt_vector_aux2 to0 = function 70 | | None -> None 71 | | Some (e, tov) -> Some (e, fun () -> TOCons (to0, tov ())) 72 | 73 | (* find minimum element and delete it. lazy evaluation like approach is used for performance. *) 74 | let rec delete_min_tree_opt_vector : type n. n tree_opt_vector -> (elt * (unit -> n tree_opt_vector)) option = function 75 | | TONil -> None 76 | | TOCons (to0, tov) -> 77 | begin match delete_min_tree_opt_vector_aux1 tov to0, delete_min_tree_opt_vector_aux2 to0 (delete_min_tree_opt_vector tov) with 78 | | None, None -> None 79 | | (Some _ as result1), None -> result1 80 | | None, (Some _ as result2) -> result2 81 | | (Some (e1, _) as result1), (Some (e2, _) as result2) -> 82 | if O.compare e1 e2 < 0 then result1 83 | else result2 84 | end 85 | 86 | let rec padding : type n m. n tree_opt_vector -> (n, m) le -> m tree_opt_vector = fun t hle -> 87 | match hle with 88 | | LeEq -> t 89 | | LeS hle' -> TOCons (None, padding t hle') 90 | 91 | let empty = T (Z, TONil) 92 | let singleton e = T (S Z, TOCons (Some (Node (e, TNil)), TONil)) 93 | 94 | let merge (T (n1, tov1)) (T (n2, tov2)) = 95 | match le_total n1 n2 with 96 | | Ok hle -> 97 | begin match merge_tree_opt_vector (padding tov1 hle) tov2 with 98 | | tov', None -> T (n2, tov') 99 | | tov', (Some _ as to0) -> T (S n2, TOCons (to0, tov')) 100 | end 101 | | Error hgt -> 102 | begin match merge_tree_opt_vector tov1 (padding tov2 hgt) with 103 | | tov', None -> T (n1, tov') 104 | | tov', (Some _ as to0) -> T (S n1, TOCons (to0, tov')) 105 | end 106 | 107 | let insert e t = merge (singleton e) t 108 | 109 | let find_min (T (_, tov)) = 110 | match delete_min_tree_opt_vector tov with 111 | | None -> None 112 | | Some (e, _) -> Some e 113 | 114 | let delete_min (T (n, tov)) = 115 | match delete_min_tree_opt_vector tov with 116 | | None -> None 117 | | Some (_, tov') -> 118 | begin match n, tov' () with 119 | | S n', TOCons (None, tov'') -> Some (T (n', tov'')) 120 | | _, tov'' -> Some (T (n, tov'')) 121 | end 122 | end 123 | 124 | (* test codes *) 125 | module Int = struct 126 | type t = int 127 | let compare = compare 128 | end 129 | 130 | module IntBinomialHeap = BinomialHeap (Int) 131 | 132 | let heap = List.fold_right IntBinomialHeap.insert [1; 1; 4; 5; 1; 4; 8; 10] IntBinomialHeap.empty 133 | let rec dump heap = 134 | match IntBinomialHeap.find_min heap with 135 | | None -> () 136 | | Some e -> 137 | Printf.printf "%d\n" e; 138 | begin match IntBinomialHeap.delete_min heap with 139 | | None -> () 140 | | Some heap' -> dump heap' 141 | end 142 | 143 | let () = dump heap 144 | -------------------------------------------------------------------------------- /hashtable.ml: -------------------------------------------------------------------------------- 1 | (** A GADT hash table that allows polymorphic key-value lookup 2 | 3 | Read {{:https://sympa.inria.fr/sympa/arc/caml-list/2013-07/msg00071.html} 4 | Jeremy Yallop's e-mail reply on Caml-list} for more detail 5 | *) 6 | 7 | (** Normal hash table interface *) 8 | module type S = sig 9 | type key 10 | type 'a t 11 | val create : int -> 'a t 12 | val remove : 'a t -> key -> unit 13 | val find : 'a t -> key -> 'a 14 | val iter : (key -> 'a -> unit) -> 'a t -> unit 15 | end 16 | 17 | (** GADT hash table interface *) 18 | module type GS = sig 19 | type 'a key 20 | (** type of hash table *) 21 | type t 22 | type iterator = {f: 'a. 'a key -> 'a -> unit} 23 | val create : int -> t 24 | val add : t -> 'a key -> 'a -> unit 25 | val remove : t -> 'a key -> unit 26 | (** Polymorphic iter function *) 27 | val iter : iterator -> t -> unit 28 | val find : t -> 'a key -> 'a 29 | end 30 | 31 | (** Normal key interface *) 32 | module type HashedType = sig 33 | type t 34 | val equal : t -> t -> bool 35 | val hash : t -> int 36 | end 37 | 38 | (** GADT key interface *) 39 | module type GHashedType = sig 40 | type _ key 41 | val equal : _ key -> _ key -> bool 42 | val hash : _ key -> int 43 | 44 | type pair = Pair : 'a key * 'a -> pair 45 | 46 | (** [unpack k p] retrives value stored in pair [p] using key [k] *) 47 | val unpack : 'a key -> pair -> 'a 48 | end 49 | 50 | module GHashtbl (G : GHashedType) : GS with type 'a key = 'a G.key = struct 51 | include G 52 | 53 | type k = Key : 'a key -> k 54 | 55 | module H = Hashtbl.Make (struct 56 | type t = k 57 | let hash (Key k) = hash k 58 | let equal (Key k1) (Key k2) = equal k1 k2 59 | end) 60 | 61 | (** GADT hash table is a regular hash table with value of type [pair] *) 62 | type t = pair H.t 63 | 64 | let create n = H.create n 65 | 66 | let add tbl k v = H.add tbl (Key k) (Pair (k, v)) 67 | 68 | let remove tbl k = H.remove tbl (Key k) 69 | 70 | let find tbl key = unpack key (H.find tbl (Key key)) 71 | 72 | type iterator = {f: 'a. 'a key -> 'a -> unit} 73 | 74 | let iter iterator tbl = 75 | H.iter (fun _ (Pair (k, v)) -> iterator.f k v) tbl 76 | 77 | end 78 | 79 | module Test = struct 80 | 81 | module KeyType = struct 82 | type _ key = 83 | | Int : int -> int list key 84 | | String : string -> bool key 85 | 86 | let equal : type a b. a key -> b key -> bool = fun k1 k2 -> 87 | match k1, k2 with 88 | | Int x, Int y -> x = y 89 | | String s, String t -> s = t 90 | | _ -> false 91 | 92 | let hash = Hashtbl.hash 93 | 94 | type pair = Pair : 'a key * 'a -> pair 95 | 96 | let rec unpack : type a. a key -> pair -> a = fun k p -> 97 | match k, p with 98 | | Int _, Pair (Int _, v) -> v 99 | | String _, Pair (String _, v) -> v 100 | | _ -> raise Not_found 101 | end 102 | 103 | module HT1 = GHashtbl (KeyType) 104 | 105 | let test1 () = 106 | let ht = HT1.create 10 in 107 | HT1.add ht KeyType.(Int 10) [1]; 108 | HT1.add ht KeyType.(String "a") false; 109 | assert([1] = HT1.find ht KeyType.(Int 10)); 110 | assert(false = HT1.find ht KeyType.(String "a")) 111 | 112 | end 113 | 114 | -------------------------------------------------------------------------------- /hlinearmap.ml: -------------------------------------------------------------------------------- 1 | (* Two implementations of heterogeneous maps, 2 | from discussions between Jeremy and me *) 3 | 4 | module type HMAP = sig 5 | type _ key 6 | type _ value 7 | type t 8 | val fresh_key : unit -> 'a key 9 | val empty : t 10 | val add : t -> 'a key -> 'a value -> t 11 | val find : t -> 'a key -> 'a value option 12 | end 13 | 14 | module Modern : HMAP = struct 15 | 16 | type _ k' = .. 17 | 18 | type (_, _) eql = Refl : ('a, 'a) eql 19 | 20 | type 'a key = { 21 | k : 'a k'; 22 | eq : 'b. 'b k' -> ('a, 'b) eql option 23 | } 24 | 25 | type _ value 26 | 27 | let fresh_key (type a) () = 28 | let module M = struct type _ k' += T : a k' end in 29 | let eq : type b. b k' -> (a, b) eql option = 30 | function M.T -> Some Refl | _ -> None in 31 | {k = M.T; eq} 32 | 33 | type t = Nil | Cons : 'a key * 'a value * t -> t 34 | 35 | let empty = Nil 36 | 37 | let add t k v = Cons (k, v, t) 38 | 39 | let rec find : type a. t -> a key -> a value option = 40 | fun t k -> 41 | match t with 42 | | Nil -> None 43 | | Cons ({k = k'}, v, rest) -> 44 | match k.eq k' with 45 | | Some Refl -> Some v 46 | | None -> find rest k 47 | 48 | end 49 | 50 | (* No GADT or first-class module free involved, but is much 51 | more tricky. You may need to ponder for a while to understand 52 | its mechanism *) 53 | module OldSchool : HMAP = struct 54 | 55 | type s = bool -> unit 56 | 57 | type 'a key = ('a value -> s) * (s -> 'a value option) 58 | and _ value 59 | 60 | (* Consider [inj] as a pair buttons. Pressing "true" button puts value inside 61 | box, and pressing "false" button takes the item in box outside *) 62 | let fresh_key () = 63 | let r = ref None in 64 | let inj x b = r := if b then Some x else None in 65 | let prj f = f true; let res = !r in f false; res in 66 | (inj, prj) 67 | 68 | type t = s list 69 | 70 | let empty = [] 71 | 72 | let add l (inj, _) v = inj v :: l 73 | 74 | let rec find t ((inj, prj) as k) = match t with 75 | [] -> None 76 | | x :: xs -> 77 | match prj x with 78 | Some v -> Some v 79 | | None -> find xs k 80 | end 81 | -------------------------------------------------------------------------------- /hlist.ml: -------------------------------------------------------------------------------- 1 | module HList = struct 2 | type (_, _) hlist = 3 | | Empty : ('a, 'a) hlist 4 | | :: : 'c * ('a, 'b) hlist -> ('c -> 'a, 'b) hlist 5 | 6 | let cons : type a b c. c -> (a, b) hlist -> (c -> a, b) hlist = 7 | fun h tl -> h :: tl 8 | 9 | let hd : type a b c. (c -> a, b) hlist -> c option = function 10 | | Empty -> None 11 | | c :: _ -> Some c 12 | 13 | let tl : type a b c. (c -> a, b) hlist -> (a, b) hlist option = function 14 | | Empty -> None 15 | | _ :: tl -> Some tl 16 | 17 | type iterf = { 18 | iter : 'a. 'a -> unit; 19 | } 20 | 21 | let rec iter : type a b. iterf -> (a, b) hlist -> unit = fun iterf l -> 22 | match l with 23 | | Empty -> () 24 | | c :: tl -> iterf.iter c; iter iterf tl 25 | 26 | let l = '2' :: "str" :: Empty 27 | 28 | let rec append : type a b c d. (a, b) hlist -> (b, d) hlist -> (a, d) hlist = fun l1 l2 -> 29 | match l1 with 30 | | Empty -> l2 31 | | hd :: tl -> hd :: (append tl l2) 32 | end 33 | 34 | -------------------------------------------------------------------------------- /htreemap.ml: -------------------------------------------------------------------------------- 1 | (* Heterogeneous AVL tree, by Jeremy Yallop. 2 | Used in GADT LR automata *) 3 | 4 | type (_, _) ordering = 5 | LT : (_, _ ) ordering 6 | | EQ : ('a, 'a) ordering 7 | | GT : (_, _ ) ordering 8 | 9 | module type OrderedType = 10 | sig 11 | type 'a t 12 | type 'a value 13 | val compare : 'a t -> 'b t -> ('a, 'b) ordering 14 | end 15 | 16 | module type S = 17 | sig 18 | type _ key 19 | type _ value 20 | type t 21 | val empty : t 22 | val mem : _ key -> t -> bool 23 | val add : 'a key -> 'a value -> t -> t 24 | val find : 'a key -> t -> 'a value option 25 | end 26 | 27 | module Make (Ord: OrderedType) 28 | : S with type 'a key = 'a Ord.t 29 | and type 'a value = 'a Ord.value 30 | = 31 | struct 32 | type 'a key = 'a Ord.t 33 | type 'a value = 'a Ord.value 34 | 35 | (* Borrowed and adapted from OCaml's standard library. The OCaml 36 | license (LGPL version 2 with linking exception) applies. *) 37 | type t = 38 | Empty 39 | | Node : t * 'a key * 'a value * t * int -> t 40 | 41 | let empty = Empty 42 | 43 | let height = function 44 | Empty -> 0 45 | | Node(_,_,_,_,h) -> h 46 | 47 | let create : 'a. t -> 'a key -> 'a value -> t -> t = 48 | fun l x d r -> 49 | let hl = height l and hr = height r in 50 | Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) 51 | 52 | let bal : 'a. t -> 'a key -> 'a value -> t -> t = 53 | fun l x d r -> 54 | let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in 55 | let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in 56 | if hl > hr + 2 then begin 57 | match l with 58 | Empty -> invalid_arg "Hmap.bal" 59 | | Node(ll, lv, ld, lr, _) -> 60 | if height ll >= height lr then 61 | create ll lv ld (create lr x d r) 62 | else begin 63 | match lr with 64 | Empty -> invalid_arg "Hmap.bal" 65 | | Node(lrl, lrv, lrd, lrr, _)-> 66 | create (create ll lv ld lrl) lrv lrd (create lrr x d r) 67 | end 68 | end else if hr > hl + 2 then begin 69 | match r with 70 | Empty -> invalid_arg "Hmap.bal" 71 | | Node(rl, rv, rd, rr, _) -> 72 | if height rr >= height rl then 73 | create (create l x d rl) rv rd rr 74 | else begin 75 | match rl with 76 | Empty -> invalid_arg "Hmap.bal" 77 | | Node(rll, rlv, rld, rlr, _) -> 78 | create (create l x d rll) rlv rld (create rlr rv rd rr) 79 | end 80 | end else 81 | Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) 82 | 83 | 84 | let rec add : type a. a key -> a value -> t -> t = 85 | fun x data -> function 86 | Empty -> 87 | Node(Empty, x, data, Empty, 1) 88 | | Node(l, v, d, r, h) -> 89 | match Ord.compare x v with 90 | | EQ -> 91 | Node(l, x, data, r, h) 92 | | LT -> 93 | let ll = add x data l in 94 | bal ll v d r 95 | | GT -> 96 | let rr = add x data r in 97 | bal l v d rr 98 | 99 | let rec mem : type a. a key -> t -> bool = 100 | fun x -> function 101 | Empty -> 102 | false 103 | | Node(l, v, d, r, _) -> 104 | match Ord.compare x v with 105 | EQ -> true 106 | | LT -> mem x l 107 | | GT -> mem x r 108 | 109 | let rec find : type a. a key -> t -> a value option = 110 | fun x -> function 111 | Empty -> 112 | None 113 | | Node(l, v, d, r, _) -> 114 | match Ord.compare x v with 115 | EQ -> Some d 116 | | LT -> find x l 117 | | GT -> find x r 118 | end 119 | 120 | -------------------------------------------------------------------------------- /leftist_heap.ml: -------------------------------------------------------------------------------- 1 | (* Leftist Heap with invariants enforced by GADT *) 2 | open Nat 3 | 4 | module type OrderedType = sig 5 | type t 6 | val compare: t -> t -> int 7 | end 8 | 9 | module type HEAP = sig 10 | type elt 11 | type t 12 | 13 | val empty : t 14 | val merge : t -> t -> t 15 | val insert : elt -> t -> t 16 | val find_min : t -> elt option 17 | val delete_min : t -> t option 18 | end 19 | 20 | module LeftistHeap (O : OrderedType) : HEAP with type elt = O.t = struct 21 | type elt = O.t 22 | 23 | (* shape enforced leftist tree *) 24 | type _ tree = 25 | | Empty : z tree 26 | (* the rank of left child is at least as large as the rank of right sibling *) 27 | | Node : ('r s) nat * ('r, 'l) le * 'l tree * elt * 'r tree -> ('r s) tree 28 | type t = Exists : 'r tree -> t 29 | 30 | let rank : type r. r tree -> r nat = function 31 | | Empty -> Z 32 | | Node (r, _, _, _, _) -> r 33 | 34 | (* swap if the rank of right one is larger than left one *) 35 | let make_node (Exists a) x (Exists b) = 36 | let n = rank a in 37 | let m = rank b in 38 | match le_total n m with 39 | | Ok hle -> Exists (Node (S n, hle, b, x, a)) 40 | | Error hle -> Exists (Node (S m, hle, a, x, b)) 41 | 42 | let empty = Exists Empty 43 | 44 | let rec merge h1 h2 = 45 | match h1, h2 with 46 | | Exists Empty, _ -> h2 47 | | _, Exists Empty -> h1 48 | | Exists (Node (_, _, a1, x, b1)), Exists (Node (_, _, a2, y, b2)) -> 49 | if O.compare x y <= 0 then make_node (Exists a1) x (merge (Exists b1) h2) 50 | else make_node (Exists a2) y (merge h1 (Exists b2)) 51 | 52 | let insert x = merge (Exists (Node (S Z, LeEq, Empty, x, Empty))) 53 | 54 | let find_min = function 55 | | Exists Empty -> None 56 | | Exists (Node (_, _, _, x, _)) -> Some x 57 | 58 | let delete_min = function 59 | | Exists Empty -> None 60 | | Exists (Node (_, _, l, _, r)) -> Some (merge (Exists l) (Exists r)) 61 | end 62 | 63 | (* test codes *) 64 | module Int = struct 65 | type t = int 66 | let compare = compare 67 | end 68 | 69 | module IntLeftistHeap = LeftistHeap (Int) 70 | 71 | let heap = List.fold_right IntLeftistHeap.insert [1; 1; 4; 5; 1; 4; 8; 10] IntLeftistHeap.empty 72 | let rec dump heap = 73 | match IntLeftistHeap.find_min heap with 74 | | None -> () 75 | | Some e -> 76 | Printf.printf "%d\n" e; 77 | begin match IntLeftistHeap.delete_min heap with 78 | | None -> () 79 | | Some heap' -> dump heap' 80 | end 81 | 82 | let () = dump heap 83 | -------------------------------------------------------------------------------- /lr_parser.ml: -------------------------------------------------------------------------------- 1 | (* http://gallium.inria.fr/~fpottier/publis/fpottier-regis-gianas-typed-lr.pdf *) 2 | (* Aho 4.1 *) 3 | 4 | type token = 5 | KPlus | KStar | KLeft | KRight | KEnd | KInt of int | EOF 6 | 7 | let peek = List.hd and rest = List.tl 8 | 9 | module GADT = struct 10 | 11 | type empty = SEmpty 12 | (* stack *) 13 | type 'a cP = SP : 'a * 'a state -> 'a cP (* Plus *) 14 | and 'a cS = SS : 'a * 'a state -> 'a cS (* Star *) 15 | and 'a cL = SL : 'a * 'a state -> 'a cL (* Left *) 16 | and 'a cR = SR : 'a * 'a state -> 'a cR (* Right *) 17 | (* last field is semantic value *) 18 | and 'a cI = SI : 'a * 'a state * int -> 'a cI (* Int *) 19 | and 'a cE = SE : 'a * 'a state * int -> 'a cE (* Expression *) 20 | and 'a cT = ST : 'a * 'a state * int -> 'a cT (* Term *) 21 | and 'a cF = SF : 'a * 'a state * int -> 'a cF (* Factor *) 22 | 23 | (* States in action/goto table *) 24 | and _ state = 25 | | S0 : empty state 26 | | S1 : empty cE state 27 | | S2 : 'a cT state 28 | | S3 : 'a cF state 29 | | S4 : 'a cL state 30 | | S5 : 'a cI state 31 | | S6 : 'a cE cP state 32 | | S7 : 'a cT cS state 33 | | S8 : 'a cL cE state 34 | | S9 : 'a cE cP cT state 35 | | S10 : 'a cT cS cF state 36 | | S11 : 'a cL cE cR state 37 | 38 | 39 | let rec action : type a. a state -> token list -> a -> int = 40 | fun s tl stack -> 41 | match s, (peek tl) with 42 | (* S0 *) 43 | | S0, KInt x -> action S5 (rest tl) (SI (stack, S0, x)) 44 | | S0, KLeft -> action S4 (rest tl) (SL (stack, S0)) 45 | (* S1 *) 46 | | S1, KPlus -> action S6 (rest tl) (SP (stack, S1)) 47 | | S1, EOF -> let SE (stack, s, v) = stack in v 48 | (* S2 *) 49 | | S2, KPlus -> 50 | let ST (stack, s, v) = stack in gotoE s tl (SE (stack, s, v)) 51 | | S2, KStar -> 52 | action S7 (rest tl) (SS (stack, s)) 53 | | S2, KRight -> 54 | let ST (stack, s, v) = stack in gotoE s tl (SE (stack, s, v)) 55 | | S2, EOF -> 56 | let ST (stack, s, v) = stack in gotoE s tl (SE (stack, s, v)) 57 | (* S3 *) 58 | | S3, KPlus -> 59 | let SF (stack, s, v) = stack in gotoT s tl (ST (stack, s, v)) 60 | | S3, KStar -> 61 | let SF (stack, s, v) = stack in gotoT s tl (ST (stack, s, v)) 62 | | S3, KRight -> 63 | let SF (stack, s, v) = stack in gotoT s tl (ST (stack, s, v)) 64 | | S3, EOF -> 65 | let SF (stack, s, v) = stack in gotoT s tl (ST (stack, s, v)) 66 | (* S4 *) 67 | | S4, KInt x -> action S5 (rest tl) (SI (stack, s, x)) 68 | | S4, KLeft -> action S4 (rest tl) (SL (stack, s)) 69 | (* S5 *) 70 | | S5, KPlus -> 71 | let SI (stack, s, v) = stack in 72 | gotoF s tl (SF (stack, s, v)) 73 | | S5, KStar -> 74 | let SI (stack, s, v) = stack in gotoF s tl (SF (stack, s, v)) 75 | | S5, KRight -> 76 | let SI (stack, s, v) = stack in gotoF s tl (SF (stack, s, v)) 77 | | S5, EOF -> 78 | let SI (stack, s, v) = stack in gotoF s tl (SF (stack, s, v)) 79 | (* S6 *) 80 | | S6, KInt x -> action S5 (rest tl) (SI (stack, s, x)) 81 | | S6, KLeft -> action S4 (rest tl) (SL (stack, s)) 82 | (* S7 *) 83 | | S7, KInt x -> action S5 (rest tl) (SI (stack, s, x)) 84 | | S7, KLeft -> action S4 (rest tl) (SL (stack, s)) 85 | (* S8 *) 86 | | S8, KPlus -> action S6 (rest tl) (SP (stack, s)) 87 | | S8, KRight -> action S11 (rest tl) (SR (stack, s)) 88 | (* S9 *) 89 | | S9, KPlus -> 90 | let ST (SP (SE (stack, s, x), _), _, y) = stack in 91 | let stack = SE (stack, s, x + y) in 92 | gotoE s tl stack 93 | | S9, KStar -> action S7 (rest tl) (SS (stack, S9)) 94 | | S9, KRight -> 95 | let ST (SP (SE (stack, s, x), _), _, y) = stack in 96 | let stack = SE (stack, s, x + y) in 97 | gotoE s tl stack 98 | | S9, EOF -> 99 | let ST (SP (SE (stack, s, x), _), _, y) = stack in 100 | let stack = SE (stack, s, x + y) in 101 | gotoE s tl stack 102 | (* S10 *) 103 | | S10, KPlus -> 104 | let SF (SS (ST (stack, s, x), _), _, y) = stack in 105 | let stack = ST (stack, s, x * y) in 106 | gotoT s tl stack 107 | | S10, KStar -> 108 | let SF (SS (ST (stack, s, x), _), _, y) = stack in 109 | let stack = ST (stack, s, x * y) in 110 | gotoT s tl stack 111 | | S10, KRight -> 112 | let SF (SS (ST (stack, s, x), _), _, y) = stack in 113 | let stack = ST (stack, s, x * y) in 114 | gotoT s tl stack 115 | | S10, EOF -> 116 | let SF (SS (ST (stack, s, x), _), _, y) = stack in 117 | let stack = ST (stack, s, x * y) in 118 | gotoT s tl stack 119 | (* S11 *) 120 | | S11, KPlus -> 121 | let SR (SE (SL (stack, s), _, v), _) = stack in 122 | let stack = SF (stack, s, v) in 123 | gotoF s tl stack 124 | | S11, KStar -> 125 | let SR (SE (SL (stack, s), _, v), _) = stack in 126 | let stack = SF (stack, s, v) in 127 | gotoF s tl stack 128 | | S11, KRight -> 129 | let SR (SE (SL (stack, s), _, v), _) = stack in 130 | let stack = SF (stack, s, v) in 131 | gotoF s tl stack 132 | | S11, EOF -> 133 | let SR (SE (SL (stack, s), _, v), _) = stack in 134 | let stack = SF (stack, s, v) in 135 | gotoF s tl stack 136 | | _ -> failwith "Invalid grammar" 137 | 138 | (* switch state *) 139 | and gotoE : type a. a state -> token list -> a cE -> int = fun s tl stack -> 140 | match s with 141 | | S0 -> action S1 tl stack 142 | | S4 -> action S8 tl stack 143 | 144 | and gotoT : type a. a state -> token list -> a cT -> int = fun s tl stack -> 145 | match s with 146 | | S0 -> action S2 tl stack 147 | | S4 -> action S2 tl stack 148 | | S6 -> action S9 tl stack 149 | 150 | and gotoF : type a. a state -> token list -> a cF -> int = fun s tl stack -> 151 | match s with 152 | | S0 -> action S3 tl stack 153 | | S4 -> action S3 tl stack 154 | | S6 -> action S3 tl stack 155 | | S7 -> action S10 tl stack 156 | 157 | let test () = action S0 [KInt 3; KPlus; KInt 2; EOF] SEmpty;; 158 | end 159 | -------------------------------------------------------------------------------- /nat.ml: -------------------------------------------------------------------------------- 1 | (* Arithmetics *) 2 | 3 | type z = unit 4 | type 'n s = 'n option 5 | 6 | type _ nat = 7 | | Z : z nat 8 | | S : 'n nat -> 'n s nat 9 | 10 | (* "('n, 'm) le" means n <= m *) 11 | type (_, _) le = 12 | | LeEq : ('n, 'n) le 13 | | LeS : ('n, 'm) le -> ('n, 'm s) le 14 | 15 | let le_refl = LeEq 16 | 17 | let rec le_trans : type l m n. (l, m) le -> (m, n) le -> (l, n) le = fun hle1 -> function 18 | | LeEq -> hle1 19 | | LeS hle2 -> LeS (le_trans hle1 hle2) 20 | 21 | let rec le_n_s : type n m. (n, m) le -> (n s, m s) le = function 22 | | LeEq -> LeEq 23 | | LeS hle -> LeS (le_n_s hle) 24 | 25 | let rec le_0_n : type n. n nat -> (z, n) le = function 26 | | Z -> LeEq 27 | | S n -> LeS (le_0_n n) 28 | 29 | let rec le_total : type n m. n nat -> m nat -> ((n, m) le, (m, n) le) result = fun n m -> 30 | match n, m with 31 | | Z, _ -> Ok (le_0_n m) 32 | | _, Z -> Error (le_0_n n) 33 | | S n', S m' -> 34 | begin match le_total n' m' with 35 | | Ok hle -> Ok (le_n_s hle) 36 | | Error hge -> Error (le_n_s hge) 37 | end 38 | 39 | -------------------------------------------------------------------------------- /prime.ml: -------------------------------------------------------------------------------- 1 | (* prove a number is prime using GADT. 2 | needs to use OCaml 4.03.0 which has refutation case support 3 | 4 | written by Jeremy Yallop *) 5 | 6 | type z = Z 7 | type _ s = S 8 | 9 | type (_, _, _) add = 10 | | Zz: (z, 'a, 'a) add 11 | | Zr: ('a, 'b, 'c) add -> ('a, 'b s, 'c s) add 12 | 13 | type (_, _, _) mul = 14 | | Mone : (z s, 'a, 'a) mul 15 | | Mn : ('m, 'o, 'n) mul * ('n, 'o, 'p) add -> ('m s, 'o, 'p) mul 16 | 17 | type absurd = {p: 'a. 'a} 18 | 19 | type 'a neg = 'a -> absurd 20 | 21 | (* a number n is composite if there exists two numbers >= 2 and 22 | their production is n *) 23 | type 'a composite = 24 | C : (_ s s, _ s s, 'a) mul -> 'a composite 25 | 26 | type 'a prime = 'a composite neg 27 | 28 | type two = z s s 29 | 30 | let two_is_prime : two prime = function 31 | | C (Mn (Mone, Zr Zr _)) -> . 32 | | C (Mn (Mn _, Zr Zr _)) -> . 33 | | C (Mn (Mn (_, _), Zr Zz)) -> . 34 | | C (Mn (Mn (_, _), Zz)) -> . 35 | 36 | type ('a, 'b, 'c) addable = A of ('a, 'b, 'c) add 37 | type four = z s s s s 38 | let v : (two, two, four) addable neg = function 39 | | A (Zr (Zr _)) -> . 40 | -------------------------------------------------------------------------------- /safe_list.ml: -------------------------------------------------------------------------------- 1 | type ('a,_) t = 2 | | Nil : ('a, unit) t 3 | | Cons : 'a * ('a, 'b) t -> ('a, unit -> 'b) t 4 | 5 | let rec smap: type l. ('a -> 'b) -> ('a, l) t -> ('b, l) t = fun f -> function 6 | | Nil -> Nil 7 | | Cons (h, t) -> Cons (f h, smap f t) 8 | 9 | let rec smap2: type l. ('a -> 'b -> 'c) -> ('a, l) t -> ('b, l) t -> ('c, l) t = 10 | fun f a b -> 11 | match b with 12 | | Nil -> Nil 13 | | Cons (hb,tb) -> 14 | let Cons (ha, ta) = a in Cons (f ha hb , smap2 f ta tb) 15 | --------------------------------------------------------------------------------