Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(**
Classical logic is somewhat surprising!
Prove that given two arbitrary propositions
a and b, either a implies b or the converse *)

Lemma CL_is_wrong_and_boolrefl_is_nice (A B : (*D*)bool(*D*)) :
  (A -> B) \/ (B -> A).
(*A*)Proof. case: A; case: B; by [left | right]. Qed.

(** Enrico is a lazy student.  When asked to reverse and filter
a list he comes up with the following ugly code. *)

Fixpoint filtrev T (p : pred T) (acc : seq T) (l : seq T) : seq T :=
  if l is x :: xs then
    if p x then filtrev p (x :: acc) xs
           else filtrev p       acc  xs
  else acc.

(**  The teacher asks him to prove that his ugly code is equivalent
 to the nicer code [[seq x <- rev l | p x]] he could have written
by reusing the seq library.

Such proof is not trivial:
  - [filtrev] has an accumulator, [rev] (at least apparently)
    does not.
  - which is the invariant linking the accumulator [acc] and [p]
    in the code of [filtrev]?  Depending on how you expose
    the accumulator on the right hand side of the goal,
    such invariant may need to be taken into account by the induction.

Relevant keywords for [Search] are: rev cons cat filter rcons
Hint: it is perfectly fine to state intermediate lemmas
*)

Lemma filterrev_ok T p (l : seq T) :
  filtrev p [::] l = [seq x <- rev l | p x ].
Proof.
(*X*)rewrite -[RHS]cats0; elim: l [::] => [|x l ihl] l' //=.
(*X*)by case: ifP => px; rewrite ihl rev_cons filter_rcons ?px ?cat_rcons.
(*A*)Qed.

(** Prove the equivalence of these two sums.
    E.g. (n=8)
<<
    1 + 3 + 5 + 7 = 7-0 + 7-2 + 7-4 + 7-6
>>
*)
Lemma sum_odd n :
  ~~ odd n -> \sum_(i < n | odd i) i = \sum_(i < n | ~~ odd i) (n.-1 - i).
Proof.
(*X*)rewrite (reindex_inj rev_ord_inj) /= => /negPf n_oddF.
(*X*)by apply: eq_big => i; rewrite odd_sub ?n_oddF //; case: n i {n_oddF}.
(*A*)Qed.

(** Even the Mathematical Components library misses some theorems,
    for example the following one.

    Would you help us improve the library with this lemma?

    Hint: check out the theory of [iota]
*)

Lemma big_nat_shift (T : Type) (op: T -> T -> T) (idx : T)
  m c n (Pr : pred nat) (f : nat -> T):
  \big[op/idx]_(m + c <= i < n + c | Pr i) f i =
  \big[op/idx]_(m <= i < n | Pr (i + c)%N) f (i + c)%N.
(*A*)Proof. by rewrite big_addn addnK. Qed.
(**

Now, some algebra.

*)
From mathcomp Require Import all_algebra.
From mathcomp Require Import algC zmodp.

Section AlgebraicHierarchy.
Section GaussIntegers.
Import GRing.Theory Num.Theory.
Local Open Scope ring_scope.

(** Big operations and [zmodType]. Now that [ring_scope] is open we are in
    an algebraic setting.  Think about the meaning of [+] now, and find
    the right injectivity lemma. *)
Lemma big_ord_shift1 (T : Type) (idx : T) (op : Monoid.com_law idx) n
 P F : \big[op/idx]_(i < n.+2 | P i) F i =
       \big[op/idx]_(i < n.+2 | P (i + 1)) F (i + 1).
Proof.
(*X*)apply: reindex_inj; apply: addIr.
(*A*)Qed.

(**

We remind what Gauss integer are and recall some theory about it.

*)
Definition gaussInteger := [qualify a x | ('Re x \in Cint) && ('Im x \in Cint)].
Axiom Cint_GI : forall (x : algC), x \in Cint -> x \is a gaussInteger.
Axiom GI_subring : subring_closed gaussInteger.

Fact GI_key : pred_key gaussInteger. Proof. by []. Qed.
Canonical GI_keyed := KeyedQualifier GI_key.
Canonical GI_opprPred := OpprPred GI_subring.
Canonical GI_addrPred := AddrPred GI_subring.
Canonical GI_mulrPred := MulrPred GI_subring.
Canonical GI_zmodPred := ZmodPred GI_subring.
Canonical GI_semiringPred := SemiringPred GI_subring.
Canonical GI_smulrPred := SmulrPred GI_subring.
Canonical GI_subringPred := SubringPred GI_subring.

Record GI := GIof {algGI : algC; algGIP : algGI \is a gaussInteger }.
Hint Resolve algGIP.

Canonical GI_subType := [subType for algGI].
Definition GI_eqMixin := [eqMixin of GI by <:].
Canonical GI_eqType := EqType GI GI_eqMixin.
Definition GI_choiceMixin := [choiceMixin of GI by <:].
Canonical GI_choiceType := ChoiceType GI GI_choiceMixin.
Definition GI_countMixin := [countMixin of GI by <:].
Canonical GI_countType := CountType GI GI_countMixin.
Definition GI_zmodMixin := [zmodMixin of GI by <:].
Canonical GI_zmodType := ZmodType GI GI_zmodMixin.
Definition GI_ringMixin := [ringMixin of GI by <:].
Canonical GI_ringType := RingType GI GI_ringMixin.
Definition GI_comRingMixin := [comRingMixin of GI by <:].
Canonical GI_comRingType := ComRingType GI GI_comRingMixin.

Lemma conjGIE x : (x^* \is a gaussInteger) = (x \is a gaussInteger).
Proof. by rewrite ![_ \is a _]qualifE algRe_conj algIm_conj rpredN. Qed.

Fact conjGI_subproof (x : GI) : (val x)^* \is a gaussInteger.
Proof. by rewrite conjGIE. Qed.

Canonical conjGI x := GIof (conjGI_subproof x).

Definition gaussNorm (x : algC) := x * x^*.

Axiom gaussNormE : forall x, gaussNorm x = `|x| ^+ 2.
Axiom gaussNormCnat : forall (x : GI), gaussNorm (val x) \in Cnat.
(**

Prove these two facts. (Hint: conjugation is a morphism)

*)
Lemma gaussNorm1 : gaussNorm 1 = 1.
(*A*)Proof. by rewrite /gaussNorm rmorph1 mulr1. Qed.

Lemma gaussNormM : {morph gaussNorm : x y / x * y}.
(*A*)Proof. by move=> x y; rewrite /gaussNorm rmorphM mulrACA. Qed.
(**

** Question: Prove that GI euclidean for the stasm gaussNorm.

 - i.e. ∀ (a, b) ∈ GI × GI*, ∃ (q, r) ∈ GI² s.t. a = q b + r and φ(r) < φ(b)
 - Suggested strategy: sketch the proof on a paper first, don't let Coq
   divert you from your proofsketch
 - We first sketch the "paper proof" here and then do it in Coq:
  - take a / b = x + i y
  - take u the closest integer to x, and v the closest integer to y
  - satisfy the existential with q = u + i v and r = a - q b,
    which are both Gauss integers.
  - We want to show that |a - q b|² < |b|².
  - It suffices to show |a / b - q|² < 1
  - But |a / b - q|² = (u - x)² + (v - x)² ≤ ½² + ½² < 1
 - Now we give a Coq proof with holes, fill in the holes.
*)
Lemma euclideanGI (a b : GI) : b != 0 ->
  exists2 qr : GI * GI, a = qr.1 * b + qr.2
                      & (gaussNorm (val qr.2) < gaussNorm (val b)).
Proof.
move=> b_neq0.

(* Trivial preliminaries *)
have oneV2 : 1 = 2%:R^-1 + 2%:R^-1 :> algC.
  by rewrite -mulr2n -[_ *+ 2]mulr_natr mulVf ?pnatr_eq0.
have V2ge0 : 0 <= 2%:R^-1 :> algC by (*a*)rewrite invr_ge0 ler0n.
have V2real : (2%:R^-1 : algC) \is Num.real by (*a*)rewrite realE V2ge0.

(* Closest integer to x, when x is real *)
pose approx (x : algC) : int :=
  floorC x + (if `|x - (floorC x)%:~R| <= 2%:R^-1 then 0 else 1).
have approxP x : x \is Creal -> `|x - (approx x)%:~R| <= 2%:R^-1.
  rewrite /approx => x_real; have /andP [x_ge x_le] := floorC_itv x_real.
  have [] // := @real_lerP _  `|_ - (floorC _)%:~R| _;
    first by rewrite addr0.
  rewrite [`|_ - (_ + 1)%:~R|]distrC !ger0_norm ?subr_ge0 //=;
     last by rewrite ltrW.
  move=> Dx1_gtV2; rewrite real_lerNgt ?rpredB // ?Creal_Cint ?Cint_int //.
  apply/negP=> /ltr_add /(_ Dx1_gtV2); rewrite -oneV2 !addrA addrNK.
  by rewrite [_ + 1]addrC rmorphD /= addrK ltrr.
have approxP2 x (_ : x \is Creal) : `|x - (approx x)%:~R| ^+ 2 < 2%:R^-1.
  rewrite (@ler_lt_trans _ (2%:R^-1 ^+ 2)) // ?ler_expn2r ?qualifE ?approxP //.
  by rewrite exprVn -natrX ltf_pinv ?qualifE ?ltr_nat ?ltr0n.

(* Proper proof *)
pose u := 'Re (val a / val b); pose v := 'Im (val a / val b).
have qGI : (approx u)%:~R + algCi * (approx v)%:~R \is a gaussInteger.
  (* Hint: use qualifE, alg*_rect and lemmas about Creal, Cint and _%:~R *)
  (*a*)by rewrite qualifE /= algRe_rect ?algIm_rect // ?Creal_Cint ?Cint_int.
pose q := GIof qGI.
exists (q, a - q * b); first by rewrite addrC addrNK.
rewrite !gaussNormE /=.
rewrite -(@ltr_pmul2r _ (`|val b| ^-2)) ?invr_gt0 ?exprn_gt0 ?normr_gt0 //.
rewrite mulfV ?expf_eq0 /= ?normr_eq0 // -exprVn -exprMn.
rewrite -normfV -normrM mulrBl mulfK //.
suff uvP : `|u - (approx u)%:~R + 'i * (v - (approx v)%:~R)| ^+ 2 < 1.
  (* Hint: use algCrect and algebraic transformations *)
  (*a*)by rewrite [X in X - _]algCrect opprD addrACA -mulrBr.
set Du := _ - _; set Dv := _ - _.
have /andP [DuReal DvReal] : (Du \is Creal) && (Dv \is Creal).
(* Hint: use rpred*, Creal_*, normC2_rect, ream_normK and approxP2 *)
(*a*)  by rewrite ?rpredB ?Creal_Re ?Creal_Im ?Creal_Cint ?Cint_int.
(*X*)rewrite normC2_rect // oneV2.
(*X*)by rewrite ltr_add // -real_normK // approxP2 ?Creal_Re ?Creal_Im.
(*A*)Qed.

End GaussIntegers.
End AlgebraicHierarchy.

Section PolynomialsLagrange.

Open Scope ring_scope.
Import GRing.Theory Num.Theory.
(**

* Definition and properties of Lagrange polynomials.

Prove only one of the following lemmas
*)
Variables (n : nat) (x : algC ^ n).

Definition lagrange (i : 'I_n) : {poly algC} :=
  let p := \prod_(j < n | j != i) ('X - (x j)%:P) in (p.[x i]^-1)%:P * p.

Hypothesis n_gt0 : (0 < n)%N.
Hypothesis x_inj : injective x.

Lemma lagrangeE (i j : 'I_n) : (lagrange i).[x j] = (i == j)%:R.
Proof using x_inj.
(*X*)rewrite /lagrange hornerM hornerC; set p := (\prod_(_ < _ | _) _).
(*X*)have [<-|neq_ij] /= := altP eqP.
(*X*)  rewrite mulVf // horner_prod; apply/prodf_neq0 => k neq_ki.
(*X*)  by rewrite hornerXsubC subr_eq0 inj_eq // eq_sym.
(*X*)rewrite [X in _ * X]horner_prod (bigD1 j) 1?eq_sym //=.
(*X*)by rewrite hornerXsubC subrr mul0r mulr0.
(*A*)Qed.

Lemma size_lagrange i : size (lagrange i) = n.
Proof using n_gt0 x_inj.
(*X*)rewrite size_Cmul; last first.
(*X*)  suff : (lagrange i).[x i] != 0 by rewrite hornerE mulf_eq0 => /norP [].
(*X*)  by rewrite lagrangeE ?eqxx ?oner_eq0.
(*X*)rewrite size_prod /=; last first.
(*X*)  by move=> j neq_ji; rewrite polyXsubC_eq0.
(*X*)rewrite (eq_bigr (fun=> (2 * 1)%N)); last first.
(*X*)  by move=> j neq_ji; rewrite size_XsubC.
(*X*)rewrite -big_distrr /= sum1_card cardC1 card_ord /=.
(*X*)by case: (n) {i} n_gt0 => ?; rewrite mul2n -addnn -addSn addnK.
(*A*)Qed.

Lemma lagrange_free (lambda : 'rV_n):
  \sum_i (lambda 0 i)%:P * lagrange i = 0 -> lambda = 0.
Proof using x_inj.
(*X*)move=> eq_l; apply/rowP=> i; rewrite mxE.
(*X*)have /(congr1 (fun p => p.[x i])) := eq_l.
(*X*)rewrite horner_sum horner0 (bigD1 i) //= hornerE lagrangeE // eqxx mulr1.
(*X*)rewrite big1 ?addr0 // => j neq_ji.
(*X*)by rewrite hornerM lagrangeE // (negPf neq_ji) mulr0.
(*A*)Qed.

Lemma lagrange_gen (p : {poly algC}) :
   (size p <= n)%N -> p = \sum_i p.[x i]%:P * lagrange i.
Proof using n_gt0 x_inj.
(*X*)(* fancy proof using marix spaces *)
(*X*)move=> sp_le_n; pose L := \matrix_(i < n) @poly_rV _ n (lagrange i).
(*X*)suff /(congr1 rVpoly) : poly_rV p = \row_i p.[x i] *m L.
(*X*)  rewrite poly_rV_K // => {1}->; rewrite mulmx_sum_row raddf_sum /=.
(*X*)  apply: eq_bigr=> i _; rewrite linearZ /= mxE mul_polyC.
(*X*)  by rewrite rowK poly_rV_K ?size_lagrange.
(*X*)have /submxP [u puL]: (poly_rV p <= L)%MS.
(*X*)  rewrite (submx_trans (submx1 _)) // sub1mx row_full_unit -row_free_unit.
(*X*)  rewrite -kermx_eq0; apply/rowV0P => v /sub_kermxP.
(*X*)  move=> /(congr1 rVpoly); rewrite !raddf0 mulmx_sum_row raddf_sum /= => vL0.
(*X*)  rewrite [v]lagrange_free // -[RHS]vL0; apply: eq_bigr => i _.
(*X*)  by rewrite linearZ rowK mul_polyC /= poly_rV_K ?size_lagrange.
(*X*)rewrite puL; congr (_ *m _); apply/rowP=> i; rewrite mxE.
(*X*)have /(congr1 (fun v => (rVpoly v).[x i])) := puL.
(*X*)rewrite poly_rV_K // mulmx_sum_row raddf_sum /=.
(*X*)rewrite (bigD1 i) //= linearZ /= rowK poly_rV_K ?size_lagrange //.
(*X*)rewrite 2!hornerE lagrangeE eqxx mulr1 horner_sum big1 ?addr0 //.
(*X*)move=> j neq_ji; rewrite linearZ rowK /= ?poly_rV_K ?size_lagrange //.
(*X*)by rewrite hornerZ lagrangeE (negPf neq_ji) mulr0.

(*X*)Restart. (* shorter proof, direct *)

(*X*)move=> sp_le_n; apply/eqP; rewrite -subr_eq0; apply: contraTT isT.
(*X*)move=> /max_poly_roots - /(_ [seq x i | i <- enum 'I_n]).
(*X*)rewrite size_map size_enum_ord map_inj_uniq ?enum_uniq //.
(*X*)rewrite [(n < _)%N]negbTE; [apply=>//|rewrite -leqNgt].
(*X*)  apply/allP=> /= _ /imageP [/= i _ ->].
(*X*)  rewrite rootE !hornerE horner_sum (bigD1 i) //=.
(*X*)  rewrite hornerM hornerC lagrangeE // eqxx mulr1 opprD addNKr.
(*X*)  rewrite big1 ?oppr0 // => j neq_ji.
(*X*)  by rewrite hornerM lagrangeE // (negPf neq_ji) mulr0.
(*X*)rewrite (leq_trans (size_add _ _)) // size_opp geq_max sp_le_n /=.
(*X*)rewrite (leq_trans (size_sum _ _ _)) //; apply/bigmax_leqP=> j _.
(*X*)rewrite (leq_trans (size_mul_leq _ _)) // size_polyC size_lagrange //.
(*X*)by move: (n) n_gt0 (_ == _) => [] // ? _ [].
(*A*)Qed.

End PolynomialsLagrange.

Section PolynomialsTaylor.
(**
Taylor formula for polynomials

*)
Import GRing.Theory.
Open Scope ring_scope.
Variable R: idomainType.

(*X*)(* This is the strongest statement I could prove *)
(*X*)(* uses max_poly_roots and nderiv_taylor *)
(*X*)Lemma Taylor_formula_strong (p : {poly R}) (x : R) (rs : seq R) :
(*X*)  (size p <= size rs)%N -> uniq rs ->
(*X*)  p = \sum_ (i < size p) p^`N(i).[x] *: ('X - x%:P) ^+ i.
(*X*)Proof.
(*X*)move=> sprs /max_poly_roots prs; apply/eqP; rewrite -subr_eq0.
(*X*)apply: contraTT isT => /prs; rewrite [(_ < _)%N]negbTE; [apply|rewrite -leqNgt].
(*X*)  apply/allP=> y y_rs; rewrite rootE hornerD hornerN subr_eq0; apply/eqP.
(*X*)  rewrite -[y in X in p.[X]](addrNK x) [_ + x]addrC.
(*X*)  rewrite nderiv_taylor; last exact: mulrC.
(*X*)  by rewrite horner_sum; apply: eq_bigr=> i _; rewrite !(hornerE, horner_exp).
(*X*)rewrite (leq_trans (size_add _ _)) // geq_max sprs /= size_opp.
(*X*)rewrite (leq_trans (size_sum _ _ _)) //; apply/bigmax_leqP=> i _.
(*X*)rewrite (leq_trans (size_scale_leq _ _)) //.
(*X*)by rewrite size_exp_XsubC (leq_trans _ sprs).
(*X*)Qed.

(*X*)Lemma natr_injP (D : idomainType) :
(*X*)  (forall n, (n%:R == 0 :> D) = (n == 0)%N) <-> injective (@GRing.natmul D 1).
(*X*)Proof.
(*X*)split=> [natr_eq0 i j|natr_inj n]; last by rewrite -(inj_eq natr_inj).
(*X*)wlog: i j / (j <= i)%N => [hwlog|].
(*X*)  by have [/hwlog//|/ltnW/hwlog/(_ (esym _))/esym] := leqP j i.
(*X*)by move=> /subnK<- /eqP; rewrite -subr_eq0 natrD addrK natr_eq0 => /eqP->.
(*X*)Qed.

(*X*) (* This is the statement we ask the students to prove *)
Hypothesis charR_eq0 : [char R] =i pred0.
Lemma Taylor_formula (p : {poly R}) (x : R) :
  p = \sum_ (i < size p) p^`N(i).[x] *: ('X - x%:P) ^+ i.
(*X*)Proof. (* Proof using the stronger version *)
(*X*)apply: (@Taylor_formula_strong _ _ [seq i%:R | i <- iota 0 (size p)]).
(*X*)  by rewrite size_map size_iota.
(*X*)by rewrite map_inj_uniq ?iota_uniq //; apply/natr_injP/charf0P.
(*X*)
(*X*)Restart. (* Proof for the students *)
(*X*)
Proof.
wlog: p x / x = 0 => [hwlog|->]; rewrite ?subr0; last first.
(*X*)  transitivity (\poly_(i < size p) p^`N(i).[0]);
(*X*)    last by rewrite poly_def.
(*X*)  apply/polyP=> /= i; rewrite coef_poly.
(*X*)  have [i_small|i_big]:= ltnP; last by rewrite nth_default.
  (*a*)by rewrite horner_coef0 coef_nderivn addn0 binn mulr1n.
rewrite -[LHS](comp_polyXaddC_K _ x) -[RHS](comp_polyXaddC_K _ x).
congr (_ \Po _); rewrite [LHS](hwlog _ 0 erefl) ?subr0 [RHS]raddf_sum /=.
rewrite size_comp_poly2; last first.
  by rewrite -[x%:P as X in 'X + X]opprK -[- x%:P]raddfN /= size_XsubC.
(*X*)apply: eq_bigr => i _.
(*X*)have nderivn_compXD q (a : R) j :
(*X*)  (q \Po ('X + a%:P))^`N(j) = q^`N(j) \Po ('X + a%:P).
       have /charf0P/natr_injP natr_inj := charR_eq0.
(*X*)  apply: (@mulfI _ j`!%:R%:P).
(*X*)     rewrite polyC_eq0; have/charf0P -> := charR_eq0.
     (*a*)by rewrite -lt0n fact_gt0.
(*X*)  rewrite !mul_polyC !scaler_nat -rmorphMn /= -!nderivn_def.
  (*a*)by elim: j => //= j ->; rewrite deriv_comp !derivE addr0 mulr1.
(*X*)rewrite nderivn_compXD horner_comp !hornerE // linearZ rmorphX /=.
(*X*)rewrite -['X - x%:P]comp_polyX -[x%:P as X in 'X + X]opprK.
(*X*)by rewrite -[- x%:P]raddfN /= comp_polyXaddC_K.
(*A*)Qed.

End PolynomialsTaylor.

Section LinearAlgebra.
Import GRing.Theory Num.Theory.
Local Open Scope ring_scope.
(**

* Endomorphisms u such that Ker u ⊕ Im u = E.

The endomorphisms of a space E of finite dimension n, such that u o v
= 0 and v + u is invertible are exactly the endomorphisms such that
Ker u ⊕ Im u = E.

 - Assume u o v = 0 and v + u is invertible,
  - we have rank (v + u) = n
  - we have rank v + rank u = n and we have Im v ⊂ Ker u
  - Hence we have Im v = Ker u
  - We deduce that Ker u ⊕ Im u = Im v ⊕ Im u = E

*)
Variables (F : fieldType) (n' : nat).
Let n := n'.+1.

Lemma ex_6_13 (u : 'M[F]_n):
  reflect (exists2 v : 'M_n, v * u = 0 & v + u \is a GRing.unit)
          ((kermx u + u == 1)%MS && mxdirect (kermx u + u)).
Proof.
(* Hint: use mxrank* lemmas and search on addsmx, submx and eqmx
sometimes. Don't forget about mxdirect_addsP and sub_kermxP. *)
apply: (iffP idP) => [|[v vMu vDu]]; last first.
  have rkvDu: \rank (v + u)%R = n by (*a*)rewrite mxrank_unit.
  have /eqP rkvDrku : (\rank v + \rank u)%N == n.
    by rewrite eqn_leq; (*a*)rewrite mulmx0_rank_max //= -{1}rkvDu mxrank_add.
  have sub_v_ku : (v <= kermx u)%MS by (*a*)apply/sub_kermxP.
  have /eqmxP/eqmx_sym eq_vu: (v == kermx u)%MS.
    rewrite -(geq_leqif (mxrank_leqif_eq _)) //.
(*X*)    rewrite -(leq_add2r (\rank u)) rkvDrku.
    (*a*)by rewrite mxrank_ker subnK // rank_leq_row.
  rewrite submx1 sub1mx -col_leq_rank mxdirectEgeq /=.
  (* use adds_eqmx to lift eq_vu to a sum *)
(*X*)  rewrite eq_vu (adds_eqmx eq_vu (eqmx_refl _)).
  (* Warning: - (u + v)%R  is a sum of matrices
              - (u + v)%MS is a sum of spaces
     use addmx_sub_adds and mxrankS
     to compare the rank (u + v) with dim (Im u + Im v) *)
(*X*)  have /mxrankS leq_rk := addmx_sub_adds (submx_refl v) (submx_refl u).
  (* finish using hypothesis *)
  (*a*)by rewrite !(leq_trans _ leq_rk) //= ?rkvDu ?rkvDrku.
move=> /andP [/eqmxP kuDu_eq1 /mxdirect_addsP kvDu_direct].
pose v := proj_mx (kermx u) u; exists v.
  (*a*)by apply/sub_kermxP; rewrite -[X in (X <= _)%MS]mul1r proj_mx_sub.
rewrite -row_free_unit -kermx_eq0.
apply/negP => /negP /rowV0Pn [x /sub_kermxP]; rewrite mulmxDr.
move=> /(canRL (addrK _)); rewrite sub0r => eq_xv_Nxu.
apply/negP; rewrite negbK; apply/eqP.
have : (x *m v <= kermx u :&: u)%MS.
(* Hint: use sub_*, proj_mx*, eqmx_*, mxdirect_addsP, *)
  (*a*)by rewrite sub_capmx proj_mx_sub eq_xv_Nxu eqmx_opp submxMl.
(*X*)rewrite kvDu_direct ?submx0 // => /eqP xv_eq0.
(*X*)move/eqP : eq_xv_Nxu; rewrite xv_eq0 eq_sym oppr_eq0 => /eqP.
(*X*)by move=> /sub_kermxP x_in_keru; move: xv_eq0; rewrite proj_mx_id.
(*A*)Qed.

End LinearAlgebra.

(*X*)(*
(*X*)*** Local Variables: ***
(*X*)*** coq-prog-args: ("-emacs-U" "-R" "/Users/lrg/coq/math-comp/mathcomp" "mathcomp" "-I" "/Users/lrg/coq/math-comp/mathcomp" ) ***
(*X*)*** End: ***
(*X*)*)


Require Import Coq.Arith.PeanoNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.

Section Repeat.
  Context {A : Type}.

  Fixpoint rep (f : A -> A) (n : nat) (z : A) : A :=
    match n with
    | O => z
    | S m => f (rep f m z)
    end.

  Theorem rep_l : forall f n z,
      f (rep f n z) = rep f (S n) z.
  Proof. reflexivity. Qed.

  Theorem rep_r  : forall f n z,
      rep f n (f z) = rep f (S n) z.
  Proof.
    induction n; intros.
    - reflexivity.
    - simpl rep at 1. rewrite IHn. easy.
  Qed.

  Theorem rep_split : forall f n m z,
      rep f n (rep f m z) = rep f (n + m) z.
  Proof.
    intros.
    induction m.
    - simpl.
      rewrite Nat.add_0_r. reflexivity.
    - simpl; rewrite rep_r. simpl; rewrite IHm.
      rewrite rep_l.
      f_equal. omega.
  Qed.
End Repeat.

Section Invertible.
  Context {A : Type} (f g : A -> A).
  Hypothesis HI: forall x, g (f x) = x.

  Lemma rep_inv1_l : forall n z,
      g (rep f (S n) z) = rep f n z.
  Proof.
    intros.
    simpl. rewrite HI.
    easy.
  Qed.

  Lemma rep_inv1_r : forall n z,
      rep g (S n) (f z) = rep g n z.
  Proof.
    intros. induction n.
    - simpl. auto.
    - remember (S n) as n'; simpl; subst.
      rewrite IHn. apply rep_l.
  Qed.

  Theorem rep_inv_l : forall n m z,
      n >= m -> rep g m (rep f n z) = rep f (n - m) z.
  Proof.
    intros n m. revert n. induction m; intros.
    - simpl. rewrite Nat.sub_0_r. reflexivity.
    - simpl. rewrite IHm by omega.
      destruct (n - m) as [|x] eqn:Hn; try omega.
      rewrite rep_inv1_l by auto.
      replace (n - S m) with x by omega.
      reflexivity.
  Qed.

  Theorem rep_inv_r : forall n m z,
      m >= n -> rep g m (rep f n z) = rep g (m - n) z.
  Proof.
    intros n m. induction n; intros.
    - simpl. rewrite Nat.sub_0_r.
      reflexivity.
    - rewrite <- rep_r, IHn by omega.
      destruct (m - n) as [|x] eqn:Hm; try omega.
      rewrite rep_inv1_r by auto.
      replace (m - S n) with x by omega.
      reflexivity.
  Qed.
End Invertible.

Section Preserves.
  Context {A : Type} (P : A -> Prop) (f : A -> A).
  Hypothesis HP : forall x, P x -> P (f x).

  Theorem rep_preserves : forall z n,
      P z -> P (rep f n z).
  Proof.
    intros z n Pz; revert z Pz.
    induction n; auto; intros.
    simpl. auto.
  Qed.
End Preserves.

Section Map.
  Context {A : Type}.

  Variable f : A -> A.

  Lemma rep_map_cons : forall n a l,
      rep (map f) n (a :: l) = rep f n a :: rep (map f) n l.
  Proof.
    induction n; intros a l; [reflexivity|].
    cbn. rewrite IHn. cbn. reflexivity.
  Qed.

  Theorem rep_map : forall n l,
      rep (map f) n l = map (rep f n) l.
  Proof.
    induction l.
    - cbn. apply rep_preserves; [|reflexivity].
      intros; subst; reflexivity.
    - cbn. rewrite <- IHl.
      apply rep_map_cons.
  Qed.
End Map.


(** * Coinduction: Infinite Data and Proofs *)
(* CIS670, Homework assignments 6 and 7 *)

(* This material builds on:
   - sections 7.1 from the tutorial by Giménez and Castéran
   - sections 5.1-5.2 from the CPDT book by Adam Chlipala
*)

Require Import Bool.
Require Import List.

Require Import CpdtTactics.

Set Implicit Arguments.

(* ------------------------------------------------------------ *)
(** ** Computing with Infinite Data *)

(** The most basic type of infinite data is infinite lists, usually
    known as _streams_ *)

CoInductive stream (A : Type) : Type :=
  | Cons : A -> stream A -> stream A.

(** If we want _both_ finite and infinite lists, then we can also keep
    the cons *)

CoInductive llist (A: Type) : Type :=
|  LNil : llist A
|  LCons : A -> llist A -> llist A.

(** Exercise (easy): define the coinductive types representing the
    following 3 infinite data structures: *)

(* 1. infinite binary trees *)
CoInductive ibtree (A : Type) : Type :=
  | IBNode : A -> ibtree A -> ibtree A -> ibtree A.

(* 2. infinitely branching infinite trees
      (i.e. infinitely wide and infinitely deep) *)
CoInductive itree (A : Type) : Type :=
  | INode : A -> (nat -> itree A) -> itree A.

(* 3. finitely and infinitely branching infinite trees
      (i.e. finitely or infinitely wide and infinitely deep *)
CoInductive iftree (A : Type) : Type :=
  | IINode : A -> llist (iftree A) -> iftree A.

(** Pattern matching on coinductive values works as usual *)

Definition head (A:Type) (s : stream A) :=
  match s with
  | Cons a s' => a
  end.

Definition tail (A : Type)(s : stream A) :=
  match s with
  | Cons a s' => s'
  end.

(* Exercise (easy): Using the functions head and tail, define a
   recursive function which takes the n-th element of an infinite
   stream. *)
Fixpoint nth (A : Type) (n : nat) (s : stream A) : A :=
  match n with
  | O => head s
  | S n' => nth n' (tail s)
  end.

(* Infinite objects are defined using the CoFixpoint command *)

CoFixpoint repeat (A : Type) (a : A) : stream A := Cons a (repeat a).

(** Note: whereas recursive definitions (fixpoints) were necessary to
    _use_ values of recursive inductive types effectively, we need
    co-recursive definitions (co-fixpoints) to _build_ (infinite)
    values of co-inductive types *)

(** Every CoFixpoint has to return a coinductive type (in the same way
    every Fixpoint has to take and break up an inductive argument). *)

(*
CoFixpoint to_bool (x : stream nat) : bool := to_bool x.

Error:
Recursive definition of to_bool is ill-formed.
In environment
to_bool : stream nat -> bool
x : stream nat
The codomain is "bool"
which should be a coinductive type.
Recursive definition is: "fun x : stream nat => to_bool x".
*)

(** Co-inductive values can be arguments to recursive functions.
    However, there also needs to be an inductive argument in order to
    convince Coq that the function is terminating. We can use this to
    write a function that computes the finite approximation of a
    stream: *)

Fixpoint approx A (n : nat) (s : stream A) {struct n} : list A :=
  match n with
    | O => nil
    | S n' =>
      match s with
        | Cons h t => h :: approx n' t
      end
  end.

Definition ones := repeat 1.

Eval simpl in approx 10 ones.

(** We can of course also define [ones] directly, without using
    [iterate] *)

CoFixpoint ones' : stream nat := Cons 1 ones'.

Eval simpl in approx 10 ones'.

(** In order to prevent non-termination, co-fixpoints are evaluated
    lazily. They are unfolded _only_ when they appear as the argument
    of a match expression. We can check this using Eval. *)

Eval simpl in (repeat 4).

Eval simpl in (head (repeat 4)).

(** Here are three useful co-recursive functions on streams: *)

CoFixpoint iterate (A : Type) (f : A -> A) (a : A) : stream A :=
  Cons a (iterate f (f a)).

CoFixpoint map (A B : Type) (f : A -> B) (s : stream A) : stream B :=
  match s with
  | Cons a tl => Cons (f a) (map f tl)
  end.

CoFixpoint interleave (A : Type) (s1 s2 : stream A) : stream A :=
  match s1, s2 with
  | Cons n1 s1', Cons n2 s2' => Cons n1 (Cons n2 (interleave s1' s2'))
  end.

(** Using [iterate] we can define the stream of natural numbers: *)

Definition nats : stream nat := iterate S 0.
Eval simpl in approx 10 nats.

(* We can of course also define nats more directly: *)
CoFixpoint nats_from_n (n : nat) : stream nat :=
  Cons n (nats_from_n (S n)).
Definition nats' := nats_from_n 0.

Eval simpl in approx 10 nats.

(** We can define a stream that alternates between [true] and [false]
    using a mutual co-fixpoint (there are simpler ways, though). *)

CoFixpoint trues_falses : stream bool := Cons true  falses_trues
      with falses_trues : stream bool := Cons false trues_falses.

(* Exercise (easy): Find two more ways for constructing the stream
   which infinitely alternates the values true and false. *)
Definition trues_falses' : stream bool := iterate negb true.
Definition trues_falses'' : stream bool := interleave (repeat true) (repeat false).

(* Not every co-fixpoint is accepted by Coq, though: there are
   important restrictions that are dual to the restrictions on the use
   of inductive types. Fixpoints _consume_ values of inductive types,
   with restrictions on which _arguments_ may be passed in recursive
   calls. Dually, co-fixpoints _produce_ values of co-inductive types,
   with restrictions on what may be done with the _results_ of
   co-recursive calls. *)

(* Coq enforces that every co-recursive call must be guarded by a
   constructor; that is, every co-recursive call must be a direct
   argument to a constructor of the co-inductive type we are
   generating. For instance, the following co-fixpoint does not pass
   Coq's guardedness condition:

CoFixpoint looper : stream nat := looper.

<<
Error:
Recursive definition of looper is ill-formed.
In environment
looper : stream nat

unguarded recursive call in "looper"
>> *)

(* It is a good thing that this guardedness condition is enforced. If
   the definition of [looper] were accepted, our [approx] function
   would run forever when passed [looper], and we would have fallen
   into inconsistency. *)

(* Many other standard functions on lazy data structures (like [map],
   [iterate] and [iterate] above) can be implemented easily in Coq.
   Some, others like [filter], cannot be implemented.  (Why?) *)

(* ------------------------------------------------------------ *)
(** ** Finite Proofs about Infinite Objects *)

(* We saw that we can define recursive functions on infinite (or
   potentially infinite) objects -- e.g., approx.  We can also use the
   standard Inductive machinery to define (some) useful properties of
   potentially infinite objects. *)

Inductive finite A : llist A -> Prop :=
| fin_LNil : finite (LNil A)
| fin_LCons : forall l x, finite l -> finite (LCons x l).

(* What about defining a similar predicate [infinite]? *)

(* ------------------------------------------------------------ *)
(** ** Infinite Proofs *)

(** Suppose that we wanted to prove formally that the streams [nats]
    and [nats'] from above are equivalent. The naive way to do this is
    to state it as the following equality: *)

Theorem nats_eq : nats = nats'.
Abort.

(** However, faced with the initial subgoal, it is not at all clear
    how this theorem can be proved.  In fact, it is unprovable. The
    [eq] predicate that we use is fundamentally limited to equalities
    that can be demonstrated by finite arguments. All we can prove
    this way is that any finite approximation of [nats] and [nats']
    are equal. *)

(* First try: *)
Lemma approx_nats_eq : forall k,
  approx k nats = approx k nats'.
Proof. induction k; intros. reflexivity. simpl. Abort.

(** For this we need to work we need to first generalize the induction
    hypothesis and consider increasing streams of naturals starting
    at any natural number. *)

Lemma approx_nats_eq_helper : forall k n,
  approx k (iterate S n) = approx k (nats_from_n n).
Proof. induction k; crush. Qed.

Lemma approx_nats_eq : forall k,
  approx k nats = approx k nats'.
Proof. intros. eapply approx_nats_eq_helper. Qed.

(** In order to deal with interesting properties of infinite objects,
    it is necessary to construct infinite proofs. What we need for
    that is a _co-inductive proposition_.  That is, we want to define
    a proposition whose _proofs_ may be infinite (subject to the
    guardedness condition, of course). *)

CoInductive stream_eq (A : Type) : stream A -> stream A -> Prop :=
| Stream_eq : forall (h : A) t1 t2,
        stream_eq t1 t2
     -> stream_eq (Cons h t1) (Cons h t2).

(** We say that two streams are equal if and only if they have the
    same heads and their tails are equal.  We use normal
    finite/syntactic equality for the heads, and we refer to our new
    equality (co-)recursively for the tails. *)

(** In order to construct infinite proof terms we need to use a
    co-fixpoint, in the same way as we did for constructing infinite
    program terms. While in programming mode we used [CoFixpoint]; in
    tactic mode we can use the related [cofix] tactic for building
    co-fixpoints. *)

(** Before attacking the slightly harder problem of proving [nats] and
    [nats'] in the [stream_eq] relation, we first try to prove that
    [ones] and [ones'] are in [stream_eq]. We start by doing this
    directly using the [cofix] tactic. *)

Theorem ones_eq : stream_eq ones ones'.
  cofix.
  assumption. (* "proof completed" *)
(* Qed. --> Unguarded recursive call in "ones_eq" *)

(** The same guardedness condition applies to our co-inductive proofs
    as to our co-inductive data structures. We should be grateful that
    this proof is rejected, because, if it were not, the same proof
    structure could be used to prove any co-inductive theorem
    vacuously, by direct appeal to itself! *)

(** Looking at the proof term Coq generates from the proof script
    above, we see that the problem is that we are violating the
    guardedness condition. *)

Show Proof.
(** (cofix ones_eq  : stream_eq ones ones' := ones_eq) *)

(** During our proofs, Coq can help us check whether we have yet gone
    wrong in this way. We can run the command [Guarded] in any
    context to see if it is possible to finish the proof in a way that
    will yield a properly guarded proof term.

    Running [Guarded] here gives us the same error message that we got
    when we tried to run [Qed]. In larger proofs, [Guarded] can be
    helpful in detecting problems _before_ we think we are ready to
    run [Qed]. *)

Restart.

(** We need to start the co-induction by applying [stream_eq]'s
    constructor. To do that, we need to know that both arguments to
    the predicate are [Cons]es. Informally, this is trivial, but
    [simpl] is not able to help us, because co-fixpoint have to be
    evaluated lazily. *)

  cofix.
  simpl. (* does nothing *)

Abort.

(** It turns out that the simplest way to get off the ground with this
    proof is a commonly used hack. First, we need to define an
    identity function that seems pointless on first glance. *)

Definition id_force A (s : stream A) : stream A :=
  match s with
    | Cons h t => Cons h t
  end.

(** Next, we need to prove a theorem that seems equally pointless. *)

Theorem id_force_eq : forall A (s : stream A), s = id_force s.
Proof. destruct s; reflexivity. Qed.

(** But, miraculously, this theorem turns out to be just what we needed. *)

Theorem ones_eq : stream_eq ones ones'.
  cofix.

  (** We can use the theorem to rewrite the two streams. *)
  rewrite (id_force_eq ones).
  rewrite (id_force_eq ones').

  (** Now [simpl] is able to reduce the streams. *)
  simpl.

  (** Why did this silly-looking trick help?  The answer has to do
      with the constraints placed on Coq's evaluation rules by the
      need for termination.  The [cofix]-related restriction that
      foiled our first attempt at using [simpl] is dual to a
      restriction for [fix].  In particular, an application of an
      anonymous [fix] only reduces when the top-level structure of the
      recursive argument is known.  Otherwise, we would be unfolding
      the recursive definition ad infinitum.

      Fixpoints only reduce when enough is known about the
      _definitions_ of their arguments.  Dually, co-fixpoints only
      reduce when enough is known about _how their results will be
      used_.  In particular, a [cofix] is only expanded when it is the
      discriminee of a [match].  Rewriting with our superficially
      silly lemma wrapped new [match]es around the two [cofix]es,
      triggering reduction.

      If [cofix]es reduced haphazardly, it would be easy to run into
      infinite loops in evaluation, since we are, after all, building
      infinite objects. *)

  (** Since we have exposed the [Cons] structure of each stream, we
     can apply the constructor of [stream_eq]. *)

  constructor.
  assumption.
Qed.

(** The example above shows that one can construct infinite proofs by
    directly using [cofix], but there are two important problems with
    this. First, it's hard to keep guardedness in mind when building
    large proofs. Second, using [cofix] directly interacts very badly
    with Coq's standard automation machinery. If we try to prove
    [ones_eq] with automation we get an invalid proof. *)

Theorem ones_eq' : stream_eq ones ones'.
  cofix.
Proof.
  cofix; auto.
  (** [[
  Guarded.
  ]]
  *)
Abort.

(** The standard [auto] machinery sees that our goal matches an
    assumption and so applies that assumption, even though this
    violates guardedness.  One usually starts a proof like this by
    [destruct]ing some parameter and running a custom tactic to figure
    out the first proof rule to apply for each case.  Alternatively,
    there are tricks that can be played with "hiding" the co-inductive
    hypothesis. *)

(** However, we can devise a more principled solution to this problem
    by looking at how the dual version of the problem is generally
    solved for induction. It's equally hard to build inductive proofs
    directly using [fix], but one almost never does that. Instead one
    uses [fix] to proving general _induction principles_, and then
    simply applies those principles. *)

(** It turns out that we can usually do the same with _co-induction
    principles_. Coq will not generate co-induction principles for us
    though, so we need to define them by hand using co-fixpoints. *)

Section stream_eq_coind1.
  Variable A : Type.
  Variable R : stream A -> stream A -> Prop.

  (* This is mechanically extracted from the definition of stream_eq *)
  Hypothesis H : forall s1 s2, R s1 s2 ->
    exists h, exists t1, exists t2,
      s1 = Cons h t1 /\ s2 = Cons h t2 /\ R t1 t2.

  Theorem stream_eq_coind1 : forall s1 s2 : stream A,
    R s1 s2 -> stream_eq s1 s2.
  Proof. cofix. intros s1 s2 H0. apply H in H0.
    destruct H0 as [h [t1 [t2 [H1 [H2 HR]]]]]. subst.
    apply Stream_eq. apply stream_eq_coind1. assumption.
  Qed.
End stream_eq_coind1.

(** We can now return to the proof of [ones_eq] *)

Theorem ones_eq' : stream_eq ones ones'.
Proof.
  apply stream_eq_coind1 with
    (R := fun s1 s2 => s1 = ones /\ s2 = ones'); [clear | tauto].
    (* We'll return later on how to mechanically construct the R
       from the statement of the theorem we're trying to prove.
       In this case what we do here corresponds to the [remember]
       we do before inducting on compound terms. *)
  intros s1 s2 [? ?]. subst. repeat esplit.
  rewrite (id_force_eq ones) at 1. simpl. reflexivity.
  rewrite (id_force_eq ones') at 1. simpl. reflexivity.
Qed.

(** The previous coinduction principle works, but it can be further
    simplified to reach a more standard formulation (commonly called
    Park's principle) that's easier to use in automated proofs. *)

Section stream_eq_coind.
  Variable A : Type.
  Variable R : stream A -> stream A -> Prop.

  (* We use head and tail instead of existential quantification *)
  Hypothesis H1 : forall s1 s2,
    R s1 s2 -> head s1 = head s2.
  Hypothesis H2 : forall s1 s2,
    R s1 s2 -> R (tail s1) (tail s2).

  (* We show that H1 /\ H2 is in equivalent the same as the previous H
     using existential quantification *)
  Lemma equiv : forall s1 s2, R s1 s2 ->
    ((exists h, exists t1, exists t2,
      s1 = Cons h t1 /\ s2 = Cons h t2 /\ R t1 t2)
    <->
    (head s1 = head s2 /\ R (tail s1) (tail s2))).
  Proof. clear; split; intros.
    destruct H0 as [h [t1 [t2 [H1 [H2 H3]]]]].
      subst. simpl. eauto.
    destruct H0 as [H1 H2].
      exists (head s1). exists (tail s1). exists (tail s2).
      destruct s1; destruct s2; simpl in *; subst; intuition.
  Qed.

  (* The proof of the coinduction principle is different; e.g. we
     don't need to use the id_force_eq trick *)
  Theorem stream_eq_coind : forall s1 s2 : stream A,
    R s1 s2 -> stream_eq s1 s2.
  Proof. cofix. intros s1 s2 H0. destruct s1. destruct s2.
    pose proof (H1 H0). simpl in *. subst.
    pose proof (H2 H0). simpl in *.
    apply Stream_eq. apply stream_eq_coind. assumption.
  Qed. (* Note: we didn't need to use the  *)

End stream_eq_coind.

(** We return again to the proof of [ones_eq] *)

Theorem ones_eq'' : stream_eq ones ones'.
Proof.
  apply stream_eq_coind with
    (R := fun s1 s2 => s1 = ones /\ s2 = ones'); crush.
Qed.

(** This principle is better in terms of automation. Let's try to
    use it to prove that [nats] and [nats'] are in [stream_eq].*)

Lemma nats_eq : stream_eq nats nats'.
Proof.
  apply stream_eq_coind with (R := fun s1 s2 => s1 = nats /\ s2 = nats');
    crush.
  (* At this point we get two goals that are wrong:
     [iterate S 1 = nats] and [nats_from_n 1 = nats']
     The co-induction hypothesis is not general enough! *)
Abort.

(** In the same way we had to strengthen the inductive hypothesis in
    [approx_nats_eq_helper], here we have to strengthen the
    co-inductive hypothesis *)

Lemma nats_eq_helper : forall n,
  stream_eq (iterate S n) (nats_from_n n).
Proof.
  intro n. apply stream_eq_coind with
    (R := fun s1 s2 => exists n, s1 = iterate S n /\ s2 = nats_from_n n);
      [crush | clear | eauto].
    intros ? ? [n [? ?]]. exists (S n); crush.
Qed.

Theorem nats_eq : stream_eq nats nats'.
Proof. apply nats_eq_helper. Qed.

(** Recipe for constructing the "bisimulation" relation

You have a goal of the form:
forall x1, ..., xn,
  H1 -> ... -> Hm ->
  P t1 ... tl

Where P is a coinductively defined predicate for which you've already
defined a coinduction principle P_coind. In order to call P_coind you
need to provide a predicate R. Here is a receipe to build R.

** Step 1 (remember)

Replace any argument tj that's not a variable from xs with a fresh
variable yj, universally quantify over yj at the top and add an
additional hypothesis Hj : yj = tk. Repeat this until the goal looks
like this:

forall x1, ..., xn,
  H1' -> ... -> Hm' ->
  P y1 ... yl

** Step 2 (linearize)

If a certain y appears twice in the proposition replace one of the
occurrences with a fresh variable y' and add an equality of the form
y = y' as a hypothesis.

[You don't really need to change your goal to this, just construct
this proposition in your mind.]

[This step corresponds to "remember"-ing compound terms before
 applying induction ]

** Step 3 (conjunction + existentials)

Construct the conjunction of all premises H1' /\ ... /\ Hm',
and existentially quantify over all xs that are not ys:
exists x1', exists x2', ... exists xn', H1' /\ ... /\ Hm'

** Step 4 (add a lambda on top)

Chose R to be (fun y1 ... yl =>
                 exists x1', exists x2', ... exists xn',
	           H1' /\ ... /\ Hm') and you're done.
*)

(* Exercise (medium): prove that ...*)
Theorem map_iterate : forall (A:Type) (f:A->A) (x:A),
                       stream_eq (iterate f (f x)) (map f (iterate f x)).
Proof.
  cofix; intros.
  apply (stream_eq_coind (fun s1 s2 : stream A => exists f : A -> A, exists x : A,
       s1 = iterate f (f x) /\ s2 = map f (iterate f x))). Guarded.
  intros. inversion H as [fe [xe ?]]. inversion_clear H0.
    rewrite H1; rewrite H2. reflexivity.
  Guarded.
  intros. inversion H as [fe [xe ?]]; inversion_clear H0. exists fe, (fe xe). rewrite H1, H2.
    constructor; reflexivity.
  Guarded.
    exists f, x. constructor; reflexivity. Guarded.
Qed.

(* Exercise: Define a co-inductive type Nat containing non-standard
natural numbers - this is, verifying
exists m : Nat, forall n : Nat, n < m. *)

(* Exercise: Prove that the equality of streams is an equivalence
   relation using the co-induction principle.  (Hint: try reflexivity
   first, then symmetry, then transitivity.) *)

Section stream_eq_eqv.
  Variable A : Type.

  Theorem stream_eq_refl : forall (s : stream A), stream_eq s s.
  Proof. (* it is longer with coinduction *)
    cofix; intros; destruct s; constructor. apply stream_eq_refl.
  Qed.

  Theorem stream_eq_symm : forall (s1 s2 : stream A), stream_eq s2 s1 -> stream_eq s1 s2.
  Proof.
    cofix; apply (stream_eq_coind (fun s1 s2 : stream A => stream_eq s2 s1));
    intros; destruct s1; destruct s2; inversion H; [ reflexivity | simpl; assumption ].
  Qed.

  (* tried to make this predicate 2-arity *)
  Theorem stream_eq_trans : forall (s1 s3: stream A), (exists s2, stream_eq s1 s2 /\ stream_eq s2 s3) -> stream_eq s1 s3.
  Proof.
    cofix;
    apply (stream_eq_coind (fun s1 s3 => exists s2, stream_eq s1 s2 /\ stream_eq s2 s3));
    intros; inversion H as [x H0]; inversion H0 as [H1 H2]; destruct x, s1, s2;
    inversion H1; inversion H2; [ reflexivity | exists x; auto ].
  Qed.
End stream_eq_eqv.

(* Exercise: Provide a suitable definition of "being an ordered list"
   for infinite lists and define a principle (similar to the Park
   principle) for proving that an infinite list is ordered.  Apply
   this method to the stream [nats].

   Hint: There are different ways of formulating the definition.  If
   you find yourself having trouble proving things, back up and see if
   you can state the definition a different way. *)

CoInductive ordered : stream nat -> Prop :=
  | OrdCons : forall s a, a <= head s -> ordered s -> ordered (Cons a s).

Section ordered_coind.
  Variable P : stream nat -> Prop.

  Hypothesis Head_case : forall a s, P (Cons a s) -> a <= head s.
  Hypothesis Tail_case : forall a s, P (Cons a s) -> P s.

  Theorem ordered_coind : forall s, P s -> ordered s.
  Proof.
    cofix; intros; destruct s;
      apply (OrdCons (Head_case H));
      apply Tail_case in H;
      apply ordered_coind.
    assumption.
  Qed.
End ordered_coind.

Require Import Arith.

Lemma ord_nats_S : forall n, ordered (iterate S n).
Proof.
  cofix; intros; rewrite id_force_eq; constructor;
  [ simpl; apply le_S; apply le_n | apply ord_nats_S ].
Qed.

Theorem ord_nats : ordered nats.
Proof.
  apply (ord_nats_S 0).
Qed.


From mathcomp Require Import all_ssreflect.

(** ** case

case というのは場合分けを行う tactic です。

証明項では match 式によって場合分けが行われるので、
case は証明項に match を構築する tactic といえます。

*)

(**

まず、bool 型の二重否定の除去の証明を見てみましょう。
(なお、難しい話を知っているひとに注意しておきますが、
これは bool の話であり、命題の話ではないので、直観主義論理でも問題なく証明できます。)

*)

Goal forall b, ~~ ~~ b = b.
Proof.
(**
SSReflect では、単に case. と指示すると、
証明すべき命題の最も外側の引数を場合分けします。
今回の場合、証明すべき命題は forall b : bool, ... という形なので、
この b を場合分けします。
*)
  case.
(**
このように場合分けすると、以下のようにふたつの subgoal が生成されます。
<<
2 subgoals
______________________________________(1/2)
~~ ~~ true = true
______________________________________(2/2)
~~ ~~ false = false
>>

この状態で証明項を表示すると以下のようになります。
*)
  Show Proof.
(**
<<
(fun _top_assumption_ : bool =>
 (fun (_evar_0_ : (fun b : bool => ~~ ~~ b = b) true)
    (_evar_0_0 : (fun b : bool => ~~ ~~ b = b) false) =>
  if _top_assumption_ as b return ((fun b0 : bool => ~~ ~~ b0 = b0) b)
  then _evar_0_
  else _evar_0_0) ?Goal ?Goal0)
>>

match じゃなくて if と表示されてしまったので、
Display all low-level contents を有効にして
Show Proof をやりなおすと以下のようになります。

<<
(fun _top_assumption_ : bool =>
 (fun (_evar_0_ : (fun b : bool => @eq bool (negb (negb b)) b) true)
    (_evar_0_0 : (fun b : bool => @eq bool (negb (negb b)) b) false) =>
  match
    _top_assumption_ as b
    return ((fun b0 : bool => @eq bool (negb (negb b0)) b0) b)
  with
  | true => _evar_0_
  | false => _evar_0_0
  end) ?Goal ?Goal0)
>>

これで、case が match を構築することが確認できました。

証明項をみると、まず、?Goal と ?Goal0 というふたつの未知の部分があることがわかります。
これは subgoal がふたつあることに対応しています。

また、?Goal は <<_evar_0_>> に束縛され、その型は (fun b : bool => ~~ ~~ b = b) true です。
この型はちょっと計算を進めると（ベータ展開すると）~~ ~~ true = true になるので、
?Goal は最初の subgoal に対応することが分かります。

同様に、?Goal0 は <<_evar_0_0>> に束縛され、最後の subgoal に対応することが分かります。

証明項全体は <<fun _top_assumption_ : bool => ...>> という形なので、
場合分けの対象の bool 値は <<_top_assumption_>> に束縛されます。

そして、（<<_evar_0_>> と <<_evar_0_0>> に今後行う証明を受け取った後）
以下の match で場合分けが行われます。
<<
match
  _top_assumption_ as b
  return ((fun b0 : bool => ~~ ~~ b0 = b0) b)
with
| true => _evar_0_
| false => _evar_0_0
end
>>

この match では <<_top_assumption_>> で場合分けを行い、
場合分けを行った値を b という変数に束縛した上で、
true もしくは false の分岐を評価します。
今回の場合は <<_evar_0_>> と <<_evar_0_0>> のどちらかの値（証明）を返すだけです。

そして、return のところに書いてある ((fun b0 : bool => ~~ ~~ b0 = b0) b) が
この match 式の型であり、また、各分岐の型にもなっています。

((fun b0 : bool => ~~ ~~ b0 = b0) b) は計算を進めると（ベータ展開すると）
~~ ~~ b = b となり、もともと証明すべき命題になっています。

true が選ばれたときを考えると、b は true になるので、
((fun b0 : bool => ~~ ~~ b0 = b0) true) が true の分岐の型であり、
ちょっと計算を進めると、~~ ~~ true = true になるので
分岐本体の <<_evar_0_>> と型が一致します。

同様に、false が選ばれたときは ((fun b0 : bool => ~~ ~~ b0 = b0) false) という型になり、
分岐本体の <<_evar_0_0>> と型が一致します。

というわけでどっちの分岐が選ばれても型は合うので、match 式自体の型は
（b は <<_top_asssumption_>> なので）、<<~~ ~~ _top_assumption_ = _top_assumption_>> になります。

これの外側を <<fun _top_assumption_ : bool => ...>> という関数抽象でくくってあるので、
全体の型は <<forall _top_assumption_ : bool, ~~ ~~ _top_assumption_ = _top_assumption_>>
であり、ローカル変数の名前を変換（アルファ変換）すると、<<forall b : bool, ~~ ~~ b = b>> という
もともと証明しようとしている命題と同じになることがわかります。

というわけで、あとは場合分けした結果の ~~ ~~ true = true と ~~ ~~ false = false の
証明を行えば証明項を完成できます。

~~ ~~ true と ~~ ~~ false には変数が含まれておらず、実際に計算を進めれば
true と false になります。
つまり、命題はすでに reflexivity で証明できるようになっています。
*)
    reflexivity.
  reflexivity.
  Show Proof.
(**
<<
(fun _top_assumption_ : bool =>
 (fun (_evar_0_ : (fun b : bool => ~~ ~~ b = b) true)
    (_evar_0_0 : (fun b : bool => ~~ ~~ b = b) false) =>
  if _top_assumption_ as b return ((fun b0 : bool => ~~ ~~ b0 = b0) b)
  then _evar_0_
  else _evar_0_0) (erefl true) (erefl false))
>>

証明項をみると、?Goal と ?Goal0 だったところに
reflexivity が構築した (erefl true) と (erefl false) が入っていることがわかります。
*)
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Omega.

Require Import utils pos vec.
Require Import subcode sss.

Set Implicit Arguments.

Tactic Notation "rew" "length" := autorewrite with length_db.

Local Notation "e #> x" := (vec_pos e x).
Local Notation "e [ v / x ]" := (vec_change e x v).

(** * Minsky Machines

    A Minsky machine has n registers and there are just two instructions

    1/ INC x   : increment register x by 1
    2/ DEC x k : decrement register x by 1 if x > 0
                 or jump to k if x = 0

  *)

Inductive mm_instr n : Set :=
  | mm_inc : pos n -> mm_instr n
  | mm_dec : pos n -> nat -> mm_instr n
  .

Notation INC := mm_inc.
Notation DEC := mm_dec.

(** ** Semantics for MM *)

Section Minsky_Machine.

  Variable (n : nat).

  Definition mm_state := (nat*vec nat n)%type.

  (* Minsky machine small step semantics *)

  Inductive mm_sss : mm_instr n -> mm_state -> mm_state -> Prop :=
    | in_mm_sss_inc   : forall i x v,                   INC x   // (i,v) -1> (1+i,v[(S (v#>x))/x])
    | in_mm_sss_dec_0 : forall i x k v,   v#>x = O   -> DEC x k // (i,v) -1> (k,v)
    | in_mm_sss_dec_1 : forall i x k v u, v#>x = S u -> DEC x k // (i,v) -1> (1+i,v[u/x])
  where "i // s -1> t" := (mm_sss i s t).

  Fact mm_sss_fun i s t1 t2 : i // s -1> t1 -> i // s -1> t2 -> t1 = t2.
  Proof.
    intros []; subst.
    inversion 1; subst; auto.
    inversion 1; subst; auto.
    rewrite H in H6; discriminate.
    inversion 1; subst; auto.
    rewrite H in H6; discriminate.
    rewrite H in H6; inversion H6; subst; auto.
  Qed.

  Fact mm_sss_total ii s : { t | ii // s -1> t }.
  Proof.
    destruct s as (i,v).
    destruct ii as [ x | x j ]; [ | case_eq (v#>x); [ | intros k ]; intros E ].
    * exists (1+i,v[(S (v#>x))/x]); constructor.
    * exists (j,v); constructor; auto.
    * exists (1+i,v[k/x]); constructor; auto.
  Qed.

  Fact mm_sss_INC_inv x i v j w : INC x // (i,v) -1> (j,w) -> j=1+i /\ w = v[(S (v#>x))/x].
  Proof. inversion 1; subst; auto. Qed.

  Fact mm_sss_DEC0_inv x k i v j w : v#>x = O -> DEC x k // (i,v) -1> (j,w) -> j = k /\ w = v.
  Proof.
    intros H; inversion 1; subst; auto; rewrite H in H2; try discriminate.
  Qed.

  Fact mm_sss_DEC1_inv x k u i v j w : v#>x = S u -> DEC x k // (i,v) -1> (j,w) -> j=1+i /\ w = v[u/x].
  Proof.
    intros H; inversion 1; subst; auto; rewrite H in H2; try discriminate.
    inversion H2; subst; auto.
  Qed.

(*
  Definition mm_step_stall := sss_step_stall mm_sss.
  Definition mm_program := (nat*list (mm_instr n))%type.
  Definition mm_steps := sss_steps mm_sss.
  Definition mm_compute := sss_compute mm_sss.
*)

  Notation "P // s -[ k ]-> t" := (sss_steps mm_sss P k s t).
  Notation "P // s -+> t" := (sss_progress mm_sss P s t).
  Notation "P // s ->> t" := (sss_compute mm_sss P s t).

  Fact mm_progress_INC P i x v st :
         (i,INC x::nil) <sc P
      -> P // (1+i,v[(S (v#>x))/x]) ->> st
      -> P // (i,v) -+> st.
  Proof.
    intros H1 H2.
    apply sss_progress_compute_trans with (2 := H2).
    apply subcode_sss_progress with (1 := H1).
    exists 1; split; auto; apply sss_steps_1.
    apply in_sss_step with (l := nil).
    simpl; omega.
    constructor; auto.
  Qed.

  Corollary mm_compute_INC P i x v st : (i,INC x::nil) <sc P -> P // (1+i,v[(S (v#>x))/x]) ->> st -> P // (i,v) ->> st.
  Proof. intros; apply sss_progress_compute; eapply mm_progress_INC; eauto. Qed.

  Fact mm_progress_DEC_0 P i x k v st :
         (i,DEC x k::nil) <sc P
      -> v#>x = O
      -> P // (k,v) ->> st
      -> P // (i,v) -+> st.
  Proof.
    intros H1 H2 H3.
    apply sss_progress_compute_trans with (2 := H3).
    apply subcode_sss_progress with (1 := H1).
    exists 1; split; auto; apply sss_steps_1.
    apply in_sss_step with (l := nil).
    simpl; omega.
    constructor; auto.
  Qed.

  Corollary mm_compute_DEC_0 P i x k v st : (i,DEC x k::nil) <sc P -> v#>x = O -> P // (k,v) ->> st -> P // (i,v) ->> st.
  Proof. intros; apply sss_progress_compute; eapply mm_progress_DEC_0; eauto. Qed.

  Fact mm_progress_DEC_S P i x k v u st :
         (i,DEC x k::nil) <sc P
      -> v#>x = S u
      -> P // (1+i,v[u/x]) ->> st
      -> P // (i,v) -+> st.
  Proof.
    intros H1 H2 H3.
    apply sss_progress_compute_trans with (2 := H3).
    apply subcode_sss_progress with (1 := H1).
    exists 1; split; auto; apply sss_steps_1.
    apply in_sss_step with (l := nil).
    simpl; omega.
    constructor; auto.
  Qed.

  Corollary mm_compute_DEC_S P i x k v u st : (i,DEC x k::nil) <sc P -> v#>x = S u -> P // (1+i,v[u/x]) ->> st -> P // (i,v) ->> st.
  Proof. intros; apply sss_progress_compute; eapply mm_progress_DEC_S; eauto. Qed.

  Fact mm_steps_INC_inv k P i x v st :
         (i,INC x::nil) <sc P
      -> k <> 0
      -> P // (i,v) -[k]-> st
      -> exists k', k' < k /\ P // (1+i,v[(S (v#>x))/x]) -[k']-> st.
  Proof.
    intros H1 H2 H4.
    apply sss_steps_inv in H4.
    destruct H4 as [ (? & ?) | (k' & st2 & ? & H4 & H5) ]; subst; auto.
    destruct H2; auto.
    apply sss_step_subcode_inv with (1 := H1) in H4.
    exists k'; split.
    omega.
    inversion H4; subst; auto.
  Qed.

  Fact mm_steps_DEC_0_inv k P i x p v st :
         (i,DEC x p::nil) <sc P
      -> k <> 0
      -> v#>x = 0
      -> P // (i,v) -[k]-> st
      -> exists k', k' < k /\ P // (p,v) -[k']-> st.
  Proof.
    intros H1 H2 H3 H4.
    apply sss_steps_inv in H4.
    destruct H4 as [ (? & ?) | (k' & st2 & ? & H4 & H5) ]; subst; auto.
    destruct H2; auto.
    apply sss_step_subcode_inv with (1 := H1) in H4.
    exists k'; split.
    omega.
    inversion H4; subst; auto.
    rewrite H3 in H9; discriminate.
  Qed.

  Fact mm_steps_DEC_1_inv k P i x p v u st :
         (i,DEC x p::nil) <sc P
      -> k <> 0
      -> v#>x = S u
      -> P // (i,v) -[k]-> st
      -> exists k', k' < k /\ P // (1+i,v[u/x]) -[k']-> st.
  Proof.
    intros H1 H2 H3 H4.
    apply sss_steps_inv in H4.
    destruct H4 as [ (? & ?) | (k' & st2 & ? & H4 & H5) ]; subst; auto.
    destruct H2; auto.
    apply sss_step_subcode_inv with (1 := H1) in H4.
    exists k'; split.
    omega.
    inversion H4; subst; auto; rewrite H3 in H9.
    discriminate.
    inversion H9; subst; auto.
  Qed.

End Minsky_Machine.

Local Notation "P // s -[ k ]-> t" := (sss_steps (@mm_sss _) P k s t).
Local Notation "P // s -+> t" := (sss_progress (@mm_sss _) P s t).
Local Notation "P // s ->> t" := (sss_compute (@mm_sss _) P s t).

Tactic Notation "mm" "sss" "INC" "with" uconstr(a) :=
  match goal with
    | |- _ // _ -+> _ => apply mm_progress_INC with (x := a)
    | |- _ // _ ->> _ => apply mm_compute_INC with (x := a)
  end; auto.

Tactic Notation "mm" "sss" "DEC" "0" "with" uconstr(a) uconstr(b) :=
  match goal with
    | |- _ // _ -+> _ => apply mm_progress_DEC_0 with (x := a) (k := b)
    | |- _ // _ ->> _ => apply mm_compute_DEC_0 with (x := a) (k := b)
  end; auto.

Tactic Notation "mm" "sss" "DEC" "S" "with" uconstr(a) uconstr(b) uconstr(c) :=
  match goal with
    | |- _ // _ -+> _ => apply mm_progress_DEC_S with (x := a) (k := b) (u := c)
    | |- _ // _ ->> _ => apply mm_compute_DEC_S with (x := a) (k := b) (u := c)
  end; auto.

Tactic Notation "mm" "sss" "stop" := exists 0; apply sss_steps_0; auto.

(* The Halting problem for MM, for linear logic encoding, we restrict
   to a very specific halting problem. Starting from (1,v), does the
   MM halt at state (0,vec_zero) *)

Definition MM_PROBLEM := { n : nat & { P : list (mm_instr n) & vec nat n } }.

Local Notation "P // s ~~> t" := (sss_output (@mm_sss _) P s t).

Definition MM_HALTING (P : MM_PROBLEM) :=
  match P with existT _ n (existT _ P v) => (1,P) // (1,v) ~~> (0,vec_zero) end.


From Coq Require Import Arith.

Fixpoint le_bool (n m : nat ) : bool :=
  match n,m with
    | 0,_ => true
    | _,0 => false
    | S n, S m => le_bool n m
  end.

Lemma le_bool_ok_true :
  forall n m, le_bool n m = true -> le n m.
Proof.
  induction n.

  intros m _;induction m.
  constructor.
  constructor;exact IHm.

  intros [|m].
  intros abs;discriminate abs.
  simpl;intros h.
  apply le_n_S.
  apply IHn. exact h.
Qed.


From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq fintype.

Section SeqSet.

  (* Let T be any type with decidable equality. *)
  Context {T: eqType}.

  (* We define a set as a sequence that has no duplicates. *)
  Record set :=
  {
    _set_seq :> seq T ;
    _ : uniq _set_seq (* no duplicates *)
  }.

  (* Now we add the [ssreflect] boilerplate code. *)
  Canonical Structure setSubType := [subType for _set_seq].
  Definition set_eqMixin := [eqMixin of set by <:].
  Canonical Structure set_eqType := EqType set set_eqMixin.
  Canonical Structure mem_set_predType := PredType (fun (l : set) => mem_seq (_set_seq l)).
  Definition set_of of phant T := set.

End SeqSet.

Notation " {set R } " := (set_of (Phant R)).

Section Lemmas.

  Context {T: eqType}.
  Variable s: {set T}.

  Lemma set_uniq : uniq s.
  Proof.
    by destruct s.
  Qed.

End Lemmas.


Goal forall n : nat, n * 1 = n.
intros.
elim n.
simpl.
reflexivity.
intros.
simpl.
rewrite H.
reflexivity.

Fixpoint f (n : nat) : nat :=
match n with
| 0 => 1
| S p => (2 * (f p))
end.

Goal f(10) = 1024.
simpl.
reflexivity.

Open Scope list.
Require Import List.
Import ListNotations.

Lemma P1 : forall E : Type, forall l : (list E) , forall e : E, rev(l ++ [e]) = e :: rev l.
intros.
elim l.
simpl.
reflexivity.
intros.
simpl.
rewrite H.
simpl.
reflexivity.

Save.

Lemma P2 : forall E : Type, forall l : (list E), rev( rev( l) ) = l.
intros.
elim l.
simpl.
reflexivity.
intros.
simpl.
rewrite (P1 E (rev l0) a).
rewrite H.
reflexivity.

Save.

Lemma my_eq_nat_dec : forall n m : nat, {n = m} + {n <> m}.
double induction n m.
left.
reflexivity.
intros.
right.
discriminate.
intros.
right.
discriminate.
intros.
elim (H0 n0).
left.
elim a.
reflexivity.
right.
congruence.

Save.

Lemma my_eq_nat_dec2  : forall n m : nat, {n = m} + {n <> m}.
intros.
decide equality.

Save.

Fixpoint function_equality (a b : nat) : bool :=
match a with
| 0 => match b with
       | 0 =>  true
       | S p => false
       end
| S p1 => match b with
          | 0 => false
          | S p2 => (function_equality p1 p2)
          end
end.

Save.

Eval compute in (function_equality 0 0).
Eval compute in (function_equality (S 0) 0).
Eval compute in (function_equality (S 0) (S 0)).

Inductive BinTree : Set :=
| Leaf : nat -> BinTree
| Node : nat -> BinTree -> BinTree -> BinTree.

Save.

Lemma my_eq_nat_Tree : forall n m : BinTree, {n = m} + {n <> m}.
induction n.
induction m.
elim (my_eq_nat_dec n n0).
left.
rewrite a.
reflexivity.
right.
congruence.
right.
discriminate.
induction m.
right.
discriminate.
elim (my_eq_nat_dec n1 n).
intros.
rewrite a.
elim (IHn1 m1).
intros.
rewrite a0.
elim (IHn2 m2).
intros.
rewrite a1.
left.
reflexivity.
intros.
right.
congruence.
right.
congruence.
right.
congruence.

Save.

Lemma my_eq_nat_Tree2 : forall n m : BinTree, {n = m} + {n <> m}.
intros.
decide equality.
elim (my_eq_nat_dec2 n0 n1).
left.
rewrite a.
reflexivity.
right.
congruence.
elim (my_eq_nat_dec2 n0 n1).
left.
rewrite a.
reflexivity.
right.
congruence.

Inductive is_even : nat -> Prop :=
| is_even_0 : is_even 0
| is_even_S : forall n : nat, is_even n -> is_even (S (S n)).

Fixpoint is_even_tac (n : nat) : bool :=
match n with
| 0 => true
| 1 => false
| S (S p) => (is_even_tac p)
end.

Ltac is_event_tac :=
repeat apply is_even_S;
apply is_even_0.

Eval compute in (is_even_tac (S (S 0))).
Eval compute in (is_even_tac (S (S (S 0)))).

Open Scope nat_scope.
Check (S (S 0)).

Save.

Lemma test_even : (is_even (S(S(S(S 0))))).
is_event_tac.

Save.

Goal ~(is_even 7).
intro.
inversion_clear H.
inversion_clear H0.
inversion_clear H.
inversion_clear H0.

Ltac is_event_tac_tild :=
intro;
repeat (match goal with
| H : is_even ?e |- _ => inversion_clear H
end).

Goal ~(is_even 9).
is_event_tac_tild.

Inductive is_perm : list nat -> list nat -> Prop :=
| is_perm_append : forall n : nat, forall l : list nat, (is_perm (n::l) (l++[n]))
| is_perm_syme : forall l1 : list nat, forall l2 : list nat, (is_perm l1 l2) -> (is_perm l2 l1)
| is_perm_refl : forall l : list nat, is_perm l l
| is_perm_trans : forall l1 l2 l3 : list nat , is_perm l1 l2 -> is_perm l2 l3 -> is_perm l1 l3
| is_perm_cons : forall n : nat, forall l1 l2 : list nat, is_perm l1 l2 -> is_perm (n::l1) (n::l2)
.

Lemma is_perm_ex1 : is_perm (1::2::3::nil) (3::2::1::nil).
Proof.
apply (is_perm_trans (1::2::3::nil) ((2::3::nil) ++ 1::nil) (3::2::1::nil)).
apply is_perm_append.
simpl.
apply (is_perm_trans (2::3::1::nil) ((3::1::nil) ++ 2::nil) (3::2::1::nil)).
apply is_perm_append.
simpl.
apply is_perm_cons.
apply (is_perm_trans (1::2::nil) ((2::nil) ++ 1::nil) (2::1::nil)).
apply is_perm_append.
simpl.
apply is_perm_cons.
apply is_perm_refl.

Save.


From Nominal Require Export Name.

Definition Swap: Type := (Name * Name).

Definition swap '(a,b): Name → Name :=
  λ c, if decide (a = c) then b else if decide (b = c) then a else c.

Notation "⟨ a , b ⟩" := (@cons Swap (a,b) nil).

Section SwapProperties.
  Context (a b c d: Name).

  Lemma swap_left: swap (a,b) a = b.
  Proof. simpl; repeat case_decide; congruence. Qed.

  Lemma swap_right: swap (a,b) b = a.
  Proof. simpl; repeat case_decide; congruence. Qed.

  Lemma swap_neither1: a ≠ c → b ≠ c → swap (a, b) c = c.
  Proof. intros; simpl; repeat case_decide; congruence. Qed.

  Lemma swap_neither2: swap (a, b) c = c → (a ≠ c ∧ b ≠ c) ∨ (a = c ∧ b = c).
  Proof.
    intros; simpl in *; try repeat case_decide; subst;
        [right | congruence | left]; auto.
  Qed.

  Lemma swap_neq: a ≠ b → swap (c, d) a ≠ swap (c, d) b.
  Proof. intros; simpl; repeat case_decide; congruence. Qed.

  Lemma swap_id: swap (a,a) c = c.
  Proof. simpl; case_decide; congruence. Qed.

  Lemma swap_involutive p: swap p (swap p a) = a.
  Proof. destruct p; simpl; repeat case_decide; congruence. Qed.
End SwapProperties.