Require Import Arith.
Require Import Ascii.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Lists.List.
Require Import Coq.Program.Program.
Require Import Coq.Strings.Byte.
Require Import Coq.Strings.String.
Import ListNotations.
Definition parser (A : Type) : Type := string -> option (A * string).
Definition isLt {A : Type} (p : parser A) : Prop :=
forall s : string,
match p s with
| None => True
| Some (x, s') => length s' < length s
end.
#[program]
Fixpoint some {A : Type} (p1 : parser A) (p1_isLt : isLt p1) (s : string) {measure (length s)} : option (list A * string) :=
match p1 s with
| None => None
| Some (x, s') =>
match some p1 p1_isLt s' with
| None => Some ([x], s')
| Some (xs, s'') => Some (x :: xs, s'')
end
end.
Next Obligation. pose proof (p1_isLt s) as H. rewrite <- Heq_anonymous in H. assumption. Defined.
Lemma some_unfold {A : Type} (p1 : parser A) (p1_isLt : isLt p1) (s : string) :
some p1 p1_isLt s =
match p1 s with
| None => None
| Some (x, s') =>
match some p1 p1_isLt s' with
| None => Some ([x], s')
| Some (xs, s'') => Some (x :: xs, s'')
end
end.
Proof.
unfold some at 1. unfold some_func. rewrite fix_sub_eq.
{ destruct (p s) as [[x s'] | ] eqn: OBS_p_s; simpl.
- rewrite OBS_p_s. destruct (some p p_isLt s') as [[xs s''] | ] eqn: OBS_some_p_s'.
+ unfold some in OBS_some_p_s'. unfold some_func in OBS_some_p_s'.
rewrite OBS_some_p_s'. reflexivity.
+ unfold some in OBS_some_p_s'. unfold some_func in OBS_some_p_s'.
rewrite OBS_some_p_s'. reflexivity.
- rewrite OBS_p_s. reflexivity.
}
{ intros [_A [_p [_p_isLt _s]]] f g f_eq_g; simpl.
admit. (* because `destruct (_p _s).` fails *)
}
Admitted.
How can I prove the lemma some_unfold?
I proved an unfold lemma for other program fixpoint:
unfold the program fixpoint.
rewrite fix_sub_eq.
- destruct the argument which has measure; eauto.
- intros. destruct the argument again; simpl; eauto. rewrite H; eauto.
But this problem is slightly different from the above.
Require Import Coq.Program.Wf.
Lemma some_unfold {A : Type} (p1 : parser A) (p1_isLt : isLt p1) (s : string) :
some p1 p1_isLt s =
match p1 s with
| None => None
| Some (x, s') =>
match some p1 p1_isLt s' with
| None => Some ([x], s')
| Some (xs, s'') => Some (x :: xs, s'')
end
end.
Proof.
unfold some at 1. unfold some_func. rewrite WfExtensionality.fix_sub_eq_ext.
destruct (p s) as [[x s'] | ] eqn: OBS_p_s; simpl.
- rewrite OBS_p_s. destruct (some p p_isLt s') as [[xs s''] | ] eqn: OBS_some_p_s'.
+ unfold some in OBS_some_p_s'. unfold some_func in OBS_some_p_s'.
rewrite OBS_some_p_s'. reflexivity.
+ unfold some in OBS_some_p_s'. unfold some_func in OBS_some_p_s'.
rewrite OBS_some_p_s'. reflexivity.
- rewrite OBS_p_s. reflexivity.
Qed.
Related
I want to prove following lemmas.
Lemma AppendAndSplit {n m}(e:Euc n) (f:Euc m): # (e +++ f) = (e, f).
Proof.
induction e.
reflexivity.
remember (r:::e).
Admitted.
Lemma SplitRule {n m}(e:Euc (n+m)) : (fst (# e)) +++ (snd (# e)) = e.
Proof.
induction n.
reflexivity.
Admitted.
# and +++ are notations of EucAppend and Split_Euc.
I can feel that these hold, but I don't know how prove them.
Please tell me some techniques.
(* There are codes needed below *)
Require Import Coq.Reals.Reals.
Inductive Euc:nat -> Type:=
|RO : Euc 0
|Rn : forall {n:nat}, R -> Euc n -> Euc (S n).
Notation "[ ]" := RO.
Notation "[ r1 , .. , r2 ]" := (Rn r1 .. ( Rn r2 RO ) .. ).
Infix ":::" := Rn (at level 60, right associativity).
Fixpoint EucAppend {n m} (e:Euc n) (f:Euc m) :Euc (n+m):=
match e with
|[] => f
|e' ::: es => e' ::: (EucAppend es f)
end.
Infix "+++" := EucAppend (at level 60, right associativity).
Fixpoint split_Euc {n m : nat} (xi : Euc (n + m)) : Euc n ∧ Euc m.
Proof.
destruct n as [ | n].
- exact (RO, xi).
- inversion_clear xi.
apply split_Euc in H0 as [l r].
exact (Rn H l, r).
Defined.
Notation "# n" := (split_Euc n) (at level 60, right associativity).
The main problem you cannot solve your goals is because of the definitional problem. Split_Euc is defined to perform induction on n, and that's okay however, the definitions perform an inversion on Euc. Inversion is normally a tactic for proofs, once the tactics generate very heavy proofs terms :
Fixpoint split_Euc {n m : nat} (xi : Euc (n + m)) : Euc n * Euc m.
Proof.
destruct n as [ | n].
- exact (RO, xi).
- inversion_clear xi.
Show Proof. (* let see what is actually the problem *)
...
Defined.
You'll see something like that :
eq_rec_r (fun n2 : nat => R -> Euc n2 -> Euc (S n0) * Euc m)
(fun (H6 : R) (H7 : Euc (n0 + m)) =>
?Goal#{n:=n0; H:=H6; H0:=H7}) H5) H3) H1 H H0
Notice your definition uses a proof (induction scheme of equality) term to make the join of the tuple. Proofs terms are not easily normalized and some others don't even get a normalized term (it is the case of Opaque proofs). The solution is to avoid tactics that generate heavy proofs terms and substitute for inductions schemes (like destruct, induction, case...), once they are "free" or almostt of automatic proofs.
Definition rect_euc {n : nat} (v : Euc (S n)) : forall (P : Euc (S n) -> Type) (H : forall ys a, P (a ::: ys)), P v.
refine (
match v with
|#Rn _ _ _ => _
|R0 => _
end).
exact idProp.
intros.
apply : H.
Defined.
Fixpoint split_Euc {n m : nat} (xi : Euc (n + m)) : Euc n * Euc m.
Proof.
destruct n as [ | n].
- exact (RO, xi).
- elim/#rect_euc : xi.
intros.
pose (split_Euc _ _ ys).
exact (Rn a (fst p), (snd p)).
Defined.
Now, as split_euc is defined using induction on n, you should do the same to get a straightforward proof.
Lemma AppendAndSplit {n m}(e:Euc n) (f:Euc m): # (e +++ f) = (e, f).
Proof.
induction n.
- remember 0.
destruct e.
reflexivity.
inversion Heqn.
- apply (rect_euc e).
intros.
assert (forall n (xs ys : Euc n) (x y : R), x = y -> xs = ys -> x ::: xs = y ::: ys).
intros.
rewrite H; rewrite H0; trivial.
pose (IHn ys).
apply : injective_projections.
simpl;apply : H; trivial.
exact (f_equal fst e0).
exact (f_equal snd e0).
Qed.
Lemma SplitRule {n m}(e:Euc (n+m)) : (fst (split_Euc e)) +++ (snd (split_Euc e)) = e.
YOUR_TURN. (* now it's your turn, just do the same and u will get the goal*)
Qed.
I am using index function to find the value of element at any location in the list nat. Plz guide me in proving the second part of the lemma, which is illustrated below
Fixpoint index(n: nat) (m: nat) (l: list nat) : nat :=
match l with
| nil => 0
| cons h tl => match (eqb n m) with
| true => h
| false => index (succ n) m tl
end
end.
Theorem a_ref:forall (a:nat),
a <= a.
Proof.
intros. eauto.
Qed.
Theorem n_leq_0 :forall (n:nat),
n <= 0.
Proof.
intros. induction n.
+ simpl. apply a_ref.
+ Admitted.
Theorem n_le_index:forall (n:nat) (l:list nat),
n <= index (succ (succ 0)) 0 l.
Proof.
intros. induction l as [| l'].
+ simpl. apply n_leq_0.
+ simpl in *. inversion IHl.
rewrite <- H.
The theorem you want cannot be proved:
Fixpoint index(n: nat) (m: nat) (l: list nat) : nat :=
match l with
| nil => 0
| cons h tl => match (Nat.eqb n m) with
| true => h
| false => index (Nat.succ n) m tl
end
end.
Theorem n_le_index:forall (n:nat) (l:list nat),
n <= index (Nat.succ (Nat.succ 0)) 0 l.
Admitted.
Require Import Omega.
Goal False.
pose proof (n_le_index 10 nil).
simpl in H.
omega.
Qed.
Currently, I've started working on proving theorems about first-order logic in Coq(VerifiedMathFoundations). I've proved deduction theorem, but then I got stuck with lemma 1 for theorem of correctness. So I've formulated one elegant piece of the lemma compactly and I invite the community to look at it. That is an incomplete the proof of well-foundness of the terms. How to get rid of the pair of "admit"s properly?
(* PUBLIC DOMAIN *)
Require Export Coq.Vectors.Vector.
Require Export Coq.Lists.List.
Require Import Bool.Bool.
Require Import Logic.FunctionalExtensionality.
Require Import Coq.Program.Wf.
Definition SetVars := nat.
Definition FuncSymb := nat.
Definition PredSymb := nat.
Record FSV := {
fs : FuncSymb;
fsv : nat;
}.
Record PSV := MPSV{
ps : PredSymb;
psv : nat;
}.
Inductive Terms : Type :=
| FVC :> SetVars -> Terms
| FSC (f:FSV) : (Vector.t Terms (fsv f)) -> Terms.
Definition rela : forall (x y:Terms), Prop.
Proof.
fix rela 2.
intros x y.
destruct y as [s|f t].
+ exact False.
+ refine (or _ _).
exact (Vector.In x t).
simple refine (#Vector.fold_left Terms Prop _ False (fsv f) t).
intros Q e.
exact (or Q (rela x e)).
Defined.
Definition snglV {A} (a:A) := Vector.cons A a 0 (Vector.nil A).
Definition wfr : #well_founded Terms rela.
Proof.
clear.
unfold well_founded.
assert (H : forall (n:Terms) (a:Terms), (rela a n) -> Acc rela a).
{ fix iHn 1.
destruct n.
+ simpl. intros a b; destruct b.
+ simpl. intros a Q. destruct Q as [L|R].
* admit. (* smth like apply Acc_intro. intros m Hm. apply (iHn a). exact Hm. *)
* admit. (* like in /Arith/Wf_nat.v *)
}
intros a.
simple refine (H _ _ _).
exact (FSC (Build_FSV 0 1) (snglV a)).
simpl.
apply or_introl.
constructor.
Defined.
It is also available here: pastebin.
Update: At least transitivity is needed for well-foundness. I also started a proof, but didn't finished.
Fixpoint Tra (a b c:Terms) (Hc : rela c b) (Hb : rela b a) {struct a}: rela c a.
Proof.
destruct a.
+ simpl in * |- *.
exact Hb.
+ simpl in * |- *.
destruct Hb.
- apply or_intror.
revert f t H .
fix RECU 1.
intros f t H.
(* ... *)
Admitted.
You can do it by defining a height function on Terms, and showing that decreasing rela implies decreasing heights:
Require Export Coq.Vectors.Vector.
Require Export Coq.Lists.List.
Require Import Bool.Bool.
Require Import Logic.FunctionalExtensionality.
Require Import Coq.Program.Wf.
Definition SetVars := nat.
Definition FuncSymb := nat.
Definition PredSymb := nat.
Record FSV := {
fs : FuncSymb;
fsv : nat;
}.
Record PSV := MPSV{
ps : PredSymb;
psv : nat;
}.
Unset Elimination Schemes.
Inductive Terms : Type :=
| FVC :> SetVars -> Terms
| FSC (f:FSV) : (Vector.t Terms (fsv f)) -> Terms.
Set Elimination Schemes.
Definition Terms_rect (T : Terms -> Type)
(H_FVC : forall sv, T (FVC sv))
(H_FSC : forall f v, (forall n, T (Vector.nth v n)) -> T (FSC f v)) :=
fix loopt (t : Terms) : T t :=
match t with
| FVC sv => H_FVC sv
| FSC f v =>
let fix loopv s (v : Vector.t Terms s) : forall n, T (Vector.nth v n) :=
match v with
| #Vector.nil _ => Fin.case0 _
| #Vector.cons _ t _ v => fun n => Fin.caseS' n (fun n => T (Vector.nth (Vector.cons _ t _ v) n))
(loopt t)
(loopv _ v)
end in
H_FSC f v (loopv _ v)
end.
Definition Terms_ind := Terms_rect.
Fixpoint height (t : Terms) : nat :=
match t with
| FVC _ => 0
| FSC f v => S (Vector.fold_right (fun t acc => Nat.max acc (height t)) v 0)
end.
Definition rela : forall (x y:Terms), Prop.
Proof.
fix rela 2.
intros x y.
destruct y as [s|f t].
+ exact False.
+ refine (or _ _).
exact (Vector.In x t).
simple refine (#Vector.fold_left Terms Prop _ False (fsv f) t).
intros Q e.
exact (or Q (rela x e)).
Defined.
Require Import Lia.
Definition wfr : #well_founded Terms rela.
Proof.
apply (Wf_nat.well_founded_lt_compat _ height).
intros t1 t2. induction t2 as [sv2|f2 v2 IH]; simpl; try easy.
intros [t_v|t_sub]; apply Lt.le_lt_n_Sm.
{ clear IH. induction t_v; simpl; lia. }
revert v2 IH t_sub; generalize (fsv f2); clear f2.
intros k v2 IH t_sub.
enough (H : exists n, rela t1 (Vector.nth v2 n)).
{ destruct H as [n H]. apply IH in H. clear IH t_sub.
transitivity (height (Vector.nth v2 n)); try lia; clear H.
induction v2 as [|t2 m v2 IHv2].
- inversion n.
- apply (Fin.caseS' n); clear n; simpl; try lia.
intros n. specialize (IHv2 n). lia. }
clear IH.
assert (H : Vector.fold_right (fun t Q => Q \/ rela t1 t) v2 False).
{ revert t_sub; generalize False.
induction v2 as [|t2 n v2]; simpl in *; trivial.
intros P H; specialize (IHv2 _ H); clear H.
induction v2 as [|t2' n v2 IHv2']; simpl in *; tauto. }
clear t_sub.
induction v2 as [|t2 k v2 IH]; simpl in *; try easy.
destruct H as [H|H].
- apply IH in H.
destruct H as [n Hn].
now exists (Fin.FS n).
- now exists Fin.F1.
Qed.
(Note the use of the custom induction principle, which is needed because of the nested inductives.)
This style of development, however, is too complicated. Avoiding certain pitfalls would greatly simplify it:
The Coq standard vector library is too hard to use. The issue here is exacerbated because of the nested inductives. It would probably be better to use plain lists and have a separate well-formedness predicate on terms.
Defining a relation such as rela in proof mode makes it harder to read. Consider, for instance, the following simpler alternative:
Fixpoint rela x y :=
match y with
| FVC _ => False
| FSC f v =>
Vector.In x v \/
Vector.fold_right (fun z P => rela x z \/ P) v False
end.
Folding left has a poor reduction behavior, because it forces us to generalize over the accumulator argument to get the induction to go through. This is why in my proof I had to switch to a fold_right.
I want to declare a function that yeilds the element (b, n) that the b is equal to true.
Require Export List.
Import Coq.Lists.List.ListNotations.
Definition lstest := list (bool * nat).
Fixpoint existbool (l : lstest) : option (bool * nat) :=
match l with
| [] => None
| (b, n) :: l' => if b then Some (b, n) else existbool l'
end.
The function always get the first element satisfyting b = true. I want to express that there exists an element satisfyting b = true and returns the element. How can I define such a function?
In the following function the type of existbool_ex tells you that we output a pair contained in the list with its first element true (assuming we output a Some).
(* These are all from the standard library *)
Locate "{ _ : _ | _ }".
Print sig.
Print In.
Print fst.
(* Defining Property here to shorten code for exist *)
Definition P l (x : bool * nat) := fst x = true /\ In x l.
Fixpoint existbool_ex (l : list (bool * nat)) :
option {x : bool * nat | fst x = true /\ In x l} :=
match l return option {x : bool * nat | P l x} with
| [] => None
| x' :: l' =>
match x' with
| (true,n) as ans =>
Some (exist (P (ans :: l')) ans (conj eq_refl (or_introl eq_refl)))
| (false,n) =>
match existbool_ex l' with
| None => None
| Some (exist _ x a) =>
match a with
| conj Heq Hin =>
Some (exist (P ((false, n) :: l')) x (conj Heq (or_intror Hin)))
end
end
end
end.
(* Note the as pattern got desugared into a let binding. *)
Print existbool_ex.
(* However we have a somewhat sane extraction, (tail recursive) *)
Require Extraction.
Extraction existbool_ex.
You could write a function get_number that requires a proof that the list has a true value somewhere.
Definition has_true (l : lstest):= exists n, In (true, n) l.
get_number is defined with the help of refine which lets us leave 'holes' (written _) in the proof term to fill in later. Here we have two holes; one for the absurd case when the list is [], and one where we construct the proof term for the recursive call.
Fixpoint get_number (l:lstest) (H: has_true l) : nat.
refine (
match l as l' return l' = _ -> nat with
| (true, n)::_ => fun L => n
| (false, _)::l' => fun L => get_number l' _
| [] => fun L => _
end eq_refl).
now exfalso; subst l; inversion H.
now subst l; inversion H; inversion H0;
[congruence | eexists; eauto].
Defined.
The function uses the convoy pattern so that the match statement does not forget the shape of l in the different branches.
If you want to, you can prove rewriting lemmas to make it easier to use.
Lemma get_number_false l m H: exists H', get_number ((false, m)::l) H = get_number l H'.
Proof. eexists; reflexivity. Qed.
Lemma get_number_true l m H: get_number ((true, m)::l) H = m.
Proof. reflexivity. Qed.
Lemma get_number_nil H m: get_number [] H <> m.
Proof. now inversion H. Qed.
Lemma get_number_proof_irrel l H1 H2: get_number l H1 = get_number l H2.
Proof. induction l as [ | [[|] ?] l']; eauto; now inversion H1. Qed.
It looks definitely simple task until I actually try to work on it. My method is to use twin pointers to avoid asking the length of the list ahead of time, but the difficulties come from the implication that I know for sure one list is "no emptier" than another. Specifically, in pseudo-coq:
Definition twin_ptr (heads, tail, rem : list nat) :=
match tail, rem with
| _, [] => (rev heads, tail)
| _, [_] => (rev heads, tail)
| t :: tl, _ :: _ :: rm => twin_ptr (t :: heads) tl rm
end.
Definition split (l : list nat) := twin_ptr [] l l
But definitely it's not going to compile because the match cases are incomplete. However, the missing case by construction doesn't exist.
What's your way of implementing it?
I you are not afraid of dependent types, you can add a proof that rem is shorter than tail as an argument of twin_ptr. Using Program to help manage these dependent types, this could give the following.
Require Import List. Import ListNotations.
Require Import Program.
Require Import Arith.
Require Import Omega.
Program Fixpoint twin_ptr
(heads tail rem : list nat)
(H:List.length rem <= List.length tail) :=
match tail, rem with
| a1, [] => (rev heads, tail)
| a2, [a3] => (rev heads, tail)
| t :: tl, _ :: _ :: rm => twin_ptr (t :: heads) tl rm _
| [], _::_::_ => !
end.
Next Obligation.
simpl in H. omega.
Qed.
Next Obligation.
simpl in H. omega.
Qed.
Definition split (l : list nat) := twin_ptr [] l l (le_n _).
The exclamation mark means that a branch is unreachable.
You can then prove lemmas about twin_ptr and deduce the properties of split from them. For example,
Lemma twin_ptr_correct : forall head tail rem H h t,
twin_ptr head tail rem H = (h, t) ->
h ++ t = rev head ++ tail.
Proof.
Admitted.
Lemma split_correct : forall l h t,
split l = (h, t) ->
h ++ t = l.
Proof.
intros. apply twin_ptr_correct in H. assumption.
Qed.
Personally, I dislike to use dependent types in functions, as resulting objects are more difficult to manipulate. Instead, I prefer defining total functions and give them the right hypotheses in the lemmas.
You do not need to maintain the invariant that the second list is bigger than the third. Here is a possible solution:
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Div2.
Require Import Coq.Lists.List.
Import ListNotations.
Section Split.
Variable A : Type.
Fixpoint split_aux (hs ts l : list A) {struct l} : list A * list A :=
match l with
| [] => (rev hs, ts)
| [_] => (rev hs, ts)
| _ :: _ :: l' =>
match ts with
| [] => (rev hs, [])
| h :: ts => split_aux (h :: hs) ts l'
end
end.
Lemma split_aux_spec hs ts l n :
n = div2 (length l) ->
split_aux hs ts l = (rev (rev (firstn n ts) ++ hs), skipn n ts).
Proof.
revert hs ts l.
induction n as [|n IH].
- intros hs ts [|x [|y l]]; easy.
- intros hs ts [|x [|y l]]; simpl; try easy.
intros Hn.
destruct ts as [|h ts]; try easy.
rewrite IH; try congruence.
now simpl; rewrite <- app_assoc.
Qed.
Definition split l := split_aux [] l l.
Lemma split_spec l :
split l = (firstn (div2 (length l)) l, skipn (div2 (length l)) l).
Proof.
unfold split.
rewrite (split_aux_spec [] l l (div2 (length l))); trivial.
now rewrite app_nil_r, rev_involutive.
Qed.
End Split.
May I suggest going via a more precise type? The main idea is to define a function splitting a Vector.t whose nat index has the shape m + n into a Vector.t of size m and one of size n.
Require Import Vector.
Definition split_vector : forall a m n,
Vector.t a (m + n) -> (Vector.t a m * Vector.t a n).
Proof.
intros a m n; induction m; intro v.
- firstorder; constructor.
- destruct (IHm (tl v)) as [xs ys].
firstorder; constructor; [exact (hd v)|assumption].
Defined.
Once you have this, you've reduced your problem to defining the floor and ceil of n / 2 and proving that they sum to n.
Fixpoint div2_floor_ceil (n : nat) : (nat * nat) := match n with
| O => (O , O)
| S O => (O , S O)
| S (S n') => let (p , q) := div2_floor_ceil n'
in (S p, S q)
end.
Definition div2_floor (n : nat) := fst (div2_floor_ceil n).
Definition div2_ceil (n : nat) := snd (div2_floor_ceil n).
Lemma plus_div2_floor_ceil : forall n, div2_floor n + div2_ceil n = n.
Proof.
refine
(fix ih n := match n with
| O => _
| S O => _
| S (S n') => _
end); try reflexivity.
unfold div2_floor, div2_ceil in *; simpl.
destruct (div2_floor_ceil n') as [p q] eqn: eq.
simpl.
replace p with (div2_floor n') by (unfold div2_floor ; rewrite eq ; auto).
replace q with (div2_ceil n') by (unfold div2_ceil ; rewrite eq ; auto).
rewrite <- plus_n_Sm; do 2 f_equal.
apply ih.
Qed.
Indeed, you can then convert length xs into ceil (length xs / 2) + floor (length xs / 2) and use split_vector to get each part.
Definition split_list a (xs : list a) : (list a * list a).
Proof.
refine
(let v := of_list xs in
let (p , q) := split_vector a (div2_floor _) (div2_ceil _) _ in
(to_list p, to_list q)).
rewrite plus_div2_floor_ceil; exact v.
Defined.