(**
 Mini projet de Coq (INF 462)

 Se fait par groupe de 2 ou 3 d'un meme groupe de TD

 Date de remise :  4 novembre
                   On envoie a) un fichier dont le nom contient au moins
                   un participant du groupe :
                   exemple projet_dupont.v

                   un rapport (format pdf) rapport_dupont.pdf

                   dans un courrier dont le titre contient la chaine de
                   caracteres  PROJET COQ, adresse a **votre** responsable de
                   TD.

 Le fichier comporte un certain nombre d'Admitted, qu'il s'agit de
 remplacer par des preuves completes.

 Que doit contenir le rapport ?
 1) la reponse aux questions a la fin de ce fichier

 2) si une preuve utilise un lemme de la bibliotheque standard, et/ou
  une tactique  non vue en cours mais trouvée dans la doc, le signaler

 3) des commentaires sur les lemmes ou definitions auxiliaires non demandes
   dans le sujet mais que vous avez trouve utile d'ajouter

 4) Les etapes principales d'une preuve qui vous paraissent interessantes
 (choix d'une recurrence sur un type de donnee ou un predicat, utilisation
  d'inversion, injection, etc.)

 5) Les problemes que vous avez rencontres et pourquoi vous n'avez pas su les
    resoudre.

6) En revanche, ne mettez pas dans le rapport les informations qu'on peut
   trouver dans votre fichier .v  (en le lisant sous coqIde ou Proof-General)
   ce serait du remplissage inutile.

FAQ.

 Si vous rencontrez des (vraies) difficultes, ecrivez aux *deux* chargés de
 TD (Frederique Carrere et Pierre Casteran). Les reponses seront ajoutees
 au fichier http://www.labri.fr/~casteran/FM/Logique/FAQ.txt

*)

Require Import Arith.
Require Import Max.
Require Import ArithRing.
Require Import List.

(* On considere les definitions suivantes *)

Inductive btree(A:Type): Type :=
  leaf : btree A
| bin : A -> btree A -> btree A -> btree A.

Implicit Arguments  leaf [A].
Implicit Arguments  bin [A].

Definition tree_example := bin 6 (bin 7 leaf leaf)
                                 (bin 8 (bin 3 leaf leaf)
                                        (bin 8 leaf leaf)).

Fixpoint tree_size {A:Type}(t: btree A):=
 match t with leaf => 1
            | bin _ t1 t2 => 1 + tree_size t1 + tree_size t2
 end.

Fixpoint tree_mirror {A:Type}(t: btree A):=
 match t with leaf => leaf
            | bin i t1 t2 => bin i (tree_mirror t2) (tree_mirror t1)
 end.

Eval compute in tree_size tree_example.

Eval compute in tree_mirror tree_example.

(* 1- definir une fonction is_leaf qui retourne true si un arbre est une feuille
                                                false sinon *)

Definition is_leaf {A: Type}(t: btree A) : bool :=
   match t with
      leaf => true
    | _ => false end.

Eval compute in is_leaf tree_example.

(* Vous devrez ensuite prouver le lemme suivant *)

Lemma leaf_is_leaf : forall (A:Type)(t: btree A),
   is_leaf t = true <-> t = leaf.
Proof.
induction t.
split.
unfold is_leaf.
trivial.
unfold is_leaf.
trivial.
split.
unfold is_leaf.
intros.
discriminate.
intros.
unfold is_leaf.
discriminate.
Qed.

(* 2- Prouver les lemmes suivants *)

Lemma mirror_mirror : forall (A:Type)(t: btree A),
    tree_mirror (tree_mirror t) = t.
Proof.
induction t.
unfold tree_mirror.
trivial.
symmetry.
simpl.
rewrite IHt1.
rewrite IHt2.
trivial.
Qed.

Lemma mirror_size : forall (A:Type)(t: btree A),
    tree_size (tree_mirror t) = tree_size t.
Proof.
induction t.
simpl.
trivial.
simpl.
rewrite IHt1.
rewrite IHt2.
rewrite plus_comm.
trivial.
Qed.

(* 3- On definit les fonctions number_of_bin et number_of_leaves *)

Fixpoint number_of_bin {A:Type}(t: btree A):=
 match t with leaf => 0
            | bin i t1 t2 => 1 + number_of_bin t1 + number_of_bin t2
 end.

Fixpoint  number_of_leaves {A:Type} (t : btree A) : nat :=
  match t with leaf => 1
             | bin r t1 t2 =>  number_of_leaves t1 + number_of_leaves t2
  end.

(* Prouver le lemme suivant *)

Lemma bin_n_leaves : forall (A:Type)(t: btree A),
            number_of_leaves t = S (number_of_bin t).
Proof.
induction t.
unfold number_of_leaves.
trivial.
simpl.
rewrite IHt1.
rewrite IHt2.
rewrite plus_n_Sm.
simpl.
trivial.
Qed.

(* 4- On definit la fonction tree_to_list *)

Fixpoint tree_to_list {A:Type}(t: btree A) : list A :=
 match t with leaf => nil
            | bin n t1 t2 => tree_to_list t1 ++ (n :: tree_to_list t2)
 end.

(* Prouver le lemme suivant *)

Lemma tree_to_list_length :  forall A (t:btree A),
    length (tree_to_list t) = number_of_bin t.
Proof.
induction t.
unfold number_of_bin.
unfold tree_to_list.
trivial.
simpl.

symmetry in IHt1.
symmetry in IHt2.
rewrite IHt1.
rewrite IHt2.
rewrite plus_n_Sm.
symmetry.
destruct IHt1.
destruct IHt2.
rewrite plus_n_Sm.
unfold tree_to_list.
simpl.
rewrite plus_Sn_m.
simpl.
unfold tree_to_list.
rewrite IHt2.
unfold length.
simpl.

simpl.
unfold number_of_bin.
simpl.
unfold
rewrite IHt1.
Admitted.

(* 5- on considere la definition suivante *)

Fixpoint tree_fold {A B:Type}(f: A -> B -> B -> B)(b:B) (t : btree A) :=
 match t with leaf => b
            | bin a t1 t2 => f a (tree_fold f b t1)
                                 (tree_fold f b t2)
 end.

(* donner une nouvelle definition de tree_size, tree_to_list , mirror
   sous la forme suivante

Definition tree_size' {A:Type}(t : btree A) :=  tree_fold  XXX YYY t
Definition tree_mirror'{A:Type}(t : btree A) := tree_fold TTT UUU t.

prouver que vos nouvelles definitons sont equivalentes aux precedentes.

*)

(* 6- On definit les fonctions the_subtree et Subtree
      de la maniere suivante: *)

Inductive direction : Set := g (* gauche *) | d (* droite *).
Definition path := list direction.

Fixpoint the_subtree  {A:Type} (p:path)(t: btree A) : btree A :=
    match p, t with nil, _ =>  t
                  |g::p', bin _ t1 _ => the_subtree p' t1
                  |d::p', bin _ _ t2  => the_subtree p' t2
                  | _ ,  _ => leaf
    end.

Definition Subtree {A:Type} (t t': btree A) :=
                exists p, the_subtree p t' = t.

(* Prouver les lemmes suivants *)

Lemma Subtree_refl : forall A (t:btree A), Subtree t t.
Proof.
Admitted.

Lemma the_subtree_app : forall  A p1 p2 (t : btree A),
                          the_subtree (p1 ++ p2) t =
                          the_subtree p2 (the_subtree p1 t).
Proof.
Admitted.

Lemma Subtree_trans :forall A (t t1 t2:btree A), Subtree t t1->
                                                 Subtree t1 t2 ->
                                                 Subtree t t2.
Proof.
Admitted.

(* 7- Demontrer le lemme suivant *)

Lemma not_left_son_of_itselt :
   forall (A:Type)(a:A)(t1 t2:btree A), t1 <> bin a t1 t2.
Proof.
Admitted.

(* 8- On considere les definitions suivantes *)

Fixpoint h_l {A:Type}(t:btree A) : nat :=
  match t with leaf => 0
             | bin _ t1 _ => 1 + h_l t1
  end.

Fixpoint test_aux  {A:Type}(t:btree A)(h:nat) :=
 match t,h with leaf,0 => true
              | bin _ t1 t2, S h' => andb (test_aux t1 h') (test_aux t2 h')
              | _ , _ => false
 end.

Definition test {A:Type}(t:btree A) := test_aux t (h_l t).

(* Dans le rapport, donnez  une caracterisation des arbres t tels
que l'evaluation de test t renvoie true. Expliquez votre reponse.

 On vous demande egalement de prouver vos affirmations (en Coq, bien sur).

 Votre caracterisation prendra la forme d'un predicat

 Caracterisation {A:Type} : btree A -> Prop.

 Il va  de soi qu'une reponse caricaturale n'apportant rien, genre

 Definition Caracterisation {A:Type} (t: btree A) := test t = true.

 ne serait meme pas consideree.

 En revanche, vous pouvez definir les fonctions, predicats et prouver
 les lemmes qui vous paraissent utiles, et commenter vos decisions  dans le
 rapport *)


Require Import Equations.Prop.Equations.
Require Import Arith.
Require Import Compare_dec.

Inductive term : Set :=
| Var (n : nat)
| Lam (t : term)
| App (t : term) (l : list term).

Equations subst_var (k : nat) (u : term) (t : nat) : term :=
  subst_var k u n with k ?= n =>
   { | Eq => u;
     | Gt => Var n;
     | Lt => Var (pred n) }.

Equations subst_term (k : nat) (u : term) (t : term) : term := {
subst_term k u (Var n) => subst_var k u n;
subst_term k u (Lam t) => Lam (subst_term (S k) u t);
subst_term k u (App t l) => App (subst_term k u t) (subst_tlist k u l) }

where subst_tlist (k : nat) (u : term) (t : list term) : list term := {
  subst_tlist k u nil := nil;
  subst_tlist k u (cons t ts) := cons (subst_term k u t) (subst_tlist k u ts) }.
  (* id_tlist t := List.map id_term t }. *)

Lemma subst_subst k u t : subst_term k u t = subst_term k u t.
Proof.
  revert k u t.
  refine (fst (subst_term_elim (fun k u t c => c = c) (fun k u l c => c = c) _ _ _ _ _));
  trivial.
Qed.


Require Import ZArith.
Require Import Coq.Arith.Compare_dec.
Require Import String.
Require Import Coq.Lists.List.
Import ListNotations.

Section ListUtil.

Variable V : Set.
Hypothesis V_eq_dec : forall x y : V, { x = y } + { x <> y }.

(* TODO: prove *)
Axiom edge_eq_dec :
	forall (x y : prod String String), { x = y } + { x <> y }.

Fixpoint FilterLenGEQ (L : list String) (a : String) : list String :=
	match L with
	| [] => []
	| b :: R =>
		if le_lt_dec (length a) (length b) then
			b :: FilterLenGEQ R a
		else
			FilterLenGEQ R a
	end.

Fixpoint StalinSort (L : list String) : list String :=
	match L with
	| [] => []
	| a :: R => a :: FilterLenGEQ (StalinSort R) a
	end.

Definition FilterMax (L : list String) : list String :=
	rev (StalinSort (rev (StalinSort L))).

Fixpoint RemoveFirst (L : list V) (a : V) : list V :=
	match L with
	| [] => []
	| b :: R => if V_eq_dec a b then R else (b :: (RemoveFirst R a))
	end.

Fixpoint RemoveAll (L : list V) (a : V) : list V :=
	match L with
	| [] => []
	| b :: R => if V_eq_dec a b then RemoveAll R a else (b :: RemoveAll R a)
	end.

Fixpoint Contains (L : list V) (a : V) : bool :=
	match L with
	| [] => false
	| b :: R => if V_eq_dec a b then true else Contains R a
	end.

Fixpoint Count (L : list V) (a : V) : nat :=
	match L with
	| [] => 0
	| b :: R =>
		if V_eq_dec a b then
			1 + (Count R a)
		else
			Count R a
	end.

Fixpoint RemoveDuplicates' (S L : list V) : list V :=
	match L with
	| [] => S
	| a :: R =>
		if Contains S a then
			RemoveDuplicates' S R
		else
			RemoveDuplicates' (a :: S) R
	end.

Definition RemoveDuplicates (L : list V) : list V :=
	RemoveDuplicates' [] L.

Fixpoint RemoveList (L S : list V) : list V :=
	match S with
	| [] => L
	| a :: R => RemoveList (RemoveFirst L a) R
	end.

Fixpoint StrSuffixes (L : list String) : list String :=
	match L with
	| [] => []
	| a :: R => (suff a) :: StrSuffixes R
	end.

Fixpoint StrPrefixes (L : list String) : list String :=
	match L with
	| [] => []
	| a :: R => (pref a) :: StrPrefixes R
	end.

Fixpoint StrMaxLen' (L : list String) (n : nat) {struct L} : nat :=
	match L with
	| [] => n
	| a :: R => StrMaxLen' R (max n (length a))
	end.

Definition StrMaxLen (L : list String) : nat := StrMaxLen' L 0.

Variable U : Set.
Hypothesis U_le : U -> U -> bool.
Hypothesis U_le_dec :
	forall (x y : U), { U_le x y = true } + { U_le y x = true }.

Fixpoint InsertSorted (L : list U) (z : U) : list U :=
	match L with
	| [] => [z]
	| a :: R =>
		if U_le_dec z a then
			z :: a :: R
		else
			a :: InsertSorted R z
	end.

Fixpoint Sort' (L S : list U) {struct L} : list U :=
	match L with
	| [] => S
	| a :: R => Sort' R (InsertSorted S a)
	end.

Definition Sort (L : list U) : list U :=
	Sort' L [].

End ListUtil.


From iris.proofmode Require Export tactics.
From iris.program_logic Require Export weakestpre total_weakestpre.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import proofmode notation.
From iris.prelude Require Import options.

Inductive tree :=
  | leaf : Z → tree
  | node : tree → tree → tree.

Fixpoint is_tree `{!heapGS Σ} (v : val) (t : tree) : iProp Σ :=
  match t with
  | leaf n => ⌜v = InjLV #n⌝
  | node tl tr =>
     ∃ (ll lr : loc) (vl vr : val),
       ⌜v = InjRV (#ll,#lr)⌝ ∗ ll ↦ vl ∗ is_tree vl tl ∗ lr ↦ vr ∗ is_tree vr tr
  end%I.

Fixpoint sum (t : tree) : Z :=
  match t with
  | leaf n => n
  | node tl tr => sum tl + sum tr
  end.

Definition sum_loop : val :=
  rec: "sum_loop" "t" "l" :=
    match: "t" with
      InjL "n" => "l" <- "n" + !"l"
    | InjR "tt" => "sum_loop" !(Fst "tt") "l" ;; "sum_loop" !(Snd "tt") "l"
    end.

Definition sum' : val := λ: "t",
  let: "l" := ref #0 in
  sum_loop "t" "l";;
  !"l".

Lemma sum_loop_wp `{!heapGS Σ} v t l (n : Z) :
  [[{ l ↦ #n ∗ is_tree v t }]]
    sum_loop v #l
  [[{ RET #(); l ↦ #(sum t + n) ∗ is_tree v t }]].
Proof.
  iIntros (Φ) "[Hl Ht] HΦ".
  iInduction t as [n'|tl ? tr] "IH" forall (v l n Φ); simpl; wp_rec; wp_let.
  - iDestruct "Ht" as "%"; subst.
    wp_load. wp_store.
    by iApply ("HΦ" with "[$Hl]").
  - iDestruct "Ht" as (ll lr vl vr ->) "(Hll & Htl & Hlr & Htr)".
    wp_load. wp_apply ("IH" with "Hl Htl"). iIntros "[Hl Htl]".
    wp_load. wp_apply ("IH1" with "Hl Htr"). iIntros "[Hl Htr]".
    iApply "HΦ". iSplitL "Hl".
    { by replace (sum tl + sum tr + n)%Z with (sum tr + (sum tl + n))%Z by lia. }
    iExists ll, lr, vl, vr. by iFrame.
Qed.

Lemma sum_wp `{!heapGS Σ} v t :
  [[{ is_tree v t }]] sum' v [[{ RET #(sum t); is_tree v t }]].
Proof.
  iIntros (Φ) "Ht HΦ". rewrite /sum' /=.
  wp_lam. wp_alloc l as "Hl".
  wp_smart_apply (sum_loop_wp with "[$Hl $Ht]").
  rewrite Z.add_0_r.
  iIntros "[Hl Ht]". wp_load. by iApply "HΦ".
Qed.


Require Import List.

Inductive Typ : Set :=
  | Top : Typ
  | Imp : Typ -> Typ -> Typ
  | Cnj : Typ -> Typ -> Typ.

Inductive Trm : Set :=
  | top : Trm
  | hyp : nat -> Trm
  | lam : Typ -> Trm -> Trm
  | app : Trm -> Trm -> Trm
  | cnj : Trm -> Trm -> Trm
  | proj_1 : Trm -> Trm
  | proj_2 : Trm -> Trm.

Definition  Cntxt := list Typ.

Inductive Tyty : Cntxt -> Trm -> Typ -> Prop :=
  | ND_top_intro : forall G, Tyty G top Top
  | ND_hypO : forall G A, Tyty (A :: G) (hyp 0) A
  | ND_hypS :
      forall G A B I,
      Tyty G (hyp I) A -> Tyty (B :: G) (hyp (S I)) A
  | ND_lam :
      forall G t A B,
      Tyty (A :: G) t B -> Tyty G (lam A t) (Imp A B)
  | ND_app :
      forall G t s A B,
      Tyty G t (Imp A B) -> Tyty G s B -> Tyty G (app t s) B
  | ND_cnj :
      forall G t s A B,
      Tyty G t A -> Tyty G s B -> Tyty G (cnj t s) (Cnj A B)
  | ND_proj_1 :
      forall G t A B,
      Tyty G t (Cnj A B) -> Tyty G (proj_1 t) A
  | ND_proj_2 :
      forall G t A B,
      Tyty G t (Cnj A B) -> Tyty G (proj_2 t) B.

Notation "G '⊢' t '[:]' A" := (Tyty G t A) (at level 70, no associativity) : type_scope.

Notation "'⊢' t '[:]' A" := (Tyty nil t A) (at level 70, no associativity) : type_scope.

Class Category := {
  Obj :> Type;

  uHom := Type : Type;

  Hom : Obj -> Obj -> uHom;

  Id : forall x, Hom x x;

  Dom {x y} (f: Hom x y) := x;

  CoDom {x y} (f: Hom x y) := y;

  Compose : forall {x y z}, (Hom y z)->(Hom x y)->(Hom x z);

  assoc : forall x y z w (f : (Hom z w)) (g:(Hom y z)) (h:(Hom x y)),
        (Compose f (Compose g h) ) = (Compose (Compose f g) h);

  id_1 : forall x y (f : (Hom x y)), (Compose f (Id x)) = f ;

  id_2 : forall x y (f : (Hom x y)), (Compose (Id y) f) = f ;

}.

Notation "x → y" := (Hom x y) (at level 90, right associativity) :
type_scope.

Notation "g ∘ f" := (Compose g f) (at level 40, left associativity) :
type_scope.

Context {CC : Category}.

Class CartClosed := {

(* terminal *)

  Top_obj : Obj;

  Top_mor : forall {x}, x → Top_obj;

  unique_top : forall {x} (f : x → Top_obj), f = Top_mor;

(* szorzat *)

  Prod_obj : Obj -> Obj -> Obj;

  Prod_mor : forall {x y z} (f:x → y) (g:x → z), x → Prod_obj y z;

  First {x y} : (Prod_obj x y) → x;
  Second {x y} : (Prod_obj x y) → y;

  prod_ax : forall {x y z} (f : x → y) (g : x → z),
    (First ∘ (Prod_mor f g) = f) /\ (Second ∘ (Prod_mor f g) = g);

  unique_prod : forall {x y z} (f : x → y) (g : x → z) (h : x → Prod_obj y
z),
    ((First ∘ h) = f) /\ ((Second ∘ h) = g) -> h = Prod_mor f g;

(* exponenciális *)

  Exp_obj : Obj -> Obj -> Obj;

  Exp_mor : forall {y z}, (Prod_obj (Exp_obj z y) y) → z;

  Lam : forall {x y z} (g : (Prod_obj x y) → z), x → (Exp_obj z y);

  exp_ax : forall {x y z} (g : (Prod_obj x y) → z),
    Exp_mor ∘ (Prod_mor (Compose (Lam g) First) (Compose (Id y) Second)) = g;

  unique_exp : forall {x y z} (h : x → Exp_obj z y),
    Lam (Exp_mor ∘ (Prod_mor (Compose h First) (Compose (Id y) Second))) = h
}.

Notation "⊤" := (Top_obj) (at level 40, no
associativity) : type_scope.

Notation "'〈' x ',' y '〉'" := (Prod_mor x y) (at level 40, no
associativity) : type_scope.

Notation "x × y" := (Prod_obj x y) (at level 40, left associativity) :
type_scope.

Notation "x 'e↑' y" := (Exp_obj x y) (at level 80, right associativity) :
type_scope.

Notation "f '⊠' g" := (Prod_mor (Compose f First) (Compose g Second)) (at level 40, left associativity) :
type_scope.

Context {CCC : CartClosed}.

Structure VAL : Type := makeVAL
  { V :> Typ -> Obj;
    VAL_top : V Top = Top_obj;
    VAL_imp : forall {A B}, V (Imp A B) = Exp_obj (V B) (V A);
    VAL_Cnj : forall {A B}, V (Cnj A B) = Prod_obj (V A) (V B);
  }.

Fixpoint VAL_Cntxt (v : VAL) (G : list Typ) :=
  match G with
    | nil => Top_obj
    | A :: G' => Prod_obj (v A) (VAL_Cntxt v G')
  end.

Notation "'[[' G ']]_C' v" := (VAL_Cntxt v G) (at level 40, no associativity) :
type_scope.

(*Bemelegítő példák*)

Lemma verum : forall A B, exists t, ⊢ t [:] (Imp A (Imp B A)).
Proof.
  intros.
  exists (lam A (lam B (hyp 1))).
  apply ND_lam.
  apply ND_lam.
  apply ND_hypS.
  apply ND_hypO.
  Show Proof.
Qed.

Lemma problem_cont : forall (v: VAL) G A,
(v A) × ([[ G ]]_C v) = [[ A :: G ]]_C v.
Proof.
  intros.
  all: simpl; auto.
Qed.

Lemma problem_1 : forall x y z (g : x × y → z) (h : x → (z e↑ y) ), g = eval ∘ (h × id y) -> Lam g = h.


From Typonomikon Require Import F3.

CoInductive Odd (c : conat) : Type :=
{
  Oz  : c = zero -> False;
  Oss : forall {c' : conat}, c = succ (succ c') -> Odd c';
}.

Lemma p0 : Odd zero -> False.
Proof.
  destruct 1.
  apply Oz0.
  reflexivity.
Defined.

Lemma p2 : Odd (succ (succ zero)) -> False.
Proof.
  destruct 1.
  specialize (Oss0 _ eq_refl).
  apply p0.
  assumption.
Defined.


Require Import Basics.Utf8 Basics.Overture Basics.Tactics.
Require Import Types.Forall.
Require Import WildCat.Core WildCat.Prod WildCat.Bifunctor
  WildCat.Equiv WildCat.NatTrans.

Section Monoidal.
  Context (C : Type).
  Context `{Is1Cat C}.
  Context `{HasEquivs C}.
  Context (tensor : C -> C -> C).
  Context `{!IsBifunctor tensor}.

  Definition left_assoc : C -> C -> C -> C :=
    fun a b c => tensor (tensor a b) c.

  Definition right_assoc : C -> C -> C -> C :=
    fun a b c => tensor a (tensor b c).

  Let right_assoc' := uncurry (uncurry (right_assoc)).
  Let left_assoc' := uncurry (uncurry (left_assoc)).

  #[export] Instance Is0Functor_right_assoc
    : Is0Functor right_assoc'.
  Proof.
    srapply Build_Is0Functor.
    intros [[a1 b1] c1] [[a2 b2] c2] [[f g] h];
      cbn in f, g, h.
    exact (fmap11 tensor f (fmap11 tensor g h)).
  Defined.

  #[export] Instance Is0Functor_left_assoc : Is0Functor left_assoc'.
  Proof.
    srapply Build_Is0Functor.
    intros [[a1 b1] c1] [[a2 b2] c2] [[f g] h];
      cbn in f, g, h.
    exact (fmap11 tensor (fmap11 tensor f g) h).
  Defined.

  (* Left to right is the convention in Mac Lane. *)
  Class Associator := assoc : NatEquiv right_assoc' left_assoc'.

  Notation "a ⊗ b" := (tensor a b).

  Definition PentagonLaw `{Associator} (a b c d : C) :=
    (assoc (a ⊗ b, c, d)) $o (assoc (a, b, c ⊗ d)) $==
      (fmap (flip tensor d) (assoc (a, b, c)))
      $o assoc (a, b ⊗ c, d) $o (fmap (tensor a) (assoc (b, c, d))).

  Context (I : C).

  Class LeftUnitor := left_unitor : NatEquiv (tensor I) idmap.

  Class RightUnitor := right_unitor : NatEquiv (flip tensor I) idmap.

  Definition TriangleLaw {assoc : Associator}
    `{LeftUnitor} `{RightUnitor} (a c : C)
    :=  fmap (tensor a) (left_unitor c)
    $== fmap (flip tensor c) (right_unitor a) $o assoc (a, I, c).

  Class MonoidalStructure
    `{forall a, Is1Functor (tensor a)}
    `{forall b, Is1Functor (flip tensor b)}
    {assoc : Associator}
    {left_unitor : LeftUnitor}
    {right_unitor : RightUnitor}
    := {
      pentagon_law : forall a b c d : C, PentagonLaw a b c d;
      triangle_law : forall a c : C, TriangleLaw a c
    }.

  (** TODO *)
  Proposition left_unitor_associator_coherence
    `{M : MonoidalStructure} (x y : C)
    : fmap (flip tensor y) (left_unitor x) $o
        assoc (I, x ,y) $== left_unitor (x ⊗ y).
  Proof.
    Abort.

  (** TODO *)
  Proposition left_right_unitor_agree `{M : MonoidalStructure}
    : cate_fun (left_unitor I) $== cate_fun (right_unitor I).
  Proof.
    Abort.

End Monoidal.


Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

(* No helper lemma *)
Theorem theorem0 : forall (x : natural) (y : natural) (z : natural), eq (plus (plus x y) z) (plus x (plus y z)).
Proof.
intros.
induction x.
- simpl. rewrite IHx. reflexivity.
- reflexivity.

Qed.


Require Export FunctionProperties.
Require Export Relation_Definitions.
Require Import Relation_Definitions_Implicit.
Require Import CSB.
Require Import EnsemblesSpec.

Inductive Cardinal : Type :=
  | cardinality: Type -> Cardinal.

Fixpoint n_element_set (n:nat) : Set :=
  match n with
  | O => False
  | S m => option (n_element_set m)
  end.
Definition nat_to_cardinal (n:nat) :=
  cardinality (n_element_set n).

Definition aleph0 := cardinality nat.

Inductive eq_cardinal : Cardinal -> Cardinal -> Prop :=
  | bij_eq_cardinal: forall {X Y:Type} (f:X->Y),
    bijective f -> eq_cardinal (cardinality X) (cardinality Y).
Inductive le_cardinal : Cardinal -> Cardinal -> Prop :=
  | inj_le_cardinal: forall {X Y:Type} (f:X->Y),
    injective f -> le_cardinal (cardinality X) (cardinality Y).

Definition lt_cardinal (kappa lambda:Cardinal) : Prop :=
  le_cardinal kappa lambda /\ ~ eq_cardinal kappa lambda.
Definition ge_cardinal (kappa lambda:Cardinal) : Prop :=
  le_cardinal lambda kappa.
Definition gt_cardinal (kappa lambda:Cardinal) : Prop :=
  lt_cardinal lambda kappa.

Lemma eq_cardinal_equiv: equivalence eq_cardinal.
Proof.
constructor.
red; intro.
destruct x.
exists (fun x:T => x).
red; split.
red; intros.
assumption.
red; intro.
exists y.
reflexivity.

red; intros.
destruct H.
inversion H0.
destruct H1.
destruct H3.
exists (fun x:X => f0 (f x)).
red; split.
red; intros.
apply H.
apply H2.
assumption.
red; intro.
destruct H.
destruct H2.
pose proof (H3 y).
destruct H4.
pose proof (H1 x).
destruct H5.
exists x0.
rewrite H5.
assumption.

red; intros.
destruct H.
apply bijective_impl_invertible in H.
destruct (function_inverse f H) as [finv].
destruct a.
exists finv.
apply invertible_impl_bijective.
exists f.
assumption.
assumption.
Qed.

Lemma eq_cardinal_impl_le_cardinal: forall kappa lambda: Cardinal,
  eq_cardinal kappa lambda -> le_cardinal kappa lambda.
Proof.
intros.
destruct H.
exists f.
destruct H.
assumption.
Qed.

Lemma le_cardinal_preorder: preorder le_cardinal.
Proof.
constructor.
red; intro.
apply eq_cardinal_impl_le_cardinal.
apply (equiv_refl eq_cardinal_equiv).
red; intros.
destruct H.
inversion H0.
exists (fun x:X => f0 (f x)).
red; intros.
apply H.
apply H2.
assumption.
Qed.

Lemma le_cardinal_antisym: forall kappa lambda:Cardinal,
  le_cardinal kappa lambda -> le_cardinal lambda kappa ->
  eq_cardinal kappa lambda.
Proof.
intros.
destruct H.
inversion H0.
destruct H1.
destruct H2.
pose proof (CSB Y0 X0 f f0 H H3).
destruct H1.
exists x.
assumption.
Qed.

Lemma cantor_diag: forall (X:Type) (f:X->(X->bool)),
  ~ surjective f.
Proof.
intros.
red; intro.
pose (g := fun x:X => negb (f x x)).
pose proof (H g).
destruct H0.
assert (f x x = g x).
rewrite H0.
reflexivity.
unfold g in H1.
destruct (f x x).
discriminate H1.
discriminate H1.
Qed.

Lemma P_neq_not_P: forall (P:Prop), P <> ~P.
Proof.
unfold not; intros.
assert (~P).
unfold not; intro.
assert (P->False).
rewrite <- H.
assumption.
tauto.
assert P.
rewrite H.
assumption.
tauto.
Qed.

Lemma cantor_diag2: forall (X:Type) (f:X->(X->Prop)),
  ~ surjective f.
Proof.
unfold not; intros.
pose (g := fun x:X => ~ f x x).
pose proof (H g).
destruct H0.
assert (f x x = g x).
rewrite H0.
reflexivity.
unfold g in H1.
contradiction P_neq_not_P with (f x x).
Qed.

Lemma cardinals_unbounded: forall kappa:Cardinal, exists lambda:Cardinal,
  gt_cardinal lambda kappa.
Proof.
destruct kappa.
exists (cardinality (T->Prop)).
red; red; split.
exists (@eq T).
red; intros.
rewrite H.
reflexivity.

unfold not; intro.
inversion H.
destruct H0.
destruct H2.
contradiction (cantor_diag2 _ f).
Qed.

(* The results below require Axiom of Choice *)
Require Import ClassicalChoice.

Lemma surj_le_cardinal: forall {X Y:Type} (f:X->Y),
  surjective f -> le_cardinal (cardinality Y) (cardinality X).
Proof.
intros.
pose proof (choice (fun (y:Y) (x:X) => f x = y) H).
simpl in H0.
destruct H0 as [g].
exists g.
red; intros.
congruence.
Qed.

Section le_cardinal_total.

Variable X Y:Type.

Require Import ZornsLemma.
Require Import EnsemblesImplicit.
Require Import ProofIrrelevance.
Require Import FunctionalExtensionality.
Require Import Description.

Record partial_injection : Type := {
  pi_dom: Ensemble X;
  pi_func: forall x:X, In pi_dom x -> Y;
  pi_inj: forall (x1 x2:X) (i1:In pi_dom x1) (i2:In pi_dom x2),
    pi_func x1 i1 = pi_func x2 i2 -> x1 = x2
}.
Record partial_injection_ord (pi1 pi2:partial_injection) : Prop := {
  pi_dom_inc: Included (pi_dom pi1) (pi_dom pi2);
  pi_func_ext: forall (x:X) (i1:In (pi_dom pi1) x)
   (i2:In (pi_dom pi2) x),
    pi_func pi1 x i1 = pi_func pi2 x i2
}.

Lemma partial_injection_preord: preorder partial_injection_ord.
Proof.
constructor.
red; intros.
destruct x.
constructor.
auto with sets.
intros.
assert (i1 = i2).
apply proof_irrelevance.
rewrite H.
reflexivity.

red; intros.
destruct H.
destruct H0.
constructor.
auto with sets.
intros.
assert (In (pi_dom y) x0).
auto with sets.
transitivity (pi_func y x0 H); trivial.
Qed.

Lemma partial_injection_chain_ub: forall S:Ensemble partial_injection,
  chain partial_injection_ord S -> exists x:partial_injection,
  forall y:partial_injection, In S y -> partial_injection_ord y x.
Proof.
intros.
pose (ub_dom := [x:X | exists y:partial_injection,
  In S y /\ In (pi_dom y) x]).
assert (forall x:X, In ub_dom x -> { y:Y | exists z:partial_injection,
  In S z /\ exists i:In (pi_dom z) x, pi_func z x i = y }).
intros.
apply constructive_definite_description.
destruct H0.
destruct H0.
destruct H0.
exists (pi_func x0 x H1).
red; split.
exists x0.
split.
assumption.
exists H1.
reflexivity.
intros.
destruct H2.
destruct H2.
destruct H3.
pose proof (H x0 x1 H0 H2).
case H4.
intro.
rewrite <- H3.
apply pi_func_ext.
assumption.
intro.
rewrite <- H3.
symmetry.
apply pi_func_ext.
assumption.

assert (forall (x1 x2:X) (i1:In ub_dom x1) (i2:In ub_dom x2),
  proj1_sig (X0 x1 i1) = proj1_sig (X0 x2 i2) -> x1 = x2).
intros.
destruct X0 in H0.
destruct X0 in H0.
simpl in H0.
destruct H0.
destruct e.
destruct H0.
destruct H1.
destruct e0.
destruct H2.
destruct H3.
destruct H1.
case (H x0 x4 H0 H2).
intro.
assert (In (pi_dom x4) x1).
apply (pi_dom_inc _ _ H1).
assumption.
assert (pi_func x4 x1 H4 = pi_func x4 x2 x5).
rewrite H3.
symmetry.
apply pi_func_ext.
assumption.
apply pi_inj in H5.
assumption.

intro.
assert (In (pi_dom x0) x2).
apply (pi_dom_inc _ _ H1).
assumption.
assert (pi_func x0 x1 x3 = pi_func x0 x2 H4).
rewrite <- H3.
apply pi_func_ext.
assumption.
apply pi_inj in H5.
assumption.

exists (Build_partial_injection ub_dom
  (fun (x:X) (i:In ub_dom x) => proj1_sig (X0 x i)) H0).
intros.
constructor.
simpl.
red; intros.
constructor.
exists y.
tauto.
simpl.
intros.
destruct (X0 x i2).
simpl.
destruct e.
destruct H2.
destruct H3.
destruct H3.
case (H y x1 H1 H2).
intro.
apply pi_func_ext.
assumption.
intro.
symmetry.
apply pi_func_ext.
assumption.
Qed.

Lemma premaximal_partial_injection:
  exists x:partial_injection, premaximal partial_injection_ord x.
Proof.
apply ZornsLemmaForPreorders.
exact partial_injection_preord.
exact partial_injection_chain_ub.
Qed.

Lemma premaximal_pi_is_full_or_surj:
  forall x:partial_injection, premaximal partial_injection_ord x ->
    pi_dom x = Full_set \/
    forall y:Y, exists x0:X, exists i:(In (pi_dom x) x0),
      pi_func x x0 i = y.
Proof.
intros.
case (classic (pi_dom x = Full_set)).
left.
trivial.
intro.
assert (exists x0:X, ~ In (pi_dom x) x0).
apply NNPP.
intuition.
apply H0.
apply Extensionality_Ensembles.
red; split.
red; intros.
constructor.
red; intros.
apply NNPP.
intuition.
apply H1.
exists x0.
assumption.
right.
destruct H1.
intros.
apply NNPP.
intuition.

pose (pi_dom_ext := Add (pi_dom x) x0).
assert (forall (x':X), In pi_dom_ext x' ->
  { y':Y | (exists i2:In (pi_dom x) x', y' = pi_func x x' i2) \/
          (x' = x0 /\ y' = y) }).
intros.
apply constructive_definite_description.
case H3.
intros.
exists (pi_func x x1 H4).
red; split.
left.
exists H4.
reflexivity.
intros.
case H5.
intro.
destruct H6.
rewrite H6.
assert (H4 = x2).
apply proof_irrelevance.
rewrite H7.
reflexivity.

intros.
destruct H6.
contradict H1.
rewrite <- H6.
assumption.

intros.
destruct H4.
exists y.
red; split.
right.
tauto.
intros.
case H4.
intro.
destruct H5.
contradiction H1.
intros.
symmetry.
tauto.

pose (pi_func_ext0 := fun (x:X) (i:In pi_dom_ext x) =>
  proj1_sig (X0 x i)).

assert (forall (x1:X) (i:In (pi_dom x) x1) (i2:In pi_dom_ext x1),
  pi_func_ext0 x1 i2 = pi_func x x1 i).
intros.
unfold pi_func_ext0.
destruct (X0 x1 i2).
simpl.
case o.
intros.
destruct H3.
assert (i = x3).
apply proof_irrelevance.
rewrite H4.
assumption.
intros.
destruct H3.
contradiction H1.
rewrite <- H3.
assumption.

assert (forall (i:In pi_dom_ext x0), pi_func_ext0 x0 i = y).
intros.
unfold pi_func_ext0.
destruct (X0 x0 i); simpl.
case o.
intro.
destruct H4.
contradiction H1.
tauto.

assert (forall (x1 x2:X) (i1:In pi_dom_ext x1) (i2:In pi_dom_ext x2),
  pi_func_ext0 x1 i1 = pi_func_ext0 x2 i2 -> x1 = x2).
intros.
inversion i1.
inversion i2.
rewrite (H3 x1 H6 i1) in H5.
rewrite (H3 x2 H8 i2) in H5.
apply pi_inj in H5.
assumption.
destruct H8.
rewrite (H3 x1 H6 i1) in H5.
rewrite H4 in H5.
contradiction H2.
exists x1.
exists H6.
assumption.
destruct H6.
rewrite H4 in H5.
inversion i2.
rewrite (H3 x2 H6 i2) in H5.
contradiction H2.
exists x2.
exists H6.
symmetry; assumption.
destruct H6.
reflexivity.

pose (pi_ext := Build_partial_injection pi_dom_ext pi_func_ext0 H5).
assert (partial_injection_ord x pi_ext).
constructor.
unfold pi_ext; simpl.
unfold pi_dom_ext.
red; intros.
left.
assumption.
intros.
symmetry.
apply H3.

apply H in H6.
contradiction H1.
apply (pi_dom_inc _ _ H6).
simpl.
right.
auto with sets.
Qed.

Lemma types_comparable: (exists f:X->Y, injective f) \/
                        (exists f:Y->X, injective f).
Proof.
pose proof premaximal_partial_injection.
destruct H.
apply premaximal_pi_is_full_or_surj in H.
case H.
left.
assert (forall x0:X, In (pi_dom x) x0).
rewrite H0.
constructor.
exists (fun x0:X => pi_func x x0 (H1 x0)).
red; intros.
apply pi_inj in H2.
assumption.

right.
assert (forall y:Y, { x0:X | exists i:In (pi_dom x) x0, pi_func x x0 i = y }).
intro.
apply constructive_definite_description.
pose proof (H0 y).
destruct H1.
exists x0.
red; split.
assumption.
intros.
destruct H1.
destruct H2.
destruct H2.
apply pi_inj in H1.
assumption.

exists (fun y:Y => proj1_sig (X0 y)).
red; intros.
destruct X0 in H1; destruct X0 in H1; simpl in H1.
destruct e; destruct e0.
destruct H1.
assert (x4 = x5).
apply proof_irrelevance.
destruct H1.
destruct H2.
assumption.
Qed.

End le_cardinal_total.

Lemma le_cardinal_total: forall kappa lambda:Cardinal,
  le_cardinal kappa lambda \/ le_cardinal lambda kappa.
Proof.
intros.
destruct kappa.
destruct lambda.
pose proof (types_comparable T T0).
case H.
left.
destruct H0.
exists x.
assumption.
right.
destruct H0.
exists x.
assumption.
Qed.


(* infotheo v2 (c) AIST, Nagoya University. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice.
From mathcomp Require Import fintype div prime bigop finset ssralg finalg.
From mathcomp Require Import binomial poly polydiv cyclic perm finfun matrix.
From mathcomp Require Import mxpoly vector mxalgebra zmodp.

Require Import ssr_ext ssralg_ext vandermonde linearcode.
Require Import dft poly_decoding.

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

Import GRing.Theory.
Local Open Scope ring_scope.

Local Open Scope vec_ext_scope.

(** * Generalized Reed-Solomon Codes *)

(** OUTLINE
- Module GRS.
- Section GRS_rank.
- Section reduced_key_equation.
*)

Module GRS.

Section GRS_def.

Variables (n (*q*) : nat).
(*Hypothesis nq : n <= q.*)
Variable (F : finFieldType).
Variable a : 'rV[F]_n.
Hypothesis a_inj : injective [ffun i => a``_i]. (* pairwise distinct *)
Variable b : 'rV[F]_n.
Hypothesis b_neq0 : forall i, b ``_ i != 0.
Variable k : nat.
Hypothesis Hk : 1 <= k <= n.

(* 'rV[F]_k = polynomials of deg < k *)
Definition codebook :=
  [set \row_i ((rVpoly f).[a ``_ i] * (b ``_ i)) | f in 'rV[F]_k].

(* r = d - 1 *)
Definition PCM r : 'M_(r, n):= vander_gen a r *m diag_mx b.

Definition syndrome_coord (i : nat) (y : 'rV_n) :=
  \sum_(j < n) y ``_ j * b ``_ j * (a ``_ j) ^+ i.

Definition syndrome r (y : 'rV_n) : 'rV[F]_r := \row_i (syndrome_coord i y).

Lemma syndromeE r y : syndrome r y = linearcode.syndrome (PCM r) y.
Proof.
apply/rowP => l; rewrite !mxE; apply/eq_bigr => /= i _.
rewrite 2!mxE [in RHS]mulrC -mulrA; congr (_ * _).
rewrite (bigD1 i) //= !mxE eqxx /= mulr1n mulrC.
apply/eqP; rewrite addrC -subr_eq subrr; apply/eqP.
rewrite (eq_bigr (fun=> 0)) ?big_const ?iter_addr0 // => j ji.
by rewrite !mxE (negbTE ji) mulr0n mulr0.
Qed.

Definition syndrome_coord_supp (l : nat) (y : 'rV_n) :=
  \sum_(j in supp y) y ``_ j * b ``_ j * (a ``_ j) ^+ l.

Lemma syndrome_coord_suppE l y : syndrome_coord l y = syndrome_coord_supp l y.
Proof.
rewrite /syndrome_coord (bigID (fun i => i \in supp y)) /=.
rewrite addrC (eq_bigr (fun=> 0)); last first.
  by move=> i; rewrite inE negbK => /eqP ->; rewrite 2!mul0r.
by rewrite big_const iter_addr0 add0r.
Qed.

Definition syndromep r y := \poly_(l < r) (syndrome_coord l y).

Lemma syndomepE r y :
  syndromep r y = \sum_(i in supp y)
     (y ``_ i * b ``_ i)%:P * (\sum_(l < r) (a ``_ i ^+ l)%:P * 'X^l).
Proof.
rewrite /syndromep poly_def.
rewrite (eq_bigr (fun i : 'I_r=> 'X^i * (syndrome_coord i y)%:P)); last first.
  by move=> i _; rewrite mulrC -scale_polyE.
rewrite (eq_bigr (fun i : 'I_r => 'X^i * (syndrome_coord_supp i y)%:P)); last first.
  move=> i _.
  by rewrite syndrome_coord_suppE.
rewrite /syndrome_coord_supp.
rewrite (eq_bigr (fun i : 'I_r => (\sum_(j in supp y) 'X^i * (y ``_ j * b ``_ j * a ``_ j ^+ i)%:P))); last first.
  move=> i _.
  by rewrite -big_distrr /= (big_morph (id1:=0) (fun x => x%:P) (@polyC_add _)).
rewrite exchange_big /=.
rewrite (eq_bigr (fun j => (y ``_ j * b ``_ j)%:P * \sum_(l < r) ((a ``_ j ^+ l)%:P * 'X^l))) //.
move=> i isupp.
rewrite !big_distrr /=; apply eq_bigr => j _.
by rewrite mulrC mulrA polyC_mul.
Qed.

Lemma syndromep_syndrome r y : (syndrome r y == 0) = (syndromep r y == 0).
Proof.
apply/idP/idP; rewrite /syndrome /syndromep => H0.
  apply/eqP/polyP => i.
  rewrite coef0 coef_poly; case: ifPn => // ir.
  by move/eqP/rowP : H0 => /(_  (Ordinal ir)); rewrite !mxE.
apply/eqP/rowP => i.
rewrite mxE.
move/eqP/polyP : H0 => /(_ i); rewrite coef0 coef_poly (ltn_ord i) => ->.
by rewrite mxE.
Qed.

End GRS_def.

End GRS.

Section GRS_rank.

Variables (F : finFieldType) (n' : nat).
Let n := n'.+1.
Variable (r : nat).

Definition GRS_PCM_sq (a b : 'rV[F]_n) r :=
  \matrix_(i < r, j < r) (GRS.PCM a b r) i (inord j).

Lemma GRS_PCM_sq_vander (a b : 'rV[F]_n) (rn : r <= n) :
  GRS_PCM_sq a b r =
    vandermonde.vander_gen (\row_(i < r) a``_(inord i)) r *m
      diag_mx (\row_(i < r) b``_(inord i)).
Proof.
apply/matrixP => i j.
rewrite !mxE (bigID (fun i : 'I_n => i < r)) /=.
rewrite [in X in _ + X = _](eq_bigr (fun=> 0)); last first.
  move=> l lr.
  rewrite !mxE (_ : l == inord j = false); last first.
    apply/negbTE; apply: contra lr => /eqP ->.
    by rewrite inordK // (leq_trans (ltn_ord j)).
  by rewrite mulr0n mulr0.
rewrite big_const iter_addr0 addr0 big_ord_narrow //.
apply/eq_bigr => l _.
have Hl : widen_ord rn l = inord l.
  apply val_inj => /=; by rewrite inordK // (leq_trans (ltn_ord l)).
rewrite !mxE Hl; congr (_ * (_ *+ _ )).
rewrite (_ : inord j = widen_ord rn j) -?Hl //.
apply val_inj => /=; by rewrite inordK //(leq_trans (ltn_ord j)).
Qed.

Variable (a : 'rV[F]_n).
Hypothesis a_inj : injective [ffun i => a``_i]. (* pairwise distinct *)

Lemma rank_GRS_PCM_sq (b : 'rV_n) (rn : r <= n) (b0 : forall i, b ``_i != 0) :
  \rank (GRS_PCM_sq a b r) = r.
Proof.
apply mxrank_unit.
rewrite unitmxE unitfE GRS_PCM_sq_vander //.
rewrite // det_mulmx mulf_neq0 //; last first.
  rewrite det_diag prodf_seq_neq0; apply/allP => /= i _.
  by rewrite mxE b0.
destruct r as [|r']; first by rewrite det_mx00 oner_neq0.
rewrite vandermonde.det_vander.
rewrite prodf_seq_neq0; apply/allP => /= i _.
rewrite prodf_seq_neq0; apply/allP => /= j _.
apply/implyP; rewrite ltnNge => ij.
rewrite !mxE subr_eq0 !inord_val.
apply: contra ij => /eqP ij.
move: (@a_inj (inord i) (inord j)).
rewrite !ffunE ij => /(_ erefl).
move/(congr1 (@nat_of_ord n)).
rewrite inordK // ?(leq_trans (ltn_ord i)) //.
by rewrite inordK // ?(leq_trans (ltn_ord j)) // => ->.
Qed.

Lemma rank_GRS_PCM (b : 'rV[F]_n) (rn : r <= n) (b0 : forall i, b ``_i != 0) :
  \rank (GRS.PCM a b r) = r.
Proof.
set lhs := GRS.PCM _ _ _.
set lhs' := castmx (erefl r, esym (subnKC rn)) lhs.
set K1 := lsubmx lhs'.
set K2 := rsubmx lhs'.
rewrite -(mxrank_castmx lhs (erefl r) (esym (subnKC rn))).
rewrite -/lhs' -(hsubmxK lhs') rank_row_mx //.
suff -> : lsubmx lhs' = GRS_PCM_sq a b r by rewrite rank_GRS_PCM_sq.
rewrite /lhs' /lhs GRS_PCM_sq_vander //.
apply/matrixP => i j.
rewrite !mxE castmxE !mxE /=.
rewrite (bigID (fun x : 'I_n => x < r) xpredT) /=.
rewrite [in X in _ + X = _](eq_bigr (fun=> 0)); last first.
  move=> k kj; rewrite !mxE esymK (_ : _ == _ = false).
    by rewrite mulr0n mulr0.
  apply/negbTE; apply: contra kj => /eqP -> /=. done.
rewrite big_const iter_addr0 addr0.
rewrite big_ord_narrow //.
apply eq_bigr => k _.
rewrite !mxE /=.
rewrite (_ : widen_ord _ _ = inord k); last first.
  apply val_inj => /=; by rewrite inordK // (leq_trans (ltn_ord k)).
congr (_ * (_ *+ nat_of_bool _)).
rewrite esymK.
apply/idP/idP => [|/eqP ->]; last first.
  apply/eqP/val_inj => /=.
  by rewrite inordK // (leq_trans (ltn_ord j)).
move/eqP/(congr1 (@nat_of_ord n)).
rewrite inordK; last by rewrite (leq_trans (ltn_ord k)).
move=> Hk.
apply/eqP/ord_inj; by rewrite Hk.
Qed.

End GRS_rank.

Section reduced_key_equation.

Variables (F : finFieldType) (n : nat) (y : 'rV[F]_n).
Let E := supp y.
Variables b a : 'rV[F]_n.

Definition Sigma : {poly F} := errloc a E.

Definition Omega : {poly F} := @erreval F n b a y.

Definition GRS_mod r : {poly F} :=
  \sum_(i in supp y) y ``_ i *: (\prod_(i0 in E | i0 != i) ((1 - a ``_ i0 *: 'X))) * (a ``_ i ^+ r)%:P * - (b ``_ i)%:P.

Lemma GRS_key_equation r :
  Sigma * GRS.syndromep a b r y = Omega + GRS_mod r * 'X^r.
Proof.
case/boolP : (r == O) => r0.
  rewrite (eqP r0) mulr1.
  rewrite /GRS.syndromep poly_def big_ord0 mulr0.
  apply/eqP; rewrite eq_sym addr_eq0; apply/eqP.
  rewrite /GRS_mod /Omega /erreval -sumrN; apply eq_bigr => j jy.
  rewrite expr0 mulr1 mulrN opprK [in RHS]mulrC mulrC -!scalerA.
  rewrite -scalerAl mulrC mul_polyC; congr (_ *: (_ *: _)).
  apply eq_bigl => k; by rewrite in_setD1 andbC.
rewrite /GRS_mod big_distrl /= /Omega /erreval -big_split /=.
rewrite GRS.syndomepE big_distrr /=.
apply eq_bigr => i iy.
rewrite -3!scalerAl -scalerA -scalerDr.
rewrite polyC_mul -!mulrA mulrCA !mulrA mul_polyC -!scalerAl; congr (_ *: _).
rewrite /Sigma /errloc (bigD1 i) //= mulrC -!mulrA mulrBl mul1r.
set x := (X in _ * X = _).
rewrite (_ : x = (b ``_ i)%:P * (1 - (a ``_ i ^+ r)%:P * 'X^r)); last first.
  rewrite /x mulrCA -mulrBr big_distrr /= -sumrB.
  rewrite (_ : \sum_(i0 < r) _ = 1 - ((a ``_ i ^+ r)%:P * 'X^r)) //.
  rewrite big_split /=.
  destruct r => //.
  rewrite big_ord_recl /= expr0 mulr1 big_ord_recr /= -addrA.
  rewrite (addrA _ _ (- (_ *: _ * _))).
  rewrite addrCA [X in X + _](_ : _ = 0) ?add0r; last first.
    rewrite sumrN.
    apply/eqP; rewrite subr_eq0; apply/eqP.
    apply eq_bigr => j _.
    rewrite -!scalerAl mulrCA -exprS !scalerAl; congr (_ * _).
    by rewrite -mul_polyC -polyC_mul -exprS.
  by rewrite -mulrCA -scalerAl -exprS 2!mul_polyC scalerA -exprSr.
rewrite mulrA mulrBr mulr1 mulrC -mul_polyC; congr (_ * _ + _).
 apply/eq_bigl => j; by rewrite in_setD1 andbC.
rewrite -mulNr !mulrA; congr (_ * _).
by rewrite -mulNr -mulrA mulrC -!mulrA.
Qed.

End reduced_key_equation.


From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.
From Coq Require Import ssrfun.
Require Import AutosubstSsr ARS Context.
Require Import Program.Equality.

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

Require Import ast.

(* one step reduction *)
Inductive value : term -> Prop :=
| value_tt : value TT
| value_pi : forall A B, value (Pi A B)
| value_fun : forall s, value (Fun s).

Inductive step : term -> term -> Prop :=
| step_beta s t u :
  value t ->
  u = s.[Fun s,t/] ->
  step (App (Fun s) t) u
| step_appL s1 s2 t :
  step s1 s2 ->
  step (App s1 t) (App s2 t)
| step_appR s t1 t2 :
  value s ->
  step t1 t2 ->
  step (App s t1) (App s t2)
| step_castS s1 s2 A :
  step s1 s2 ->
  step (Cast s1 A) (Cast s2 A)
| step_castR s A :
  value s ->
  step (Cast s A) s.

(* TODO this can be parameterized to any definition od step and value *)
Definition Stuck e := not (value e) /\ not (exists e', step e e').

(* TODO values don't step *)
(* TODO step is deterministic *)

(*TODO final type soundness, well typed terms don't get stuck *)


Require Export FSets.FMapAVL.
Require Export Coq.Structures.OrderedTypeEx.
Require Export Coq.Arith.EqNat.

Module M := FSets.FMapAVL.Make  Nat_as_OT.

Definition uniondatastruct  : Type := M.t  ( nat * nat ).
Definition myempty := @M.empty ( nat * nat ).
Check @M.empty ( nat * nat ).

Check M.add 1 ( 1, 1 ) ( M.add 2 ( 2, 1) ( M.add 3 ( 3, 1 ) myempty ) ).

Fixpoint find ( k : nat ) ( m : uniondatastruct ) : option nat :=
  match M.find k m with
  | None  => None
  | Some ( a, _ ) => if beq_nat a k then Some a else find a m
  end.


Require Export B1_Confondu_Prop.

Section CLOCKWISE_PROPERTIES.

Lemma ClockwiseBCA : forall A B C,
	Clockwise A B C -> Clockwise B C A.
Proof.
	exact ClockwisePerm.
Qed.

Lemma ClockwiseCAB : forall A B C,
	Clockwise A B C -> Clockwise C A B.
Proof.
	intros A B C H; do 2 apply ClockwisePerm; trivial.
Qed.

Lemma NotClockwiseAAB : forall A B, ~Clockwise A A B.
Proof.
	intros A B; destruct (ClockwiseAntisym A A B); trivial.
Qed.

Lemma NotClockwiseABA : forall A B , ~Clockwise A B A.
Proof.
	intros A B H; elim (NotClockwiseAAB A B); apply ClockwiseCAB; trivial.
Qed.

Lemma NotClockwiseBAA : forall A B , ~Clockwise B A A.
Proof.
	intros A B H; elim (NotClockwiseAAB A B); apply ClockwiseBCA; trivial.
Qed.

Lemma ClockwiseDistinctAB : forall A B C,
	Clockwise A B C -> A <> B.
Proof.
	intros A B C H Hi; subst.
	elim (NotClockwiseAAB B C); trivial.
Qed.

Lemma ClockwiseDistinctBC : forall A B C,
	Clockwise A B C -> B <> C.
Proof.
	intros A B C H Hi; subst.
	elim (NotClockwiseBAA C A); trivial.
Qed.

Lemma ClockwiseDistinctCA : forall A B C,
	Clockwise A B C -> C <> A.
Proof.
	intros A B C H Hi; subst.
	elim (NotClockwiseABA A B); trivial.
Qed.

Lemma ClockwiseNotClockwise : forall A B C,
	Clockwise A B C -> ~Clockwise B A C.
Proof.
	intros A B C H H0.
	destruct (ClockwiseAntisym A B C); intuition.
Qed.

Lemma ClockwiseClockwiseDistinct : forall A B C D,
	Clockwise A B C ->
	Clockwise B A D ->
	C <> D.
Proof.
	intros A B C D H H0 H1; subst.
	elim (ClockwiseNotClockwise A B D H); trivial.
Qed.

Lemma ExclusiveFourCases : forall A B C,
	A <> C ->
	Clockwise A B C \/
	Clockwise B A C \/
	HalfLine A B C \/
	EquiOriented A B C A.
Proof.
	intros A B C H; decompose [or] (FourCases A B C).
	 auto.
	 auto.
	 auto.
	 decompose [or] (FourCases A C B).
	  generalize (ClockwiseCAB A C B H1); auto.
	  generalize (ClockwiseBCA C A B); auto.
	  generalizeChange.
	  generalizeChange.
Qed.

End CLOCKWISE_PROPERTIES.


Generalizable All Variables.
Set Implicit Arguments.

Require Import Coq.Lists.List
        Coq.Strings.String
        Coq.Arith.Arith
        Fiat.Common.
Require Export Fiat.Common.VectorFacts.
Require Coq.Vectors.Vector.

Section ilist.

  (* Lists of elements whose types depend on an indexing set (CPDT's hlists).
     These lists are a convenient way to implement finite maps
     whose elements depend on their keys. The data structures used
     by our ADT notations uses these to implement notation-friendly
     method lookups.  *)

  Import Coq.Vectors.VectorDef.VectorNotations.

  Context {A : Type}. (* The indexing type. *)
  Context {B : A -> Type}. (* The type of indexed elements. *)

  Record prim_prod A B : Type :=
    { prim_fst : A;
      prim_snd : B }.

  Fixpoint ilist {n} (l : Vector.t A n) : Type :=
    match l with
      | [] => unit
      | a :: l => @prim_prod (B a) (ilist l)
    end.

  Definition icons
             (a : A)
             {n}
             {l : Vector.t A n}
             (b : B a)
             (il : ilist l)
  : ilist (a :: l)
    := {| prim_fst := b; prim_snd := il |}.

  Definition inil : ilist [] := tt.

  (* Get the car of an ilist. *)
  Definition ilist_hd {n} {As : Vector.t A n} (il : ilist As) :
    match As return ilist As -> Type with
      | a :: As' => fun il => B a
      | [] => fun _ => unit
    end il :=
    match As return
          forall (il : ilist As),
            match As return ilist As -> Type with
              | a :: As' => fun il => B a
              | [] => fun _ => unit
            end il with
      | a :: As => fun il => prim_fst il
      | [] => fun il => tt
    end il.

  Definition ilist_hd' {n} {As : Vector.t A (S n)} (il : ilist As) :
    B (Vector.hd As)
    := Vector.caseS (fun n As => ilist As -> B (Vector.hd As))
                           (fun a As m => ilist_hd) As il.

  (* Get the cdr of an ilist. *)
  Definition ilist_tl {n} {As : Vector.t A n} (il : ilist As) :
    match As return ilist As -> Type with
      | a :: As' => fun il => ilist As'
      | [] => fun _ => unit
    end il :=
    match As return
          forall (il : ilist As),
            match As return ilist As -> Type with
              | a :: As' => fun il => ilist As'
              | [] => fun _ => unit
            end il with
      | a :: As => fun il => prim_snd il
      | [] => fun il => tt
    end il.

  Definition ilist_tl'
             {n} {As : Vector.t A (S n)} (il : ilist As)
    : ilist (Vector.tl As) :=
    Vector.caseS (fun n As => ilist As -> ilist (Vector.tl As))
                 (fun a As m => ilist_tl) As il.

  Infix "++" := Vector.append : vector_scope.

  (* Appending ilists *)
  Fixpoint ilist_app {n} {As : Vector.t A n}
    : forall {n'} {As' : Vector.t A n'},  ilist As -> ilist As' -> ilist (As ++ As') :=
      match As return
            forall {n'} (As' : Vector.t A n'),
              ilist As -> ilist As' -> ilist (As ++ As') with
        | [] =>
          fun n' As' il il' => il'
        | a :: As'' =>
          fun n' As' il il' =>
            {| prim_fst := ilist_hd il;
               prim_snd := ilist_app (ilist_tl il) il' |}
      end.

  (* Membership in an indexed list. *)

  Inductive ilist_In {a : A} (b : B a)
  : forall {n} {As : Vector.t A n} (il : ilist As), Prop :=
  | In_hd : forall n' As' (il : ilist (n := n') As'),
              ilist_In b (icons b il)
  | In_tl : forall {n'} a' (b' : B a') As' (il : ilist (n := n') As'),
              ilist_In b il ->
              ilist_In b (icons b' il).

  (* Looking up the ith value, returning None for indices not in the Vector.t *)

  Fixpoint ith
             {m : nat}
             {As : Vector.t A m}
             (il : ilist As)
             (n : Fin.t m)
  : B (Vector.nth As n) :=
    match n in Fin.t m return
          forall (As : Vector.t A m),
            ilist As
            -> B (Vector.nth As n) with
      | Fin.F1 k =>
        fun As =>
          Vector.caseS (fun n As => ilist As
                                    -> B (Vector.nth As (@Fin.F1 n)))
                       (fun h n t => ilist_hd) As
      | Fin.FS k n' =>
        fun As =>
          Vector_caseS' Fin.t
                        (fun n As n' => ilist As
                                        -> B (Vector.nth As (@Fin.FS n n')))
                        (fun h n t m il => ith (ilist_tl il) m)
                        As n'
    end As il.

  Lemma ilist_invert {n} (As : Vector.t A n) (il : ilist As) :
    match As as As' return ilist As' -> Prop with
      | a :: As' => fun il => exists b il', il = icons b il'
      | [] => fun il => il = inil
    end il.
  Proof.
    destruct As; destruct il; simpl; unfold icons; eauto.
  Qed.

  Lemma ilist_invert' {n} (As : Vector.t A n) (il : ilist As) :
    match As as As' return ilist As' -> Type with
      | a :: As' => fun il => sigT (fun b => sigT (fun il' => il = icons b il'))
      | [] => fun il => il = inil
    end il.
  Proof.
    destruct As; destruct il; unfold icons; eauto.
  Qed.

  (* The [ith_induction] tactic is for working with lookups of bounded indices.
     It first inducts on n, then destructs the index Vector.t [As] and eliminates
     the contradictory cases, then finally destructs any indexed Vector.t in the
     context with Bounds of [As]. *)

End ilist.

(** ** Mapping a function over a(n i)[list], in two non-dependent ways *)
Section ilist_map.
  Context {A} (B : A -> Type).

  Import Coq.Vectors.VectorDef.VectorNotations.

  Fixpoint imap_list (f : forall a : A, B a) {n} (As : Vector.t A n) : ilist As
    := match As with
         | [] => inil
         | x :: xs => @icons _ B x _ _ (f x) (imap_list f xs)
       end.

End ilist_map.

Ltac icons_invert :=
  repeat match goal with
           | [il : ilist _ (_ :: _) |- _]
             => let il' := fresh "il" in
                let b' := fresh "b" in
                let il'_eq := fresh "il_eq" in
                generalize (ilist_invert il);
                  intros il'; destruct il' as [b' [il' il'_eq]]; subst
         end.

Section ilist_imap.

  (* Mapping a function over an indexed Vector.t. *)

  Import Coq.Vectors.VectorDef.VectorNotations.

  Variable A : Type. (* The indexing type. *)
  Variable B B' : A -> Type. (* The two types of indexed elements. *)
  Variable f : forall a, B a -> B' a. (* The function to map over the Vector.t. *)

  Fixpoint imap {n} (As : Vector.t A n)
    : ilist As -> ilist As :=
    match As return ilist As -> ilist As with
    | [] => fun il => inil
    | a :: As' => fun il => icons (f (ilist_hd il)) (imap As' (ilist_tl il))
    end.

  (* [imap] behaves as expected with the [ith_default] lookup
     function. *)
  Lemma ith_imap :
    forall {n}
           (m : Fin.t n)
           (As : Vector.t A n)
           (il : ilist As),
      f (ith il m) = ith (imap As il) m.
  Proof.
    induction m; intro.
    - eapply Vector.caseS with (v := As); intros; simpl in *; destruct il; reflexivity.
    - revert m IHm.
      pattern n, As.
      match goal with
        |- ?P n As =>
        simpl; eapply (@Vector.rectS _ P); intros
      end.
      inversion m.
      eapply IHm.
  Qed.

End ilist_imap.

Section ilist_replace.

  Import Coq.Vectors.VectorDef.VectorNotations.

  (* Replacing an element of an indexed Vector.t. *)
  Context {A : Type}. (* The indexing type. *)
  Context {B : A -> Type}. (* The two types of indexed elements. *)

  Fixpoint replace_Index
             {m}
             (As : Vector.t A m)
             (il : ilist As)
             (n : Fin.t m)
             (new_b : B (Vector.nth As n))
             {struct n}
    : ilist As :=
    match n in Fin.t m return
          forall (As : Vector.t A m),
            ilist As
            -> B (Vector.nth As n)
            -> ilist As with
    | Fin.F1 k =>
      fun As =>
        Vector.caseS (fun n As => ilist As
                                  -> B (Vector.nth As (@Fin.F1 n))
                                  -> ilist As)
                     (fun h n t il new_b => icons new_b (ilist_tl il) ) As
    | Fin.FS k n' =>
      fun As =>
        Vector_caseS' Fin.t
                     (fun n As n' =>
                          ilist As
                          -> B (Vector.nth As (@Fin.FS n n'))
                          -> ilist As)
                     (fun h n t m il new_b => icons (ilist_hd il)
                                                    (@replace_Index _ _ (ilist_tl il) _ new_b))
                     As n'
    end As il new_b.

  Lemma ith_replace_Index_neq {m}
    : forall
      (n n' : Fin.t m)
      (As : Vector.t A m)
      (il : ilist As)
      (new_b : B (Vector.nth As n')),
      n <> n'
      -> ith (replace_Index As il n' new_b) n = ith il n.
  Proof.
    intros n n'; pattern m, n, n'.
    match goal with
      |- ?P m n n' => simpl; eapply (Fin.rect2 P); intros
    end.
    - congruence.
    - generalize il f new_b; clear f new_b il H.
      pattern n0, As.
      match goal with
        |- ?P n0 As =>
        simpl; apply (@Vector.rectS _ P); intros; reflexivity
      end.
    - generalize il f new_b; clear f new_b il H.
      pattern n0, As.
      match goal with
        |- ?P n0 As =>
        simpl; apply (@Vector.rectS _ P); intros; reflexivity
      end.
    - assert (f <> g) by congruence.
      generalize il f g new_b H H1; clear f g new_b il H H1 H0.
      pattern n0, As.
      match goal with
        |- ?P n0 As =>
        simpl; apply (@Vector.caseS _ P); intros;
        eapply (H _ (prim_snd il) new_b); eauto
      end.
  Qed.

  Lemma ith_replace_Index_eq {m}
    : forall
      (n : Fin.t m)
      (As : Vector.t A m)
      (il : ilist As)
      (new_b : B (Vector.nth As n)),
      ith (replace_Index As il n new_b) n = new_b.
  Proof.
    induction n; simpl.
    - intro As; pattern n, As.
      match goal with
        |- ?P n As =>
        simpl; apply (@Vector.caseS _ P); intros; reflexivity
      end.
    - intro As; revert n0 IHn; pattern n, As.
      match goal with
        |- ?P n As =>
        simpl; apply (@Vector.caseS _ P); simpl; eauto
      end.
  Qed.

End ilist_replace.


(*
  Exercises for <Software Foundations> V2 CH3.
  Arthur : Brethland, Late 2019.
 *)

Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Strings.String.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import omega.Omega.
Add LoadPath "C:\Users\ycy12\Documents\Workspace\LEARNING-STUFF\Coq".
Load Coq24.

Fixpoint parity x :=
  match x with
  | 0 => 0
  | 1 => 1
  | S (S x') => parity x'
  end.

Lemma parity_ge_2 : ∀x,
  2 ≤ x →
  parity (x - 2) = parity x.
Proof.
  induction x; intro. reflexivity.
  destruct x. inversion H. inversion H1.
  simpl. rewrite <- minus_n_O. reflexivity.
Qed.

Lemma parity_lt_2 : ∀x,
  ¬2 ≤ x →
  parity (x) = x.
Proof.
  intros. induction x. reflexivity. destruct x. reflexivity.
    exfalso. apply H. omega.
Qed.

Lemma silly : forall n m, n <= m -> S n <= S m.
Proof. intros. omega. Qed.

Lemma silly2 : forall n m, S n <= S m -> n <= m.
Proof. intros. omega. Qed.

Theorem le_ble_nat : forall n m,
  n <= m ->
  n <=? m = true.
Proof.
  (* Hint: This may be easiest to prove by induction on [m]. *)
  intros. generalize dependent n. induction m.
  - intros. inversion H. simpl. reflexivity.
  - intros. destruct n.
    + simpl. reflexivity.
    + simpl. apply IHm. apply silly2. apply H.
Qed.

Theorem ble_nat_true : forall n m,
  n <=? m = true -> n <= m.
Proof.
  induction n.
  - intros. omega.
  - intros. destruct m.
    + inversion H.
    + simpl in H. apply silly. apply IHn. apply H.
Qed.

Theorem ble_nat_false : forall n m,
  n <=? m = false -> ~(n <= m).
Proof.
  unfold not. intros. apply le_ble_nat in H0. rewrite H0 in H. inversion H.
Qed.

Lemma fuck : forall b, ~(b = true) -> b = false.
Proof. intros. destruct b. exfalso. apply H. auto. auto.
Qed.

Theorem parity_correct : forall m,
    {{ fun st => st X = m }}
  (WHILE 2 ≤ X DO
    X ::= X - 2
  END)
    {{ fun st => st X = parity m }}.
Proof.
  intros. eapply hoare_consequence_post.
  apply hoare_consequence_pre with (fun st => parity (st X) = parity m).
  apply hoare_while. eapply hoare_consequence_pre. apply hoare_asgn.
  unfold assert_implies, assn_sub, t_update.
  intros. simpl. destruct H. rewrite <- H. apply parity_ge_2. apply ble_nat_true. apply H0.
  unfold assert_implies, assn_sub, t_update.
  intros. auto.
  unfold assert_implies, assn_sub, t_update.
  intros. destruct H. rewrite <- H. symmetry. apply parity_lt_2.
  unfold bassn in H0. apply ble_nat_false. unfold not in H0. apply fuck. auto.
Qed.

Definition is_wp P c Q :=
  {{P}} c {{Q}} ∧
  ∀P', {{P'}} c {{Q}} → (P' ->> P).

Theorem is_wp_example :
  is_wp (fun st => st Y ≤ 4)
    (X ::= Y + 1) (fun st => st X ≤ 5).
Proof.
  unfold is_wp. split.
  - eapply hoare_consequence_pre. apply hoare_asgn.
    intros st H. unfold assn_sub, t_update. simpl. omega.
  - intros. intros st H'. unfold hoare_triple in H.
    eapply H in H'. Abort.

Fixpoint fib n :=
  match n with
  | 0 => 1
  | S n' => match n' with
            | 0 => 1
            | S n'' => fib n' + fib n''
            end
  end.

Lemma negb_inv : forall a, ~ (negb a = true) -> a = true.
Proof. intros. destruct a. auto. simpl in H. destruct H. auto.
Qed.

From Coq Require Import Arith Div2 Omega Lia Nat.

Theorem pow_correct : forall (n : nat) (a : nat), {{ fun st => st X = a /\ st Y = 1 }}
  ( WHILE ~ (Y = n) DO
      X ::= X * a ;;
      Y ::= Y + 1
    END ) {{ fun st => st X = a ^ n }}.
Proof.
  intros. eapply hoare_consequence_post.
  apply hoare_consequence_pre with (fun st => st X = a ^ (st Y)).
  apply hoare_while. eapply hoare_seq.
  apply hoare_asgn. eapply hoare_consequence_pre. apply hoare_asgn.
  unfold assert_implies, assn_sub, t_update. simpl. intros. destruct H.
  rewrite H. rewrite Nat.pow_add_r. simpl.
  assert(H' : a * 1 = a) by omega. rewrite H'. auto.
  1 - 2 : unfold assert_implies, assn_sub, t_update;intros;destruct H.
  rewrite H0. simpl. assert(H' : a * 1 = a) by omega. rewrite H'. auto.
  unfold bassn in H0. rewrite H.  assert (H' : st Y = n).
  apply negb_inv in H0. apply beq_nat_true in H0. auto. subst. auto.
Qed.

(* Leaving Weakest Preconditions and Extended Exercises *)


(* Problem 0-2 *)

Theorem tautology : forall P : Prop, P -> P.
Proof.
  intros P H.
  assumption.
Qed.

(*
Theorem wrong : forall P : Prop, P.
Proof.
  intros P.
Qed.

Error: Attempt to save an incomplete proof
*)

(* Problem 1 *)

Theorem Modus_ponens : forall P Q : Prop, P -> (P -> Q) -> Q.
Proof.
  intro.
  intro.
  intro.
  intro.
  apply H0.
  apply H.
Qed.

(* Problem 2 *)
Theorem Modus_tollens : forall P Q : Prop, ~Q /\ (P -> Q) -> ~P.
Proof.
  intros.
  destruct H.
  intro.
  apply H0 in H1.
  apply H in H1.
  apply H1.
Qed.

(* Problem 3 *)

Theorem Disjunctive_syllogism : forall P Q : Prop, (P \/ Q) -> ~P -> Q.
Proof.
  intros.
  destruct H.
  apply H0 in H.
  destruct H.
  apply H.
Qed.

(* Problem 4 *)
Theorem DeMorgan1 : forall P Q : Prop, ~P \/ ~Q -> ~(P /\ Q).
Proof.
  intros.
  intro.
  destruct H as [HA | HB].
  destruct H0 as [H0A H0B].
  apply HA in H0A. apply H0A.
  destruct H0 as [H0A H0B].
  apply HB in H0B. apply H0B.
Qed.

Theorem DeMorgan2 : forall P Q : Prop, ~P /\ ~Q -> ~(P \/ Q).
Proof.
  intros.
  intro.
  destruct H0 as [H0A | H0B].
  destruct H as [HA HB].
  apply HA in H0A. apply H0A.
  destruct H as [HA HB].
  apply HB in H0B. apply H0B.
Qed.

Theorem DeMorgan3 : forall P Q : Prop, ~(P \/ Q) -> ~P /\ ~Q.
Proof.
  intros.
  apply conj.
  intro.
  apply H.
  left. apply H0.
  intro.
  apply H.
  right.
  apply H0.
Qed.

(* Problem 5 *)
Theorem NotNot_LEM : forall P : Prop, ~ ~(P \/ ~P).
Proof.
  intros.
  intro.
  apply H.
  right.
  intro.
  apply H.
  left.
  apply H0.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_lessthanbetween.
Require Export GeoCoq.Elements.OriginalProofs.lemma_lessthanadditive.

Section Euclid.
Context `{Ax:euclidean_neutral_ruler_compass}.
Lemma lemma_21helper :
   forall A B C E,
   TG B A A E B E -> BetS A E C ->
   TT B A A C B E E C.
Proof.
intros.
rename_H H;let Tf:=fresh in
assert (Tf:exists H, (BetS B A H /\ Cong A H A E /\ Lt B E B H)) by (conclude_def TG );destruct Tf as [H];spliter.
assert (neq B A) by (forward_using lemma_betweennotequal).
assert (~ eq B E).
 {
 intro.
 assert (Lt B B B H) by (conclude cn_equalitysub).
 let Tf:=fresh in
 assert (Tf:exists K, (BetS B K H /\ Cong B K B B)) by (conclude_def Lt );destruct Tf as [K];spliter.
 assert (~ neq B K).
  {
  intro.
  assert (neq B B) by (conclude axiom_nocollapse).
  assert (eq B B) by (conclude cn_equalityreflexive).
  contradict.
  }
 assert (BetS B B H) by (conclude cn_equalitysub).
 assert (neq B B) by (forward_using lemma_betweennotequal).
 assert (eq B B) by (conclude cn_equalityreflexive).
 contradict.
 }
assert (neq A C) by (forward_using lemma_betweennotequal).
let Tf:=fresh in
assert (Tf:exists F, (BetS B A F /\ Cong A F A C)) by (conclude lemma_extension);destruct Tf as [F];spliter.
assert (neq E C) by (forward_using lemma_betweennotequal).
let Tf:=fresh in
assert (Tf:exists G, (BetS B E G /\ Cong E G E C)) by (conclude lemma_extension);destruct Tf as [G];spliter.
assert (Cong A C A F) by (conclude lemma_congruencesymmetric).
assert (Cong A E A H) by (conclude lemma_congruencesymmetric).
assert (Cong A E A E) by (conclude cn_congruencereflexive).
assert (Lt A E A C) by (conclude_def Lt ).
assert (Lt A E A F) by (conclude lemma_lessthancongruence).
assert (Lt A H A F) by (conclude lemma_lessthancongruence2).
assert (Out A H F) by (conclude_def Out ).
assert (BetS A H F) by (conclude lemma_lessthanbetween).
assert (Cong E C H F) by (conclude lemma_differenceofparts).
assert (Cong E G H F) by (conclude lemma_congruencetransitive).
assert (BetS B H F) by (conclude lemma_3_7a).
assert (Lt B G B F) by (conclude lemma_lessthanadditive).
assert (TG B A A C B G) by (conclude_def TG ).
assert (TT B A A C B E E C) by (conclude_def TT ).
close.
Qed.

End Euclid.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (n : natural) (x : lst) : natural := len (append x x).


Lemma FirstLemma: forall A B C: Prop, (A -> B -> C) -> (A -> B) -> (A -> C).
(*intros.*)
intros A B C X Y Z.

apply X.

assumption.

apply Y.
assumption.
Qed.

Print FirstLemma.

(* In natural deduction

G, A |- B
-------------------- (-> intro)
G |- A -> B

G |- A -> B      G |- A
-------------------------(-> elim) (application rule)
G |- B

*)