| A Gentle Introduction to Camelot | ||
|---|---|---|
| Prev | A. Appendix | |
let gen a b = if a = b+1 then []
else a::(gen (a+1) b)
(* Generate list [a..b] *)
let len l = match l with [] -> 0 | h::t -> 1 + len t
let hd l = match l with [] -> 0 | h::_ -> h
let tl l = match l with [] -> [] | _::t -> t
let append l m =
match l with [] -> m
| h::t -> h::(append t m)
let rev' l acc =
match l with [] -> acc
| h::t -> rev' t (h::acc)
let rev l =
match l with [] -> []
| h::t -> append (rev t) [h]
let take l n = match l with [] -> []
| h::t -> if n > 0
then h::(take t (n-1))
else []
let drop l n = match l with [] -> []
| h::t -> if n > 0 then drop t (n-1)
else l
(* Insertion sort *)
let insert n l =
match l with [] -> [n]
| h::t -> if n <= h then n::l
else h::(insert n t)
let sort l =
match l with [] -> []
| h::t -> insert h (sort t)
(* Quick sort (from Paulson) *)
let qsort l =
match l with
| [] -> []
| h::t ->
begin
match t with
| [] -> l
| x::y -> partition h [] [] t
end
and partition a left right l =
match l with [] -> append (qsort left) (a::(qsort right))
| x::xs ->
if x <= a then partition a (x::left) right xs
else partition a left (x::right) xs
(* Merge sort. Again from Paulson *)
let merge lx ly =
match lx with [] -> ly
| x::xs ->
begin
match ly with [] -> lx
| y::ys ->
if x <= y
then x::(merge xs (y::ys))
else y::(merge (x::xs) ys)
end
let mergesort l =
match l with [] -> []
| h::t ->
begin
match t with
[] -> l
| _::_ ->
let k = (len l)/2
in
merge (mergesort (take l k)) (mergesort (drop l k))
end
let member n l =
match l with [] -> false
| h::t -> if n = h then true
else member n t
let listToString' l =
match l with
[] -> ""
| h::t ->
begin
match t with [] -> string_of_int h
| h'::t' -> (string_of_int h)
^ ", "
^ (listToString' t)
end
let listToString l =
"[" ^ (listToString' l) ^ "]"
let stringListToIntList l = match l with
[] -> []
| h::t -> (int_of_string h) :: (stringListToIntList t)
let sq x = x*x
let treble x = x+x+x
let start args =
let l = stringListToIntList args
in let _ = print_string ("List has length "
^ string_of_int(len l)
^"\n")
in let _ = print_string ("Original list: "
^ (listToString l)
^ "\n")
in let _ = print_string ("Reversed list: "
^ (listToString (rev' l []))
^ "\n")
in let _ = print_string ("First 4 elements of list: "
^ (listToString (take l 4))
^ "\n")
in let _ = print_string ("All but first 4 elements of list: "
^ (listToString (drop l 4))
^ "\n")
in let _ = print_string ("Insertion sorted list: "
^ (listToString (sort l))
^ "\n")
in let _ = print_string ("Quick sorted list: "
^ (listToString (qsort l))
^ "\n")
in let _ = print_string ("Merge sorted list: "
^ (listToString (mergesort l))
^ "\n")
in ()
|
type iList = !Nil | Cons of int * iList
let ins a l =
match l with
Nil -> Cons(a,Nil)
| Cons(x,t)@_ ->
if a < x then Cons(a,Cons(x,t))
else Cons(x, ins a t)
let sort l =
match l with
Nil -> Nil
| Cons(a,t)@_ -> ins a (sort t) |
(* Linear in-place heapsort code for database program *)
type iList = !Nil | Cons of int * iList
type iresult = !None | Some of int * iTree
type iTree = !Leaf | Node of int * iTree * iTree
(* Message after copy_strings *)
(* Odd error if you use -n option. item seems to be assigned two
types: Object and Item. This appears to be reolved in DataFlow.sml,
but if we turn this off then we get a Grail error. *)
let string_less v w = string_compare v w <= 0
(* all trees are supposed to be heaps. Leaf is a heap and
t=Node(w,t1,t2) is a heap if w is the largest element of t and
moreover t1, t2 are heaps and 0<=|t1|-|t2|<=1 *)
(* insert a new element into a heap *)
let insert x t =
match t with
Leaf -> Node(x,Leaf,Leaf)
| Node(z,left,right)@_ ->
if x < z
then Node(x, insert z right, left)
else Node(z, insert x right, left)
(* siftdown w t1 t2 assumes that t1, t2 are heaps and that 0 <= |t1|-|t2| <= 1.
It returns a heap consisting of the elements of Node(w,t1,t2) *)
let siftdown w t1 t2 =
match t1 with Leaf -> Node(w,Leaf,Leaf)
| Node(v,t11,t12)@_ ->
begin
match t2 with
Leaf ->
if w < v then
Node(w, Node(v,Leaf,Leaf), Leaf) else
Node(v, Node(w,Leaf,Leaf), Leaf)
| Node(u, t21,t22)@_ ->
if w < u & w < v then
Node(w, Node(v,t11,t12), Node(u,t21,t22))
else if u < w & u < v then
Node(u, Node(v,t11,t12), siftdown w t21 t22)
else Node(v, siftdown w t11 t12, Node(u,t21,t22))
end
(* removes an arbitrary element from t and returns it as well as the
resulting heap *)
let removesome t =
match t with Leaf -> None
| Node(x, left, right)@_ ->
begin
match removesome left with
None -> Some(x, right) (* actually, right=Leaf, here *)
| Some(z, left')@_ -> Some(z, Node(x, right, left'))
end
(* removes the largest element from a heap *)
let removetop t =
match t with
Leaf -> None
| Node(x,left,right)@_ ->
begin
match removesome left with
None -> Some(x, right) (* actually, right=Leaf here *)
| Some(z, left')@_ -> Some(x, siftdown z right left')
end
let make_heap l = match l with Nil -> Leaf
| Cons(h, t)@_ ->
let hp = make_heap t
in insert h hp
let extract h = match removetop h with
None -> Nil
| Some(h,t)@_ -> Cons(h, extract t)
let sort l = extract (make_heap l)
|