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
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533

(** #<h1>StronglySpecified Functions in Coq, part 2: the <code>Program</code> Framework</h1>#
This is the second article (initially published on #<span
class="time">January 01, 2017</span>#) of a series of two on how to write
stronglyspecified functions in Coq. You can read the previous part #<a
href="/posts/StronglySpecifiedFunctions">here</a>#. # *)
(** #<div id="generatetoc"></div>#
#<div id="history">site/posts/StronglySpecifiedFunctionsProgram.v</div># *)
(** ** The Theory *)
(** If I had to explain `Program`, I would say `Program` is the heir
of the `refine` tactic. It gives you a convenient way to embed
proofs within functional programs that are supposed to fade away
during code extraction. But what do I mean when I say "embed
proofs" within functional programs? I found two ways to do it. *)
(** *** Invariants *)
(** First, we can define a record with one or more fields of type
[Prop]. By doing so, we can constrain the values of other fields. Put
another way, we can specify invariant for our type. For instance, in
SpecCert, I have defined the memory controller's SMRAMC register
as follows: *)
Record SmramcRegister := {
d_open: bool;
d_lock: bool;
lock_is_close: d_lock = true > d_open = false;
}.
(** So [lock_is_closed] is an invariant I know each instance of
`SmramcRegister` will have to comply with, because every time I
will construct a new instance, I will have to prove
[lock_is_closed] holds true. For instance: *)
Definition lock
(reg: SmramcRegister)
: SmramcRegister.
refine ({ d_open := false; d_lock := true }).
(** Coq leaves us this goal to prove.
<<
reg : SmramcRegister
============================
true = true > false = false
>>
This sound reasonable enough. *)
Proof.
trivial.
Defined.
(** We have witness in my previous article about stronglyspecified
functions that mixing proofs and regular terms may leads to
cumbersome code.
From that perspective, [Program] helps. Indeed, the [lock]
function can also be defined as follows: *)
From Coq Require Import Program.
#[program]
Definition lock'
(reg: SmramcRegister)
: SmramcRegister :=
{ d_open := false
; d_lock := true
}.
(** *** Pre and Post Conditions *)
(** Another way to "embed proofs in a program" is by specifying pre
and postconditions for its component. In Coq, this is done using
sigmatypes. *)
(** On the one hand, a precondition is a proposition a function input
has to satisfy in order for the function to be applied. For
instance, a precondition for [head : forall {a}, list a > a] the
function that returns the first element of a list [l] requires [l]
to contain at least one element. We can write that using a
sigmatype. The type of [head] then becomes [forall {a} (l: list a
 l <> []) : a]
On the other hand, a post condition is a proposition a function
output has to satisfy in order for the function to be correctly
implemented. In this way, `head` should in fact return the first
element of [l] and not something else.
<<Program>> makes writing this specification straightforward. *)
(* begin hide *)
From Coq Require Import List.
Import ListNotations.
(* end hide *)
#[program]
Definition head {a} (l : list a  l <> [])
: { x : a  exists l', x :: l' = l }.
(* begin hide *)
Abort.
(* end hide *)
(** We recall that because `{ l: list a  l <> [] }` is not the same
as [list a], in theory we cannot just compare [l] with [x ::
l'] (we need to use [proj1_sig]). One benefit on <<Program>> is to
deal with it using an implicit coercion.
Note that for the type inference to work as expected, the
unwrapped value (here, [x :: l']) needs to be the left operand of
[=].
Now that [head] have been specified, we have to implement it. *)
#[program]
Definition head {a} (l: list a  l <> [])
: { x : a  exists l', cons x l' = l } :=
match l with
 x :: l' => x
 [] => !
end.
Next Obligation.
exists l'.
reflexivity.
Qed.
(** I want to highlight several things here:
 We return [x] (of type [a]) rather than a gigmatype, then <<Program>> is smart
enough to wrap it. To do so, it tries to prove the post condition and because
it fails, we have to do it ourselves (this is the Obligation we solve after
the function definition.)
 The [[]] case is absurd regarding the precondition, we tell Coq that using
the bang (`!`) symbol.
We can have a look at the extracted code:
<<
(** val head : 'a1 list > 'a1 **)
let head = function
 Nil > assert false (* absurd case *)
 Cons (a, _) > a
>>
The implementation is pretty straightforward, but the pre and
post conditions have faded away. Also, the absurd case is
discarded using an assertion. This means one thing: [head] should
not be used directly from the Ocaml world. "Interface" functions
have to be total. *)
(** ** The Practice *)
From Coq Require Import Lia.
(** I have challenged myself to build a strongly specified library. My goal was to
define a type [vector : nat > Type > Type] such as [vector a n] is a list of
[n] instance of [a]. *)
Inductive vector (a : Type) : nat > Type :=
 vcons {n} : a > vector a n > vector a (S n)
 vnil : vector a O.
Arguments vcons [a n] _ _.
Arguments vnil {a}.
(** I had three functions in mind: [take], [drop] and [extract]. I
learned few lessons. My main takeaway remains: do not use
gigmatypes, <<Program>> and dependenttypes together. From my
point of view, Coq is not yet ready for this. Maybe it is possible
to make those three work together, but I have to admit I did not
find out how. As a consequence, my preconditions are defined as
extra arguments.
To be able to specify the post conditions my three functions and
some others, I first defined [nth] to get the _nth_ element of a
vector.
My first attempt to write [nth] was a failure.
<<
#[program]
Fixpoint nth {a n}
(v : vector a n) (i : nat) {struct v}
: option a :=
match v, i with
 vcons x _, O => Some x
 vcons x r, S i => nth r i
 vnil, _ => None
end.
>>
raises an anomaly. *)
#[program]
Fixpoint nth {a n}
(v : vector a n) (i : nat) {struct v}
: option a :=
match v with
 vcons x r =>
match i with
 O => Some x
 S i => nth r i
end
 vnil => None
end.
(** With [nth], it is possible to give a very precise definition of [take]: *)
#[program]
Fixpoint take {a n}
(v : vector a n) (e : nat  e <= n)
: { v' : vector a e  forall i : nat,
i < e > nth v' i = nth v i } :=
match e with
 S e' => match v with
 vcons x r => vcons x (take r e')
 vnil => !
end
 O => vnil
end.
Next Obligation.
now apply le_S_n.
Defined.
Next Obligation.
induction i.
+ reflexivity.
+ apply e0.
now apply Lt.lt_S_n.
Defined.
Next Obligation.
now apply PeanoNat.Nat.nle_succ_0 in H.
Defined.
Next Obligation.
now apply PeanoNat.Nat.nlt_0_r in H.
Defined.
(** As a side note, I wanted to define the post condition as follows:
[{ v': vector A e  forall (i : nat  i < e), nth v' i = nth v i
}]. However, this made the goals and hypotheses become very hard
to read and to use. Sigmatypes in sigmatypes: not a good
idea.
<<
(** val take : 'a1 vector > nat > 'a1 vector **)
let rec take v = function
 O > Vnil
 S e' >
(match v with
 Vcons (_, x, r) > Vcons (e', x, (take r e'))
 Vnil > assert false (* absurd case *))
>>
Then I could tackle `drop` in a very similar manner: *)
#[program]
Fixpoint drop {a n}
(v : vector a n) (b : nat  b <= n)
: { v': vector a (n  b)  forall i,
i < n  b > nth v' i = nth v (b + i) } :=
match b with
 0 => v
 S n => (match v with
 vcons _ r => (drop r n)
 vnil => !
end)
end.
Next Obligation.
now rewrite < Minus.minus_n_O.
Defined.
Next Obligation.
induction n;
rewrite < eq_rect_eq;
reflexivity.
Defined.
Next Obligation.
now apply le_S_n.
Defined.
Next Obligation.
now apply PeanoNat.Nat.nle_succ_0 in H.
Defined.
(** The proofs are easy to write, and the extracted code is exactly what one might
want it to be:
<<
(** val drop : 'a1 vector > nat > 'a1 vector **)
let rec drop v = function
 O > v
 S n >
(match v with
 Vcons (_, _, r) > drop r n
 Vnil > assert false (* absurd case *))
>>
But <<Program>> really shone when it comes to implementing extract. I just
had to combine [take] and [drop]. *)
#[program]
Definition extract {a n} (v : vector a n)
(e : nat  e <= n) (b : nat  b <= e)
: { v': vector a (e  b)  forall i,
i < (e  b) > nth v' i = nth v (b + i) } :=
take (drop v b) (e  b).
Next Obligation.
transitivity e; auto.
Defined.
Next Obligation.
now apply PeanoNat.Nat.sub_le_mono_r.
Defined.
Next Obligation.
destruct drop; cbn in *.
destruct take; cbn in *.
rewrite e1; auto.
rewrite < e0; auto.
lia.
Defined.
(** The proofs are straightforward because the specifications of [drop] and
[take] are precise enough, and we do not need to have a look at their
implementations. The extracted version of [extract] is as clean as we can
anticipate.
<<
(** val extract : 'a1 vector > nat > nat > 'a1 vector **)
let extract v e b =
take (drop v b) (sub e b)
>> *)
(** I was pretty happy, so I tried some more. Each time, using [nth], I managed
to write a precise post condition and to prove it holds true. For instance,
given [map] to apply a function [f] to each element of a vector [v]: *)
#[program]
Fixpoint map {a b n} (v : vector a n) (f : a > b)
: { v': vector b n  forall i,
nth v' i = option_map f (nth v i) } :=
match v with
 vnil => vnil
 vcons a v => vcons (f a) (map v f)
end.
Next Obligation.
induction i.
+ reflexivity.
+ apply e.
Defined.
(** I also managed to specify and write [append]: *)
Program Fixpoint append {a n m}
(v : vector a n) (u : vector a m)
: { w : vector a (n + m)  forall i,
(i < n > nth w i = nth v i) /\
(n <= i > nth w i = nth u (i  n)) } :=
match v with
 vnil => u
 vcons a v => vcons a (append v u)
end.
Next Obligation.
split.
+ now intro.
+ intros _.
now rewrite PeanoNat.Nat.sub_0_r.
Defined.
Next Obligation.
rename wildcard' into n.
destruct (Compare_dec.lt_dec i (S n)); split.
+ intros _.
destruct i.
++ reflexivity.
++ cbn.
specialize (a1 i).
destruct a1 as [a1 _].
apply a1.
auto with arith.
+ intros false.
lia.
+ now intros.
+ intros ord.
destruct i.
++ lia.
++ cbn.
specialize (a1 i).
destruct a1 as [_ a1].
apply a1.
auto with arith.
Defined.
(** Finally, I tried to implement [map2] that takes a vector of [a], a vector of
[b] (both of the same size) and a function [f : a > b > c] and returns a
vector of [c].
First, we need to provide a precise specification for [map2]. To do that, we
introduce [option_app], a function that Haskellers know all to well as being
part of the <<Applicative>> type class. *)
Definition option_app
{A B: Type}
(opf: option (A > B))
(opx: option A)
: option B :=
match opf, opx with
 Some f, Some x => Some (f x)
 _, _ => None
end.
(** We thereafter use [<$>] as an infix operator for [option_map] and [<*>] as
an infix operator for [option_app]. *)
Infix "<$>" := option_map (at level 50).
Infix "<*>" := option_app (at level 55).
(** Given two vectors [v] and [u] of the same size and a function [f], and given
[w] the result computed by [map2], then we can propose the following
specification for [map2]:
[forall (i : nat), nth w i = f <$> nth v i <*> nth u i]
This reads as follows: the [i]th element of [w] is the result of applying
the [i]th elements of [v] and [u] to [f].
It turns out implementing [map2] with the <<Program>> framework has proven
to be harder than I originally expected. My initial attempt was the
following:
<<
#[program]
Fixpoint map2
{A B C: Type}
{n: nat}
(v: vector A n)
(u: vector B n)
(f: A > B > C)
{struct v}
: { w: vector C n  forall i,
nth w i = f <$> nth v i <*> nth u i } :=
match v, u with
 vcons x rst, vcons x' rst' =>
vcons (f x x') (map2 rst rst' f)
 vnil, vnil => vnil
 _, _ => !
end.
>>
<<
Error: Illegal application:
The term "@eq" of type "forall A : Type, A > A > Prop"
cannot be applied to the terms
"nat" : "Set"
"S wildcard'" : "nat"
"B" : "Type"
The 3rd term has type "Type" which should be
coercible to "nat".
>> *)
#[program]
Fixpoint map2
{A B C: Type}
{n: nat}
(v: vector A n)
(u: vector B n)
(f: A > B > C)
{struct v}
: { w: vector C n  forall i,
nth w i = f <$> nth v i <*> nth u i } := _.
Next Obligation.
dependent induction v; dependent induction u.
+ remember (IHv u f) as u'.
inversion u'.
refine (exist _ (vcons (f a a0) x) _).
intros i.
induction i.
* cbv.
reflexivity.
* simpl.
apply (H i).
+ refine (exist _ vnil _).
cbv.
reflexivity.
Qed.
(** ** Is It Usable? *)
(** This post mostly gives the "happy ends" for each function. I think I tried
to hard for what I got in return and therefore I am convinced <<Program>> is
not ready (at least for a dependent type, I cannot tell for the rest). For
instance, I found at least one bug in Program logic (I still have to report
it). Have a look at the following code: *)
#[program]
Fixpoint map2 {a b c n}
(v : vector a n) (v': vector b n)
(f: a > b > c) {struct v}
: vector c n :=
match v with
 _ => vnil
end.
(** It gives the following error:
<<
Error: Illegal application:
The term "@eq" of type "forall A : Type, A > A > Prop"
cannot be applied to the terms
"nat" : "Set"
"0" : "nat"
"wildcard'" : "vector A n'"
The 3rd term has type "vector A n'" which should be
coercible to "nat".
>> *)
(* begin hide *)
Reset map2.
(* end hide *)
