Source file batOrd.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166

##V>=5##module Pervasives = Stdlib

type order = Lt | Eq | Gt

type 'a comp = 'a -> 'a -> int
type 'a ord = 'a -> 'a -> order

module type Comp = sig
  type t
  val compare : t comp
end

module type Ord = sig
  type t
  val ord : t ord
end

let ord0 n =
  if n < 0 then Lt
  else if n > 0 then Gt
  else Eq

let ord comp = fun a b -> ord0 (comp a b)

let poly_comp = Pervasives.compare

(* eta-expand to avoid value restriction *)
let poly_ord = fun a b -> ord poly_comp a b

let poly = poly_ord

module Ord (Comp : Comp) : Ord with type t = Comp.t = struct
  type t = Comp.t
  let ord = ord Comp.compare
end

let comp0 = function
  | Lt -> -1
  | Eq -> 0
  | Gt -> 1

let comp ord = fun a b -> comp0 (ord a b)

module Comp (Ord : Ord) : Comp with type t = Ord.t = struct
  type t = Ord.t
  let compare = comp Ord.ord
end

let rev_ord0 = function
  | Lt -> Gt
  | Eq -> Eq
  | Gt -> Lt

let rev_comp0 n =
  if n < 0 then 1
  else if n > 0 then -1
  else 0

let rev_ord ord = fun a b -> rev_ord0 (ord a b)
let rev_comp comp = fun a b -> rev_comp0 (comp a b)

let rev = rev_ord

module RevOrd (Ord : Ord) : Ord with type t = Ord.t = struct
  type t = Ord.t
  let ord = rev Ord.ord
end

module RevComp (Comp : Comp) : Comp with type t = Comp.t = struct
  type t = Comp.t
  let compare = rev_comp Comp.compare
end

module Rev = RevOrd

type 'a eq = 'a -> 'a -> bool

let eq_ord0 = function
  | Eq -> true
  | Lt | Gt -> false

let eq_comp0 = function
  | 0 -> true
  | _ -> false

let eq_ord ord = fun a b -> eq_ord0 (ord a b)
let eq_comp comp = fun a b -> eq_comp0 (comp a b)

let eq = eq_ord

module type Eq = sig
  type t
  val eq : t eq
end

module EqOrd (Ord : Ord) : Eq with type t = Ord.t = struct
  type t = Ord.t
  let eq = eq_ord Ord.ord
end

module EqComp (Comp : Comp) : Eq with type t = Comp.t = struct
  type t = Comp.t
  let eq = eq_comp Comp.compare
end

module Eq = EqOrd

type 'a choice = 'a -> 'a -> 'a

let min_ord ord = fun a b ->
  match ord a b with
  | Lt | Eq -> a
  | Gt -> b

let min_comp comp = fun a b ->
  if comp a b <= 0 then a else b

(*$T max_ord
   max_ord poly_ord 1 2 = 2
*)
(*$T max_comp
  max_comp poly_comp 1 2 = 2
*)
let max_ord ord = min_ord (rev_ord ord)
let max_comp comp = min_comp (rev_comp comp)

let min = min_ord
let max = max_ord

let bin_eq eq1 t1 t1' eq2 t2 t2' =
  eq1 t1 t1' && eq2 t2 t2'

let bin_ord ord1 t1 t1' ord2 t2 t2' =
  match ord1 t1 t1' with
  | Eq -> ord2 t2 t2'
  | (Lt | Gt) as neq -> neq

let bin_comp comp1 t1 t1' comp2 t2 t2' =
  match comp1 t1 t1' with
  | 0 -> comp2 t2 t2'
  | nzero -> nzero

let map_eq f eq = fun a b -> eq (f a) (f b)
let map_comp f comp = fun a b -> comp (f a) (f b)
let map_ord f ord = fun a b -> ord (f a) (f b)

(*$T map_eq
  map_eq List.length Int.equal [3] [7]
  not (map_eq List.length Int.equal [] [8;9])
*)
(*$T map_comp
  map_comp Array.length Int.compare [|5;6;7|] [|1;2;3|] = 0
  map_comp Array.length Int.compare [||] [|8|] < 0
*)
(*$T map_ord
  map_ord List.hd String.ord ["foo"; "bar"] ["foo"] = Eq
  map_ord List.tl (List.ord Int.ord) [1;2;3] [8;2;3] = Eq
  map_ord String.length Int.ord "Foo" "Foobar" = Lt
*)

module Incubator = struct
  let eq_by proj = fun x y -> proj x = proj y
  let comp_by proj = fun x y -> Pervasives.compare (proj x) (proj y)
  let ord_by proj = fun x y -> ord0 (Pervasives.compare (proj x) (proj y))
end