From Hammer Require Import Tactics Reflect Hints.
From Hammer Require Import Hammer.

From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat ssralg seq fintype tuple eqtype.

From Coq Require Import FunctionalExtensionality.
From Coq Require Import Relation_Definitions RelationClasses.

Require Import CoqArith.Utils.

Require Import Program.

Section Sigma_1_1_Internal.

Definition SOctx := seq nat.
Definition FOctx := nat.

Inductive RingTerm {soctx : SOctx} {foctx : FOctx} : Type :=
| RingVar : 'I_foctx -> RingTerm
| RingFun : forall (i : 'I_(length soctx)),
            ('I_(tnth (in_tuple soctx) i) -> RingTerm) ->
            RingTerm
| RingMinusOne : RingTerm
| RingPlusOne : RingTerm
| RingZero : RingTerm
| RingPlus : RingTerm -> RingTerm -> RingTerm
| RingTimes : RingTerm -> RingTerm -> RingTerm.

Definition RingTermFOQuote {soctx} {foctx} :
  @RingTerm soctx foctx ->
  RingTerm (soctx := soctx) (foctx := foctx.+1).
  intro r.
  induction r.
  - apply RingVar.
    destruct o as [o lto].
    apply (Ordinal (m := o.+1)); auto.
  - apply (RingFun i).
    intro.
    exact (X X0).
  - exact RingMinusOne.
  - exact RingPlusOne.
  - exact RingZero.
  - exact (RingPlus IHr1 IHr2).
  - exact (RingTimes IHr1 IHr2).
Defined.

Theorem RingTermFOQuote_Fun_Step {soctx} {foctx}
  (i : 'I_(length soctx))
  (t : 'I_(tnth (in_tuple soctx) i) -> RingTerm (foctx := foctx)) :
  RingTermFOQuote (RingFun i t) =
  RingFun i (fun x => RingTermFOQuote (t x)).
Proof. reflexivity. Qed.

Definition RingTermSOQuote {soctx} {foctx} {bs} :
  @RingTerm soctx foctx ->
  RingTerm (soctx := bs :: soctx) (foctx := foctx).
  elim.
  - apply RingVar.
  - move=>[i lti] _ IH.
    assert (i.+1 < length (bs :: soctx));[auto|].
    apply (RingFun (Ordinal (m := i.+1) H)).
    move=>[j ltj].
    apply: IH.
    apply (Ordinal (m := j)).
    by do 2 rewrite (tnth_nth 0) in ltj *.
  - exact RingMinusOne.
  - exact RingPlusOne.
  - exact RingZero.
  - intros r1 IHr1 r2 IHr2.
    exact (RingPlus IHr1 IHr2).
  - intros r1 IHr1 r2 IHr2.
    exact (RingTimes IHr1 IHr2).
Defined.

Theorem RingTermSOQuote_Fun_Step {soctx} {foctx} {n}
  (i : nat) (lti : i < length soctx)
  (t : 'I_(tnth (in_tuple soctx) (Ordinal lti)) -> RingTerm (foctx := foctx)) :
  RingTermSOQuote (RingFun (Ordinal lti) t) =
  RingFun (Ordinal (n:=length (n :: soctx)) (m:=i.+1) lti)
          (fun x => RingTermSOQuote (t (eq_rect _ (fun x => 'I_x) x _ (tnth_tuple_index n lti)))).
Proof.
  unfold RingTermSOQuote at 1.
  unfold RingTerm_rect.
  f_equal.
  apply functional_extensionality.
  move=>[x ltx].
  unfold RingTermSOQuote, RingTerm_rect.
  do 2 f_equal.
  apply ord_inj.
  destruct (tnth_tuple_index _ _); reflexivity.
Qed.

Definition RingTermFOSubst {soctx : SOctx} {foctx : FOctx} :
  forall (i : 'I_foctx),
  @RingTerm soctx (foctx.-1) ->
  @RingTerm soctx foctx ->
  @RingTerm soctx (foctx.-1).
  move=> [i lti] t s.
  induction s.
  - destruct o as [o lto].
    destruct (Nat.compare i o) eqn:comp.
    + exact t.
    + rewrite <- Compare_dec.nat_compare_lt in comp.
      apply (introT (b := i < o) ltP) in comp.
      apply RingVar.
      apply (Ordinal (m:=o.-1)).
      sauto q: on.
    + rewrite <- Compare_dec.nat_compare_gt in comp.
      apply (introT (b := o < i) ltP) in comp.
      apply RingVar.
      apply (Ordinal (m:=o)).
      destruct i;[auto|].
      destruct foctx as [|[|foctx]];[auto|auto|].
      hauto use: (leq_ltn_trans (n := i)), pred_Sn, subn1.
  - apply (RingFun i0).
    intro.
    exact (X X0).
  - exact RingMinusOne.
  - exact RingPlusOne.
  - exact RingZero.
  - exact (RingPlus IHs1 IHs2).
  - exact (RingTimes IHs1 IHs2).
Defined.

Theorem RingTermFOSubst_Fun_Step {soctx} {foctx}
  (i : 'I_foctx)
  (j : 'I_(length soctx))
  (r : @RingTerm soctx (foctx.-1))
  (t : 'I_(tnth (in_tuple soctx) j) -> RingTerm (foctx := foctx)) :
  RingTermFOSubst i r (RingFun j t) =
  RingFun j (fun x => RingTermFOSubst i r (t x)).
Proof. destruct i; reflexivity. Qed.

Theorem FOsubsts_unquote {soctx : SOctx} {foctx : FOctx} :
  forall (x : @RingTerm soctx foctx)
         (e : @RingTerm soctx foctx)
         (H : 0 < foctx.+1),
  RingTermFOSubst (Ordinal H) x (RingTermFOQuote e) = e.
Proof.
  move=> x; elim; try hauto q:on.
  - move=> [i lti] t rH triv.
    rewrite RingTermFOQuote_Fun_Step RingTermFOSubst_Fun_Step.
    f_equal.
    apply functional_extensionality; move=> [j ltj].
    by rewrite rH.
Qed.

Definition RingTermSOSubst {soctx : SOctx} {foctx : FOctx} :
  forall (i : 'I_(length soctx)),
  (('I_(tnth (in_tuple soctx) i) ->
   RingTerm (soctx := drop_index i soctx) (foctx := foctx)) ->
   RingTerm (soctx := drop_index i soctx) (foctx := foctx)) ->
  @RingTerm soctx foctx ->
  RingTerm (soctx := drop_index i soctx) (foctx := foctx).
  move=> [i lti] f; elim.
  - apply RingVar.
  - move=> [j ltj].
    destruct (Nat.compare i j) eqn:comp.
    + apply Compare_dec.nat_compare_eq in comp.
      move: ltj; rewrite <- comp=> ltj.
      rewrite (eq_irrelevance ltj lti); clear comp j ltj=> t tH.
      exact (f tH).
    + clear f.
      rewrite <- Compare_dec.nat_compare_lt in comp.
      apply (introT (b := i < j) ltP) in comp.
      move=> _ tH.
      assert (j.-1 < length (drop_index i soctx)) as H.
      { rewrite drop_index_length; auto.
        destruct j; auto; clear tH; destruct (length soctx); [auto|sauto q:on lazy:on]. }
      apply (RingFun (Ordinal (m := j.-1) H)).
      move=> [o lto].
      apply: tH.
      apply (Ordinal (m:=o)).
      do 2 rewrite (tnth_nth 0) in lto *.
      simpl; simpl in lto.
      by rewrite drop_index_nth_high in lto.
    + clear f.
      rewrite <- Compare_dec.nat_compare_gt in comp.
      apply (introT (b := j < i) ltP) in comp.
      move=> _ tH.
      assert (j < length (drop_index i soctx)) as H.
      { hauto use: drop_index_length, pred_Sn, ltn_predRL, leq_ltn_trans. }
      apply (RingFun (Ordinal (m := j) H)).
      move=>[o lto]; apply: tH.
      do 2 rewrite (tnth_nth 0) in lto *.
      simpl; simpl in lto.
      rewrite drop_index_nth_low in lto; sauto q:on.
  - exact RingMinusOne.
  - exact RingPlusOne.
  - exact RingZero.
  - intros r1 IHr1 r2 IHr2.
    exact (RingPlus IHr1 IHr2).
  - intros r1 IHr1 r2 IHr2.
    exact (RingTimes IHr1 IHr2).
Defined.

Lemma Lt_Compare_match {i} {j} {Q : comparison -> Type}
  {a : Q Eq} {b : Q Lt} {c : Q Gt}
  (comp : Lt = Nat.compare i j) :
  (match Nat.compare i j as c return (Q c) with
  | Eq => a
  | Lt => b
  | Gt => c
  end) = eq_rect _ Q b _ comp.
Proof. destruct comp; reflexivity. Qed.

Lemma Lt_Compare_match_fun {i} {j} {Q : comparison -> Type} {R : Type}
  {a : Q Eq -> R} {b : Q Lt -> R} {c : Q Gt -> R}
  (v : Q (Nat.compare i j))
  (comp : Nat.compare i j = Lt) :
  match Nat.compare i j as c return (Q c -> R) with
  | Eq => a
  | Lt => b
  | Gt => c
  end v = b (eq_rect _ Q v _ comp).
Proof.
  rewrite (Lt_Compare_match (esym comp)).
  destruct comp; reflexivity.
Qed.

Theorem RingTermSOSubst_Fun_Step_Lt {soctx : SOctx} {foctx : FOctx}
  (i : nat) (lti : i < length soctx)
  (f : ('I_(tnth (in_tuple soctx) (Ordinal lti)) ->
        RingTerm (soctx := drop_index i soctx) (foctx := foctx)) ->
        RingTerm (soctx := drop_index i soctx) (foctx := foctx))
  (j : nat) (ltj : j < length soctx)
  (t : 'I_(tnth (in_tuple soctx) (Ordinal ltj)) ->
        RingTerm  (soctx := soctx) (foctx := foctx))
  (ltij : i < j) :
  RingTermSOSubst (Ordinal lti) f (RingFun (Ordinal ltj) t) =
  RingFun (Ordinal (n:=length (drop_index (Ordinal lti) soctx)) (m:=j.-1) (index_low_decr ltij ltj))
          (fun x => RingTermSOSubst (Ordinal lti) f
                      (t (eq_rect _ (fun x => 'I_x) x _
                         (decr_index_const ltj (index_low_decr ltij ltj) ltij)))).
Proof.
  assert (PeanoNat.Nat.compare i j = Lt) as comp_lt;[exact
    (iffLR (Compare_dec.nat_compare_lt i j) (elimT (b := i < j) ltP ltij))|].
  unfold RingTermSOSubst at 1; unfold RingTerm_rect; rewrite (Lt_Compare_match_fun _ comp_lt);
  rewrite (eq_irrelevance (eq_ind_r (fun pv : nat => j.-1 < pv) _ _) (index_low_decr ltij ltj)).
  f_equal.
  apply functional_extensionality;move=>[x ltx].
  unfold RingTermSOSubst, RingTerm_rect; do 2 f_equal.
  remember (eq_ind_r (fun pv : nat => x < pv -> x < _) _ _ _) as ltx2 eqn:dx; clear dx.
  destruct (decr_index_const _ _ _); by apply ord_inj.
Qed.

Lemma Gt_Compare_match {i} {j} {Q : comparison -> Type}
  {a : Q Eq} {b : Q Lt} {c : Q Gt}
  (comp : Gt = Nat.compare i j) :
  (match Nat.compare i j as c return (Q c) with
  | Eq => a
  | Lt => b
  | Gt => c
  end) = eq_rect _ Q c _ comp.
Proof. destruct comp; reflexivity. Qed.

Lemma Gt_Compare_match_fun {i} {j} {Q : comparison -> Type} {R : Type}
  {a : Q Eq -> R} {b : Q Lt -> R} {c : Q Gt -> R}
  (v : Q (Nat.compare i j))
  (comp : Nat.compare i j = Gt) :
  match Nat.compare i j as c return (Q c -> R) with
  | Eq => a
  | Lt => b
  | Gt => c
  end v = c (eq_rect _ Q v _ comp).
Proof.
  rewrite (Gt_Compare_match (esym comp)).
  destruct comp; reflexivity.
Qed.

Theorem RingTermSOSubst_Fun_Step_Gt {soctx : SOctx} {foctx : FOctx}
  (i : nat) (lti : i < length soctx)
  (f : ('I_(tnth (in_tuple soctx) (Ordinal lti)) ->
        RingTerm (soctx := drop_index i soctx) (foctx := foctx)) ->
        RingTerm (soctx := drop_index i soctx) (foctx := foctx))
  (j : nat) (ltj : j < length soctx)
  (t : 'I_(tnth (in_tuple soctx) (Ordinal ltj)) ->
        RingTerm  (soctx := soctx) (foctx := foctx))
  (ltij : j < i) :
  RingTermSOSubst (Ordinal lti) f (RingFun (Ordinal ltj) t) =
  RingFun (Ordinal (low_index_bound ltj ltij))
          (fun x => RingTermSOSubst (Ordinal lti) f
                      (t (eq_rect _ (fun x => 'I_x) x _
                         (low_index_const ltj (low_index_bound ltj ltij) ltij)))).
Proof.
  assert (PeanoNat.Nat.compare i j = Gt) as comp_gt;[exact
    (iffLR (Compare_dec.nat_compare_gt i j) (elimT (b := j < i) ltP ltij))|].
  unfold RingTermSOSubst at 1; unfold RingTerm_rect; rewrite (Gt_Compare_match_fun _ comp_gt);
  rewrite (eq_irrelevance (eq_ind_r (fun pv : nat => j < pv) _ _) (low_index_bound ltj ltij)).
  f_equal.
  apply functional_extensionality;move=>[x ltx].
  unfold RingTermSOSubst, RingTerm_rect; do 2 f_equal.
  apply ord_inj.
  unfold eq_rect_r.
  rewrite (rew_map (fun x => x -> _) (fun v => x < v)).
  destruct (low_index_const _ _ _); simpl.
  by destruct (f_equal _ _), (Logic.eq_sym _), (Logic.eq_sym _).
Qed.

Lemma Eq_Compare_match {i} {j} {Q : comparison -> Type}
  {a : Q Eq} {b : Q Lt} {c : Q Gt}
  (comp : Eq = Nat.compare i j) :
  (match Nat.compare i j as c return (Q c) with
  | Eq => a
  | Lt => b
  | Gt => c
  end) = eq_rect _ Q a _ comp.
Proof. destruct comp; reflexivity. Qed.

Lemma Eq_Compare_match_fun {i} {j} {Q : comparison -> Type} {R : Type}
  {a : Q Eq -> R} {b : Q Lt -> R} {c : Q Gt -> R}
  (v : Q (Nat.compare i j))
  (comp : Nat.compare i j = Eq) :
  match Nat.compare i j as c return (Q c -> R) with
  | Eq => a
  | Lt => b
  | Gt => c
  end v = a (eq_rect _ Q v _ comp).
Proof.
  rewrite (Eq_Compare_match (esym comp)).
  destruct comp; reflexivity.
Qed.

Theorem RingTermSOSubst_Fun_Step_Eq {soctx : SOctx} {foctx : FOctx}
  (i : nat) (lti : i < length soctx)
  (f : ('I_(tnth (in_tuple soctx) (Ordinal lti)) ->
        RingTerm (soctx := drop_index i soctx) (foctx := foctx)) ->
        RingTerm (soctx := drop_index i soctx) (foctx := foctx))
  (t : 'I_(tnth (in_tuple soctx) (Ordinal lti)) ->
        RingTerm  (soctx := soctx) (foctx := foctx)) :
  RingTermSOSubst (Ordinal lti) f (RingFun (Ordinal lti) t) =
  f (fun x => RingTermSOSubst (Ordinal lti) f (t x)).
Proof.
  unfold RingTermSOSubst at 1; unfold RingTerm_rect; rewrite (Eq_Compare_match_fun _ (PeanoNat.Nat.compare_refl i)).
  rewrite <- Eqdep.Eq_rect_eq.eq_rect_eq.
  unfold eq_rect_r.
  rewrite <- Eqdep.Eq_rect_eq.eq_rect_eq.
  reflexivity.
Qed.

(* A generalized version where i and j are merely assumed equal
Theorem RingTermSOSubst_Fun_Step_Eq {soctx : SOctx} {foctx : FOctx}
  (i : nat) (lti : i < length soctx)
  (f : ('I_(length ((tnth (in_tuple soctx) (Ordinal lti)).2)) ->
        RingTerm (soctx := drop_index i soctx) (foctx := foctx)) ->
        RingTerm (soctx := drop_index i soctx) (foctx := foctx))
  (j : nat) (ltj : j < length soctx)
  (t : 'I_(length ((tnth (in_tuple soctx) (Ordinal ltj)).2)) ->
        RingTerm  (soctx := soctx) (foctx := foctx))
  (ltij : j = i)
  (ltm : i < length (@drop_index (nat * seq nat) i soctx))
  (e : tnth (in_tuple soctx) (Ordinal lti) =
       tnth (in_tuple soctx) (Ordinal ltj)) :
  RingTermSOSubst (Ordinal lti) f (RingFun (Ordinal ltj) t) =
  f (fun x => t (eq_rect _ (fun x => 'I_(length x.2)) x _ e)).
Proof.
*)

Lemma eq_rect_f_ap {T} {B} {Q : T -> Type} {a b : T} {e : a = b}
  (f : Q a -> B) :
  eq_rect _ (fun x => Q x -> B) f _ e
  = fun x => f (eq_rect _ Q x _ (esym e)).
Proof. by destruct e. Qed.

Theorem SOsubsts_unquote {soctx : SOctx} {foctx : FOctx} :
  forall n
         (e : @RingTerm soctx foctx)
         (H : 0 < length (n :: soctx)) f,
  RingTermSOSubst (Ordinal H) f (RingTermSOQuote (bs := n) e) = e.
Proof.
  move=> n; elim.
  - hauto.
  - move=> [i lti] t IHe H f.
    rewrite RingTermSOQuote_Fun_Step.
    rewrite RingTermSOSubst_Fun_Step_Lt.
    change (drop_index _ (_ :: soctx)) with soctx.
    assert (Ordinal (n:=length soctx) (m:=i) lti =
            Ordinal (n:=length soctx) (m:=i.+1.-1)
                    (@index_low_decr 0 i.+1 _ (n :: soctx) H lti)) as H0;[apply ord_inj;hauto|].
    transitivity
      (RingFun (Ordinal (n:=length soctx) (m:=i.+1.-1) (@index_low_decr 0 i.+1 _ (n :: soctx) H lti))
      (eq_rect _ (fun x => 'I_(tnth _ x) -> _) t _ H0));[|destruct H0;reflexivity].
    f_equal.
    apply functional_extensionality.
    move=>[x ltx].
    rewrite IHe; clear IHe.
    rewrite eq_rect_f_ap.
    f_equal.
    apply ord_inj.
    rewrite (rew_map (fun x => 'I_x) (tnth (in_tuple soctx))).
    do 3 rewrite <- (map_subst (P := (fun x => 'I_x)) (fun _ p => nat_of_ord p)).
    by do 3 rewrite rew_const.
  - hauto.
  - hauto.
  - hauto.
  - move=> r1 IHr1 r2 IHr2 h f.
    by rewrite <- IHr1 at 2; rewrite <- IHr2 at 2.
  - move=> r1 IHr1 r2 IHr2 h f.
    by rewrite <- IHr1 at 2; rewrite <- IHr2 at 2.
Qed.

Inductive ZerothOrderFormula {soctx : SOctx} {foctx : FOctx} : Type :=
| ZOTrue : ZerothOrderFormula
| ZOFalse : ZerothOrderFormula
| ZONot : ZerothOrderFormula -> ZerothOrderFormula
| ZOAnd : ZerothOrderFormula ->
          ZerothOrderFormula ->
          ZerothOrderFormula
| ZOOr : ZerothOrderFormula ->
         ZerothOrderFormula ->
         ZerothOrderFormula
| ZOImp : ZerothOrderFormula ->
          ZerothOrderFormula ->
          ZerothOrderFormula
| ZOEq : @RingTerm soctx foctx ->
         @RingTerm soctx foctx ->
         ZerothOrderFormula.

Definition ZerothOrderFormulaFOSubst {soctx : SOctx} {foctx : FOctx} :
  forall (i : 'I_foctx),
  @RingTerm soctx foctx.-1 ->
  @ZerothOrderFormula soctx foctx ->
  @ZerothOrderFormula soctx foctx.-1.
  intros i t s.
  induction s.
  - exact ZOTrue.
  - exact ZOFalse.
  - exact (ZONot IHs).
  - exact (ZOAnd IHs1 IHs2).
  - exact (ZOOr IHs1 IHs2).
  - exact (ZOImp IHs1 IHs2).
  - exact (ZOEq (RingTermFOSubst i t r) (RingTermFOSubst i t r0)).
Defined.

Definition ZerothOrderFormulaSOSubst {soctx : SOctx} {foctx : FOctx} :
  forall (i : 'I_(length soctx)),
  (('I_(tnth (in_tuple soctx) i) ->
   @RingTerm (drop_index i soctx) foctx) ->
   @RingTerm (drop_index i soctx) foctx) ->
  @ZerothOrderFormula soctx foctx ->
  @ZerothOrderFormula (drop_index i soctx) foctx.
  intros i f s.
  induction s.
  - exact ZOTrue.
  - exact ZOFalse.
  - exact (ZONot IHs).
  - exact (ZOAnd IHs1 IHs2).
  - exact (ZOOr IHs1 IHs2).
  - exact (ZOImp IHs1 IHs2).
  - exact (ZOEq (RingTermSOSubst i f r) (RingTermSOSubst i f r0)).
Defined.

Inductive FirstOrderFormula {soctx : SOctx} {foctx : FOctx} : Type :=
| ZO : @ZerothOrderFormula soctx foctx -> FirstOrderFormula
| FOExists : nat -> FirstOrderFormula (foctx := foctx.+1) -> FirstOrderFormula
| FOForall : nat -> FirstOrderFormula (foctx := foctx.+1) -> FirstOrderFormula.

Definition FirstOrderFormulaFOSubst {soctx : SOctx} {foctx : FOctx} :
  forall (i : 'I_foctx),
  @RingTerm soctx foctx.-1 ->
  @FirstOrderFormula soctx foctx ->
  @FirstOrderFormula soctx foctx.-1.
  intros i t s.
  induction s.
  - exact (ZO (ZerothOrderFormulaFOSubst i t z)).
  - apply (FOExists n).
    destruct i as [i lti].
    assert (i.+1 < foctx.+1) as H;[auto|].
    destruct foctx;[fcrush|].
    apply (IHs (Ordinal (m := i.+1) H)).
    apply RingTermFOQuote.
    exact t.
  - apply (FOForall n).
    destruct i as [i lti].
    assert (i.+1 < foctx.+1) as H;[auto|].
    destruct foctx;[fcrush|].
    apply (IHs (Ordinal (m := i.+1) H)).
    apply RingTermFOQuote.
    exact t.
Defined.

Definition FirstOrderFormulaSOSubst {soctx : SOctx} {foctx : FOctx} :
  forall (i : 'I_(length soctx)),
  (('I_(tnth (in_tuple soctx) i) ->
   @RingTerm (drop_index i soctx) foctx) ->
   @RingTerm (drop_index i soctx) foctx) ->
  @FirstOrderFormula soctx foctx ->
  @FirstOrderFormula (drop_index i soctx) foctx.
  intros i f s.
  induction s.
  - exact (ZO (ZerothOrderFormulaSOSubst i f z)).
  - apply (FOExists n).
    apply IHs.
    intro t.
    assert (0 < foctx.+1) as H;[auto|].
    apply (fun x => RingTermFOQuote (f x)).
    exact (fun x => (RingTermFOSubst (Ordinal H) RingZero (t x))).
  - apply (FOForall n).
    apply IHs.
    intro t.
    assert (0 < foctx.+1) as H;[auto|].
    apply (fun x => RingTermFOQuote (f x)).
    exact (fun x => (RingTermFOSubst (Ordinal H) RingZero (t x))).
Defined.

Inductive SecondOrderFormula {soctx : SOctx} {foctx : FOctx} : Type :=
| FO : @FirstOrderFormula soctx foctx ->
       SecondOrderFormula
| SOExists : forall (y : nat) (bs : seq nat),
              SecondOrderFormula (soctx := length bs :: soctx) ->
              SecondOrderFormula.

Definition SecondOrderFormulaFOSubst {soctx : SOctx} {foctx : FOctx} :
  forall (i : 'I_foctx),
  @RingTerm soctx foctx.-1 ->
  @SecondOrderFormula soctx foctx ->
  @SecondOrderFormula soctx foctx.-1.
  intros i t s.
  induction s.
  - exact (FO (FirstOrderFormulaFOSubst i t f)).
  - apply (SOExists y bs).
    apply (IHs i).
    exact (RingTermSOQuote (bs := length bs) t).
Defined.

Definition SecondOrderFormulaSOSubst {soctx : SOctx} {foctx : FOctx} :
  forall (i : 'I_(length soctx)),
  (('I_(tnth (in_tuple soctx) i) ->
   @RingTerm (drop_index i soctx) foctx) ->
   @RingTerm (drop_index i soctx) foctx) ->
  @SecondOrderFormula soctx foctx ->
  @SecondOrderFormula (drop_index i soctx) foctx.
  move=> i f X;move: i f.
  induction X; move=>[i lti] f2.
  - exact (FO (FirstOrderFormulaSOSubst _ f2 f)).
  - apply (SOExists y bs).
    assert (i.+1 < length (length bs :: soctx)) as H;[auto|].
    apply (IHX (Ordinal (m := i.+1) H)).
    move=> t.
    apply RingTermSOQuote.
    apply: f2.
    move=> jo.
    replace (tnth (in_tuple (length bs :: soctx))
             (Ordinal (n:=length (length bs :: soctx)) (m:=i.+1) H))
       with (tnth (in_tuple soctx)
             (Ordinal (n:=length soctx) (m:=i) lti)) in t;
    [|by do 2 rewrite (tnth_nth 0)].
    apply t in jo; clear t.
    assert (forall ctx, 0 < length (length bs :: ctx)) as H0;[fcrush|].
    apply (RingTermSOSubst (Ordinal (H0 _)) (fun _ => RingZero)).
    exact jo.
Defined.

Example sigma11_1 : @SecondOrderFormula nil 0.
  apply (SOExists 5 [::2;3;4]).
  apply (SOExists 3 [::1;2]).
  apply FO.
  apply (FOExists 7).
  apply (FOForall 6).
  apply (FOExists 5).
  apply ZO.
  apply ZOOr.
  apply ZOAnd.
  apply ZOEq.
  apply RingPlusOne.
  apply (RingVar (inord 0)).
  apply ZOEq.
  apply (RingFun (soctx := [::_;_]) (inord 0)).
  intros [i lt].
  destruct i;[apply RingPlusOne|].
  destruct i;[apply RingMinusOne|].
  unfold in_tuple, tnth, tval in lt.
  rewrite inordK in lt;[|auto]; cbn in lt; inversion lt.
  apply (RingFun (soctx := [::_;_]) (inord 1)).
  intros [i lt].
  destruct i;[apply RingPlusOne|].
  destruct i;[apply RingMinusOne|].
  destruct i;[apply RingZero|].
  unfold in_tuple, tnth, tval in lt.
  rewrite inordK in lt;[|auto];cbn in lt;inversion lt.
  apply ZOTrue.
Defined.

Example sigma11_2 : @SecondOrderFormula nil 0 :=
  SOExists 5 [:: 2; 3; 4] (SOExists 3 [:: 1; 2]
	(FO (FOExists 7 (FOForall 6 (FOExists 5 (ZO
  (ZOOr
    (ZOAnd
      (ZOEq RingPlusOne (RingVar (inord 0)))
      (ZOEq
        (RingFun (soctx := [:: _; _]) (inord 0)
          (fun X  =>
            match X with
            | @Ordinal _ i _ =>
                match i with
                | 0 => RingPlusOne
                | _.+1 => RingMinusOne
                end
            end))
        (RingFun (soctx := [:: _; _]) (inord 1)
          (fun X =>
            match X with
            | @Ordinal _ i _ =>
                match i with
                | 0 => RingPlusOne
                | 1 => RingMinusOne
                | _.+2 => RingZero
                end
            end))
      )) ZOTrue))))))).

End Sigma_1_1_Internal.

Section Sigma_1_1_Denotation.

Record SecondOrderFormulaModel : Type :=
    mkSecondOrderFormulaModel {
        R : ringType;
        (*lt should be a strict, total order with a least element*)
        lt : relation R;
        so : StrictOrder lt;
        lt_total : forall x y, lt x y \/ x==y \/ lt y x;
        min : R;
        least_elem : forall x, lt min x
      }.

Fixpoint naturalRingElement {R : ringType} (n : nat) : R :=
  match n with
  | 0 => 0
  | x.+1 => naturalRingElement x + 1
  end.

(* Coercion naturalRingElement : nat >-> ringType. *)

Theorem map_length {A B} (f : A -> B) (s : seq A) : length [seq f i | i <- s] = length s.
Proof. move: s; elim; hauto q:on. Qed.

Theorem Ordinal_Rect n n2 m (i : m < n) (e : n = n2) :
  (eq_rect _ _ (Ordinal (n:=n) (m:=m) i) _ e) = Ordinal (eq_rect _ (fun x => m < x) i _ e).
Proof. by destruct e. Qed.

Theorem map_nth {A B} (f : A -> B) (s : seq A) (o : 'I_(length [seq f i | i <- s])) :
  tnth (in_tuple [seq f i | i <- s]) o =
  f (tnth (in_tuple s) (eq_rect _ _ o _ (map_length _ _))).
Proof.
  move: s o; elim;[move=> [x xlt]; fcrush|].
  simpl.
  move=> a l IH o.
  destruct o.
  rewrite Ordinal_Rect.
  rewrite (tnth_nth (f a)).
  rewrite (tnth_nth a).
  destruct m;[reflexivity|].
  simpl.
  assert (m < length [seq f i | i <- l]) as H;[hauto|].
  transitivity (tnth (in_tuple [seq f i0 | i0 <- l]) (Ordinal H));[
  by rewrite (tnth_nth (f a))|].
  rewrite IH.
  rewrite Ordinal_Rect.
  by rewrite (tnth_nth a).
Qed.

Theorem map_nth_2 {A B} (f : A -> B) (s : seq A) (o : 'I_(length s)) :
  f (tnth (in_tuple s) o)
  = tnth (in_tuple [seq f i | i <- s]) (eq_rect _ _ o _ (esym (map_length f _))).
Proof.
  move: s o; elim;[move=> [x xlt]; fcrush|].
  simpl.
  move=> a l IH o.
  destruct o.
  rewrite Ordinal_Rect.
  rewrite (tnth_nth (f a)).
  rewrite (tnth_nth a).
  destruct m;[reflexivity|].
  simpl.
  assert (m < length l) as H;[hauto|].
  transitivity (f (tnth (in_tuple l) (Ordinal H)));[
  by rewrite (tnth_nth a)|].
  rewrite IH.
  rewrite Ordinal_Rect.
  by rewrite (tnth_nth (f a)).
Qed.

Lemma map_nth_3_lem
  {A T} {a b} (P Q : A -> Type) (tt : forall a, P a -> Q a -> T)
  (e : a = b) (pa : P a) (qb : Q b) :
  tt _ (eq_rect _ _ pa _ e) qb =
  tt _ pa (eq_rect _ _ qb _ (esym e)).
Proof. by destruct e. Qed.

Theorem map_nth_3 {A B} (f : A -> B) (s : seq A) (o : 'I_(length s)) :
  f (tnth (in_tuple s) o)
  = tnth (eq_rect _ (fun i => i.-tuple B) (in_tuple [seq f i | i <- s])
         _
         (map_length f _)) o.
Proof.
  rewrite map_nth_2.
  by rewrite (map_nth_3_lem _ _ (fun x => @tnth x B) _ _ _).
Qed.

(*Interpreting a ring term with free variables as a function from ring elems. and functions. *)
Definition Ring_Denote (M : SecondOrderFormulaModel)
  (v1 : seq (R M))
  (v2 : seq {n : nat &
            {y : (R M) &
            {bs : n.-tuple (R M) &
            {f : ('I_n -> R M) -> R M |
            (forall (t : 'I_n -> R M), (forall x : 'I_n, lt M (t x) (tnth bs x)) -> lt M (f t) y)
            }}}})
  (s : @RingTerm [seq projT1 i | i <- v2] (length v1)) :
  R M.
  move:s; elim.
  - move=> idx; exact (tnth (in_tuple v1) idx).
  - move=> idx _ IH.
    rewrite map_nth in IH.
    destruct (tnth _ _) as [n[y[bs[f p]]]].
    exact (f IH).
  - exact (-1)%R.
  - exact 1%R.
  - exact 0%R.
  - move=> _ r1 _ r2; exact (r1 + r2)%R.
  - move=> _ r1 _ r2; exact (r1 * r2)%R.
Defined.

Fixpoint ZerothOrder_Denote (M : SecondOrderFormulaModel)
  (v1 : seq (R M))
  (v2 : seq {n : nat &
            {y : (R M) &
            {bs : n.-tuple (R M) &
            {f : ('I_n -> R M) -> R M |
            (forall (t : 'I_n -> R M), (forall x : 'I_n, lt M (t x) (tnth bs x)) -> lt M (f t) y)
            }}}})
  (f : @ZerothOrderFormula [seq projT1 i | i <- v2] (length v1)) : Prop :=
  match f with
  | ZOTrue => true
  | ZOFalse => false
  | ZONot f => not (ZerothOrder_Denote M v1 v2 f)
  | ZOAnd f1 f2 => (ZerothOrder_Denote M v1 v2 f1) /\ (ZerothOrder_Denote M v1 v2 f2)
  | ZOOr f1 f2 => (ZerothOrder_Denote M v1 v2 f1) \/ (ZerothOrder_Denote M v1 v2 f2)
  | ZOImp f1 f2 => (ZerothOrder_Denote M v1 v2 f1) -> (ZerothOrder_Denote M v1 v2 f2)
  | ZOEq r1 r2 => Ring_Denote M v1 v2 r1 = Ring_Denote M v1 v2 r2
  end.

Fixpoint FirstOrder_Denote (M : SecondOrderFormulaModel)
  (v1 : seq (R M))
  (v2 : seq {n : nat &
            {y : (R M) &
            {bs : n.-tuple (R M) &
            {f : ('I_n -> R M) -> R M |
            (forall (t : 'I_n -> R M), (forall x : 'I_n, lt M (t x) (tnth bs x)) -> lt M (f t) y)
            }}}})
  (f : @FirstOrderFormula [seq projT1 i | i <- v2] (length v1)) : Prop :=
  match f with
  | ZO z => ZerothOrder_Denote M v1 v2 z
  | FOExists n f =>
    exists (r : R M),
      lt M r (naturalRingElement n) /\
      FirstOrder_Denote M (r :: v1) v2 f
  | FOForall n f =>
    forall (r : R M),
      lt M r (naturalRingElement n) ->
      FirstOrder_Denote M (r :: v1) v2 f
  end.

(*Interpreting a ring term with free variables as a function from ring elems. and functions. *)
Program Fixpoint SecondOrder_Denote (M : SecondOrderFormulaModel)
  (v1 : seq (R M))
  (v2 : seq {n : nat &
            {y : (R M) &
            {bs : n.-tuple (R M) &
            {f : ('I_n -> R M) -> R M |
            (forall (t : 'I_n -> R M), (forall x : 'I_n, lt M (t x) (tnth bs x)) -> lt M (f t) y)
            }}}})
  (f : @SecondOrderFormula [seq projT1 i | i <- v2] (length v1)) : Prop :=
  match f with
  | FO f => FirstOrder_Denote M v1 v2 f
  | SOExists y bs f =>
    exists (rf : ('I_(length bs) -> R M) -> R M)
    (p : forall (t : 'I_(length bs) -> R M),
          (forall x : 'I_(length bs),
            lt M (t x) (naturalRingElement (tnth (in_tuple bs) x))) ->
            lt M (rf t) (naturalRingElement y)),
    SecondOrder_Denote M v1
      (existT _ (length bs)
      (existT _ (naturalRingElement y)
      (existT _ (in_tuple (map naturalRingElement bs))
      (exist _ rf p))) :: v2) f
  end.
Next Obligation.
  by rewrite <- (map_length (@naturalRingElement (R M))).
Qed.
Next Obligation.
  rewrite map_nth_3.
  do 2 f_equal.
  apply proof_irrelevance.
Qed.

(*
Note: This is impossible. Consider if one of the bs bounds is 0; then it's impossible
      for any applied argument to type check. Bounds should be part of the proposition,
      not enforced on the type level.

Definition Sigma11_Pred (M : SecondOrderFormulaModel)
  (v1 : seq (R M))
  (v2 : seq {n : nat &
            {y : (R M) &
            {bs : n.-tuple (R M) &
            ((forall o : 'I_n, {r : (R M) | lt M r (tnth bs o)}) -> {r : R M | lt M r y})}}})
  (s : @RingTerm [seq projT1 i | i <- v2] (length v1)) :
  R M := ...
*)

End Sigma_1_1_Denotation.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e192m2e64m1_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


(**
 Pierre Castéran, LaBRI and University of Bordeaux

 We prove that the impossibility result of # Epsilon0_Needed_Free# still holds for "standard" battles *)

From hydras Require Import Epsilon0_Needed_Generic.
Import Hydra_Lemmas Epsilon0 Canon Paths Relation_Operators O2H.
Import Hydra_Definitions.

Open Scope t1_scope.
(* begin snippet theContext *)

Section Impossibility_Proof.

  Context (mu: T1)
          (m : Hydra -> T1)
          (Var : Hvariant  T1_wf standard m)
          (Hy : BoundedVariant Var mu).

  Let big_h := big_h mu.
  Let small_h := small_h mu m.

  (* end snippet theContext *)

  (* begin snippet mGe *)

  Lemma m_ge : m big_h t1<= m small_h. (* .no-out *)
  (* end snippet mGe *)

  Proof.
    unfold big_h, small_h.  eapply m_ge_generic; trivial.
    intros; eapply variant_decr; eauto.
     intro; subst h; apply (head_no_round_n _ _ H).
  Qed.

  (** ** Proof of the inequality m small_h t1< m big_h *)

  (**  The measure is strictly decreasing along any round *)

  Lemma Lvar : forall h h0 i,
      h <> head ->
      battle_rel standard i h h0 -> m h0 t1< m h.
  Proof.
    intros h h0 i H  H1;  apply Var with  i; auto.
  Qed.

  (** Application to standard battles *)

  Lemma m_decrease : forall j h0 i h,
      h <> head -> rounds standard i  h j h0  -> m h0 t1< m h.
  Proof.
    induction 2.
    -  apply Lvar with i; auto.
    -  destruct (h_eq_dec h'' head).
       + rewrite e in H1;  assert False by
          (eapply standard_battle_head; eauto); contradiction.
       + apply LT_trans with (m h'');auto.
         apply Lvar with i; auto.
  Qed.

  (** Conversion of ordinal inequalities into  standard battles  *)

  (* begin hide *)
  Lemma o2iota_0 : forall j beta i alpha,
      standard_path_to j beta i alpha -> (0   nf alpha ->
      nf beta ->  beta <> T1.zero ->
      rounds standard (Nat.pred i) (iota alpha) j (iota beta) .
  Proof.
    induction 1.
    - intros; subst j; destruct i.
      +  now destruct  H2.
      +  simpl; left; trivial.
         * subst beta;   apply canonS_iota_i; trivial.
    -  intros  H0 H1 H2 H3;   destruct i.
       + inversion H0.
       +  eapply rounds_trans with  (S i) (iota (canon alpha (S i)));
            trivial.
          2:(left; simpl); trivial.
          replace (S i) with (Nat.pred (S (S i))).
          *   eapply IHstandard_path_to; trivial.
              auto with arith.
              eapply nf_canon;eauto.
          * simpl; auto.
          * apply canonS_iota_i; trivial.
            intro; subst alpha.
            apply H3;  eapply standard_path_zero; eauto.
  Qed.

  Lemma o2iota_1 : forall j beta i alpha,
      standard_path_to j beta (S i) alpha ->  nf alpha ->
      nf beta ->  beta <> T1.zero ->
      rounds standard  i (iota alpha) j (iota beta) .
  Proof.
    intros; change i with (Nat.pred (S i)); apply o2iota_0; trivial.
    auto with arith.
  Qed.

  Lemma o2iota : forall alpha  ,
      nf alpha -> forall i,
        (0  alpha = T1.zero \/
                       exists k : nat,
                         rounds standard (Nat.pred i) (iota alpha) k head .
  Proof.
    intros alpha; transfinite_induction_lt alpha.
    intros x H H0 i H1;  destruct (T1_eq_dec x T1.zero).
    -   now  left.
    -  right; destruct i.
       +   inversion H1.
       +   specialize (H (canon x (S i)) H0);
             assert (nf (canon x (S i))) by (eapply nf_canon; eauto).
           assert (T1.lt (canon x (S i)) x).
           { eapply canon_lt; eauto. }
           specialize (H H2 H3 H2 (S (S i)) ).
           destruct H.
           *  auto with arith.
           *  destruct (canonS_zero_inv _ _ H).
              subst; now destruct n.
              subst; exists (S i);  simpl;  left.
              { left;  split; now left.
              }
           *  simpl;  destruct H; exists x0.
              eapply rounds_trans with (S i) (iota (canon x (S i))).
              { simpl; simpl in H; trivial. }
              { left.
                eapply canonS_iota_i; auto.
              }
  Qed.

  (* end hide *)

  (* begin snippet LTToStandardBattle *)

  Lemma LT_to_standard_battle :
    forall alpha beta,
      beta t1< alpha ->
      exists n i,  rounds standard n (iota alpha) i (iota beta). (* .no-out *)
  (* end snippet LTToStandardBattle *)

  Proof.
    intros;  assert (nf beta) by eauto with T1.
    assert (nf alpha) by eauto with T1.
    assert (Halpha : alpha <> zero) .
    { intro; subst. apply (not_LT_zero H). }
    destruct (T1_eq_dec beta zero) as [Hbeta | Hbeta].
    {    subst beta.
         destruct (o2iota alpha H1 1).
         auto.
         subst; now destruct Halpha.
         destruct H2.
         exists 0,x.
         assumption.
    }
    {   destruct (Lemma2_6_1 H1 H) as [n Hn].
        destruct n.
        {
          destruct (constant_to_standard_path H1 Hn).
          now     apply not_zero_lt.

          exists 0, x.
          apply o2iota_1.
          assumption.
          auto.
          auto.
          auto.
        }
        {
          destruct (constant_to_standard_path H1 Hn).
          now     apply not_zero_lt.
          apply o2iota_1 in s; auto.
          exists ((S n)), x; auto.
        }
    }
  Qed.

  Remark Rem3 : beta_h mu m  t1< mu.
  Proof. unfold beta_h; auto. destruct Hy; auto. Qed.

  Remark Rem4 : exists n i,
      rounds  standard n (iota mu) i (iota (beta_h mu m)).
  Proof. apply (LT_to_standard_battle  _ _ Rem3).  Qed.

  Remark Hmu : nf mu.
    destruct Hy as [H]. now destruct (H head) as [_ [_ H1 ]].
  Qed.

  (* begin snippet mLt *)

  Lemma m_lt : m small_h  t1< m big_h. (* .no-out *)
  (* end snippet mLt *)
  Proof.
    destruct Rem4 as [x [i H]].
    eapply m_decrease with i x; eauto.
    intro H0;  unfold big_h in *.
    clear H;  destruct (T1_eq_dec mu T1.zero).
    -  now apply (mu_positive  _  mu Hmu m Var Hy).
    -  apply n;   destruct mu.
       + auto.
       + discriminate H0.
  Qed.

  (** End of the proof *)

  (* begin snippet endOfProof *)

  (*| .. coq:: no-out |*)

  Fact self_lt_standard : m big_h t1< m big_h.
  Proof.
    apply LE_LT_trans with (m small_h);[apply m_ge | apply m_lt].
  Qed.

  Theorem Impossibility_std: False.
  Proof.  apply (LT_irrefl self_lt_standard).  Qed.

End Impossibility_Proof.
(*||*)
Check Impossibility_std.
 (* end snippet endOfProof *)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** This file provides classical logic and definite description, which is
    equivalent to providing classical logic and Church's iota operator *)

(** Classical logic and definite descriptions implies excluded-middle
    in [Set] and leads to a classical world populated with non
    computable functions. It conflicts with the impredicativity of
    [Set] *)

Set Implicit Arguments.

Require Export Classical.   (* Axiomatize classical reasoning *)
Require Export Description. (* Axiomatize constructive form of Church's iota *)
Require Import ChoiceFacts.

Local Notation inhabited A := A (only parsing).

(** The idea for the following proof comes from [ChicliPottierSimpson02] *)

Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}.
Proof.
apply
  (constructive_definite_descr_excluded_middle
   constructive_definite_description classic).
Qed.

Theorem classical_definite_description :
  forall (A : Type) (P : A->Prop), inhabited A ->
  { x : A | (exists! x : A, P x) -> P x }.
Proof.
intros A P i.
destruct (excluded_middle_informative (exists! x, P x)) as [Hex|HnonP].
  apply constructive_definite_description with (P:= fun x => (exists! x : A, P x) -> P x).
  destruct Hex as (x,(Hx,Huni)).
  exists x; split.
    intros _; exact Hx.
    firstorder.
exists i; tauto.
Qed.

(** Church's iota operator *)

Definition iota (A : Type) (i:inhabited A) (P : A->Prop) : A
  := proj1_sig (classical_definite_description P i).

Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) :
  (exists! x:A, P x) -> P (iota i P)
  := proj2_sig (classical_definite_description P i).

(** Axiom of unique "choice" (functional reification of functional relations) *)
Theorem dependent_unique_choice :
  forall (A:Type) (B:A -> Type) (R:forall x:A, B x -> Prop),
    (forall x:A, exists! y : B x, R x y) ->
    (exists f : (forall x:A, B x), forall x:A, R x (f x)).
Proof.
intros A B R H.
assert (Hexuni:forall x, exists! y, R x y).
  intro x. apply H.
exists (fun x => proj1_sig (constructive_definite_description (R x) (Hexuni x))).
intro x.
apply (proj2_sig (constructive_definite_description (R x) (Hexuni x))).
Qed.

Theorem unique_choice :
  forall (A B:Type) (R:A -> B -> Prop),
    (forall x:A,  exists! y : B, R x y) ->
    (exists f : A -> B, forall x:A, R x (f x)).
Proof.
intros A B.
apply dependent_unique_choice with (B:=fun _:A => B).
Qed.

(** Compatibility lemmas *)

Unset Implicit Arguments.

Definition dependent_description := dependent_unique_choice.
Definition description := unique_choice.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults32.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.UnsaturatedSolinas.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.UnsaturatedSolinas.
Local Open Scope Z_scope.
Import ListNotations.

Local Existing Instances default_parameters default_parameters_ok.
Local Definition n := 5%nat.
Local Definition s := 2^130.
Local Definition c := [(1, 5)].
Local Definition prefix := "poly1305_"%string.

Instance names : names_of_operations.
  make_names_of_operations prefix. Defined.

Definition ops : unsaturated_solinas_reified_ops n s c.
Proof. make_reified_ops. Time Defined.

Instance poly1305_bedrock2_funcs : bedrock2_unsaturated_solinas_funcs.
Proof. funcs_from_ops ops. Defined.

Instance poly1305_bedrock2_specs : bedrock2_unsaturated_solinas_specs.
Proof. specs_from_ops ops n s c. Defined.

Instance poly1305_bedrock2_correctness :
  bedrock2_unsaturated_solinas_correctness.
Proof. prove_correctness ops n s c. Qed.
(*
Eval cbv [add poly1305_bedrock2_funcs] in add.
Eval cbv [spec_of_add poly1305_bedrock2_specs] in spec_of_add.
*)


Generalizable All Variables.

Open Scope type_scope.

Section type_reification.

Inductive term :Type :=
   Fun : term -> term -> term
 | Prod : term -> term -> term
 | Bool : term
 | SET :term
 | PROP :term
 | TYPE :term
 | Var : Type -> term.

Fixpoint interp (t:term) :=
  match t with
    Bool => bool
  | SET => Set
  | PROP => Prop
  | TYPE => Type
  | Fun a b => interp a -> interp b
  | Prod a b => interp a * interp b
  | Var x => x
end.

Class interp_pair (abs : Type) :=
 { repr : term;
  link: abs = interp repr }.

Arguments repr _ {interp_pair}.
Arguments link _ {interp_pair}.

Lemma prod_interp `{interp_pair a, interp_pair b} : a * b = interp (Prod (repr a) (repr b)).
  simpl. intros. rewrite <- link. rewrite <- (link b). reflexivity.
Qed.

Lemma fun_interp :forall `{interp_pair a, interp_pair b}, (a -> b) = interp (Fun (repr a) (repr b)).
  simpl. intros. rewrite <- link. rewrite <- (link b). reflexivity.
Qed.

Coercion repr : interp_pair >-> term.

Definition abs `{interp_pair a} : Type := a.
Coercion abs : interp_pair >-> Sortclass.

Lemma fun_interp' :forall `{ia : interp_pair, ib : interp_pair}, (ia -> ib) = interp (Fun ia ib).
  simpl. intros a ia b ib. rewrite <- link. rewrite <- (link b). reflexivity.
Qed.

Instance ProdCan `(interp_pair a, interp_pair b) : interp_pair (a * b) :=
  { repr := Prod (repr a) (repr b) ; link := prod_interp }.

Instance FunCan `(interp_pair a, interp_pair b) : interp_pair (a -> b) :=
  { link := fun_interp }.

Instance BoolCan : interp_pair bool :=
  { repr := Bool ; link := refl_equal _ }.

Instance VarCan x : interp_pair x | 10 := { repr := Var x ; link := refl_equal _ }.
Instance SetCan : interp_pair Set := { repr := SET ; link := refl_equal _ }.
Instance PropCan : interp_pair Prop := { repr := PROP ; link := refl_equal _ }.
Instance TypeCan : interp_pair Type := { repr := TYPE ; link := refl_equal _ }.

(* Print Canonical Projections. *)

Variable A:Type.

Variable Inhabited: term -> Prop.

Variable Inhabited_correct: forall `{interp_pair p}, Inhabited (repr p) -> p.

Lemma L : Prop * A -> bool * (Type -> Set) .
apply (Inhabited_correct _ _).
change (Inhabited (Fun (Prod PROP (Var A)) (Prod Bool (Fun TYPE SET)))).
Admitted.

End type_reification.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype path fingraph.
From fourcolor Require Import hypermap walkup geometry color chromogram.

(******************************************************************************)
(* Hypermap, graph and contract colorings, colorable maps, ring traces, valid *)
(* contracts, and the definition of the special maps used in the proof:       *)
(* minimal counter example, C-reducible, and embeddable.                      *)
(*   For G : hypermap, k : G -> color, and cc, r : seq G, we have             *)
(*  coloring k <-> k is a map coloring: k assigns the same color to each dart *)
(*                 in a face cycle of G, but a different color to the ends of *)
(*                 each edge link, hence to adjacent faces.                   *)
(*  four_colorable G <-> G has a map coloring; we prove this is decidable.    *)
(* minimal_counter_example G <-> G is a minimal counter-example to the finite *)
(*                 hypermap four color theorem: a non-four_colorable planar   *)
(*                 bridgeless plain and precubic hypermap, such that all such *)
(*                 hypermaps with fewer darts are four_colorable. We show     *)
(*                 immediately that such a G must be cubic, and later that it *)
(*                 must be connected (patch.v) and pentagonal (birkhoff.v).   *)
(*  cc_coloring cc k <-> assuming G is a plain map, k is a contract map       *)
(*                 coloring for the contract cc: k assigns the same color to  *)
(*                 faces adjacent via an E-link (x, edge x), for x \in cc,    *)
(*                 but different colors to other adjacent faces.              *)
(*  cc_colorable cc <-> there is a contract map coloring for cc.              *)
(*  ring_trace r et <-> there is a map coloring k such that et is the edge    *)
(*                 coloring trace of map k r.                                 *)
(* cc_ring_trace cc r et <-> there is a contract coloring for cc with trace   *)
(*                 et on r.                                                   *)
(* good_ring_arity x <=> the arity (face size) for x is between 3 and 6; it   *)
(*                 is easier to check the embedding of a configuration whose  *)
(*                 perimeter satisfies this condition in an internally        *)
(*                 6-connected map.                                           *)
(* at_radius2 A x y <=> x and y are both adjacent to some common z \in A;     *)
(*                 when A is face-closed and contains both x and y, this      *)
(*                 implies the face at y is at distance at most 2 from the    *)
(*                 the face at x, in A.                                       *)
(*   radius2 A <=> A has radius 2, i.e., there is an x in A such that         *)
(*                 at_radius2 A x y holds for all y in A.                     *)
(* embeddable r <-> G is an embeddable configuration with perimeter r: G is   *)
(*                 planar, bridgeless, connected, plain, and r-quasicubic for *)
(*                 the simple N-cycle r, while good_ring_arity holds on r and *)
(*                 kernel r has radius 2.                                     *)
(*    sparse p <=> p is node-simple: no two darts in p belong to the same     *)
(*                 node.                                                      *)
(*   triad p x <=> x is a triad for p: at least three of the faces around the *)
(*                 face of x contain a dart y in p (so x and y are adjacent), *)
(*                 but not all y in p are adjacent to x.                      *)
(* valid_contract r cc <-> cc is a valid contract for ring r: cc has size at  *)
(*                 most 4, and the edge completion of cc is disjoint from r,  *)
(*                 sparse and has a triad if cc has size 4.                   *)
(* C_reducible r cc <-> assuming G is a configuration with ring r, G is       *)
(*                 C-reducible with contract cc: cc is valid, and any         *)
(*                 contract ring trace et for cc is in the Kempe (co)closure  *)
(*                 of the set of ring traces of colorings of G. This means    *)
(*                 that G cannot be embedded in a minimal counter-example, as *)
(*                 then applying cc to G would yield a four_colorable smaller *)
(*                 map whose coloring could be adjusted by a series of Kempe  *)
(*                 flips to match a coloring of G.                            *)
(* edge_central h x <=> h : G -> G' commutes with edge at x : G.              *)
(*                  := h (edge x) == edge (h x)                               *)
(* preembedding A h <-> h : G -> G' is an embedding for a subset A of G: in A *)
(*                h commutes with face and preserves arity, A is included in  *)
(*                the face-closure of its h-edge_central subset, which is     *)
(*                rlink-connected.                                            *)
(******************************************************************************)

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

Section Coloring.

Variable G : hypermap.

Definition coloring (k : G -> color) :=
  invariant edge k =1 pred0 /\ invariant face k =1 G.

Lemma coloring_inj h k : injective h -> coloring k -> coloring (h \o k).
Proof.
move=> injh [kE kF]; split=> x; rewrite /invariant.
  by move: (kE x); rewrite -(invariant_inj edge k injh).
by move: (kF x); rewrite -(invariant_inj face k injh).
Qed.

Definition ring_trace r et := exists2 k, coloring k & et = trace (map k r).

Definition four_colorable := exists k, coloring k.

Lemma colorable_bridgeless : four_colorable -> bridgeless G.
Proof.
case=> k [kE kF]; apply/existsP => [[x eFex]]; case/negP: (kE x); apply/eqP.
by rewrite -(fconnect_invariant kF eFex).
Qed.

Definition graph_coloring (k : G -> color) :=
  invariant edge k =1 pred0 /\ invariant node k =1 G.

Definition graph_four_colorable : Prop := exists k, graph_coloring k.

Definition cc_coloring cc (k : G -> color) :=
  invariant edge k =i insertE cc /\ invariant face k =1 G.

Definition cc_colorable cc := exists k, cc_coloring cc k.

Definition cc_ring_trace cc r et :=
  exists2 k, cc_coloring cc k & et = trace (map k r).

End Coloring.

Arguments coloring {G} k.
Arguments ring_trace {G} r et.
Arguments cc_coloring {G} cc k.
Arguments cc_colorable {G} cc.
Arguments cc_ring_trace {G} cc r et.

Section ColoringDual.

Variable G : hypermap.

Lemma coloring_dual (k : G -> color) :
  @coloring (dual G) k <-> graph_coloring k.
Proof.
split=> [[kE' kF'] | [kE kN]].
  split=> x; rewrite /= eq_sym.
    by rewrite -{1}(finv_f edgeI x) [_ == _]kE'.
  by rewrite -{1}(finv_f nodeI x) [_ == _]kF'.
split; move=> /= x; rewrite eq_sym.
  by rewrite -{1}(f_finv edgeI x) [_ == _]kE.
by rewrite -{1}(f_finv nodeI x) [_ == _]kN.
Qed.

Lemma four_colorable_dual :
  four_colorable (dual G) <-> graph_four_colorable G.
Proof. by split=> [] [k colk]; exists k; case (coloring_dual k); auto. Qed.

Lemma coloring_mirror (k : G -> color) : @coloring (mirror G) k -> coloring k.
Proof.
case=> kE' kF'; have kF x: k (face x) = k x.
  by apply/esym/eqP; rewrite -{1}(finv_f faceI x) [_ == _]kF'.
split=> x //=; rewrite eq_sym -kF ?eqxx // -(kF (edge x)) -{1}[x]edgeK.
exact: kE'.
Qed.

Lemma colorable_mirror : four_colorable (mirror G) -> four_colorable G.
Proof. by case=> k /coloring_mirror; exists k. Qed.

End ColoringDual.

Section EqmColorable.

Variable G G' : hypermap.
Hypothesis eqG : eqm G G'.

Lemma eqm_colorable : four_colorable G -> four_colorable G'.
Proof.
case: G eqG => [d e n f GeK] [e' n' f' G'eK De _ Df] [k [kE kF]]; exists k.
by split=> x; rewrite /= -?De -?Df; [apply: kE | apply: kF].
Qed.

Lemma eqm_graph_colorable : graph_four_colorable G -> graph_four_colorable G'.
Proof.
case: G eqG => [d e n f GeK] [e' n' f' G'eK De Dn _] [k [kE kN]]; exists k.
by split; move=> x; rewrite /= -?De -?Dn; [apply: kE | apply: kN ].
Qed.

End EqmColorable.

Section DecideColorable.

Variable G : hypermap.

(* We need decidability of ring traces in birkhoff.                           *)
Lemma decide_ring_trace (r : seq G) et :
  {ring_trace r et} + {~ ring_trace r et}.
Proof.
pose kpr k p := [pred lc : colseq | (map k p == lc) && (trace (map k r) == et)].
pose ekpr := exists2 k, coloring k & kpr k _ _; pose lc : colseq := [::].
suff: {ekpr [::] lc} + {~ ekpr [::] lc}.
  case=> [col | no_col]; [left | right].
    by have [k colk /eqseqP Det] := col; exists k.
  by case=> k colk /esym/eqP Det; case: no_col; exists k.
move Dn: #|[predC (Nil G)]| => n.
elim: n [::] lc Dn => [|n IHn] p lc Dn.
  have allp x: x \in p := negbFE (card0_eq Dn x).
  pose kp := nth Color0 lc (index _ p).
  pose kkp := [pred x | (kp (edge x) == kp x) || (kp (face x) != kp x)].
  case kp_ok: (pred0b kkp && kpr kp p lc).
    case/andP: kp_ok => col_kp Det; left; exists kp => //.
    by split=> x; [apply negbTE | apply negbNE]; case/norP: (pred0P col_kp x).
  right=> [[k [kE kF] /andP[/eqP Dlc Det]]].
  have Dkp: kp =1 k.
    by move=> x; rewrite /kp -Dlc (nth_map x) ?nth_index ?index_mem.
  rewrite /= !(eq_map Dkp) Dlc Det eqxx /= andbT in kp_ok.
  by case/pred0Pn: kp_ok => x /=; rewrite !Dkp [_ == _]kE [_ == _]kF.
have [x p'x | p0] := pickP [predC p]; last by rewrite (eq_card0 p0) in Dn.
pose ekprx c := ekpr (x :: p) (c :: lc).
have ekprxP c : {ekprx c} + {~ ekprx c}.
  apply: IHn; rewrite (cardD1 x) [x \in _]p'x in Dn; case: Dn => <-.
  by apply: eq_card => y; rewrite !inE negb_or.
have [cb /= cb_ok | no_cb] := pickP [pred cb | ekprxP (ccons cb.1 cb.2)].
  left; move: (ccons _ _) (ekprxP _) cb_ok => c [] // [k col_k] /=.
  by rewrite eqseq_cons -andbA => /andP[]; exists k.
right=> [[k colk kpr_k]]; pose cb := (cbit1 (k x), cbit0 (k x)).
case/idP: (no_cb cb) => /=; case: (ekprxP _) => // [[]]; exists k => //=.
by rewrite ccons_cbits eqseq_cons eqxx.
Qed.

Lemma decide_colorable : {four_colorable G} + {~ four_colorable G}.
Proof.
case: (decide_ring_trace [::] [::]) => [colG | col'G]; [left | right].
  by have [k colk _] := colG; exists k.
by case=> k colk; case: col'G; exists k.
Qed.

End DecideColorable.

Section MinimalCounterExample.

Variable G : hypermap.

Record minimal_counter_example : Prop := MinimalCounterExample {
  minimal_counter_example_is_planar_bridgeless_plain_precubic :>
    planar_bridgeless_plain_precubic G;
  minimal_counter_example_is_noncolorable :
    ~ four_colorable G;
  minimal_counter_example_is_minimal : forall G',
    planar_bridgeless_plain_precubic G' -> #|G'| < #|G| -> four_colorable G'
}.

Lemma minimal_counter_example_is_cubic : minimal_counter_example -> cubic G.
Proof.
move=> cexG; have F'eG := bridgeless_cface cexG.
have plainG : plain G := cexG; have nGle3 := precubic_leq cexG.
apply/subsetP => /= x _; apply/idPn=> n3'x.
have x'nx: node x != x.
  by apply: contraFneq (F'eG x) => {2}<-; rewrite cface1r nodeK.
have nnx: node (node x) = x.
  apply: contraNeq n3'x => x'n2x; rewrite [x \in _]eqn_leq nGle3 /order.
  rewrite (cardD1 x) (cardD1 (node x)) (cardD1 (node (node x))) !inE.
  by rewrite (inj_eq nodeI) x'nx x'n2x -!cnode1r connect0.
pose G' := WalkupE x; pose h' (u : G') := val u.
pose unx : G' := Sub (node x) x'nx; pose G'' := WalkupE unx.
pose h'' (w : G'') := val w; pose h := h' (h'' _).
have Ih': injective h' := val_inj; have Ih'': injective h'' := val_inj.
have Ih: injective h := inj_comp Ih' Ih''.
have hF w1 w2: cface w1 w2 = cface (h w1) (h w2).
  by apply: etrans (fconnect_skip faceI _ _); apply: (fconnect_skip faceI).
have hN w1 w2: cnode w1 w2 = cnode (h w1) (h w2).
  by apply: etrans (fconnect_skip nodeI _ _); apply: (fconnect_skip nodeI).
have hN1 w: h (node w) = node (h w).
  pose nw' := WalkupI unx (node (h w)); pose nw := WalkupI w nw'.
  have Dnw': h' nw' = node (h w).
    by rewrite [h' _]WalkupI_eq -{1}nnx (inj_eq nodeI) eq_sym -if_neg (valP w).
  have Dnw: h nw = node (h w).
    rewrite {1}/h [h'' _]WalkupI_eq -(inj_eq Ih') Dnw' (inj_eq nodeI).
    by rewrite eq_sym -if_neg (valP (h'' w)).
  by rewrite -Dnw; congr h; symmetry; do 2!apply: (valE_skip nodeI).
have ltG''G: #|G''| < #|G| by rewrite ltnW // -!card_S_Walkup.
have oE_G'' w: order edge w = #|predD1 (cedge (h'' w)) unx|.
  rewrite /order -(card_image Ih''); apply: eq_card => u; rewrite inE /=.
  have [u_nx | nx'u] := altP eqP.
    by apply/imageP => [[wu _ u_wu]]; case/eqP: (valP wu); rewrite -{4}u_nx.
  set wu : G'' := Sub u nx'u; rewrite (mem_image Ih'' _ wu) /=.
  apply: etrans (eq_fconnect (glink_fp_skip_edge _) w wu) _.
    by rewrite /glink /= -!val_eqE /= nnx !eqxx /= orbT.
  exact: (fconnect_skip edgeI w wu).
have [|k [kE kF]] := minimal_counter_example_is_minimal cexG _ ltG''G.
  do ?split; last 1 first.
  - apply/subsetP => [w _]; rewrite !inE; apply: leq_trans (nGle3 (h w)).
    rewrite /order -(card_image Ih) subset_leq_card //.
    by apply/subsetP=> _ /imageP[w' cww' ->]; rewrite -[_ \in _]hN.
  - by do 2!apply: planar_WalkupE; apply: cexG.
  - apply/existsP=> [[w]]; rewrite -{1}[w]edgeK cface1r hF hN1.
    by move: (h _) => y; rewrite -{2}[y]nodeK -cface1r F'eG.
  apply/subsetP => [w _]; rewrite /order_set /in_mem /= oE_G''; set u := h'' w.
  have [EuNx | Eu'Nx] := boolP (has (cedge (h' u)) [:: x; node x]); last first.
    rewrite -(eqnP (predT_subset plainG (h w))) -(card_image Ih').
    have [/negPf Eu'x Eu'nx] := norP Eu'Nx; rewrite /= orbF in Eu'nx.
    apply/eqP; apply: eq_card => y.
    have [-> {y} | x'y] := eqVneq y x; last first.
      pose v : G' := Sub y x'y; rewrite (mem_image Ih' _ v) !inE.
      case: eqP => [[ynx] | _]; last exact (same_cskip_edge Eu'Nx).
      by apply/esym/(contraNF _ Eu'nx) => wEy; rewrite /= -ynx.
    rewrite [x \in cedge _]Eu'x; apply/imageP=> [[[z x'z] _ /= zx]].
    by case/eqP: (x'z).
  have x'Enx: ~~ (cross_edge x).
    move: EuNx; rewrite /= orbF /cross_edge !(cedgeC (h' u)).
    rewrite ![cedge _ _]plain_orbit // !inE (negPf x'nx).
    apply: contraTneq => nx_ex; rewrite nx_ex plain_eq // (negPf (valP u)).
    by rewrite orbF orbb -nx_ex (valP w).
  have:= cardD1 unx (cedge u); rewrite [_ \in _](cskip_edge_merge x'Enx EuNx).
  rewrite /= connect0 orbT -eqSS -add1n => <-.
  have:= cardUI (cedge x) (cedge (node x)); rewrite -!/(order _ _) -eqSS.
  rewrite !(eqnP (predT_subset plainG _)) addn2 eq_sym addnC => <-.
  rewrite eq_card0 ?add0n => [|y]; last first.
    apply: contraNF x'Enx => /andP[/same_cedge xEy /= neEy].
    by rewrite /cross_edge xEy cedgeC.
  rewrite (cardD1 x) !inE connect0 eqSS /order -(card_image Ih').
  apply/eqP/esym/eq_card => y; rewrite !inE; have [-> | x'y] /= := altP eqP.
    by apply/imageP=> [[[z x'z] _ /esym/eqP/idPn]].
  set v : G' := Sub y x'y; rewrite (mem_image Ih' _ v).
  by apply: (etrans (cskip_edge_merge x'Enx EuNx)); rewrite /= orbF !(cedgeC y).
case: (minimal_counter_example_is_noncolorable cexG).
pose a' x w := cface x (h w).
have a'0P y: a' y =1 pred0 -> pred2 x (node x) y.
  move=> a'y0; apply/norP => [[x'y nx'y]]; pose uy : G' := Sub y x'y.
  by case/idP: (a'y0 ((Sub uy : _ -> G'') nx'y)); apply: connect0.
have a'F y z: a' y =1 pred0 -> cface y z -> y = z.
  move=> a'y0 yFz; suffices: pred2 y (node y) z.
    by case/pred2P=> // zny; rewrite -[y]nodeK -zny -cface1 cfaceC F'eG in yFz.
  have: pred2 x (node x) z.
    by apply a'0P => w; rewrite /a' -(same_cface yFz) -a'y0.
  by case/pred2P: (a'0P _ a'y0) => -> /pred2P[]-> /=; rewrite ?nnx ?eqxx ?orbT.
pose k' y := oapp k (ccons false (y == x)) (pick (a' y)).
have kFF w w': cface w w' -> k w = k w'.
  case/connectP=> p wFp ->{w'}; elim: p w wFp => //= _ p IHp w /andP[/eqP <-].
  by move/IHp <-; rewrite (eqcP (kF w)).
have k'F y z: cface y z -> k' y = k' z.
  rewrite /k' => yFz; case: pickP => [w yFw | a'y0]; last first.
    by rewrite -(a'F y z) //; case: pickP => // w yFw; case/idP: (a'y0 w).
  rewrite /a' (same_cface yFz) in yFw; case: pickP => [w' zFw' | /(_ w)/idP//].
  by apply: kFF; rewrite hF -(same_cface yFw).
have k'E y: ~~ (pred2 x (node x) y) -> k' y != k' (edge y).
  case/norP=> [x'y nx'y]; pose w := (Sub (Sub y x'y : G') : _ -> G'') nx'y.
  have Dfey: (face (edge y) = h (face (edge w))).
    by apply: nodeI; rewrite -hN1 !edgeK.
  rewrite (k'F (edge y) _ (fconnect1 _ _)) /k'.
  case: pickP => [w' yFw' | /(_ w)]; last by rewrite /a' connect0.
  case: pickP => [w'' feyFw'' /= | /(_ (face (edge w)))]; last first.
    by rewrite /a' Dfey connect0.
  apply: contraFneq (kE w) => eq_kw; rewrite /= -(eqcP (kF _)); apply/eqP/esym.
  by apply: (etrans (etrans _ eq_kw)); apply: kFF; rewrite hF // -Dfey cfaceC.
exists k'; split=> y; last by apply/eqP/k'F; rewrite cfaceC fconnect1.
have [Dy | /k'E/negPf] := boolP (pred2 x (node x) y); last by rewrite eq_sym.
have eey := plain_eq cexG y.
have [Dey|/k'E/negPf] := boolP (pred2 x (node x) (edge y)); last by rewrite eey.
rewrite /k' /= eq_sym; case: pickP => [w yFw /= | a'y0].
  suffices cycFy: fcycle face [:: y].
    rewrite /a' [cface y _](fconnect_cycle cycFy) ?mem_head // inE in yFw.
    by case/norP: Dy; rewrite -(eqP yFw) (valP (h'' w)) (valP w).
  suffices: pred2 y (node y) (face y).
    rewrite /= andbT orbC [_ == _](contraFF _ (F'eG (node y))) //.
    by move/eqP=> fn_y; rewrite 2!cface1r nodeK fn_y.
  have: pred2 x (node x) (face y).
    by rewrite -eey /= !(canF_eq (canF_sym nodeK)) nnx orbC.
  by case/pred2P=> ->; case/pred2P: Dy => ->; rewrite /= ?nnx eqxx ?orbT.
case: pickP => [w eyFw | a'ey0].
  suffices cycFey: fcycle face [:: edge y].
    rewrite /a' [cface _ _](fconnect_cycle cycFey) ?mem_head // inE in eyFw.
    by case/norP: Dey; rewrite -(eqP eyFw) (valP (h'' w)) (valP w).
  suffices: pred2 (edge y) (node (edge y)) (face (edge y)).
    rewrite /= andbT orbC [_ == _](contraFF _ (F'eG (node (edge y)))) //.
    by move/eqP=> fn_ey; rewrite 2!cface1r nodeK fn_ey.
  have: pred2 x (node x) (face (edge y)).
    by rewrite /= !(canF_eq (canF_sym nodeK)) nnx orbC.
  by case/pred2P=> ->; case/pred2P: Dey => ->; rewrite /= ?nnx eqxx ?orbT.
apply/eqP; move: Dy => /=; case: eqP => [-> | _]; first by rewrite plain_neq.
by move/eqP=> ynx; rewrite (a'F _ x a'ey0) ?eqxx // cface1 ynx nodeK.
Qed.

Coercion minimal_counter_example_is_cubic : minimal_counter_example >-> cubic.

End MinimalCounterExample.

(* Used for symmetry disposition, and flipped configuration match. *)
Lemma minimal_counter_example_mirror : forall G,
  minimal_counter_example G -> minimal_counter_example (mirror G).
Proof.
move=> G; do 4![case] => planarG bridge'G plainG cubicG noncolG minG.
split; last 1 [by move/colorable_mirror | by []].
split; last by rewrite precubic_mirror.
split; last by rewrite plain_mirror.
split; last by rewrite bridgeless_mirror.
by rewrite planar_mirror.
Qed.

Section ConfigurationProperties.

Variables (n0 : nat) (G : hypermap) (r cc : seq G).

(******************************************************************************)
(*   We state and prove separately the geometrical and semantic requirements  *)
(* on configurations. The former ("embeddable") are established by the quiz   *)
(* construction; the latter ("C_reducible") by the reducibility check.        *)
(*   The geometrical requirements are that configuration maps must be plain   *)
(* quasicubic planar bridgeless maps with a simple ring, that satisfy two     *)
(* additional conditions: the ring faces arities must be in the 3..6 range,   *)
(* and the kernel must have radius 2. These two additional properties are     *)
(* used in embed.v to extend a partial hypermap morphism into an embedding.   *)
(******************************************************************************)

Definition good_ring_arity (x : G) : bool := pred4 3 4 5 6 (order face x).

Section Radius2.

(******************************************************************************)
(*   Since our configuration maps have at most one "bridge" face, we can use  *)
(* a slightly more restrictive definition of "radius 2" : we insist that      *)
(* every region is a exactly two adj "hops" away from the center rather than  *)
(* just "at most two" (the extra requirement will always be met, because we   *)
(* can always take a detour through an adjacent spoke. The weaker definition  *)
(* is more complex, and in particular it's easier to check the stricter       *)
(* condition using the configuration data.                                    *)
(******************************************************************************)

Variable A : pred G.

Definition at_radius2 := [rel x y | ~~ [disjoint adj y & [predI adj x & A]]].

Lemma at_radius2P {x y} :
   fclosed face A ->
 reflect (exists x', exists2 y', cface x x' /\ cface y y'
                               & edge x' \in A /\ cface (edge x') (edge y'))
         (at_radius2 x y).
Proof.
move=> clFA; apply: (iffP pred0Pn); case.
  move=> z /and3P[/adjP[y' yFy' y'Rz] /adjP[x' xHx' x'Rz] Az].
  exists x', y' => //; split; first by rewrite (closed_connect clFA x'Rz).
  by rewrite (same_cface x'Rz) cfaceC.
move=> x' [y' [xFx' yFy'] [Aex' ex'Fey']]; exists (edge x').
by rewrite !inE /in_mem /= (adjF xFx') (adjF yFy') (adjFr ex'Fey') !adjE.
Qed.

Definition radius2 := ~~ [disjoint A & [pred x | A \subset at_radius2 x]].

Lemma radius2P :
  reflect (exists2 x, x \in A & {subset A <= at_radius2 x}) radius2.
Proof.
apply: (iffP pred0Pn) => [[x /andP[]] | [x]] Ax /subsetP; exists x => //.
by rewrite !inE Ax.
Qed.

End Radius2.

Record embeddable : Prop := Embeddable {
  embeddable_base :> scycle_planar_bridgeless_plain_quasicubic_connected r;
  embeddable_ring : all good_ring_arity r;
  embeddable_kernel : radius2 (kernel r)
}.

Definition sparse (p : seq G) := simple (p : seq (permF G)).

Lemma sparse_cons x p : sparse (x :: p) = ~~ has (cnode x) p && sparse p.
Proof. exact: (@simple_cons (permF G)). Qed.

Lemma sparse_catC p1 p2 : sparse (p1 ++ p2) = sparse (p2 ++ p1).
Proof. exact: (@simple_catC (permF G)). Qed.

Lemma sparse_catCA p1 p2 p3 : sparse (p1 ++ p2 ++ p3) = sparse (p2 ++ p1 ++ p3).
Proof. exact: (@simple_catCA (permF G)). Qed.

Lemma sparse_rot p : sparse (rot n0 p) = sparse p.
Proof. exact: (@simple_rot n0 (permF G)). Qed.

Definition triad (p : seq G) :=
  let adjp y := fband p (edge y) in
  [pred x | (2 < count adjp (orbit face x)) && ~~ (p \subset adj x)].

Record valid_contract : Prop := ValidContract {
  valid_contract_is_off_ring : [disjoint r & insertE cc];
  valid_contract_is_sparse : sparse (insertE cc);
  valid_contract_size : pred4 1 2 3 4 (size cc);
  valid_contract_triad :
     size cc = 4 -> ~~ [disjoint kernel r & triad (insertE cc)]
}.

Record C_reducible : Prop := Creducible {
  C_reducible_base :> valid_contract;
  C_reducible_coclosure : forall et : colseq,
    cc_ring_trace cc (rev r) et -> Kempe_coclosure (ring_trace (rev r)) et
}.

End ConfigurationProperties.

Arguments good_ring_arity {G} x.
Arguments radius2 {G} A.
Arguments sparse {G} p.
Arguments triad {G} p.

Section Preembedding.

(******************************************************************************)
(*   The properties of the partial morphism contructed in quiz, and extended  *)
(* to an embedding in embed. The morphism is only defined on the kernel of    *)
(* the configuration. On this subset, it should be a strict morphism for face *)
(* and arity. The darts on which it commutes with edge should form an         *)
(* rlink-connected cover of the kernel, up to cface.                          *)
(******************************************************************************)

Variables (G G' : hypermap) (A : pred G) (h : G -> G').

Definition edge_central := [pred x | h (edge x) == edge (h x)].

Lemma edge_central_edge : plain G -> plain G' ->
  forall x, edge_central (edge x) = edge_central x.
Proof.
move=> plainG plainG' x; rewrite /= eq_sym plain_eq //.
by rewrite (canF_eq (plain_eq plainG')).
Qed.

Record preembedding : Prop := Preembedding {
  preembedding_face : {in A, {morph h: x / face x}};
  preembedding_arity : {in A, {mono h: x / order face x}};
  preembedding_cover : A \subset fclosure face edge_central;
  preembedding_rlinked : rlink_connected [predI A & edge_central]
}.

Lemma preembedding_simple_path : preembedding -> fclosed face A ->
    forall x y, edge x \in A -> y \in A ->
 exists2 p, [/\ path rlink x p, cface (last x p) y & p != [::]]
          & simple p /\ all [predI A & edge_central] p.
Proof.
case=> _ _ hfA heA Af x y Aex Ay; set B := [predI A & edge_central].
have /pred0Pn[z /andP[/= exFz zcE]] := subsetP hfA _ Aex.
have{hfA} /pred0Pn[t /andP[/= yFt tcE]] := subsetP hfA _ Ay.
have Bz: B z by rewrite !inE -[_ \in _](closed_connect Af exFz) Aex.
have Bt: B t by rewrite !inE -[_ \in _](closed_connect Af yFt) Ay.
have{heA} [p nfzRp Bp] := heA _ _ Bz Bt; rewrite -/B in Bp.
have{nfzRp} xRp: path rlink x (rcons p t).
  by move: nfzRp; rewrite headI /= {1}/rlink faceK -(same_cface exFz).
have [q [xRq Uq] [Eq Eq0 /allP sqp]] := simplify_rlink xRp.
exists q; split=> //; first by rewrite -Eq last_rcons cfaceC.
  by rewrite (sameP eqP nilP) -Eq0 headI.
by apply/allP=> u /sqp; apply/allP; rewrite all_rcons Bt.
Qed.

End Preembedding.

Arguments edge_central {G G'} h.


Require Import Coq.Logic.Classical_Prop.
Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.

Local Open Scope kripke_model.
Import KripkeModelNotation_Intuitionistic.

Section UpwardsClosure.

Context {worlds: Type}
        {R: Relation worlds}
        {po_R: PreOrder Krelation}
        {J: Join worlds}
        {SA: SeparationAlgebra worlds}
        {dSA: DownwardsClosedSeparationAlgebra worlds}.

(** *Upwards CLosure*)
Definition UpwardsClosure_J: Join worlds.
Proof. intros m1 m2 m; exact (exists n, n <= m /\ join m1 m2 n).
Defined.

Definition UpwardsClosure_SA:
  @SeparationAlgebra worlds (UpwardsClosure_J).
Proof.
  constructor.
  + intros.
    destruct H as [n [? ?]].
    exists n.
    split; auto.
    apply join_comm; auto.
  + intros.
    rename mx into mx', my into my', mz into mz'.
    destruct H as [mxy' [? ?]].
    destruct H0 as [mxyz' [? ?]].
    destruct (join_Korder_down _ _ _ _ mz' H2 H) as [mxyz'' [? ?]]; [reflexivity |].
    destruct (join_assoc _ _ _ _ _ H1 H3) as [myz' [? ?]].
    exists myz'.
    split.
    - exists myz'; split; auto.
      reflexivity.
    - exists mxyz''; split; auto.
      etransitivity; eauto.
Defined.

Lemma UpwardsClosure_increasing:
  forall m, @increasing _ _ J m <-> @increasing _ _ (UpwardsClosure_J) m.
Proof.
  intros.
  unfold increasing; split; intros.
  + destruct H0 as [n0 [? ?]].
    etransitivity; eauto.
  + apply H.
    exists n'.
    split; auto.
    reflexivity.
Qed.

Definition UpwardsClosure_UpwardsClosed:
  @UpwardsClosedSeparationAlgebra worlds _ (UpwardsClosure_J).
Proof.
  intros until m2; intros.
  exists m1, m2.
  split; [| split]; [| reflexivity | reflexivity].
  destruct H as [n' [? ?]].
  exists n'.
  split; auto; etransitivity; eauto.
Defined.

Definition UpwardsClosure_DownwardsClosed:
  @DownwardsClosedSeparationAlgebra worlds _ (UpwardsClosure_J).
Proof.
  intros until n2; intros.
  simpl in *.
  destruct H as [n [? ?]].
  destruct (join_Korder_down _ _ _ _ _ H2 H0 H1) as [n' [? ?]].
  exists n; split; auto.
  exists n'; split; auto.
Defined.

Definition UpwardsClosure_USA {USA: UnitalSeparationAlgebra worlds}:
  @UnitalSeparationAlgebra worlds _ (UpwardsClosure_J).
Proof.
  constructor.
  - intros.
    simpl.
    destruct (incr_exists n) as [u [? ?]].
    destruct H as [n' [H1 H2]].
    exists u; split; auto.
    + exists n'; split; auto.
      exists n; split; auto; reflexivity.
    + rewrite <- UpwardsClosure_increasing; auto.
Defined.

Definition UpwardsClosure_incrSA {incrSA: IncreasingSeparationAlgebra worlds}:
  @IncreasingSeparationAlgebra worlds _ (UpwardsClosure_J).
Proof.
  constructor.
  simpl.
  intros.
  hnf; intros.
  destruct H as [m [? ?]].
  etransitivity; eauto.
  eapply all_increasing; eauto.
Qed.

End UpwardsClosure.


Require Export GeoCoq.Tarski_dev.Ch06_out_lines.
Require Import GeoCoq.Tactics.Coinc.tactics_axioms.

(* In this file we prove that Col in Tarski neutral dimensionless is a Coinc_theory *)

Section Tarski_is_a_Coinc_theory_for_col.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Definition diff : arity Tpoint 2 := fun A B : Tpoint => A <> B.

Lemma diff_perm_1 : forall A B, app_1_n diff A B -> app_n_1 diff B A.
Proof.
unfold diff.
simpl.
auto.
Qed.

Lemma diff_perm_2 : forall A B (X : cartesianPower Tpoint 0), app_2_n diff A B X -> app_2_n diff B A X.
Proof.
unfold diff.
unfold app_2_n.
simpl.
auto.
Qed.

Definition col : arity Tpoint 3 := Col.

Lemma col_perm_1 : forall A (X : cartesianPower Tpoint 2), app_1_n col A X -> app_n_1 col X A.
Proof.
unfold col.
simpl.
Col.
Qed.

Lemma col_perm_2 : forall A B (X : cartesianPower Tpoint 1), app_2_n col A B X -> app_2_n col B A X.
Proof.
unfold col.
unfold app_2_n.
simpl.
Col.
Qed.

Lemma col_bd : forall A (X : cartesianPower Tpoint 1), app_2_n col A A X.
Proof.
unfold col.
unfold app_2_n.
simpl.
Col.
Qed.

Lemma col_3 : forall (COL : cartesianPower Tpoint 3) (DIFF : cartesianPower Tpoint 2),
  pred_conj col COL DIFF -> app diff DIFF -> app col COL.
Proof.
unfold pred_conj.
unfold col.
unfold diff.
simpl in *.
intros COL DIFF HCol HDiff.
destruct HCol as [HCol1 [HCol2 HCol3]].
apply col3 with (fst DIFF) (snd DIFF); Col.
Qed.

Global Instance Tarski_is_a_Arity_for_col : Arity.
Proof. exact (Build_Arity Tpoint 0). Defined.

Global Instance Tarski_is_a_Coinc_predicates_for_col :
  (Coinc_predicates Tarski_is_a_Arity_for_col).
Proof.
exact (Build_Coinc_predicates Tarski_is_a_Arity_for_col diff Col).
Defined.

Global Instance Tarski_is_a_Coinc_theory_for_col :
  (Coinc_theory Tarski_is_a_Arity_for_col Tarski_is_a_Coinc_predicates_for_col).
Proof.
exact (Build_Coinc_theory Tarski_is_a_Arity_for_col
                          Tarski_is_a_Coinc_predicates_for_col
                          diff_perm_1 diff_perm_2 col_perm_1 col_perm_2
                          col_bd col_3).
Defined.

End Tarski_is_a_Coinc_theory_for_col.


Require Import New.Complex.
Require Import New.Field.
Require Import Scalars.
Require Import States.
Require Import Coq.Sets.Ensembles.

(* Induction theorem with basis sets.  Any inductive predicate P over
 * a basis B holds for all elements of any state S such that B is a
 * basis for S.
 *)
Theorem state_basis_induction
  {Scalar} {State}
  {sops : ScalarOps Scalar}
  {state_ops : StateOps Scalar State}
  (B : Ensemble State) (P : State -> Prop) :
  state_pred_inductive P -> state_pred_forall_basis B P ->
  (forall (S : State), state_basis B S -> P S).
Proof.
  unfold state_pred_inductive.
  intros (join_P & meet_P & scalar_P & conj_P & null_P).
  unfold state_pred_forall_basis.
  intro basis_P.
  intros.
  apply (state_basis_ind Scalar State sops state_ops B).
  assumption.
  intros.
  apply basis_P.
  assumption.
  intros.
  apply join_P.
  assumption.
  assumption.
  intros.
  apply meet_P.
  assumption.
  assumption.
  intros.
  apply scalar_P.
  assumption.
  intros.
  apply conj_P.
  assumption.
  assumption.
Qed.

(* Is B a basis for all states in set SS? *)
Definition state_set_basis
  {Scalar} {State}
  {sops : ScalarOps Scalar}
  {state_ops : StateOps Scalar State}
  (B : Ensemble State) (SS : Ensemble State) :=
  forall (S : State), In State SS S -> state_basis B S.

(* A version of the basis induction theorem for sets of states. *)
Lemma state_set_basis_induction
  {Scalar} {State}
  {sops : ScalarOps Scalar}
  {state_ops : StateOps Scalar State}
  (B : Ensemble State) (SS : Ensemble State) (P : State -> Prop) :
  state_pred_inductive P -> state_pred_forall_basis B P ->
  state_set_basis B SS -> (forall (S : State), In State SS S -> P S).
Proof.
  unfold state_set_basis.
  intros.
  apply H1 in H2.
  apply (state_basis_induction B).
  assumption.
  assumption.
  assumption.
Qed.


(* Raccourcis clavier de coqide *)
(* CTRL-flèche bas: avancer d'une commande *)
(* CTRL-flèche haut: revenir en arrière d'une commande *)
(* CTRL-flèche droit: avancer ou revenir en arrière jusqu'au curseur *)

(** premiers pas en Coq *)

(* Logique minimale "pure": pas de négation/contradiction *)

Section Exemples.

  (* Définition de variables propositionnelles *)
  Variables P Q R S T : Prop.

  (* Une Section peut contenir d'autres [sous-]Sections. C'est le bon endroit
     pour definir des hypotheses (et donc prouver des sequents avec hypotheses).
   *)

  Lemma imp_dist: (P -> Q -> R) -> (P -> Q) -> P -> R.
  Proof.
    intro Hpqr.
    intro Hpq.
    intro Hp.
    apply Hpqr.
    - assumption.
    - apply Hpq.
      assumption.
  Qed.

  (* Explication des tactiques utilisées: *)
  (* intro: utilisation de la regle d'introduction pour changer de but *)
  (* apply: utilisation d'une implication qui a la bonne conclusion
     (il va falloir prouver ses hypotheses) *)
  (* Note: on ne peut faire "apply" que sur une propriété déjà prouvée,
     contrairement au modus ponens des preuves en arbres *)
  (* C'est automatiquement un modus ponens: "apply Hpqr" pour prouver R
     demande à prouver P et Q *)
  (* assumption: utilisation de la regle d'hypothese *)

  (* Autre tactique utile: intros
     permet de faire plusieurs introductions d'un coup (intro multiple) *)

  Check imp_dist.  (* On voit la formule prouvée *)
  Print imp_dist.  (* Pour voir le "terme de preuve" calculé *)
  (* la syntaxe est très proche de celle de Ocaml *)

  (* exemple de preuve d'un sequent avec hypothèses *)
  (* On crée une section spécifique, sinon les hypothèses
     ajoutées pour ce lemme resteront pour les suivants *)
  Section S1.
    Hypothesis H : P -> Q.
    Hypothesis H0 : P -> Q -> R.

    Lemma L2 : P -> R.
    (* le sequent est: P->Q, P->Q->R |- P->R *)
    Proof.
      intro p.
      apply H0.
      - assumption.
      - apply H.
        assumption.
    Qed.

    Check L2. (* Les hypothèses font partie de la section *)
  End S1.

  (* Quand on ferme la section, ses hypotheses sont "exportees" sous la
     forme d'hypotheses supplementaires pour L2                         *)
  Check L2.
End Exemples.

Check L2.
(* La section Exemples avait des variables P Q R; une
   fois fermée, ces variables sont exportées sous forme
   universelle: cela permet d'appliquer L2 à d'autres
   propositions (théorème de substitution) *)

Section Exemple_bis.
  Variables A B C: Prop.

  Lemma L2': (A->B)->(A->B->C)->A-> C.
  Proof.
    apply L2. (* Ici Coq "voit" tout seul qu'il suffit
                 de prendre A pour P, B pour Q et
                 C pour R, et L2 a alors le bon énoncé *)
  Qed.
End Exemple_bis.

Section Exercices.
  Variables P Q R S T: Prop.

  Section About_cuts.
    Hypothesis H : P -> Q.
    Hypothesis H0 : P -> Q -> R.
    Hypothesis H1 : Q -> R -> S.
    Hypothesis H2 : Q -> R -> S -> T.

    (* preuve sans lemme (coupure) *)
    Lemma L3 : P -> T.
    (* QUESTION: Quel est le séquent qu'on s'apprête à prouver? *)

    (* QUESTION: Faites-en une preuve papier AVANT de continuer *)
    Proof.
      intro p.
      apply H2.
      apply H.
      assumption.
      apply H0.
      assumption.
      apply H.
      assumption.
      apply H1.
      apply H.
      assumption.
      apply H0.
      assumption.
      apply H.
      assumption.
    Restart. (* Restart.: recommence une preuve de zéro *)
    (* QUESTION: Réécrivez le script ci-dessus en introduisant des tirets
       (-, *, +) à chaque fois qu'une tactique engendre plus d'un
       sous-but *)

    Admitted. (* À remplacer par "Qed." une fois la preuve faite. *)

    (* preuve avec coupures: on prouve Q et R une seule fois chacun,
       puis on les utilise *)

     Lemma L'3 : P -> T.
     Proof.
       intro p.
       assert (q: Q). {
         apply H. assumption.
         }
       (* On a fini de prouver Q; on a maintenant une hypothèse (q:Q) *)
       assert (r: R). {
         apply H0.
         - assumption.
         - assumption.
          }
       (* Pareil: on a maintenant prouvé R, et on a gagné une hypothèse *)
       assert (s : S). {
        apply H1. assumption. assumption.
       }
       apply H2; assumption. (* sans le ; il faut trois "assumption" *)
     Qed.

     (* assert: permet d'ouvrir une nouvelle sous-preuve, *)
     (* dans laquelle on se définit un nouveau but; c'est *)
     (* une coupure. Les accolades sont optionnelles mais *)
     (* facilitent la lecture humaine                     *)

     Check L'3.

(* remarquez la différence entre les termes de preuves avec coupure et sans coupure. *)
     Print L'3.
     Print L3.
(* Les coupures deviennent des "let.. in.." similaires à ceux de Ocaml *)

  End About_cuts.

 (* Les exercices commencent ici, à part la preuve admise de L2.

    Reprendre les exemples vus en TD, en utilisant les tactiques
    assumption, apply, assert et intro/intros.

    Remplacer chaque commande Admitted par un script correct de preuve,
    suivi de la commande Qed.

  *)

  Lemma IdP : P -> P.
  Proof.
    intros.
    apply H.
  Admitted.

  Lemma IdPP : (P -> P) -> P -> P.
  Proof.
    intros.
    apply H0.
  Admitted.

  (* sans regarder le fichier de demo, c'est de la triche *)
  Lemma imp_trans : (P -> Q) -> (Q -> R) -> P -> R.
  Proof.
    intros.
    apply H0.
    apply H.
    assumption.
  Qed.

  Section proof_of_hyp_switch.
    Hypothesis H : P -> Q -> R.
    Lemma hyp_switch : Q -> P -> R.
    Proof.
      intros.
      apply H.
      assumption.
      assumption.
    Qed.

  End proof_of_hyp_switch.

  Check hyp_switch.

  Section proof_of_add_hypothesis.
    Hypothesis H : P -> R.

    Lemma add_hypothesis : P -> Q -> R.
    Proof.
      intros.
      apply H.
      assumption.
    Qed.

  End proof_of_add_hypothesis.

  Section proof_of_remove_dup_hypothesis.
  (* prouver le sequent (P -> P -> Q) |- P -> Q
     (il faut l'énoncer, et faire la preuve) *)
    Hypothesis H: P-> P -> Q.
    Lemma pq_hypothesis :P ->Q.
    Proof.
      intro.
      apply H.
      assumption.
      assumption.
    Qed.

  End proof_of_remove_dup_hypothesis.

  Section proof_of_dup_hypothesis.
  (* même exercice avec le séquent P->Q |- P->P->Q *)
  Hypothesis H: P->Q.
  Lemma aaaa_hypothesis :P->P->Q.
  Proof.
    intros.
    apply H.
    assumption.
  Qed.
  End proof_of_dup_hypothesis.

  Section proof_of_distrib_impl.
 (* meme exercice avec
     P -> Q , P -> R , Q -> R -> T |- P -> T  *)
  Hypothesis H: P-> Q.
  Hypothesis H1: P->R.
  Hypothesis H2: Q->R->T.
  Lemma distrib_impl_hypothesis:P->T .
  Proof.
    intro.
    apply H2.
    apply H.
    assumption.
    apply H1.
    assumption.
  Qed.

  End proof_of_distrib_impl.

  Section proof_of_ex9.
  (* même exercice, avec
     P->Q, Q->R, (P->R)->T->Q, (P->R)->T |- Q
     (ex. 9 de la feuille "Logique minimale")*)
  Hypothesis H: P->Q.
  Hypothesis H1:Q->R.
  Hypothesis H2:(P->R)->T->Q.
  Hypothesis H3:(P->R)->T.
  Lemma proof_of_ex9_hypothesis: Q.
    Proof.
      apply H2.
      - intro.
        apply H1.
        apply H.
        assumption.
      -apply H3.
        intro.
        apply H1.
        apply H.
        assumption.
    Qed.
  End proof_of_ex9.

  (* exercice 10 de la feuille "Logique minimale" *)
  Section Proof_of_weak_Peirce.

    Hypothesis H: (((P->Q)->P)->P)->Q.
    Lemma weak_Peirce : Q.
    Proof.
      apply H.
      intros.
      apply H0.
      intro.
      apply H.
      intros.
      assumption.
    Qed.

  End Proof_of_weak_Peirce.
  Check weak_Peirce.
  Print weak_Peirce. (* Pas facile à déchiffrer *)
  (* QUESTION: si vous n'aviez pas déjà fait cet exercice sur papier,
     écrivez une preuve papier du même séquent; votre script de preuve
     devrait vous aider à identifier quelle règle utiliser à chaque étape.
  *)

End Exercices.

Section Exercices_bis. (* Les séquents proposés en tests semaine 3 *)
  Variables P Q R S: Prop.

  Section Test_mercredi_1.
    Hypothesis H: (P->P)->Q->R.
    Lemma Mercredi1: Q->R.
    Proof.
      intro.
      apply H.
      - intro.
        assumption.
      -assumption.
    Qed.
  End Test_mercredi_1.

  Section Test_mercredi_2.
    Hypothesis H: P->Q.

    Lemma Mercredi2: (P->Q->R)->P->R.
    Proof.
    Admitted.
  End Test_mercredi_2.

  Section Jeudi_1.
    Hypothesis H:P.

    Lemma Jeudi1: (P->Q)->Q.
    Proof.
    Admitted.
  End Jeudi_1.

  Section Jeudi_2.
    Hypothesis H: Q->R.

    Lemma Jeudi2: ((P->R)->S)->(P->Q)->S.
    Proof.
    Admitted.
  End Jeudi_2.

  Section Vendredi_1.
    Hypothesis H: (P->Q)->R.

    Lemma Vendredi1: P->(Q->R).
    Proof.
    Admitted.
  End Vendredi_1.

  Section Vendredi_2.
    Hypothesis H: P->R.

    Lemma Vendredi2: (P->Q)->(P->R).
    Proof.
    Admitted.
  End Vendredi_2.
End Exercices_bis.


Require Export Bridges_order2_LS.

Import mBridges2_LS.
Import LSw.

(** congruent is an equivalence relation *)

Lemma congr_refl : forall a, congruent a a.
Proof.
destruct Aw as [nw Hnw]; unfold a0 in Hnw.
red;intros.
exists (nw+1)%nat.
intros.
setoid_replace ((a k - a k) * w l - (a l - a l) * w k)%Z with 0%Z by ring.
simpl.
replace (r * 0)%Z with (w k * 0)%Z by ring.
apply Zmult_le_compat_l.
assert (0< w l)%Z by (apply Hnw; omega).
omega.
assert (0< w k)%Z by (apply Hnw; omega).
omega.
Qed.

Lemma congr_sym : forall a b, congruent a b -> congruent b a.
Proof.
unfold congruent; intros a b Hab r Hr.
destruct (Hab r Hr) as [p Hp].
exists p.
intros.
setoid_replace ((b k - a k) * w l - (b l - a l) * w k)%Z with
(- ((a k - b k) * w l - (a l - b l) * w k))%Z by ring.
rewrite Z.abs_opp.
apply Hp; assumption.
Qed.

Lemma congr_trans : forall a b c, congruent a b -> congruent b c -> congruent a c.
Proof.
unfold congruent; intros a b c Hab Hbc r Hr.
assert (H2r:(0 < 2 * r)%Z) by omega.
destruct (Hab (2*r)%Z H2r) as [p Hp]; clear Hab.
destruct (Hbc (2*r)%Z H2r) as [q Hq]; clear Hbc.
exists (p+q+1)%nat.
intros k Hk l Hl.
rewrite <- (Z.abs_eq r) by omega.
rewrite <- Z.abs_mul.
replace (r * ((a k - c k) * w l - (a l - c l) * w k))%Z with
(r* ((a k - b k) * w l - (a l - b l) * w k) + r*((b k - c k) * w l - (b l - c l) * w k))%Z by ring.
eapply Zle_trans.
apply Z.abs_triangle.
rewrite (Z.abs_mul r).
rewrite (Z.abs_eq r) by omega.
rewrite Z.abs_mul.
rewrite (Z.abs_eq r)by omega.
apply Zle_mult_inv with 2%Z.
omega.
rewrite Z.mul_add_distr_l.
replace (2 * (w k * w l))%Z with ((w k * w l) + (w k * w l))%Z by ring.
assert (Hkq:(k>=q)) by omega.
assert (Hkp:(k>=p)) by omega.
assert (Hlq:(l>=q)) by omega.
assert (Hlp:(l>=p)) by omega.
generalize (Hp k Hkp l Hlp); clear Hp.
generalize (Hq k Hkq l Hlq); clear Hq.
repeat rewrite Zmult_assoc.
intros; omega.
Qed.

Instance HRwcongr_equiv : Equivalence HRw_congruent.
Proof.
constructor; unfold HRw_congruent.
unfold Reflexive; intros; apply congr_refl.
unfold Symmetric; intros; apply congr_sym; assumption.
unfold Transitive; intros; eapply congr_trans; eassumption.
Qed.

Lemma congruent0_bounded : forall x, congruent x 0 -> exists M:Z, forall k, (Z.abs (x k) < M * (w k))%Z.
Proof.
Admitted.

(*

Lemma lemma1 : forall a b c, (Z.abs (a-b) <=c -> Z.abs a <= c + Z.abs b)%Z.
Proof.
intros.
Search ({_<_}+{_})%Z.
destruct (Z_lt_ge_dec (a-b) 0)%Z.
rewrite Z.abs_neq in H.
destruct (Z_lt_ge_dec a 0)%Z.
rewrite Z.abs_neq.
destruct (Z_lt_ge_dec b 0)%Z.
rewrite Z.abs_neq.
omega.
omega.
rewrite Z.abs_eq.
omega.
omega.
omega.
rewrite Z.abs_eq.
destruct (Z_lt_ge_dec b 0)%Z.
rewrite Z.abs_neq.
omega.
omega.
rewrite Z.abs_eq.
omega.
omega.
omega.
omega.
rewrite Z.abs_eq in H.

destruct (Z_lt_ge_dec a 0)%Z.
rewrite Z.abs_neq.
destruct (Z_lt_ge_dec b 0)%Z.
rewrite Z.abs_neq.
omega.
omega.
rewrite Z.abs_eq.
omega.
omega.
omega.
rewrite Z.abs_eq.
destruct (Z_lt_ge_dec b 0)%Z.
rewrite Z.abs_neq.
omega.
omega.
rewrite Z.abs_eq.
omega.
omega.
omega.
omega.
Qed.
*)

(*
Lemma HRw_congruent_0_HRwgt_w : forall x, congruent x 0 -> |x| <A w.
Proof.
unfold congruent, leA, ltA, absA.
destruct Aw as [nw Hnw].
intros.
assert (Hlt:(0<1)%Z).
omega.
destruct (H 1%Z Hlt) as [n Hn]; clear Hlt.
exists (n+nw+1)%nat.
intros p Hlt.
assert (Hpn:(p>n+nw+1)) by omega.
assert (Hpn':p>=n) by omega.
generalize (Hn p Hpn' (n+nw+1)%nat); clear Hn; intros Hp.
setoid_replace (x p - a0 p)%Z with (x p)%Z in Hp by (unfold a0; ring).
apply Zmult_lt_reg_l with (w p).
apply Hnw; omega.

setoid_replace (x p + (- a0 p))%Z with (x p)%Z in Hp by ring.

*)


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From adtind Require Import goal40.

Set Printing Depth 1000.
Definition lfind_eval  x n:=
lst_mem n x.

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil))) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Nil) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil))) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons (Succ Zero) (Cons (Succ Zero) (Cons (Succ Zero) (Cons (Succ Zero) Nil)))))) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons Zero Nil))) (Zero).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons Zero Nil))) (Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) Nil))) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).


Welcome to Coq 8.8.0 (April 2018)

Coq < Require Import Classical.

Coq < Theorem exp004 : (forall R A : Prop, ((~R \/ ~A) /\ ~A /\ ~~R) -> R).
1 subgoal

  ============================
  forall R A : Prop, (~ R \/ ~ A) /\ ~ A /\ ~ ~ R -> R

exp004 < intros.
1 subgoal

  R, A : Prop
  H : (~ R \/ ~ A) /\ ~ A /\ ~ ~ R
  ============================
  R

exp004 < destruct H.
1 subgoal

  R, A : Prop
  H : ~ R \/ ~ A
  H0 : ~ A /\ ~ ~ R
  ============================
  R

exp004 < destruct H.
2 subgoals

  R, A : Prop
  H : ~ R
  H0 : ~ A /\ ~ ~ R
  ============================
  R

subgoal 2 is:
 R

exp004 < destruct H0.
2 subgoals

  R, A : Prop
  H : ~ R
  H0 : ~ A
  H1 : ~ ~ R
  ============================
  R

subgoal 2 is:
 R

exp004 < tauto.
1 subgoal

  R, A : Prop
  H : ~ A
  H0 : ~ A /\ ~ ~ R
  ============================
  R

exp004 < tauto.
No more subgoals.

exp004 < Qed.
exp004 is defined

Coq <


Require Import stdpp.list.
From Tweetnacl Require Import Libs.Export.
From Tweetnacl Require Import ListsOp.Export.
From Tweetnacl Require Import Mid.Reduce.
From Tweetnacl Require Import Low.Carry_n.

Local Open Scope Z.

Definition backCarry (l:list Z) : (list Z) :=
  match l with
  | [] => []
  | h :: q => let v := nth 15 l 0 in
              (h + 38 * getCarry 16 v) :: take 14 q ++ [getResidue 16 v]
  end.

Lemma backCarry_ToFF_25519 : forall l, Zlength l <= 16 -> (ℤ16.lst l) :𝓖𝓕  = ((ℤ16.lst backCarry l) :𝓖𝓕).
Proof.
  destruct l as [| h l]; intro Hlength.
  - go.
  - unfold backCarry.
    repeat rewrite ZofList_cons.
    rewrite ZofList_app ; try omega.
    rewrite Zlength_cons' in Hlength.
    apply Z_le_lt_eq_dec in Hlength.
    destruct Hlength.
    + rename l0 into H.
      assert(Zlength l < 15) by omega.
      rewrite Zlength_correct in H0.
      repeat match goal with
       | _ => simpl; omega
       | _ => rewrite nth_overflow
       | _ => rewrite take_ge
       | _ => rewrite getResidue_0
       | _ => rewrite getCarry_0
       | _ => rewrite ZofList_cons_0
       | _ => f_equal ; ring
       end.
    + rename e into H.
      assert((length l = 15)%nat) by (rewrite Zlength_correct in H ; omega).
      repeat (destruct l ; tryfalse).
      clear H H0.
      unfold nth , take.
      change ([z; z0; z1; z2; z3; z4; z5; z6; z7; z8; z9; z10; z11; z12; z13]) with ([z; z0; z1; z2; z3; z4; z5; z6; z7; z8; z9; z10; z11; z12] ++ [ z13]).
      rewrite ZofList_app ; try omega.
      repeat rewrite ZofList_cons_0.
      do 2 rewrite <- Zred_factor4 ; rewrite Zplus_assoc_reverse.
      rewrite <- Z.add_mod_idemp_r by (compute ; omega);symmetry;rewrite <- Z.add_mod_idemp_r by (compute ; omega).
      f_equal; f_equal.
      rewrite Z.add_shuffle3.
      rewrite <- Z.add_mod_idemp_r by (compute ; omega);symmetry;rewrite <- Z.add_mod_idemp_r by (compute ; omega).
      f_equal; f_equal.
      rewrite <- Z.add_mod_idemp_l by (compute ; omega) ; symmetry.
      rewrite Zmult_mod.
      rewrite <- t2256is38.
      rewrite <- Zmult_mod.
      rewrite Z.add_mod_idemp_l.
      change 256 with (16 + 16 * 15).
      orewrite Z.pow_add_r.
      rewrite Zmult_assoc_reverse.
      rewrite Zred_factor4.
      rewrite Zmult_mod ; symmetry ; rewrite Zmult_mod.
      f_equal;f_equal.
      change (2 ^ (16 * 15)) with (2 ^ (16 * 14) * 2 ^ 16).
      rewrite Zmult_mod.
      symmetry.
      rewrite Zmult_assoc_reverse ; rewrite Zred_factor4 ; rewrite Zmult_mod.
      f_equal; f_equal.
      rewrite Z.add_comm.
      rewrite residuteCarry ; go.
      compute; omega.
Qed.

Close Scope Z.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.
From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
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 append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma lem: forall l n, Cons n (rev l) = rev (append l (Cons n Nil)).
Proof.
intros. induction l.
  - simpl. rewrite <- IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem2: forall l, rev (rev l) = l.
Proof.
induction l.
  - simpl. rewrite <- lem. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (append (rev (rev x)) y) (rev (rev (append x y))).
Proof.
  intros.
  rewrite lem2.
  lfind. Admitted.