Require Import syntax.
Require Import alist.
Require Import FMapWeakList.

Require Import Classical.
Require Import Coqlib.
Require Import infrastructure.
Require Import Metatheory.
Import LLVMsyntax.
Import LLVMinfra.
Require Import opsem.

Require Import sflib.
Require Import paco.
Import Opsem.

Require Import TODO.
Require Import Exprs.
Require Import Hints.
Require Import Postcond.
Require Import Validator.
Require Import GenericValues.
Require AssnMem.
Require AssnState.

Set Implicit Arguments.

Lemma project_into_IdT_spec e x:
  project_into_IdT e = Some x <-> e = Expr.value (ValueT.id x).
Proof.
  destruct e; ss. des_ifs.
  split; inversion 1; auto.
Qed.

Lemma project_into_IdTSet_In s x:
  IdTSet.In x (project_into_IdTSet s) ->
  exists e, ExprPairSet.In (Expr.value (ValueT.id x), e) s.
Proof.
  unfold project_into_IdTSet. i.
  rewrite ExprPairSet.fold_1 in *.
  rewrite <- fold_left_rev_right in *.
  remember (rev (ExprPairSet.elements s)) as s_elem.

  assert (incl s_elem (rev (ExprPairSet.elements s))).
  { subst. apply incl_refl. }
  clear Heqs_elem.

  induction s_elem; i.
  { ss. inversion H. }

  destruct a as [a1 a2]. ss.
  des_ifs.
  - rewrite IdTSetFacts.add_iff in *. des.
    + rewrite project_into_IdT_spec in *. subst.
      exploit IdT.compare_leibniz; eauto. i. subst.
      exists a2.
      rewrite ExprPairSetFacts.elements_iff.
      eapply InA_equiv with (eqB:=eq).
      { split.
        - apply ExprPair.compare_leibniz.
        - inversion 1. apply ExprPairFacts.compare_refl.
      }
      apply InA_iff_In.
      apply in_rev.
      unfold ExprPairSet.elt in *.
      exploit elim_incl_cons; eauto. i. des. eauto.
    + exploit IHs_elem; eauto.
      exploit elim_incl_cons; eauto. i. des. eauto.
  - exploit IHs_elem; eauto.
    exploit elim_incl_cons; eauto. i. des. eauto.
Qed.

Lemma reduce_maydiff_sound
      m_src m_tgt
      conf_src st_src
      conf_tgt st_tgt
      invst assnmem inv
      (CONF: AssnState.valid_conf m_src m_tgt conf_src conf_tgt)
      (STATE: AssnState.Rel.sem conf_src conf_tgt st_src st_tgt invst assnmem inv)
      (MEM: AssnMem.Rel.sem conf_src conf_tgt st_src.(Mem) st_tgt.(Mem) assnmem):
  exists invst1,
    <<STATE: AssnState.Rel.sem conf_src conf_tgt st_src st_tgt invst1 assnmem
                              (reduce_maydiff inv)>>.
Proof.
  exists invst.
  unfold reduce_maydiff. red.
  inv STATE.
  econs; ss. intro x. i.

  rewrite IdTSetFacts.diff_b in NOTIN. des_bool. des.
  { apply MAYDIFF. auto. }

  des_bool.
  rewrite <- IdTSetFacts.mem_iff in NOTIN.
  apply project_into_IdTSet_In in NOTIN. des.

  rewrite ExprPairSetFacts.filter_iff in NOTIN; [|solve_compat_bool].
  rewrite ExprPairSetFacts.filter_iff in NOTIN; [|solve_compat_bool].
  rewrite ExprPairSetFacts.filter_iff in NOTIN; [|solve_compat_bool].
  des. unfold swap_pair in *. ss.
  rewrite <- ExprPairSetFacts.mem_iff in *.

  ii.
  inv SRC. rename LESSDEF into LESSDEF_SRC.
  exploit LESSDEF_SRC; eauto. i. des. ss.

  exploit AssnState.Rel.not_in_maydiff_expr_spec; eauto.
  i. des.

  inv TGT. rename LESSDEF into LESSDEF_TGT.
  exploit LESSDEF_TGT; eauto. i. des. ss.
  esplits; eauto.

  eapply GVs.inject_lessdef_compose; eauto.
  eapply GVs.lessdef_inject_compose; eauto.
Qed.


Require Import CoqPerformanceTests.typeclass_reification_common.
Time Definition foo60 : goal 60. Time solve_P. Time Qed.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
From PLF Require Import Maps.
From PLF Require Import Smallstep.

Module STLC.

  (* type *)
  Inductive ty : Type :=
  | Bool: ty
  | Arrow: ty -> ty -> ty.

  (* term *)
  Inductive tm : Type :=
  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> ty -> tm -> tm
  | tru : tm
  | fls : tm
  | test : tm -> tm -> tm -> tm.

  Open Scope string_scope.

  Definition x := "x".
  Definition y := "y".
  Definition z := "z".
  Hint Unfold x.
  Hint Unfold y.
  Hint Unfold z.

  (* idB = \x:Bool. x *)
  Notation idB :=
    (abs x Bool (var x)).

  (* idBB = \x:Bool→Bool. x *)
  Notation idBB :=
  (abs x (Arrow Bool Bool) (var x)).

  (* idBBB = \x:(Bool -> Bool) -> (Bool -> Bool). x*)
  Notation idBBBB :=
    (abs x (Arrow (Arrow Bool Bool)
                  (Arrow Bool Bool))
         (var x)).

  (* k = \x:Bool. \y:Bool. x *)
  Notation k := (abs x Bool (abs y Bool (var x))).

  (* notB = \x:Bool. test x then fls else tru *)
  Notation notB := (abs x Bool (test (var x) fls tru)).

  Compute (fun x:bool => 3 + 4).

  Inductive value: tm -> Prop:=
  | v_abs: forall x T t,
      value (abs x T t)
  | v_tru:
      value tru
  | v_fls:
      value fls.

  Hint Constructors value.

  Reserved Notation "'[' x ':=' s ']' t" (at level 20).
  Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
    match t with
    | var x' =>
          if eqb_string x x' then s else t
    | abs x' T t1 =>
          abs x' T (if eqb_string x x' then t1 else ([x:=s] t1))
    | app t1 t2 =>
          app ([x:=s] t1) ([x:=s] t2)
    | tru =>
          tru
    | fls =>
          fls
    | test t1 t2 t3 =>
           test ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
    end

  where "'[' x ':=' s ']' t" := (subst x s t).

  Inductive substi (s : tm) (x : string) : tm -> tm -> Prop :=
  | s_var1 :
      substi s x (var x) s
  | s_var2: forall x',
      x <> x' ->
      substi s x (var x') (var x')
  | s_abs1 : forall T t1,
      substi s x (abs x T t1) (abs x T t1)
  | s_abs2 : forall x' T t1 t2,
      x <> x' ->
      substi s x t1 t2 ->
      substi s x (abs x' T t1) (abs x' T t2)
  | s_app : forall t1 t2 t1' t2',
      substi s x t1 t1' ->
      substi s x t2 t2' ->
      substi s x (app t1 t2) (app t1' t2')
  | s_tru :
      substi s x tru tru
  | s_fls :
      substi s x fls fls
  | s_test : forall t1 t2 t3 t1' t2' t3',
      substi s x t1 t1' ->
      substi s x t2 t2' ->
      substi s x t3 t3' ->
      substi s x (test t1 t2 t3) (test t1' t2' t3').

  Hint Constructors substi.
  Hint Resolve eqb_string_true_iff.
  Hint Resolve eqb_string_false_iff.

  Theorem substi_correct : forall s x t t',
      [x:=s] t = t' <-> substi s x t t'.
  Proof with auto.
    split; intros.
    - generalize dependent t'.
      induction t.
      simpl. remember (eqb_string x0 s0) as eqbXS;
      symmetry in HeqeqbXS;
      destruct eqbXS.
      Search (eqb_string _ _).
      apply eqb_string_true_iff in HeqeqbXS.
      intros; subst; auto.
      apply eqb_string_false_iff in HeqeqbXS.
      intros; subst; auto.
      intros; subst; try constructor; auto.
      simpl. remember (eqb_string x0 s0) as eqbXS;
      symmetry in HeqeqbXS;
      destruct eqbXS.
      apply eqb_string_true_iff in HeqeqbXS.
      intros. subst. auto.
      apply eqb_string_false_iff in HeqeqbXS.
      intros. subst. auto.
      intros; subst; try constructor; auto.
      intros; subst; try constructor; auto.
      intros; subst; try constructor; auto.
    - induction H; simpl; auto;
        try rewrite <- eqb_string_refl; auto;
          try rewrite false_eqb_string; subst; auto.
  Qed.

  Reserved Notation "t1 '-->' t2" (at level 40).

  Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (app (abs x T t12) v2) --> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         app t1 t2 --> app t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         app v1 t2 --> app v1 t2'
  | ST_TestTru : forall t1 t2,
      (test tru t1 t2) --> t1
  | ST_TestFls : forall t1 t2,
      (test fls t1 t2) --> t2
  | ST_Test : forall t1 t1' t2 t3,
      t1 --> t1' ->
      (test t1 t2 t3) --> (test t1' t2 t3)

  where "t1 '-->' t2" := (step t1 t2).

  Hint Constructors step.
  Notation multistep := (multi step).
  Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

  Tactic Notation "print_goal" := match goal with |- ?x => idtac x end.
  Tactic Notation "normalize" :=
    repeat (print_goal; eapply multi_step ;
            [ (eauto 10; fail) | (instantiate; simpl)]);
    apply multi_refl.
  Lemma step_example5:
    app (app idBBBB idBB) idB -->* idB.
  Proof.
    eapply multi_step.
    repeat constructor.
    eapply multi_step.
    repeat constructor.
    constructor.
  Qed.

  Definition context := partial_map ty.

  Reserved Notation "Gamma '|-' t '∈' T" (at level 40).
  Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- var x ∈ T
  | T_Abs : forall Gamma x T11 T12 t12,
      (x |-> T11 ; Gamma) |- t12 ∈ T12 ->
      Gamma |- abs x T11 t12 ∈ Arrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 ∈ Arrow T11 T12 ->
      Gamma |- t2 ∈ T11 ->
      Gamma |- app t1 t2 ∈ T12
  | T_Tru : forall Gamma,
      Gamma |- tru ∈ Bool
  | T_Fls : forall Gamma,
      Gamma |- fls ∈ Bool
  | T_Test : forall t1 t2 t3 T Gamma,
      Gamma |- t1 ∈ Bool ->
      Gamma |- t2 ∈ T ->
      Gamma |- t3 ∈ T ->
      Gamma |- test t1 t2 t3 ∈ T

  where "Gamma '|-' t '∈' T" := (has_type Gamma t T).
  Hint Constructors has_type.

  Example typing_example_1 :
    empty |- abs x Bool (var x) ∈ Arrow Bool Bool.
  Proof.
    apply T_Abs. apply T_Var. reflexivity. Qed.

  Example typing_example_2_full :
    empty |-
          (abs x Bool
               (abs y (Arrow Bool Bool)
                    (app (var y) (app (var y) (var x))))) ∈
          (Arrow Bool (Arrow (Arrow Bool Bool) Bool)).
  Proof.
    apply T_Abs. apply T_Abs.
    eapply T_App.
    apply T_Var. reflexivity.
    eapply T_App. apply T_Var. reflexivity.
    apply T_Var. reflexivity.
  Qed.

  (*  ¬∃T,
        empty ⊢ \x:Bool. \y:Bool, x y ∈ T. *)
  Example typing_nonexample_1 :
    not (exists T,
        empty |-
        (abs x Bool
             (abs y Bool
                  (app (var x) (var y)))) ∈
                                          T).
  Proof.
    intros Hc. inversion Hc.
    (* The clear tactic is useful here for tidying away bits of
     the context that we're not going to need again. *)
    inversion H. subst. clear H.
    inversion H5. subst. clear H5.
    inversion H4. subst. clear H4.
    inversion H2. subst. clear H2.
    inversion H5. subst. clear H5.
    inversion H1. Qed.

Example typing_nonexample_3 :
  not (exists S T,
        empty |-
          (abs x S
             (app (var x) (var x))) ∈
          T).
Proof.
  unfold not. intros. inversion H. clear H. inversion H0. clear H0.
  inversion H;subst; clear H.
  inversion H5; subst. clear H5.
  inversion H2;subst. clear H2.
  inversion H4;subst. clear H4.
  rewrite -> H2 in H1. inversion H1. clear H1 H2.
  generalize dependent T12. induction T11.
  + intros. inversion H0.
  + intros. inversion H0;subst. eapply IHT11_1. eauto. Qed.

End STLC.


Set Universe Polymorphism.

(** Tests for module subtyping of polymorphic terms *)

Module Type S.

Section Foo.

Universes i j.
Constraint i <= j.

Inductive foo : Type@{i} -> Type@{j} :=.

End Foo.

End S.

(** Same constraints *)

Module OK_1.

Section Foo.

Universes i j.
Constraint i <= j.

Inductive foo : Type@{i} -> Type@{j} :=.

End Foo.

End OK_1.

Module OK_1_Test : S := OK_1.

(** More general constraints *)

Module OK_2.

Inductive foo@{i j} : Type@{i} -> Type@{j} :=.

End OK_2.

Module OK_2_Test : S := OK_2.

(** Wrong instance length *)

Module KO_1.

Inductive foo@{i} : Type@{i} -> Type@{i} :=.

End KO_1.

Fail Module KO_Test_1 : S := KO_1.

(** Less general constraints *)

Module KO_2.

Section Foo.

Universe i j.
Constraint i < j.

Inductive foo : Type@{i} -> Type@{j} :=.

End Foo.

End KO_2.

Fail Module KO_Test_2 : S := KO_2.

(** Less general constraints *)

Module KO_3.

Section Foo.

Universe i j.
Constraint i = j.

Inductive foo : Type@{i} -> Type@{j} :=.

End Foo.

End KO_3.

Fail Module KO_Test_3 : S := KO_3.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj5eqsynthconj2 : forall  (lv0 : natural), (@eq natural (plus lv0 Zero) (plus Zero (plus lv0 Zero))).
Admitted.
QuickChick conj5eqsynthconj2.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^382 - 105
Base: 54 + 4/7
***)

Definition curve : CurveParameters :=
  {|
    sz := 7%nat;
    base := 54 + 4/7;
    bitwidth := 64;
    s := 2^382;
    c := [(1, 105)];
    carry_chains := Some [seq 0 (pred 7); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^383 - 187
Base: 54 + 5/7
***)

Definition curve : CurveParameters :=
  {|
    sz := 7%nat;
    base := 54 + 5/7;
    bitwidth := 64;
    s := 2^383;
    c := [(1, 187)];
    carry_chains := Some [seq 0 (pred 7); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^489 - 21
Base: 48.9
***)

Definition curve : CurveParameters :=
  {|
    sz := 10%nat;
    base := 48 + 9/10;
    bitwidth := 64;
    s := 2^489;
    c := [(1, 21)];
    carry_chains := Some [seq 0 (pred 10); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e171m19_8limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e338m15_13limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Coqlib.
Require Import Errors.
Require Import Integers.
Require Import Tree.
Require Import String.
Require Import Asm.

Local Open Scope error_monad_scope.

Set Implicit Arguments.

Parameter bool_of_str: str -> bool.
Parameter int_of_str: str -> int.
Parameter char_of_str: str -> int.

Definition to_int (c : constant) : res int :=
  match c with
  | Const_Identifier id | Const_Int id | Const_Bit id | Const_Hex id =>
    OK (int_of_str (name id))
  end.

Definition id_eq (x : identifier)(y : identifier) := peq (key x) (key y).

Fixpoint find_id_in_id_list (id : identifier) (il : list identifier) :=
  match il with
  | nil =>
    false
  | hd :: tl =>
    if id_eq id hd then
      true
    else
      find_id_in_id_list id tl
  end.

Fixpoint find_protocol_info (id : identifier) (pil : list protocol_info) : res protocol_info :=
  match pil with
  | nil => Error (msg "canot be found in protocol!!")
  | hd :: tl =>
    if id_eq id (proto_id hd) then
      OK hd
    else
      find_protocol_info id tl
  end.

Fixpoint find_protocol_info_in_pin_list (id : identifier) (pil : list pin_info) : res protocol_info :=
  match pil with
  | nil =>
    Error (msg "cannot be found in pin_list")
  | hd :: tl =>
    if id_eq id (pin_name hd) then
     OK (proto_info hd)
    else
      find_protocol_info_in_pin_list id tl
  end.

Fixpoint find_protocol_index (id : identifier) (idl : list identifier) (index : int) : res int :=
  match idl with
  | nil => Error (msg "canot be found in protocol!!")
  | hd :: tl =>
    if id_eq id hd then
      OK index
    else
      find_protocol_index id tl (Int.add index Int.one)
  end.

Fixpoint find_next_header (sl : list statement) (ps : protocol_set) : res int :=
  match sl with
  | nil =>
    Error (msg "next_header not found")
  | hd :: tl =>
    match hd with
    | Next_Header_Statement id =>
      match ps with
      | Protocol_Set id_list =>
        find_protocol_index id id_list Int.one
      end
    | _ =>
      find_next_header tl ps
    end
  end.

Fixpoint find_bypass (sl : list statement) : res int :=
  match sl with
  | nil =>
    Error (msg "bypass not found")
  | hd :: tl =>
    match hd with
    | Bypass_Statement const =>
      to_int const
    | _ =>
      find_bypass tl
    end
  end.

Fixpoint find_field (fid : identifier) (fl : list field) (index : int) : res (int * int) :=
  match fl with
  | nil =>
    OK (Int.zero, Int.zero)
  | hd :: tl =>
    match hd with
    | Field id const =>
      do num <- to_int const;
      if id_eq fid id then
        OK (index, num)
      else
        find_field fid tl (Int.add index num)
    end
  end.


Require Forcing.

Section List.

Variable Obj : Type.
Variable Hom : Obj -> Obj -> Type.

Notation "P ≤ Q" := (forall R, Hom Q R -> Hom P R) (at level 70).
Notation "#" := (fun (R : Obj) (k : Hom _ R) => k).
Notation "f ∘ g" := (fun (R : Obj) (k : Hom _ R) => f R (g R k)) (at level 40).

Forcing Translate list using Obj Hom.

Fixpoint list_rec_ p
         (A P : forall p0 : Obj, p ≤ p0 -> forall p1 : Obj, p0 ≤ p1 -> Type)
         (Hnil : forall (p0 : Obj) (α : p ≤ p0), P p0 α p0 #)
         (Hcons: forall (p0 : Obj) (α : p ≤ p0),
             (forall (p : Obj) (α0 : p0 ≤ p), A p (α ∘ α0) p #) ->
             (forall (p1 : Obj) (α0 : p0 ≤ p1),
                 listᶠ p1 (fun (p2 : Obj) (α1 : p1 ≤ p2) =>
                             A p2 (α ∘ (α0 ∘ α1)))) ->
             (forall (p : Obj) (α0 : p0 ≤ p), P p (α ∘ α0) p #) ->
             P p0 α p0 #)
         (l : listᶠ p A) {struct l} : P p # p # :=
            match l with
            | nilᶠ _ _ =>       Hnil p #
            | consᶠ _ _ ny ll => Hcons p # ny ll
                   (fun (p1 : Obj) (α1 : p ≤ p1) =>
                      list_rec_ p1
                        (fun p1 f1 => A     p1 (α1 ∘ f1))
                        (fun p1 f1 => P     p1 (α1 ∘ f1))
                        (fun p1 f1 => Hnil  p1 (α1 ∘ f1))
                        (fun p1 f1 => Hcons p1 (α1 ∘ f1))
                        (ll p1 α1))
            end.

Forcing Definition list_rec : forall A (P : Type), P -> (A -> list A -> P -> P) -> list A -> P using Obj Hom.
Proof.
  intros p A P Hnil Hcons l.
  exact (list_rec_ p A P Hnil Hcons (l p #)).
Defined.

Definition bar := fun A (P : Type) (H0 : P) (HS : A -> list A -> P -> P) (x : A) (l : list A) => list_rec A P H0 HS (cons x l).

Definition qux := fun A (P : Type) (H0 : P) (HS : A -> list A -> P -> P) (x : A) (l : list A) => HS x l (list_rec A P H0 HS l).

Forcing Translate bar using Obj Hom.
Forcing Translate qux using Obj Hom.

Eval compute in barᶠ.
Eval compute in quxᶠ.

Check (eq_refl : barᶠ = quxᶠ).

Definition list_mem : forall A R, list A -> (list A -> R) -> R :=
  fun A R : Type =>
    list_rec A ((list A -> R) -> R) (fun f => f nil)
             (fun a _ H f => H (fun ll => f (cons a ll))).

Forcing Translate list_mem using Obj Hom.

Forcing Definition list_rect : forall A (P : list A -> Type),
    P nil ->
    (forall (a:A) (l:list A), list_mem _ _ l P -> list_mem _ _ (cons a l) P) ->
    forall l : list A, list_mem _ _ l P using Obj Hom.
Proof.
  simpl; intros p A P Hnil Hcons l.

  (* avoiding noise in the actual definition *)
  (* may be improved using LTac ? *)

  pose (Type_of_A := fun p => forall p0 : Obj, p ≤ p0 -> forall p : Obj, p0 ≤ p -> Type).
  pose (Type_of_P := fun p (A : Type_of_A p) => forall (p0 : Obj) (α : p ≤ p0),
      (forall (p1 : Obj) (α0 : p0 ≤ p1),
       listᶠ p1
         (fun (p2 : Obj) (α1 : p1 ≤ p2) =>
          A p2 (# ∘ (α ∘ (# ∘ (α0 ∘ (α1 ∘ #))))))) -> forall p : Obj, p0 ≤ p -> Type).
  pose (Type_of_Hnil := fun p (A : Type_of_A p) (P : Type_of_P p A) =>
                          forall (p0 : Obj) (α : p ≤ p0),
         P p0 (fun (R : Obj) (k : Hom p0 R) => α R k)
           (fun (p : Obj) (α0 : p0 ≤ p) =>
            nilᶠ p
              (fun (p1 : Obj) (α1 : p ≤ p1) =>
               A p1 (fun (R : Obj) (k : Hom p1 R) => α R (α0 R (α1 R k)))))
           p0 #).
  pose (Type_of_Hcons := fun p (A : Type_of_A p) (P : Type_of_P p A) =>
                           forall (p0 : Obj) (α : p ≤ p0)
            (a : forall (p : Obj) (α0 : p0 ≤ p), A p (α ∘ α0) p #)
            (l : forall (p : Obj) (α0 : p0 ≤ p),
                 listᶠ p
                   (fun (p1 : Obj) (α1 : p ≤ p1) =>
                    A p1
                      (fun (R : Obj) (k : Hom p1 R) => α R (α0 R (α1 R k))))),
          (forall (p : Obj) (α0 : p0 ≤ p),
           list_memᶠ p
             (fun (p1 : Obj) (α1 : p ≤ p1) =>
              A p1 (fun (R : Obj) (k : Hom p1 R) => α R (α0 R (α1 R k))))
             (fun (p1 : Obj) (_ : p ≤ p1) (p2 : Obj) (_ : p1 ≤ p2) =>
              forall p3 : Obj, p2 ≤ p3 -> Type)
             (fun (p1 : Obj) (α1 : p ≤ p1) => l p1 (α0 ∘ α1))
             (fun (p1 : Obj) (α1 : p ≤ p1) =>
              P p1 (fun (R : Obj) (k : Hom p1 R) => α R (α0 R (α1 R k))))
             p #) ->
          list_memᶠ p0 (fun (p : Obj) (α0 : p0 ≤ p) => A p (α ∘ α0))
            (fun (p : Obj) (_ : p0 ≤ p) (p1 : Obj) (_ : p ≤ p1) =>
             forall p2 : Obj, p1 ≤ p2 -> Type)
            (fun (p : Obj) (α0 : p0 ≤ p) =>
             consᶠ p
               (fun (p1 : Obj) (α1 : p ≤ p1) =>
                A p1 (fun (R : Obj) (k : Hom p1 R) => α R (α0 R (α1 R k))))
               (fun (p1 : Obj) (α1 : p ≤ p1) => a p1 (α0 ∘ α1))
               (fun (p1 : Obj) (α1 : p ≤ p1) => l p1 (α0 ∘ α1)))
            (fun (p : Obj) (α0 : p0 ≤ p) => P p (α ∘ α0)) p0
            #).

  pose (Goal_Type := fun  p (A : Type_of_A p) (P : Type_of_P p A)
              (Hnil : Type_of_Hnil p A P)
              (Hcons : Type_of_Hcons p A P)
              (l0 : listᶠ p A) =>
(fix
 list_rec_ (p0 : Obj) (A0 P0 : forall p1 : Obj, p0 ≤ p1 -> forall p2 : Obj, p1 ≤ p2 -> Type)
           (Hnil0 : forall (p1 : Obj) (α : p0 ≤ p1), P0 p1 α p1 #)
           (Hcons0 : forall (p1 : Obj) (α : p0 ≤ p1),
                     (forall (p2 : Obj) (α0 : p1 ≤ p2), A0 p2 (α ∘ α0) p2 #) ->
                     (forall (p2 : Obj) (α0 : p1 ≤ p2),
                      listᶠ p2
                        (fun (r : Obj) (g : p2 ≤ r) => A0 r (fun (R : Obj) (k : Hom r R) => α R (α0 R (g R k))))) ->
                     (forall (p2 : Obj) (α0 : p1 ≤ p2), P0 p2 (α ∘ α0) p2 #) -> P0 p1 α p1 #)
           (l : listᶠ p0 (fun (r : Obj) (g : p0 ≤ r) => A0 r (fun (R : Obj) (k : Hom r R) => g R k))) {struct l} :
   P0 p0 # p0 # :=
   match l with
   | nilᶠ _ _ => Hnil0 p0 #
   | consᶠ _ _ ny ll =>
       Hcons0 p0 # ny ll
         (fun (p1 : Obj) (α1 : p0 ≤ p1) =>
          list_rec_ p1 (fun (p2 : Obj) (f1 : p1 ≤ p2) => A0 p2 (α1 ∘ f1))
            (fun (p2 : Obj) (f1 : p1 ≤ p2) => P0 p2 (α1 ∘ f1))
            (fun (p2 : Obj) (f1 : p1 ≤ p2) => Hnil0 p2 (α1 ∘ f1))
            (fun (p2 : Obj) (f1 : p1 ≤ p2) => Hcons0 p2 (α1 ∘ f1)) (ll p1 α1))
   end) p (fun (p0 : Obj) (α : p ≤ p0) => A p0 (fun (R : Obj) (k : Hom p0 R) => α R k))
  (fun (p0 : Obj) (α : p ≤ p0) (p1 : Obj) (α0 : p0 ≤ p1) =>
   (forall (p2 : Obj) (α1 : p1 ≤ p2),
    (forall (p3 : Obj) (α2 : p2 ≤ p3),
     listᶠ p3
       (fun (r : Obj) (g : p3 ≤ r) => A r (fun (R : Obj) (k : Hom r R) => α R (α0 R (α1 R (α2 R (g R k))))))) ->
    forall p3 : Obj, p2 ≤ p3 -> Type) -> forall p2 : Obj, p1 ≤ p2 -> Type)
  (fun (p0 : Obj) (α : p ≤ p0)
     (f : forall (p1 : Obj) (α0 : p0 ≤ p1),
          (forall (p2 : Obj) (α1 : p1 ≤ p2),
           listᶠ p2
             (fun (r : Obj) (g : p2 ≤ r) => A r (fun (R : Obj) (k : Hom r R) => α R (α0 R (α1 R (g R k)))))) ->
          forall p2 : Obj, p1 ≤ p2 -> Type) =>
   f p0 #
     (fun (p1 : Obj) (α0 : p0 ≤ p1) =>
      nilᶠ p1 (fun (r : Obj) (g : p1 ≤ r) => A r (fun (R : Obj) (k : Hom r R) => α R (α0 R (g R k))))))
  (fun (p0 : Obj) (α : p ≤ p0) (a : forall (p1 : Obj) (α0 : p0 ≤ p1), A p1 (α ∘ α0) p1 #)
     (_ : forall (p1 : Obj) (α0 : p0 ≤ p1),
          listᶠ p1 (fun (r : Obj) (g : p1 ≤ r) => A r (fun (R : Obj) (k : Hom r R) => α R (α0 R (g R k)))))
     (H : forall (p1 : Obj) (α0 : p0 ≤ p1),
          (forall (p2 : Obj) (α1 : p1 ≤ p2),
           (forall (p3 : Obj) (α2 : p2 ≤ p3),
            listᶠ p3
              (fun (r : Obj) (g : p3 ≤ r) =>
               A r (fun (R : Obj) (k : Hom r R) => α R (α0 R (α1 R (α2 R (g R k))))))) ->
           forall p3 : Obj, p2 ≤ p3 -> Type) -> forall p2 : Obj, p1 ≤ p2 -> Type)
     (f : forall (p1 : Obj) (α0 : p0 ≤ p1),
          (forall (p2 : Obj) (α1 : p1 ≤ p2),
           listᶠ p2
             (fun (r : Obj) (g : p2 ≤ r) => A r (fun (R : Obj) (k : Hom r R) => α R (α0 R (α1 R (g R k)))))) ->
          forall p2 : Obj, p1 ≤ p2 -> Type) =>
   H p0 #
     (fun (p1 : Obj) (α0 : p0 ≤ p1)
        (ll : forall (p2 : Obj) (α1 : p1 ≤ p2),
              listᶠ p2
                (fun (r : Obj) (g : p2 ≤ r) => A r (fun (R : Obj) (k : Hom r R) => α R (α0 R (α1 R (g R k))))))
      =>
      f p1 (fun (R : Obj) (k : Hom p1 R) => α0 R k)
        (fun (p2 : Obj) (α1 : p1 ≤ p2) =>
         consᶠ p2
           (fun (p3 : Obj) (α2 : p2 ≤ p3) => A p3 (fun (R : Obj) (k : Hom p3 R) => α R (α0 R (α1 R (α2 R k)))))
           (fun (p3 : Obj) (α2 : p2 ≤ p3) => a p3 (fun (R : Obj) (k : Hom p3 R) => α0 R (α1 R (α2 R k))))
           (fun (p3 : Obj) (α2 : p2 ≤ p3) => ll p3 (α1 ∘ α2))))) l0
  (fun (p0 : Obj) (α : p ≤ p0) => P p0 (fun (R : Obj) (k : Hom p0 R) => α R k)) p #
).

  compute. set (l0 := l p #). clearbody l0; clear l.
  change (Goal_Type p A P Hnil Hcons l0).

  (* Now the definition using a fixpoint *)

  exact ((fix F p (A : Type_of_A p) (P : Type_of_P p A)
              (Hnil : Type_of_Hnil p A P)
              (Hcons : Type_of_Hcons p A P)
              (l0 : listᶠ p A) : Goal_Type p A P Hnil Hcons l0
         :=
            match l0 as l1 return Goal_Type _ _ _ _ _ l1 with
            | nilᶠ _ _ =>       Hnil p #
            | consᶠ _ _ a ll =>
              Hcons p # a ll
                   (fun (p1 : Obj) (α1 : p ≤ p1) =>
                      F p1
                        (fun p1 f1 => A     p1 (α1 ∘ f1))
                        (fun p1 f1 => P     p1 (α1 ∘ f1))
                        (fun p1 f1 => Hnil  p1 (α1 ∘ f1))
                        (fun p1 f1 => Hcons p1 (α1 ∘ f1))
                        (ll p1 α1)) end
          ) p A P Hnil Hcons l0).
Defined.

Definition bar2 := fun A (P : list A -> Type)
    (H0 : P nil)
    (HS : forall (a:A) (l:list A), list_mem _ _ l P -> list_mem _ _ (cons a l) P)
    x (l : list A) => list_rect A P H0 HS (cons x l).

Definition qux2 := fun A (P : list A -> Type)
    (H0 : P nil)
    (HS : forall (a:A) (l:list A), list_mem _ _ l P -> list_mem _ _ (cons a l) P)
    x (l : list A) => HS x l (list_rect A P H0 HS l).

Forcing Translate bar2 using Obj Hom.
Forcing Translate qux2 using Obj Hom.

Eval compute in bar2ᶠ.
Eval compute in qux2ᶠ.

Check (eq_refl : bar2ᶠ = qux2ᶠ).

End List.


(*|

=========================
Reasoning about leads-to
=========================

The connective `p ~~> q`, defined to be `□(p → ◇q)`, is pervasive in liveness
reasoning. This file proves a few basic results about leads to (for example,
that it is transitive), as well as a more sophisticated result that shows how to
combine a well-founded "lattice" of leads-to facts, which is crucial for
reasoning about diverging facts that eventually converge to guarantee some
result.

Some of these rules are specialized to state predicates, because we believe that
it will often be sufficient to only use the form `⌜P⌝ ~~> ⌜Q⌝` and not use the
full generality of temporal predicates.

|*)
From TLA Require Import defs automation.
From TLA Require Import propositional_ltl modalities.
From TLA Require Import classical.
From TLA.logic Require Import safety preds.

Section TLA.

Context [Σ: Type].

Notation exec := (exec Σ).
Notation predicate := (predicate Σ).

Implicit Types (e: exec) (p q: predicate) (a: action Σ).

Theorem leads_to_refl p :
  ⊢ p ~~> p.
Proof.
  unseal.
  exists 0; eauto.
Qed.

Theorem leads_to_trans (p q r: predicate) :
  p ~~> q ∧ q ~~> r ⊢ p ~~> r.
Proof.
  unseal.
  destruct H as [Hpq Hqr].
  edestruct Hpq as [k' Hq]; eauto.
  edestruct Hqr as [k'' Hr]; eauto.
  exists (k'' + k').
  replace (k'' + k' + k) with (k'' + (k' + k)) by lia; auto.
Qed.

Theorem leads_to_trans' (p q r: predicate) :
  ⊢ p ~~> q → q ~~> r → p ~~> r.
Proof.
  rewrite <- (leads_to_trans p q r).
  tla_prop.
Qed.

Theorem leads_to_weaken (p1 p2 q1 q2: predicate) :
  (p2 ⊢ p1) →
  (q1 ⊢ q2) →
  p1 ~~> q1 ⊢ p2 ~~> q2.
Proof.
  intros H1 H2.
  rewrite /leads_to.
  rewrite H1 -H2 //.
Qed.

Theorem leads_to_weaken_internal (p1 q1 p2 q2: predicate) :
  □(p2 → p1) ∧ □(q1 → q2) ⊢ p1 ~~> q1 → p2 ~~> q2.
Proof.
  intros e [Hp Hq] Hpq.
  unseal.
  apply Hp in H.
  destruct (Hpq k) as [k' Hqk]; auto; rewrite drop_drop in Hqk.
  apply Hq in Hqk.
  eauto.
Qed.

#[global]
Instance leads_to_impl_proper :
  Proper (flip pred_impl ==> pred_impl ==> pred_impl) (leads_to (Σ := Σ)).
Proof.
  intros p1 q1 Himpl p2 q2 Himpl2.
  apply leads_to_weaken; auto.
Qed.

Theorem leads_to_or_left (Γ p q1 q2: predicate) :
  (Γ ⊢ p ~~> q1) →
  (Γ ⊢ p ~~> (q1 ∨ q2)).
Proof.
  intros H.
  rewrite -> H.
  apply leads_to_weaken; [ done | tla_prop ].
Qed.

Theorem leads_to_or_right (Γ p q1 q2: predicate) :
  (Γ ⊢ p ~~> q2) →
  (Γ ⊢ p ~~> (q1 ∨ q2)).
Proof.
  intros H.
  rewrite -> H.
  apply leads_to_weaken; [ done | tla_prop ].
Qed.

Theorem and_leads_to_elim p q :
  p ∧ p ~~> q ⊢ ◇ q.
Proof.
  rewrite /leads_to.
  rewrite -> always_weaken.
  apply modus_ponens.
Qed.

Theorem leads_to_apply q p φ :
  (p ⊢ q) →
  (p ⊢ q ~~> φ) →
  (p ⊢ ◇ φ).
Proof.
  intros Hq Hleads.
  tla_pose Hq.
  tla_pose Hleads.
  rewrite -> and_leads_to_elim.
  tla_prop.
Qed.

Theorem leads_to_impl_internal p q :
  (□ (p → q)) ⊢ p ~~> q.
Proof.
  unseal.
  exists 0; simpl; eauto.
Qed.

Theorem impl_to_leads_to p q :
  (p ⊢ q) →
  ⊢ p ~~> q.
Proof.
  unseal.
  exists 0; auto.
Qed.

Instance impl_leads_to_subrelation : subrelation pred_impl (λ p q, ⊢ p ~~> q).
Proof.
  unfold subrelation.
  apply impl_to_leads_to.
Qed.

Theorem pred_leads_to (P Q: Σ → Prop) Γ :
  (∀ s, P s → Q s) →
  Γ ⊢ ⌜P⌝ ~~> ⌜Q⌝.
Proof.
  intros.
  apply impl_drop_hyp.
  apply impl_to_leads_to.
  unseal.
Qed.

Lemma leads_to_or_split p q r :
  (p ∨ q) ~~> r == ((p ~~> r) ∧ (q ~~> r)).
Proof.
  rewrite /leads_to.
  rewrite -always_and.
  f_equal.
  rewrite !implies_to_or; tla_simp.
  rewrite !tla_or_distr_r.
  reflexivity.
Qed.

Lemma leads_to_state_pred_split Γ (P Q: Σ → Prop) φ :
  (Γ ⊢ ⌜P⌝ ~~> φ) →
  (Γ ⊢ ⌜Q⌝ ~~> φ) →
  Γ ⊢ ⌜λ s, P s ∨ Q s⌝ ~~> φ.
Proof.
  intros HP HQ.
  rewrite -combine_or_preds.
  rewrite leads_to_or_split.
  apply entails_and; auto.
Qed.

Lemma leads_to_assume (q: predicate) {p Γ φ: predicate} :
  (* side condition *)
  (Γ ⊢ □ q) →
  (* continue proof with q in the leads_to premise *)
  (Γ ⊢ (p ∧ q) ~~> φ) →
  (Γ ⊢ p ~~> φ).
Proof.
  rewrite /leads_to.
  intros H Hleads_to.
  tla_pose H.
  rewrite -> Hleads_to.
  unseal.
Qed.

(* when proving a leads_to, it's safe to assume the postcondition isn't already
achieved (because the proof is trivial in that case) *)
Lemma leads_to_assume_not p q :
  p ~~> q == (p ∧ !q) ~~> q.
Proof.
  tla_split; [ unseal | ].
  rewrite {2}(tla_and_em q p).
  rewrite tla_and_distr_l.
  rewrite leads_to_or_split; tla_split.
  - apply impl_drop_hyp.
    apply impl_to_leads_to.
    tla_prop.
  - reflexivity.
Qed.

Theorem eventually_stable (P: Σ → Prop) (next: action Σ) :
  (∀ s s', P s → next s s' → P s') →
  □⟨next⟩ ∧ ◇⌜P⌝ ⊢ ◇□ ⌜P⌝.
Proof.
  intros Hind.
  assert (□⟨next⟩ ⊢ □(⌜P⌝ → □⌜P⌝)).
  { apply always_intro_impl.
    apply impl_intro2.
    rewrite tla_and_comm. apply later_induction.
    unseal. }
  rewrite tla_and_curry.
  rewrite -> H.
  clear.
  intros e Halways.
  intros [k HP].
  exists k.
  apply Halways; eauto.
Qed.

Theorem leads_to_stable p (Q: Σ → Prop) (next: action Σ) :
  (∀ s s', Q s → next s s' → Q s') →
  □⟨next⟩ ∧ (p ~~> ⌜Q⌝) ⊢ (p ~~> □⌜Q⌝).
Proof.
  intros H.
  apply eventually_stable in H.
  apply tla_and_curry in H. rewrite tla_and_curry.
  apply always_intro_impl in H.
  rewrite -> H.
  rewrite /leads_to.
  clear.
  intros e Halways.
  intros HpQ.
  intros k Hp.
  apply Halways. apply HpQ. auto.
Qed.

Section lattice.

Context {S: Type} {R: S → S → Prop} (wf: well_founded R).

Local Infix "≺" := R (at level 50).

(* the rule as it appears in the paper *)
Theorem tla_paper_lattice_leads_to (h: S → predicate) (f g: predicate) :
  (∀ c, f ⊢ h c ~~> (g ∨ ∃ (d: S) (le: d ≺ c), h d)) →
  f ⊢ (∃ c0, h c0) ~~> g.
Proof using wf.
  intros Hto_le.

  cut (∀ c0, f ⊢ h c0 ~~> g).
  { intros Hfc0.
    rewrite /leads_to /tla_exist.
    intros e Hf k [c0 Hh].
    eapply Hfc0; eauto. }

  intros c0.
  pose proof (wf c0) as Hacc.
  induction Hacc.

  erewrite <- leads_to_trans;
  tla_split.
  { apply Hto_le. }
  rewrite leads_to_or_split.
  tla_split.
  { apply impl_drop_hyp. apply impl_to_leads_to. reflexivity. }

  rewrite /tla_exist => e Hf k.
  intros (c & Hle & Hc).
  eapply H0; eauto.
Qed.

(* a variant of the rule where the goal is also part of the lattice *)
Theorem tla_lattice_leads_to (h: S → predicate) (c0 g: S)
  (f hc0 hg: predicate) :
  h c0 = hc0 → h g = hg →
  (∀ c, c ≠ g → f ⊢ h c ~~> (∃ (d: S) (le: d = g ∨ d ≺ c), h d)) →
  f ⊢ hc0 ~~> hg.
Proof using wf.
  intros <- <- Hto_le.
  rewrite <- (leads_to_trans _ (∃ c0, h c0)); tla_split.
  { apply impl_drop_hyp. apply impl_to_leads_to. unseal. }

  apply tla_paper_lattice_leads_to.
  intros l.

  destruct (classical.excluded_middle (l = g)); subst.
  { apply impl_drop_hyp.
    apply impl_to_leads_to.
    tla_prop. }

  rewrite -> (Hto_le l) by auto.
  apply leads_to_weaken; [ done | ].

  unseal.
  naive_solver.
Qed.

Theorem lattice_leads_to (h: S → Σ → Prop) (c0 g: S)
  (f: predicate) (hc0 hg: Σ → Prop) :
  h c0 = hc0 → h g = hg →
  (∀ c, c ≠ g → f ⊢ ⌜h c⌝ ~~> ⌜λ s, ∃ (d: S), (d = g ∨ d ≺ c) ∧ h d s⌝) →
  f ⊢ ⌜hc0⌝ ~~> ⌜hg⌝.
Proof using wf.
  intros <- <- H.
  apply (tla_lattice_leads_to (λ l, ⌜h l⌝) c0 g); [ done | done | ].
  intros l Hnotg.
  rewrite -> (H l) by auto.
  apply leads_to_weaken; [ done | ].
  unseal.
Qed.

Theorem lattice_leads_to_ex (h: S → Σ → Prop) (g: S)
  (f: predicate) (hg: Σ → Prop) :
  h g = hg →
  (∀ c, c ≠ g → f ⊢ ⌜h c⌝ ~~> ⌜λ s, ∃ (d: S), (d = g ∨ d ≺ c) ∧ h d s⌝) →
  f ⊢ (∃ c0, ⌜h c0⌝) ~~> ⌜hg⌝.
Proof using wf.
  intros <- H.

  cut (∀ c0, f ⊢ ⌜h c0⌝ ~~> ⌜h g⌝).
  { intros Hfc0.
    rewrite /leads_to /tla_exist.
    intros e Hf k [c0 Hh].
    eapply Hfc0; eauto. }

  intros c0.
  apply (tla_lattice_leads_to (λ l, ⌜h l⌝) c0 g); [ done | done | ].
  intros l Hnotg.
  rewrite -> (H l) by auto.
  apply leads_to_weaken; [ done | ].
  unseal.
Qed.

End lattice.

(*|

We give a simple illustration of the lattice rule to prove the following
theorem:

::

  (f ⊢ p ~~> (q ∨ r)) →
  (f ⊢ q ~~> s) →
  (f ⊢ r ~~> s) →
  (f ⊢ p ~~> s)

The proof uses the simple lattice below:

::

      A
     / \
    B   C
    \   /
      G

The lattice points A, B, C, and G are interpreted (via the `h` argument to `lattice_leads_to`) as predicates p, q, r, and s, where s is the special goal that has nothing after it. The relation on this lattice says B ≺ A, C ≺ A, G ≺ B, and G ≺ C (one for each edge). Notice that A has two "outgoing edges" - this means we prove p ~~> (q ∨ r), and it is this non-deterministic choice that makes the rule powerful.

First, notice that this ≺ is well-founded: there are no loops (which would represent circular reasoning). Second, notice that the assumption `p ~~> (q ∨ r)` respects the ordering: it goes from `h A` to either `h B` or `h C`, both of which are "smaller" in the lattice.

|*)

Inductive abc := A | B | C | G.

Definition abc_lt (x y: abc) :=
  (* notice the reverse order in the match: we want [abc_lt x y] when [y] is
  allowed to be used in the proof of [x] *)
  match y, x with
  | A, B | A, C => True
  | B, G | C, G => True
  | _, _ => False
  end.

Ltac prove_acc :=
  try assumption;
  apply Acc_intro; intros []; simpl; inversion 1; auto.

Theorem abc_lt_wf : well_founded abc_lt.
Proof.
  (* we carefully prove these bottom up *)
  assert (Acc abc_lt G) by prove_acc.
  assert (Acc abc_lt B) by prove_acc.
  assert (Acc abc_lt C) by prove_acc.
  assert (Acc abc_lt A) by prove_acc.
  by intros [].
Qed.

Lemma leads_to_fork2 (q r f p s: predicate) :
  (f ⊢ p ~~> (q ∨ r)) →
  (f ⊢ q ~~> s) →
  (f ⊢ r ~~> s) →
  (f ⊢ p ~~> s).
Proof.
  intros.
  apply (tla_lattice_leads_to abc_lt_wf
           (λ x, match x with
                 | A => p | B => q | C => r | G => s
                 end) A G); [ done | done | ].
  intros [] Hne; simpl; try congruence.
  - rewrite -> H.
    apply leads_to_weaken; [ done | ].
    apply impl_or_split.
    * apply exist_impl_intro. exists B.
      apply exist_impl_intro. unshelve eexists _; eauto. done.
    * apply exist_impl_intro. exists C.
      apply exist_impl_intro. unshelve eexists _; eauto. done.
  - rewrite -> H0.
    apply leads_to_weaken; [ done | ].
    apply exist_impl_intro. exists G. unseal.
  - rewrite -> H1.
    apply leads_to_weaken; [ done | ].
    apply exist_impl_intro. exists G. unseal.
Qed.

Lemma leads_to_detour (q p s Γ : predicate) :
  (Γ ⊢ p ~~> (q ∨ s)) →
  (Γ ⊢ q ~~> s) →
  (Γ ⊢ p ~~> s).
Proof.
  intros.
  apply (leads_to_fork2 q s); auto.
  apply impl_drop_hyp.
  apply leads_to_refl.
Qed.

(* [leads_to_if q] is the principle that we can prove a leads_to by splitting it
into two cases: one where q is true and another where it's false *)
Lemma leads_to_if (q p φ Γ: predicate) :
  (Γ ⊢ (p ∧ q) ~~> φ) →
  (Γ ⊢ (p ∧ !q) ~~> φ) →
  (Γ ⊢ p ~~> φ).
Proof.
  intros Hq Hnotq.
  rewrite (tla_and_em q p).
  rewrite tla_and_distr_l.
  rewrite leads_to_or_split.
  tla_split; auto.
Qed.

Lemma leads_to_exist_intro {A} (Γ: predicate) (φ: A → predicate) q :
  (∀ x, Γ ⊢ φ x ~~> q) →
  (Γ ⊢ (∃ x, φ x) ~~> q).
Proof. unseal. Qed.

(* leads_to_fork is really just transitivity but it captures the idea of a
simple diverge-reconverge pattern *)
Lemma leads_to_fork {A: Type} (h: A → Σ → Prop)
  (f: predicate) (p q: Σ → Prop) :
  (f ⊢ ⌜p⌝ ~~> ⌜λ s, ∃ x, h x s⌝) →
  (∀ (x: A), f ⊢ ⌜h x⌝ ~~> ⌜q⌝) →
  (f ⊢ ⌜p⌝ ~~> ⌜q⌝).
Proof.
  intros Hph Hhq.
  erewrite <- leads_to_trans; tla_split; [ apply Hph | ].
  apply leads_to_exist_intro.
  intros x. fold (⌜h x⌝). eauto.
Qed.

Lemma always_leads_to_as_always_eventually (p q: predicate) :
  (□p) ~~> q == □◇(p → q).
Proof.
  rewrite /leads_to !implies_to_or.
  tla_simp.
  rewrite eventually_or //.
Qed.

Lemma always_leads_to_simp (p q: predicate) :
  (□p) ~~> q == (◇□p → □◇q).
Proof.
  rewrite always_leads_to_as_always_eventually.
  rewrite !implies_to_or.
  tla_simp.
  rewrite always_eventually_distrib //.
Qed.

End TLA.

Ltac leads_to_trans q :=
  rewrite <- (leads_to_trans _ q _);
  tla_split.

Ltac leads_to_etrans :=
  erewrite <- leads_to_trans;
  tla_split.

Ltac prove_acc_goal :=
  try assumption;
  apply Acc_intro; intros []; simpl; inversion 1; auto.

Ltac prove_wf xs :=
  lazymatch goal with
  | |- well_founded ?lt =>
    let rec go xs :=
      match xs with
      | nil => idtac
      | cons ?x ?xs =>
          assert (Acc lt x) by prove_acc_goal;
          go xs
      end in
    go xs;
    try solve [ intros []; assumption ]
  end.

Ltac lt_simp :=
  tla_simp;
  repeat match goal with
    | |- context[tla_exist _] => rewrite exist_state_pred || setoid_rewrite exist_state_pred
    end.

Ltac lt_intro_tac t :=
  lt_simp;
  let s := fresh "s" in
  apply pred_leads_to => s; t.

Tactic Notation "lt_unfold" := lt_intro_tac idtac.
Tactic Notation "lt_auto" := lt_intro_tac eauto.
Tactic Notation "lt_done" := lt_intro_tac ltac:(by eauto).
Tactic Notation "lt_auto" tactic1(t) := lt_intro_tac t.

Tactic Notation "lt_apply" constr(lem) :=
  lt_simp;
  leads_to_etrans; [ leads_to_etrans; [ | apply lem ] | ];
  [ try solve [ lt_auto intuition eauto ] |
    try solve [ lt_auto intuition eauto ] | .. ].

Tactic Notation "lt_eapply" constr(lem) :=
  leads_to_etrans; [ leads_to_etrans; [ | eapply lem ] | ];
  [ try solve [ lt_auto intuition eauto ] |
    try solve [ lt_auto intuition eauto ] | .. ].

Ltac lt_intro1 :=
  lazymatch goal with
  | |- _ ⊢ state_pred (λ _, ex (λ H, _)) ~~> _ =>
      rewrite -exist_state_pred;
      let x := fresh H in
      apply leads_to_exist_intro; intro x
  | |- _ ⊢ (tla_exist (λ H, _)) ~~> _ =>
      let x := fresh H in
      apply leads_to_exist_intro; intro x
  end.

Tactic Notation "lt_intro" := lt_intro1.
Ltac lt_intros := repeat lt_intro1.

Tactic Notation "lt_intro" ident(x) :=
  match goal with
  | |- _ ⊢ state_pred (λ _, ex (λ H, _)) ~~> _ =>
      rewrite -exist_state_pred;
      apply leads_to_exist_intro; intro x
  | |- _ ⊢ (tla_exist (λ _, _)) ~~> _ =>
      apply leads_to_exist_intro; intro x
  end.

Ltac lt_split_or :=
  lazymatch goal with
  | |- _ ⊢ (state_pred (fun _ => tla_or _ _)) ~~> _ =>
      apply leads_to_state_pred_split
  | |- _ ⊢ (tla_or _ _) ~~> _ =>
      rewrite leads_to_or_split; tla_split
  | |- _ ⊢ _ ~~> _ =>
    rewrite -?combine_or_preds ?tla_and_distr_l ?tla_and_distr_r;
    rewrite leads_to_or_split; tla_split
  end.

Tactic Notation "lt_split" := lt_split_or.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  A context module functor that allows us to build all of the
  context modules for all four contexts.

*)

(* TODO:
    a) signature matches lemmas
    b) masking of symbols
    c) clean usage of K_eq/T_eq in all such modules.
    d) work on map/none/some naming.
    e) r/l are really conclusion and assumption.
*)

Require Import List.
Export ListNotations.
Require Export ZArith.
Require Import Init.Datatypes.
Require Export Coq.Bool.Bool.

Require Export CpdtTactics.
Require Export Case.

Require Export ContextSigDef.
Require Export BoolEqualitySigDef.
Require Export BooleanEqualitySetFunDef.

Require Export Coq.MSets.MSets.
Require Export Coq.MSets.MSetInterface.
Require Export Coq.MSets.MSetWeakList.

Require Export MoreTacticals.

Set Implicit Arguments.

Module ContextFun(K: BoolEqualitySig) (T : BoolEqualitySig) <: ContextSig.

  Module K := K.
  Module T := T.
  Definition K := K.t.
  Definition K_eq := K.eqb.
  Definition T := T.t.
  Definition T_eq := T.eqb.

  Module KSet := BooleanEqualitySetFun(K).

Inductive Context': Type :=
| dot  : Context'
| ctxt :  K.t -> T.t -> Context' -> Context' .

Definition Context := Context'.
Tactic Notation "Context_ind_cases" tactic(first) ident(c) :=
 first;
[ Case_aux c "(dot K T)"
| Case_aux c "(ctxt k t c)"
].

Definition empty  := dot.

Function add (c : Context') (k: K.t) (t : T.t)  : Context' :=
  match c with
    | dot => (ctxt k t (dot))
    | (ctxt k' t' c') =>
      match K.eqb k k' with
        | true  => (ctxt k  t  c')
        | false => (ctxt k' t' (add c' k t))
      end
  end.
Hint Unfold add.

Function map (c : Context') (k : K.t) : option T.t :=
  match c with
    | dot => None
    | (ctxt k' t' c') =>
      match K.eqb k k' with
        | true  => Some t'
        | false => (map c' k)
      end
  end.
Hint Unfold map.

Function delete (c : Context') (k : K.t) : Context' :=
  match k, c with
    | k, dot => empty
    | k, (ctxt k' t' c') =>
      match K.eqb k k' with
        | true  => c'
        | false => (ctxt k' t' (delete c' k))
      end
  end.
Hint Unfold delete.

Function nodup (c : (Context')) : bool :=
  match c with
    | dot => true
    | (ctxt k' t' c') =>
      match map c' k' with
        | Some t  => false
        | None  => nodup c'
      end
end.
Hint Unfold nodup.

Function extends (c c' : Context') : bool :=
  match c with
    | dot => true
    | ctxt k t c'' =>
      match map c' k with
       | Some t' =>
         match (T.eqb t t') with
           | true => extends c'' c'
           | false => false
         end
       | None => false
      end
  end.
Hint Unfold extends.

Function equal (c c' : Context') : bool :=
  andb (extends c c') (extends c' c).
Hint Unfold equal.

Function concat (c c' : Context') {struct c'} : Context' :=
  match c' with
  | dot => c
  | (ctxt k v d) => (ctxt k v (concat c d))
  end.

Function dom (c : Context') : KSet.t :=
 match c with
 | dot => KSet.empty
 | (ctxt k v c') => KSet.union (KSet.singleton k) (dom c')
 end.

(* Do I need this? is it being used by LN LibEnv.env? *)
Lemma Context'_ind':
  forall (P : Context' -> Prop),
  (P empty) ->
  (forall E x v, P E -> P (concat E (ctxt x v empty))) ->
  (forall E, P E).
Proof.
  induction E; try solve[crush].
Qed.

(* Can I add k t to the front of c'? *)
Function extends1 (c : Context') (k : K.t ) (t : T.t) (c' : Context') : bool :=
  match map c' k with
   | Some _ => false
   | None =>
     match map c k with
      | Some _ => false
      | None   => (equal (ctxt k t c) c')
     end
end.
Hint Unfold extends1.

Function extends1' (c : Context') (k : K.t ) (t : T.t) (c' : Context') : bool :=
  match map c' k with
   | Some _ => false
   | None =>
     match map c k with
      | Some _ => false
      | None   => extends (ctxt k t c) c'
     end
end.
Hint Unfold extends1'.

Lemma map_empty_none: forall k, map empty k = None.
Proof.
   crush.
Qed.

Lemma nodup_empty: nodup empty = true.
Proof.
  crush.
Qed.

Lemma map_add: forall c k t, map (add c k t) k = Some t.
Proof.
  intros.
  induction c; crush.
  case_eq (K.eqb k t0); crush.
Qed.

Lemma map_agreement:
  forall c k t,
    nodup c = true ->
    map c k = Some t ->
    forall t',
      map c k = Some t' ->
      t = t'.
Proof.
 intros.
 induction c; crush.
Qed.

Lemma map_some_none_neq:
  forall c k k',
    map c k  = None ->
    forall t,
      map c k' = Some t ->
      k <> k'.
Proof.
  induction c; crush.
Qed.

Ltac expand_cases :=
  repeat match goal with
          | [ H : (if ?x then _ else _) = Some _ |- _ ] =>
            destruct x ; try solve[inversion H]
          | [ H : (if ?x then _ else _) = None   |- _ ] =>
            destruct x ; try solve[inversion H]
          end.

Ltac invert_some_eq :=
  repeat match goal with
          | [ H : Some _ = Some _ |- _ ] =>
            inversion H; subst; clear H
         end.

Lemma map_some_none_beq_t_false:
  forall c k k',
    map c k  = None ->
    forall t,
      map c k' = Some t ->
      K.eqb k k' = false.
Proof.
  intros.
  induction c.
  crush.
  pose proof H as H'.
  pose proof H0 as H0'.
  unfold map in H.
  fold map in H.
  unfold map in H0.
  fold map in H0.
  case_eq(K.eqb k t0); case_eq(K.eqb k' t0); intros; rewrite H1 in H0; rewrite H2 in H; try solve [inversion H].
  inversion H0.
  subst.
  case_eq(K.eqb k k'); intros; try reflexivity.
  apply K.eqb_to_eq in H3.
  subst.

  rewrite H1 in H2.
  inversion H2.
  apply IHc in H; try assumption.
Qed.

Lemma empty_extended_by_all:
  forall c,
    extends empty c = true.
Proof.
  crush.
Qed.

Lemma empty_extends_only_empty:
  forall c,
    extends c empty = true ->
    c = empty.
Proof.
  intros.
  induction c; crush.
Qed.

Lemma extends_r_str:
  forall c c',
    extends c c' = true ->
    forall v t,
      nodup (ctxt v t c') = true ->
      extends c (ctxt v t c') = true.
Proof.
  intros c c'.
  functional induction (extends c c'); try solve[crush].
  intros.
  apply IHb with (v:= v) (t:= t0) in H.
  unfold extends.
  fold extends.
  case_eq(map (ctxt v t0 c') k); intros.
  case_eq(T.eqb t t1); intros; try assumption.
  pose proof H0 as H0'.
  unfold map in H1.
  fold map in H1.
  case_eq(K.eqb k v); intros; try rewrite H3 in H1.
  move t1 before t.
  unfold nodup in H0.
  fold nodup in H0.
  apply K.eqb_to_eq in H3.
  rewrite <- H3 in H0.
  rewrite e0 in H0.
  inversion H0.
  rewrite e0 in H1.
  crush.

  pose proof H1 as H1'.
  unfold map in H1.
  fold map in H1.
  case_eq(K.eqb k v); intros; rewrite H2 in H1.
  inversion H1.
  rewrite e0 in H1.
  inversion H1.
  assumption.
Qed.

Lemma extends1_to_equality:
  forall c v t c',
    extends1 c v t c' = true ->
    equal (ctxt v t c) c' = true.
Proof.
  intros.
  pose proof H as H'.
  unfold extends1 in H.
  case_eq(map c' v); intros; rewrite H0 in H; try solve[inversion H];
  case_eq(map c v); intros; try rewrite H1 in H; try solve[inversion H].
  assumption.
Qed.

Lemma extends1_r_str:
  forall c v t c',
    extends1 c v t c' = true ->
    forall v' t',
      nodup (ctxt v t (ctxt v' t' c')) = true ->
      extends1 c v t (ctxt v' t' c') = true.
Proof.
  intros.
  induction c'; intros.
  unfold extends1 in H.
  fold extends1 in H.
  simpl in H.
  case_eq(map (ctxt v' t' (dot)) v); intros.

(* Stuck.
  intros c v t c'.
  functional induction (extends1 c v t c'); try solve[crush].
  intros.
  unfold extends1.
  case_eq(map (ctxt v' t' c') v); intros.
  unfold nodup in H0.
  fold nodup in H0.
  unfold map in H0.
  fold map in H0.
  case_eq(K.eqb v v'); intros; rewrite H2 in H0.
  inversion H0.
  rewrite e in H0.
  case_eq(map c' v'); intros; rewrite H3 in H0.
  inversion H0.
  unfold map in H1.
  fold map in H1.
  rewrite H2 in H1.
  rewrite H1 in e.
  inversion e.
  rewrite e0.
  unfold map in H1.
  case_eq(K.eqb v v'); intros; rewrite H2 in H1.
  inversion H1.
  fold map in H1.
  (* stuck *)
*)
Admitted.

(*
Lemma extends_refl_no_nodup:
  forall c,
    extends c c = true.
Proof.
  intros.
  induction c; try solve [crush].
  unfold extends.
  fold extends.
  simpl.
  rewrite K.eqb_refl.
  rewrite T.beq_t_refl.
  unfold extends.
  fold extends.
Qed.
*)

Lemma extends_refl:
  forall c,
    nodup c = true ->
    extends c c = true.
Proof.
  intros.
  induction c; try solve [crush].
  unfold extends.
  fold extends.
  simpl.
  rewrite K.eqb_refl.
  rewrite T.eqb_refl.
  apply extends_r_str; try assumption.
  unfold nodup in H.
  fold nodup in H.
  case_eq(map c t); intros; rewrite H0 in H.
  inversion H.
  apply IHc in H.
  assumption.
Qed.

Lemma extends_l_weak:
  forall c c' k,
    extends c c' = true ->
    forall t,
      map c' k = Some t ->
      extends (ctxt k t c) c' = true.
Proof.
  intros.
  unfold extends.
  fold extends.
  unfold map.
  fold map.
  rewrite H0.
  rewrite T.eqb_refl.
  assumption.
Qed.

Lemma extends_l_weak_r_str:
  forall c c' k,
    extends c c' = true ->
    map c' k = None  ->
    forall t,
      nodup c' = true ->
      extends (ctxt k t c) (ctxt k t c') = true.
Proof.
  intros.
  unfold extends.
  fold extends.
  unfold map.
  fold map.
  rewrite K.eqb_refl.
  rewrite T.eqb_refl.

  apply extends_r_str; try assumption.
  unfold nodup.
  fold nodup.
  rewrite H0.
  assumption.
Qed.

Lemma extends_l_str:
  forall c c' k t,
    extends (ctxt k t c) c' = true -> extends c c' = true.
Proof.
  intros.
  induction c; try solve[crush].
  unfold extends in H.
  fold extends in H.
  unfold extends.
  fold extends.
  case_eq(map c' k); intros; rewrite H0 in *; case_eq(map c' t0); intros; try rewrite H1 in *; try solve[inversion H];   case_eq(T.eqb t t2); intros; try rewrite H2 in *; try inversion H.
 case_eq(T.eqb t1 t3); intros; rewrite H4 in *; try inversion H; reflexivity.
Qed.

Lemma map_extends_none_agreement:
  forall c c',
   extends c c' = true ->
   forall v,
     map c' v = None ->
     map c v  = None.
Proof.
  intros c c' ext.
  functional induction (extends c c'); try solve [crush].
  intros.
  apply IHb with (v:= v) in ext; try assumption.
  unfold map.
  fold map.
  case_eq (K.eqb v k); intros.
  apply K.eqb_to_eq in H0.
  subst.
  rewrite e0 in H.
  inversion H.
  assumption.
Qed.

Lemma equal_empty_empty:
  forall c,
    equal empty c = true ->
    c = empty.
Proof.
  intros.
  induction c; crush.
Qed.

Lemma K_eq_sym:  forall k k', K.eqb k k' = K.eqb k' k.
Proof.
  apply K.eqb_sym.
Qed.

Lemma map_r_str:
  forall c k0 t0 k t,
    map (ctxt k0 t0 c) k = Some t ->
    K.eqb k0 k = false ->
    map c k = Some t.
Proof.
  intros.
  unfold map in H.
  fold map in H.
  rewrite K.eqb_sym in H0.
  rewrite H0 in H.
  assumption.
Qed.

Lemma map_r_str_add:
  forall c k0 t0 k t,
    map (add c k0 t0) k = Some t ->
    K.eqb k k0 = false ->
    map c k = Some t.
Proof.
  intros.
  induction c.
  unfold add in H.
  unfold map in H.
  rewrite H0 in H.
  inversion H.

  unfold map.
  fold map.
  unfold add in H.
  fold add in H.
  case_eq(K.eqb k0 t1); case_eq(K.eqb k t1); intros; rewrite H2 in H.
  apply K.eqb_trans with (x:= k) in H1.
  apply K.eqb_to_eq in H1.
  subst.
  rewrite K.eqb_sym in H0.
  apply K.eqb_to_eq in H2.
  subst.
  rewrite K.eqb_refl in H0.
  inversion H0.

  apply K.eqb_refl.
  unfold map in H.
  fold map in H.
  rewrite H0 in H.
  assumption.

  unfold map in H.
  fold map in H.
  rewrite H1 in H.
  assumption.

  unfold map in H.
  fold map in H.
  rewrite H1 in H.
  apply IHc in H.
  assumption.
Qed.

Lemma nodup_add_none:
  forall c,
    nodup c = true ->
    forall k,
     map c k = None  ->
    forall t,
      nodup (add c k t) = true.
Proof.
  induction c; try solve [crush].
  intros.
  unfold nodup in H.
  fold nodup in H.
  case_eq (map c t); intros; rewrite H1 in H; try inversion H.
  unfold map in H0.
  fold map in H0.
  case_eq (K.eqb k t); intros; rewrite H2 in H0.
  inversion H0.

  unfold add.
  fold add.
  rewrite H2.
  unfold nodup.
  fold nodup.
  rewrite H3.
  case_eq (map (add c k t1) t); intros.
  apply map_r_str_add in H4; try assumption.
  rewrite H4 in H1.
  inversion H1.
  apply IHc with (k:= k) (t:= t1) in H; try assumption.
  rewrite K.eqb_sym in H2; try assumption.
  apply IHc with (k:= k) (t:= t1) in H3; try assumption.
Qed.

Lemma nodup_r_str:
  forall c,
    nodup c = true ->
    forall k,
     map c k = None  ->
    forall t,
      nodup (ctxt k t c) = true.
Proof.
  induction c; try solve [crush].
Qed.

(* Perhaps I want this someday too. *)
(*
Lemma nodup_add_some:
  forall c,
    nodup c = true ->
    forall k t,
     map c k = Some t  ->
    forall t',
      nodup (add c k t') = true.
*)

Lemma nodup_map_some_context_absurd:
  forall c k t t',
    map c k = Some t ->
    nodup (ctxt k t' c) = true
     -> False.
Proof.
  intros.
  induction c; try solve[crush].
  unfold map in H.
  fold map in H.
  case_eq(K.eqb k t0); intros; rewrite H1 in H.
  inversion H; subst.
  apply K.eqb_to_eq in H1.
  rewrite H1 in H0.
  unfold nodup in H0.
  fold nodup in H0.
  simpl in H0.
  rewrite K.eqb_refl in H0.
  inversion H0.
  unfold nodup in H0.
  fold nodup in H0.
  simpl in H0.
  rewrite H1 in H0.
  rewrite H in H0.
  inversion H0.
Qed.

Lemma map_extension_disagreement_absurd:
  forall c c',
    extends c c' = true ->
    forall v t,
      map c v  = Some t ->
      map c' v = None ->
      False.
Proof.
  intros c c' ext.
  functional induction (extends c c'); try solve [crush].
  intros.
  apply IHb with (v:= v) (t:= t0) in ext; try assumption.
  unfold map in H.
  fold map in H.
  case_eq(K.eqb v k); intros; rewrite H1 in H; try assumption.
  apply K.eqb_to_eq in H1.
  subst.
  rewrite e0 in H0.
  inversion H0.
Qed.

Lemma map_add_recursion:
  forall c k t k',
    map (add c k' t) k = Some t ->
    K.eqb k k' = false ->
    map c k = Some t.
Proof.
  intros.
  induction c.
  simpl in H.
  rewrite H0 in H.
  inversion H.
  unfold map.
  fold map.
  case_eq(K.eqb k t0); intros.
  apply K.eqb_to_eq in H1.
  subst.
  unfold add in H.
  fold add in H.
  rewrite K.eqb_sym in H0.
  rewrite H0 in H.
  unfold map in H.
  fold map in H.
  rewrite K.eqb_refl in H.
  assumption.
  unfold add in H.
  fold add in H.
  case_eq(K.eqb k' t0); intros; rewrite H2 in H.
  unfold map in H.
  fold map in H.
  rewrite H0 in H.
  assumption.
  unfold map in H.
  fold map in H.
  rewrite H1 in H.
  apply IHc in H.
  assumption.
Qed.

Lemma extends_r_weak:
  forall c c' k t,
    extends c (ctxt k t c') = true ->
    nodup (ctxt k t c') = true ->
    map c k = None ->
    extends c c' = true.
Proof.
  intros.
  induction c; try solve[crush].
  unfold extends in H.
  fold extends in H.
  unfold extends.
  fold extends.
  case_eq(map c' t0); intros;
  case_eq(map (ctxt k t c') t0); intros; rewrite H3 in H; try solve[inversion H].
  case_eq(T.eqb t1 t2); intros; try rewrite H4 in *; try solve[inversion H].
  case_eq(T.eqb t1 t3); intros;rewrite H5 in H; try solve[inversion H].
  unfold map in H1.
  fold map in H1.
  case_eq(K.eqb k t0); intros; rewrite H6 in H1; try inversion H1.
  apply IHc in H; try assumption.
  case_eq(T.eqb t1 t3); intros; rewrite H5 in H; try solve[inversion H].
  apply T.eqb_to_eq in H5.
  subst.
  unfold map in H3.
  fold map in H3.
  unfold map in H1.
  fold map in H1.
  case_eq(K.eqb k t0); intros.
  rewrite K.eqb_sym in H3.
  rewrite H5 in *.
  inversion H1.

  rewrite K.eqb_sym in H5.
  rewrite H5 in *.
  apply T.eqb_to_neq in H4.
  rewrite H2 in H3.
  inversion H3.
  crush.
(*  apply T.eqb_to_eq in H4.
  subst. *)
  unfold map in H3.
  fold map in H3.
  unfold map in H1.
  fold map in H1.
  case_eq(K.eqb t0 k); intros.
  rewrite K.eqb_sym in H1.
  rewrite H4 in *.
  inversion H1.

  rewrite K.eqb_sym in H1.
  rewrite H4 in *.
  rewrite H2 in H3.
  inversion H3.
Qed.

Lemma map_disagreement_absurd:
  forall c k t,
    nodup c = true ->
    map c k = Some t ->
    forall k' t',
    map (ctxt  k' t' c) k = None ->
  False.
Proof.
  intros.
  assert (Z: extends c (ctxt k' t' c) = true).
  assert (Y: extends c c = true).
  apply extends_refl; try assumption.
  apply extends_r_str with (v:= k') (t:= t') in Y; try assumption.
  unfold nodup.
  fold nodup.
  case_eq(map c k'); intros; try assumption.
  unfold map in H1.
  fold map in H1.
  case_eq(K.eqb k k'); intros; rewrite H3 in H1; try solve [inversion H1].
  rewrite H1 in H0.
  inversion H0.
  apply map_extension_disagreement_absurd with (v:= k) (t:= t) in Z; try assumption.
Qed.

Lemma map_add_disagreement_absurd:
  forall c k t,
    map c k = Some t ->
    forall k' t',
    map (add c k' t') k = None ->
  False.
Proof.
  intros c.
  induction c; try solve [crush].
  intros.
  unfold map in H.
  fold map in H.
  unfold add in H0.
  fold add in H0.
  case_eq(K.eqb k t); case_eq(K.eqb k' t); intros; rewrite H1 in H0; rewrite H2 in H.
  apply K.eqb_trans with (x:= k') in H1.
  apply K.eqb_to_eq in H2.
  subst.
  unfold map in H0.
  fold map in H0.
  rewrite K.eqb_sym in H1.
  apply K.eqb_to_eq in H1.
  subst.
  rewrite K.eqb_refl in H0.
  inversion H0.
  apply K.eqb_refl.
  apply K.eqb_to_eq in H2.
  subst.
  unfold map in H0.
  fold map in H0.
  rewrite K.eqb_refl in H0.
  inversion H0.
  unfold map in H0.
  fold map in H0.
  case_eq (K.eqb k k'); intros; rewrite H3 in H0.
  inversion H0.
  rewrite H0 in H.
  inversion H0.
  inversion H.
  unfold map in H0.
  fold map in H0.
  rewrite H2 in H0.
  apply IHc with (k':= k') (t':= t') in H; try assumption.
Qed.

Lemma map_add_some_agreement:
  forall c k t,
    map c k = Some t ->
    forall k0 t0,
      K.eqb k k0 = false ->
      map (add c k0 t0) k = Some t.
Proof.
  intros.
  functional induction (add c k0 t0); try solve [crush].
  unfold map.
  fold map.
  rewrite H0.
  apply K.eqb_to_eq in e0.
  subst.
  unfold map in H.
  fold map in H.
  rewrite H0 in H.
  assumption.

  unfold map in H.
  fold map in H.
  unfold map.
  fold map.
  case_eq(K.eqb k k'); intros; rewrite H1 in H.
  assumption.

  apply IHc0 in H; try assumption.
Qed.

Lemma extends_r_str_add:
  forall c c',
    extends c c' = true ->
    forall k t,
      map c k = None ->
      extends c (add c' k t) = true.
Proof.
  (* extends *)
  intros c c'.
  functional induction (extends c c'); try solve [crush].
  intros.
  pose proof e1 as e1'.
  apply T.eqb_to_eq in e1.
  subst.
  unfold map in H0.
  fold map in H0.
  case_eq(K.eqb k0 k); intros; rewrite H1 in H0.
  inversion H0.
  apply IHb with (k:= k0) (t:= t0) in H; try assumption.
  apply extends_l_weak; try assumption.
  apply map_add_some_agreement; try assumption.
  rewrite K.eqb_sym in H1.
  assumption.
Qed.

Lemma map_extends_some_agreement:
  forall c v t,
    map c v  = Some t ->
    nodup c = true ->
    forall c',
      extends c c' = true ->
      nodup c' = true ->
      map c' v = Some t.
Proof.
  intros.
  functional induction (extends c c'); try solve [crush].
  unfold map in H.
  fold map in H.
  unfold nodup in H0.
  fold nodup in H0.
  case_eq(K.eqb v k); intros; rewrite H3 in H.
  inversion H.
  subst.
  case_eq(map c'' k); intros; rewrite H4 in H0.
  inversion H0.
  clear H.
  apply K.eqb_to_eq in H3.
  apply T.eqb_to_eq in e1.
  subst.
  assumption.
  case_eq(map c'' k); intros; rewrite H4 in H0.
  inversion H0.
  apply IHb in H; try assumption.
Qed.

Lemma map_none_r_str:
  forall c v v',
   map c v  = None ->
   map c v' = None ->
   K.eqb v' v = false ->
   forall t,
     map (ctxt v t c) v' = None.
Proof.
  intros.
  induction c.
  refold map.
  rewrite H1.
  reflexivity.
  refold map.
  refold_in map H.
  refold_in map H0.
  case_eq(K.eqb v t0); intros; rewrite H2 in *;
  case_eq(K.eqb v' t0); intros; rewrite H3 in *;
  case_eq(K.eqb v' v); intros; rewrite H4 in *;
  try solve[inversion H];
  try solve[inversion H0];
  try solve[inversion H1].
  apply IHc in H; try assumption.
Qed.

Lemma map_none_r_weak:
  forall k k' t c,
    map (ctxt k t c) k' = None ->
    K.eqb k' k = false ->
    map c k' = None.
Proof.
  intros.
  unfold map in H.
  fold map in H.
  rewrite H0 in H.
  assumption.
Qed.

Lemma extends_trans:
  forall c c' c'',
    nodup c = true ->
    extends c  c'  = true ->
    nodup c' = true ->
    extends c' c'' = true ->
    nodup c'' = true ->
    extends c  c'' = true.
Proof.
  (* triple induction *)
  intros c c' c'' nodupc extendscc' nodupc' extendsc'c'' nodupc''.
  induction c; try solve [crush]; induction c'; try solve [crush]; induction c''; try solve [crush].
  move extendscc' after IHc''.
  move extendsc'c'' after extendscc'.
  pose proof extendscc' as H'.
  apply extends_l_str in extendscc'.
  inversion nodupc.
  case_eq (map c t); intros; rewrite H in H0; try solve[inversion H0].
  rewrite H0.
  apply IHc in H0; try assumption.
  apply extends_l_weak with (k:= t) (t:= t0).
  assumption.

  unfold map.
  fold map.
  case_eq (K.eqb t t3); intros.
  apply K.eqb_to_eq in H1.
  rewrite <- H1 in extendsc'c''.
  rewrite <- H1 in H0.
  rewrite <- H1 in nodupc''.

  assert (Z: map (ctxt t t0 c) t = Some t0).
  simpl.
  rewrite K.eqb_refl.
  reflexivity.
(* Naming mess up.
  apply map_extends_some_agreement with (v:= k) (t:= t) in H'; try assumption.
  apply map_extends_some_agreement with (v:= k) (t:= t) in extendsc'c'';
    try assumption.
  unfold map in extendsc'c''.
  fold map in extendsc'c''.
  rewrite K.eqb_refl in extendsc'c''.
  assumption.

  assert (Z: map (ctxt k t c) k = Some t).
  unfold map.
  fold map.
  rewrite K.eqb_refl.
  reflexivity.
  apply map_extends_some_agreement with (v:= k) (t:= t) in H';
    try assumption.
  apply map_extends_some_agreement with (v:= k) (t:= t) in extendsc'c'';
    try assumption.
  unfold map in extendsc'c''.
  fold map in extendsc'c''.
  rewrite H1 in extendsc'c''.
  assumption.
*)
Admitted.

Lemma equal_refl:
  forall c,
    nodup c = true ->
    equal c c = true.
Proof.
  intros.
  unfold equal.
  apply andb_true_iff.
  split.
  apply extends_refl; try assumption.
  apply extends_refl; try assumption.
Qed.

Lemma equal_sym:
  forall c c',
    equal c c' = equal c' c.
Proof.
  intros.
  unfold equal.
  crush.
Qed.

Lemma equal_trans:
  forall c c' c'',
    nodup c = true ->
    equal c  c'  = true ->
    nodup c' = true ->
    equal c' c'' = true ->
    nodup c'' = true ->
    equal c  c'' = true.
Proof.
  intros c c' c'' nodupc equalcc' nodupc' equalc'c'' nodupc''.
  unfold equal in equalcc'.
  apply andb_true_iff in equalcc'.
  inversion equalcc'.
  unfold equal in equalc'c''.
  apply andb_true_iff in equalc'c''.
  inversion equalc'c''.
  unfold equal.
  apply andb_true_iff.

  split.
  intros.
  apply extends_trans with (c:= c) (c':= c') (c'':= c'') in H; try assumption.
  apply extends_trans with (c:= c'') (c':= c') (c'':= c) in H0; try assumption.
Qed.

Lemma equal_implies_extends:
  forall d d',
    equal d d' = true ->
    extends d d' = true.
Proof.
  unfold equal.
  intros.
  apply andb_true_iff in H.
  inversion H.
  assumption.
Qed.

(* It would be nice if these were true but they're not unless I cannonicalize. *)
Lemma equal_eq:
  forall c c',
    equal c c' = true ->
    c = c'.
Admitted.

Lemma equal_neq:
  forall c c',
    equal c c' = false ->
    c <> c'.
Admitted.

Lemma equal_empty_only_empty:
  forall c,
    equal empty c = true ->
    c = empty.
Proof.
  intros.
  unfold equal in H.
  apply andb_true_iff in H.
  inversion H.
  apply empty_extends_only_empty in H1.
  assumption.
Qed.

Lemma equal_if_map_some:
  forall c c',
    nodup c  = true ->
    nodup c' = true->
    equal c c' = true ->
    (forall k t, map c k = Some t -> map c' k = Some t).
Proof.
  intros c c'.
  functional induction (equal c c').
  intros.
  apply andb_true_iff in H1.
  inversion H1.
  apply map_extends_some_agreement with (c':= c') in H2; try assumption.
Qed.

Lemma equal_iff_map_some:
  forall c c',
    nodup c  = true ->
    nodup c' = true ->
    equal c c' = true ->
    (forall k t, map c k = Some t <-> map c' k = Some t).
Proof.
  intros.

  split.
  intros.
  apply equal_if_map_some with (c:= c) (c':= c') (k:= k) (t:= t) in H; try assumption.

  intros.
  rewrite equal_sym in H1.
  apply equal_if_map_some with (c:= c') (c':= c) (k:= k) (t:= t) in H; try assumption.
Qed.

(* Admitting alpha conversion in the most specific ways:
    that x is not in a context and that
    x is not equal to x'. *)
Lemma admit_alpha_conversion_context:
  forall v c,
    map v c = None.
Admitted.

Lemma admit_alpha_conversion_beq_t:
  forall k k',
    K.eqb k k' = false.
Admitted.

End ContextFun.


(* (c) Copyright 2006-2015 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 coloring patch.
From fourcolor Require Import snip revsnip birkhoff.

(******************************************************************************)
(* The proof that there exists a contract coloring for any valid contract.    *)
(* We will show in embed.v that contract validity is lifted by the embedding, *)
(* except for the ring condition, which becomes moot.                         *)
(* Definitions:                                                               *)
(*   contract_ring cc r <-> r is a proper ring (simple R-cycle) that is       *)
(*                contracted to its first dart by applying the contract cc -- *)
(*                i.e., the rest of r is in the edge-closure of cc.           *)
(*  We show that valid contracts do not admit contract rings, using the       *)
(* Birkhoff theorem, sparsity, and triads for ring size 5 / contract size 4.  *)
(******************************************************************************)

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

Definition contract_ring (G : hypermap) (cc r : seq G) : Prop :=
  [/\ scycle rlink r, proper_ring r & {subset behead r <= insertE cc}].

Section ContractLemmas.

Variable G : hypermap.
Hypothesis cexG : minimal_counter_example G.

Let planarG : planar G := cexG.
Let bridge'G := bridgeless_cface cexG.
Let plainG : plain G := cexG.
Let cubicG : cubic G := cexG.
Let pentaG : pentagonal G := cexG.
Let ccG : connected G := cexG.
Let noncolG := minimal_counter_example_is_noncolorable cexG.
Let minG := minimal_counter_example_is_minimal cexG.
Let ee := plain_eq cexG.
Let e'id := plain_neq cexG.
Let nnn := cubic_eq cexG.
Let geoG : planar_bridgeless_plain_connected G := cexG. (* revring assumption *)

Lemma sparse_contract_ring (cc : seq G) :
  sparse (insertE cc) -> forall p, contract_ring cc p -> nontrivial_ring 0 p.
Proof.
rewrite /sparse simple_recI /= => cc_sparse.
suffices dF_cc p: contract_ring cc p -> ~ diskF p =i pred0.
  move=> p cc_p; apply/nontrivial0P; split.
    by apply/existsP/pred0P; apply: dF_cc.
  have{cc_p} [URp nt_p cc_p] := cc_p.
  have URp1: scycle rlink (rot 1 p) by rewrite rot_scycle.
  have/(_ _)/pred0P/existsP[|y] := dF_cc (rev_ring (rot 1 p)); last first.
    by rewrite diskF_rev_ring ?proper_ring_rot // diskFC_rot; exists y.
  split=> [||y py]; first exact: scycle_rev_ring.
    by rewrite proper_rev_ring // proper_ring_rot.
  suff: edge y \in insertE cc by rewrite !mem_insertE // -(eq_has (cedge1 y)).
  apply: cc_p; case: (p) py => //= x p1; rewrite rot1_cons /rev_ring.
  by rewrite -map_rev rev_rcons /= -{1}[y]ee (mem_map edgeI) mem_rev.
elim: {p}_.+1 {-2}p (ltnSn (size p)) => // n IHn p le_p_n [URp nt_p cc_p] dF0.
have [cycRp /simple_uniq Up] := andP URp.
case Dp: p (nt_p) => [|x [|x1 p0]] // _.
have p_x: x \in p by rewrite Dp mem_head.
have dNx: x \in diskN p by rewrite diskN_E inE Dp /= mem_head.
move: (negbT (dF0 (node x))) (negbT (dF0 (node (node x)))).
rewrite !inE -!(fclosed1 (diskN_node p)) dNx !andbT !negbK => pFnx pFnnx.
have{pFnx} p_nx: node x \in p.
  without loss dEnx: / node x \in diskE p.
    by rewrite !inE -(fclosed1 (diskN_node p)) dNx andbT => /wlog_neg.
  have pFenx: edge (node x) \in fband p.
    by apply/hasP; exists x; rewrite // -{2}[x]nodeK fconnect1.
  rewrite (fclosed1 (diskE_edge geoG URp)) in dEnx.
  have [[pjnx nxFj] [pjenx enxFj]] := (fprojP pFnx, fprojP pFenx).
  have Djenx: fproj p (edge (node x)) = x.
    rewrite cface1 nodeK cfaceC in enxFj.
    by apply: (scycle_cface URp); rewrite // Dp mem_head.
  have j'x: x != fproj p (node x).
    apply: contraTneq nxFj => <-; by rewrite -{2}[x]nodeK -cface1r bridge'G.
  have j'x1: x1 != fproj p (node x).
    apply: contraTneq nxFj => <-; rewrite cfaceC -[node x]nodeK -cface1r.
    have:= cycRp; rewrite Dp => /andP[/same_cface <- _].
    by rewrite (canRL nodeK (nnn x)) cface1 bridge'G.
  have [i p1 _ Dp1 -> Eip] := rot_to_arc Up p_x pjnx j'x.
  rewrite -[node x]ee -{3}Djenx -cat_cons in Eip.
  case: (IHn (chord_ring p (edge (node x)))) => [||y]; last 1 first.
  - by rewrite diskF_chord_ring ?ee // inE /= dF0 andbF.
  - rewrite -ltnS (leq_trans _ le_p_n) // ltnS -(size_rot i p) Eip Dp1 size_cat.
    by rewrite {2}Dp /arc /= eqxx /= (negPf j'x) (negPf j'x1) !ltnS leq_addl.
  split=> [||y /= q_y]; try by apply: scycle_chord_ring; rewrite ?ee.
    by apply: (proper_chord_ring cexG); rewrite ?ee.
  have p_y: y \in p by rewrite -(mem_rot i) Eip mem_cat q_y orbT.
  apply: cc_p; rewrite Dp in p_y *; case/predU1P: p_y => // y_x.
  by rewrite -(rot_uniq i) Eip -{1}y_x /= mem_cat q_y orbT in Up.
have{dNx pFnnx p_x n IHn le_p_n dF0 cycRp Up URp} p_nnx: node (node x) \in p.
  without loss dEnnx: / node (node x) \in diskE p.
    by rewrite !inE -!(fclosed1 (diskN_node p)) dNx andbT => /wlog_neg.
  have pFennx: edge (node (node x)) \in fband p.
    by apply/hasP; exists (node x); rewrite // -{2}[node x]nodeK fconnect1.
  have [[pjnnx nnxFj] [pjennx ennxFj]] := (fprojP pFnnx, fprojP pFennx).
  have Djennx: fproj p (edge (node (node x))) = node x.
    by rewrite cface1 nodeK cfaceC in ennxFj; apply: (scycle_cface URp).
  have Lp0: last x1 p0 = node x.
    apply: (can_inj (prev_next Up)).
    rewrite -(next_rotr 1 Up) {1}Dp lastI rotr1_rcons /= eqxx.
    apply/esym/(scycle_cface URp); rewrite ?mem_next //.
    by rewrite -(same_cface (next_cycle cycRp p_nx)) -{2}[x]nodeK fconnect1.
  have j'nx: node x != fproj p (node (node x)).
    apply: contraTneq nnxFj => <-.
    by rewrite -{2}[node x]nodeK -cface1r bridge'G.
  have j'x: x != fproj p (node (node x)).
    apply: contraTneq nnxFj => <-.
    by rewrite (canRL nodeK (nnn x)) cfaceC -cface1r bridge'G.
  have [i p1 _ Dp1 ->] := rot_to_arc Up p_nx pjnnx j'nx.
  rewrite -{3}Djennx -cat_cons {p1}Dp1 -{2}[node (node x)]ee -{2}[p](rotrK 1).
  rewrite arc_rot ?rotr_uniq ?mem_rotr // {2}Dp lastI rotr1_rcons /= Lp0.
  rewrite {1}/arc /= eqxx /= (negPf j'nx) (negPf j'x) => Eip.
  case: (IHn (chord_ring p (edge (node (node x))))) => [||y].
  - rewrite -ltnS (leq_trans _ le_p_n) // ltnS -(size_rot i p) Eip size_cat.
    by rewrite !ltnS leq_addl.
  - split=> [||y /= q_y]; first by apply: scycle_chord_ring; rewrite ?ee.
      by rewrite proper_chord_ring ?ee -?(fclosed1 (diskE_edge cexG _)).
    have p_y: y \in p by rewrite -(mem_rot i) Eip mem_cat q_y orbT.
    apply: cc_p; move: p_y; rewrite Dp => /predU1P[y_x | //].
    move: Up; rewrite -(rot_uniq i) Eip/= -[x as X in X \in _]y_x.
    by rewrite !mem_cat/= q_y orbT andbF.
  rewrite diskF_chord_ring ?ee //; first by rewrite inE /= dF0 andbF.
  by rewrite -(fclosed1 (diskE_edge cexG _)).
have x'nx := cubic_neq cexG x.
have{p_nx} cc_nx: node x \in insertE cc.
  by apply: cc_p; move: p_nx; rewrite Dp inE x'nx.
have{p nt_p p_nnx cc_p x1 p0 Dp} cc_nnx: node (node x) \in insertE cc.
  by apply: cc_p; move: p_nnx; rewrite Dp inE (canF_eq nnn) eq_sym x'nx.
elim: cc cc_sparse cc_nx cc_nnx => [|y cc IHcc] //=.
rewrite unfold_in /= !inE => /and3P[/norP[_ yN'cc] eyN'cc cc_sparse].
case/predU1P=> [->|].
  rewrite (cubic_neq cexG) [_ == _](contraFF _ (bridge'G (node (node y)))).
    by move=> cc_ny; case/hasP: yN'cc; exists (node y); rewrite ?fconnect1.
  by move/eqP=> {2}->; rewrite 2!cface1r -{2}[y]nnn !nodeK.
case/predU1P=> [-> | cc_nx].
  rewrite (cubic_neq cexG) [_ == _](contraFF _ (bridge'G (face y))) => [?|].
    by case/hasP: eyN'cc; exists (node (edge y)); last apply: fconnect1.
  by rewrite 2!cface1r -(canRL nodeK (nnn _)) (canRL ee (faceK _)) => /eqP->.
case/predU1P=> [nnx_y | /predU1P[nnx_ey | /IHcc[]//]].
  by case/hasP: yN'cc; exists (node x); last by rewrite cnode1r nnx_y.
by case/hasP: eyN'cc; exists (node x); last by rewrite /= cnode1r nnx_ey.
Qed.

Lemma contract_ring_max (cc p : seq G) :
  contract_ring cc p -> size p <= (size cc).+1.
Proof.
case=> URp nt_p cc_p; pose df x := [predI cc & pred2 x (edge x)].
have Ddf x: x \in behead p -> ~ df x =1 pred0.
  move=> p1x dfx0; have{p1x}:= cc_p x p1x.
  rewrite mem_insertE // => /hasP[y cc_y xEy].
  by rewrite plain_orbit // !inE in xEy; case/andP: (dfx0 y).
have Udf: {in behead p &, injective (fun x => odflt x (pick (df x)))}.
  move=> x y p1x p1y; have [px py] := (mem_behead p1x, mem_behead p1y).
  case: pickP => [x1 /andP[/= _ Dx1] | /(Ddf x p1x)[]//].
  case: pickP => [y1 /andP[/= _ Dy1] | /(Ddf y p1y)[]] //= eq_xy1.
  move: eq_xy1 Dx1 Dy1 => -> /pred2P[] -> /pred2P[] // xey; last exact: edgeI.
    by have:= diskN_edge_ring cexG URp nt_p py; rewrite diskN_E inE /= -xey px.
  by have:= diskN_edge_ring cexG URp nt_p px; rewrite diskN_E inE /= xey py.
have Up1: uniq (behead p).
  by case: (p) (andP URp) => // x p' [_ /simple_uniq/andP[]].
rewrite -add1n -leq_subLR subn1 -size_behead -(card_uniqP Up1).
rewrite -(card_in_image Udf) (leq_trans _ (card_size cc)) //.
apply/subset_leq_card/subsetP=> _ /imageP[x p1x ->].
by case: pickP => [x1 /andP[] | /(Ddf x p1x)].
Qed.

Lemma contract3_valid (cc : seq G) :
  sparse (insertE cc) -> size cc <= 3 -> forall p, ~ contract_ring cc p.
Proof.
move=> cc_sparse cc_le3 p cc_p; have [URp _ _] := cc_p.
have: size p <= 4 by apply: leq_trans (contract_ring_max cc_p) _.
rewrite -ltnS ltn_neqAle => /andP[/negPf p_not5 p_le5].
case/negP: (Birkhoff cexG p_le5 URp); rewrite p_not5.
exact: sparse_contract_ring cc_p.
Qed.

Lemma triad_valid (cc : seq G) x0 :
    sparse (insertE cc) -> size cc = 4 -> triad (insertE cc) x0 ->
  forall p, ~ contract_ring cc p.
Proof.
move=> cc_sparse cc4 triad_x0 p cc_p.
have p_le5: size p <= 5 by rewrite -cc4; apply: (contract_ring_max cc_p).
have{cc_p}[[URp nt_p cc_p] nt0p] := (cc_p, sparse_contract_ring cc_sparse cc_p).
case: (size p =P 5) (Birkhoff cexG p_le5 URp) => [sz_p triv1p | _ /idP[]//].
have [y0 sAy0Fp]: exists y0, {subset adj y0 <= fband p}.
  have [y sAyFp | no_y] := pickP (fun y => adj y \subset fband p).
    by exists y; apply: (subsetP sAyFp).
  have [[y0 dFy0] [y1 dFCy1]] := nontrivial0P _ nt0p.
  case/nontrivial1P: triv1p; split.
    have /subsetPn[y /adjP[z y0Fz zRy] pF'y] := no_y y0.
    exists y0 => //; exists (face (edge z)); last first.
      by rewrite (same_cface y0Fz) -cface1r bridge'G.
    rewrite /rlink cface1 (closed_connect (diskF_face p) y0Fz) in zRy dFy0.
    rewrite !inE (closed_connect (fbandF p) zRy) (fclosed1 (diskN_node p)).
    by rewrite pF'y edgeK; case/andP: dFy0.
  have /subsetPn[y /adjP[z y1Fz zRy] pF'y] := no_y y1.
  exists y1 => //; exists (face (edge z)); last first.
    by rewrite (same_cface y1Fz) -cface1r bridge'G.
  rewrite /rlink cface1 (closed_connect (diskFC_face p) y1Fz) in zRy dFCy1.
  rewrite !inE (closed_connect (fbandF p) zRy) (fclosed1 (diskN_node p)).
  by rewrite pF'y edgeK; case/andP: dFCy1.
have sFpAy0: {subset fband p <= adj y0}.
  move=> x pFx; apply: contraLR (pentaG y0) => not_y0Ax.
  rewrite -size_spoke_ring -sz_p -ltnNge.
  have URy0 := scycle_spoke_ring cexG y0.
  rewrite -(scycle_fcard_fband URp) -(scycle_fcard_fband URy0).
  rewrite [rhs in _ < rhs](cardD1 (froot face x)) inE (roots_root cfaceC).
  rewrite /= -(closed_connect (fbandF p) (connect_root _ x)) pFx.
  apply/subset_leq_card/subsetP => y /andP/=[Dy].
  rewrite fband_spoke_ring => y0Ay.
  rewrite !inE Dy sAy0Fp // -(eqP Dy) (sameP eqP (rootP cfaceC)).
  by rewrite cfaceC (no_adj_adj not_y0Ax y0Ay).
have [z /andP/=[pF'z] | p_cc] := pickP [predD insertE cc & fband p].
  rewrite mem_insertE // => /hasP[z1 /rot_to[i cc1 Dcc1] z1Ez].
  case/eqP/idPn: sz_p; rewrite neq_ltn orbC ltnNge p_le5 -cc4 ltnS.
  rewrite -(size_rot i cc) Dcc1 /=; apply: contract_ring_max; split=> // t p1t.
  have{p1t} [p_t] := (mem_behead p1t, cc_p t p1t).
  rewrite !mem_insertE // -(has_rot i) Dcc1 /=; case/orP=> //.
  rewrite cedgeC -(same_cedge z1Ez) plain_orbit // !inE => /pred2P[] Dt.
    by case/hasP: pF'z; exists t => //; rewrite Dt.
  case/hasP: pF'z; exists (next p t); first by rewrite mem_next.
  by rewrite -[z]ee -Dt; case/andP: URp => cycRp _; apply: (next_cycle cycRp).
have [[x0Fy0 [_] | x0F'y0 []]] := (boolP (cface x0 y0), andP triad_x0).
  case/subsetP=> x cc_c; rewrite inE (adjF x0Fy0) [adj _ _]sFpAy0 //.
  by apply: contraFT (p_cc x); rewrite !inE => ->.
rewrite ltnNge (leq_trans _ (fcard_adj_max cexG x0F'y0)) //.
apply: (@leq_trans (count (mem (fband (insertE cc))) (spoke_ring x0))).
  rewrite /spoke_ring count_map; elim: (orbit face x0) => //= z q IHq.
  rewrite rev_cons -cats1 count_cat /= -(fclosed1 (fbandF _)) addn0.
  by rewrite addnC leq_add2r.
rewrite -size_filter -simple_fcard_fband; last first.
  have /andP[_] := scycle_spoke_ring cexG x0; rewrite !simple_recI.
  elim: (spoke_ring x0) => //= z q IHq /andP[qF'z /IHq].
  case: ifP => //= ccEFz; rewrite (contra _ qF'z) => // /hasP[t].
  by rewrite mem_filter => /andP[_ qt] tFz; apply/hasP; exists t.
apply/subset_leq_card/subsetP => z; rewrite !inE => /andP[-> /hasP[t]].
rewrite mem_filter /= => /andP[/hasP[u ccEu tFu] x0r_t] zFt; apply/andP; split.
  apply: contraFT (p_cc u) => /= /contra-> //.
  by rewrite (adjFr zFt) (adjFr tFu) => /sFpAy0.
by rewrite -fband_spoke_ring; apply/hasP; exists t.
Qed.

Theorem contract_coloring (r cc : seq G) :
  valid_contract r cc -> cc_colorable cc.
Proof.
case=> _ cc_sparse cc_1to4 cc_triad.
have{r cc_sparse cc_triad}: forall p, ~ contract_ring cc p.
  case/or4P: cc_1to4 => /eqP Ecc; try by apply: contract3_valid; rewrite ?Ecc.
  by have /exists_inP[x0 _]:= cc_triad Ecc; apply: triad_valid.
have{cc_1to4}: #|G| < (0  < size cc) + #|G| by case: (size cc) cc_1to4.
move: {2}(size cc) (leqnn (size cc)) => n.
move: {-2}#|G| minG (cexG : planar_bridgeless_plain_precubic G) => nG min_nG.
elim: n G cc => [|n IHn] G0 [|x cc] geoG0 //=.
- by move=> _ /min_nG[] // k; exists k.
- exact: (IHn G0 [::]).
rewrite /= add1n !ltnS => le_cc_n G0_lenG ring'cc.
have plainG0: plain G0 := geoG0; have ee0 := plain_eq geoG0.
have bridge'G0 := bridgeless_cface geoG0.
have D_E0 (y : G0): cedge x y = (y == x) || (y == edge x).
  by rewrite (plain_orbit geoG0) !inE.
pose G1 := WalkupF x; pose h1 (u : G1) : G0 := val u.
have Ih1: injective h1 by apply: val_inj.
have x'ex: edge x != x by rewrite (plain_neq geoG0).
pose uex : G1 := Sub (edge x) x'ex.
pose G2 := WalkupF uex; pose h2 (w : G2) : G1 := val w.
have Ih2: injective h2 by apply: val_inj.
pose h w := h1 (h2 w); have Ih: injective h := inj_comp Ih1 Ih2.
have Eh: codom h =i predC (cedge x).
  move=> y; rewrite inE D_E0; apply/imageP/norP => [[w _ ->] | [x'y ex'y]].
    by rewrite (valP w) (valP (val w)).
  by exists ((Sub (Sub y x'y : G1) : _ -> G2) ex'y).
have xE'h w: cedge x (h w) = false.
  by apply: negPf; rewrite -[~~ _]Eh codom_f.
have hN w w': cnode w w' = cnode (h w) (h w') by rewrite !fconnect_skip.
have hE w w': cedge w w' = cedge (h w) (h w') by rewrite !fconnect_skip.
have h_e w: h (edge w) = edge (h w).
  have ewP: edge (h w) \in codom h by rewrite Eh inE -cedge1r -[~~ _]Eh codom_f.
  rewrite -(f_iinv ewP); congr h; symmetry.
  by do 2 apply: (valE_skip nodeI); apply: (f_iinv ewP).
pose xR y := has (cface y) [:: x; edge x].
have hF w w': cface w w' = (if xR (h w) then xR (h w') else cface (h w) (h w')).
  transitivity (cface (h2 w) (h2 w')).
    rewrite [cface _ _](eq_fconnect (glink_fp_skip_edge _)) ?fconnect_skip //.
    by rewrite /glink /= orbCA -val_eqE /= ee0 !eqxx.
  case: ifP => xRw; last exact: (same_cskip_edge (negbT _)).
  by apply: cskip_edge_merge; first rewrite /cross_edge /= bridge'G0.
have ee2 w: edge (edge w) = w :> G2 by apply: Ih; rewrite !h_e ee0.
have plainG2: plain G2.
  by apply/plainP => w _; split; rewrite // -(inj_eq Ih) h_e plain_neq.
have geoG2: planar_bridgeless_plain_precubic G2.
  repeat split; auto; first exact (planar_WalkupF _ (planar_WalkupF _ geoG0)).
    apply/existsP=> [] [w wFew].
    have [y xEy cycRwy]: exists2 y, cedge x y & cycle rlink [:: h w; y].
      move: wFew; rewrite hF h_e /= bridge'G0.
      case: ifP => //; rewrite /xR /= !orbF => /orP[wFx | wFex].
        rewrite cfaceC -(same_cface wFx) bridge'G0 /= => ewFex.
        by exists (edge x); rewrite ?fconnect1 /rlink //= ewFex ee0 cfaceC wFx.
      rewrite orbC cfaceC -(same_cface wFex) bridge'G0 /= => ewFx.
      by exists x; rewrite /rlink //= ewFx cfaceC wFex.
    case: (ring'cc [:: h w; y]); split => [||z].
    - rewrite /scycle cycRwy simple_recI /=; have [ewRy _] := andP cycRwy.
      by rewrite unfold_in /= cfaceC -(same_cface ewRy) cfaceC bridge'G0.
    - by apply: contraTneq (codom_f h w) => Dy; rewrite Eh inE cedge1r Dy xEy.
    by rewrite !inE orbA => /eqP ->; rewrite -D_E0 xEy.
  apply/subsetP=> w _; apply: leq_trans (precubic_leq geoG0 (h w)).
  rewrite /order -(card_image Ih); apply/subset_leq_card/subsetP=> y.
  by case/imageP=> w1 wNw1 ->; rewrite inE -hN.
pose cc1 := filter (predC (cedge x)) cc; pose cc2 := preim_seq h cc1.
have Excc y: (y \in insertE (x :: cc)) = cedge x y || (y \in insertE cc1).
  rewrite /= !inE orbA -D_E0 !mem_insertE //; apply: orb_id2l=> xN'y.
  rewrite !(eq_has (plain_orbit geoG0 y)) !(has_sym [:: y; _]) /=.
  by rewrite !mem_filter !inE -cedge1r xN'y.
have hcc2: map h cc2 = cc1.
  by apply: map_preim => y; rewrite Eh mem_filter => /andP[].
have hEcc1 w1: (h w1 \in insertE cc1) = (w1 \in insertE cc2).
  by rewrite !mem_insertE // -hcc2 has_map; apply: eq_has => w; rewrite /= hE.
have le_cc2_cc: size cc2 <= size cc.
  by rewrite -(size_map h) hcc2 size_filter count_size.
have{IHn} [] := IHn G2 cc2 geoG2 (leq_trans le_cc2_cc le_cc_n).
- rewrite -card_S_Walkup card_Walkup (leq_trans (leq_pred _)) //.
  by rewrite (leq_trans G0_lenG) // leq_addl.
- move=> p [URp nt_p cc_p] //.
  have [cycRp UpF] := andP URp; have Up := simple_uniq UpF.
  have UhpF: simple (map h p).
    rewrite /simple -map_comp map_inj_in_uniq // => w1 w2 pw1 pw2.
    move/(rootP cfaceC)=> w1Fw2; apply: (simple_cface UpF) pw1 pw2 _.
    by rewrite hF /xR (eq_has (same_cface w1Fw2)); case: (has _ _).
  have cc_hp: {subset map h (behead p) <= insertE cc}.
    move=> _ /mapP[w1 pw1 ->].
    by have:= Excc (h w1); rewrite /= !inE orbA -D_E0 xE'h hEcc1 cc_p.
  suffices cycRhp: scycle rlink (map h p).
    have [] := ring'cc (map h p); split=> //.
      by case: (p) nt_p => [|w0 [|w1 [|w2 p2]]]; rewrite /= -?h_e.
    by rewrite behead_map => y /cc_hp cc_y; rewrite 2?mem_behead.
  apply: wlog_neg; rewrite UhpF andbT => cyc'Rhp.
  pose prevRh := [pred w | rlink (h (prev p w)) (h w)].
  have{cyc'Rhp} /hasP[w1 pw1 /= prevRh'w1]: has (predC prevRh) p.
    rewrite has_predC; apply: contra cyc'Rhp => /allP cycRhp.
    rewrite cycle_from_prev ?map_inj_uniq // => _ /mapP[w1 pw1 ->].
    by rewrite prev_map //; apply: cycRhp.
  have [i1 p1 Dp1] := rot_to pw1; pose w0 := last w1 p1.
  have p1'w1: w1 \notin p1 by move: Up; rewrite -(rot_uniq i1) Dp1 => /andP[].
  have /andP[w0Rw1 w1Rp1]: rlink w0 w1 && path rlink w1 p1.
    by have:= cycRp; rewrite -(rot_cycle i1) Dp1 (cycle_path w1).
  have{prevRh'w1} hw0R'w1: ~~ rlink (h w0) (h w1).
    move: prevRh'w1; rewrite -(prev_rot i1) // prev_nth Dp1 mem_head.
    by rewrite -{2}[p1]cats0 index_cat (negPf p1'w1) addn0 nth_last.
  have /andP[xRew0 xRw1]: xR (edge (h w0)) && xR (h w1).
    by move: w0Rw1; rewrite /rlink hF h_e [cface _ _](negPf hw0R'w1).
  have /hasP[x1 xEx1 w1Fx1] := xRw1 : has _ [:: x; _].
  have /hasP[x0 xEx0 ew0Fx0] := xRew0 : has _ [:: x; _].
  have ex0_x1: edge x0 = x1.
    have: cedge x0 x1.
      by rewrite -!plain_orbit // in xEx0 xEx1; rewrite -(same_cedge xEx0).
    rewrite plain_orbit // !inE => /pred2P[] // x01.
    by rewrite /rlink (same_cface ew0Fx0) -x01 cfaceC w1Fx1 in hw0R'w1.
  pose q1 := x0 :: (map h (w1 :: p1)).
  have p1R'x: ~~ has (preim h xR) p1.
    apply: contra p1'w1 => /hasP[w2 p1w2 /= xRw2].
    have w1Fw2: cface w1 w2 by rewrite hF xRw1.
    by rewrite (scycle_cface URp _ _ w1Fw2) // -(mem_rot i1) Dp1 mem_behead.
  have cycRq1: cycle rlink q1.
    rewrite (cycle_path x0) /= {1 2}/rlink last_map ew0Fx0 ex0_x1 cfaceC w1Fx1.
    elim: (p1) (w1) p1R'x w1Rp1 => //= w3 p2 IHp w2 /norP[xR'w3 xR'p2] /andP[].
    by rewrite {1 3}/rlink cfaceC hF (negPf xR'w3) cfaceC h_e => -> /IHp->.
  case Dp: p => // [w p0] in nt_p.
  have /rot_to[i2 q2 Dq2]: h w \in q1.
    by rewrite /q1 -Dp1 inE mem_map // mem_rot Dp mem_head orbT.
  have URq2: scycle rlink (h w :: q2).
    rewrite -Dq2 /scycle rot_cycle cycRq1 /= simple_rot /q1 simple_cons.
    apply/andP; split; last by rewrite -Dp1 /= map_rot simple_rot.
    rewrite unfold_in; apply: contra p1R'x => /hasP[x3].
    rewrite /= inE -has_map => /predU1P[-> /idPn[] | p1x3 x0Fx3].
      by rewrite cfaceC (same_cface w1Fx1) -ex0_x1 cfaceC bridge'G0.
    by apply/hasP; exists x3 => //=; apply/hasP; exists x0; rewrite // cfaceC.
  case: (ring'cc (h w :: q2)); split=> //.
    move: nt_p; rewrite -Dp -Dq2 proper_ring_rot // -(proper_ring_rot i1) //.
    by rewrite Dp1 /q1 /=; case: (p1).
  move=> y q2y; rewrite /= !inE orbA -mem_seq2.
  move: (mem_behead q2y); rewrite -Dq2 mem_rot /q1 -Dp1 /= inE map_rot mem_rot.
  move/predU1P=> [->|]; first by rewrite xEx0.
  rewrite Dp /= inE (negPf (memPn _ y q2y)) => [/mapP[u p0u ->]|].
    by rewrite orbC cc_hp // map_f // Dp.
  by case/andP: URq2 => _ /simple_uniq/andP[].
move=> k [kE /fconnect_invariant kF].
pose a y := [pred w | cface y (h w)].
have nt_ah w: ~ a (h w) =1 pred0 by move/(_ w); rewrite /= connect0.
have ae0 y: a y =1 pred0 -> a (edge y) =1 pred0.
  move=> ay0 w; have [hy | h'y] := boolP (y \in codom h).
    by case/idP: (ay0 (iinv hy)); rewrite /= f_iinv connect0.
  have [hfy | h'fy] := boolP (face y \in codom h).
    by case/idP: (ay0 (iinv hfy)); rewrite /= f_iinv fconnect1.
  move: h'y h'fy; rewrite !Eh !negbK => /same_cedge xEy.
  rewrite xEy plain_orbit // mem_seq2 orbC => /pred2P[fy_ey | fy_y].
    by have:= bridge'G0 y; rewrite -fy_ey fconnect1.
  move: (precubic_leq geoG0 y) (f_finv nodeI y); rewrite /finv.
  rewrite -[_ <= 3](mem_iota 0 4) !inE -{1}orderSpred /=.
  case/or3P=> /eqP-> /= => [ny_y | nny_y | n3y_y]; last 1 first.
  - have:= bridge'G0 (face (edge y)); rewrite -{2}(canRL nodeK n3y_y).
    by rewrite 2!cface1r nodeK -{2}fy_y -{2}[y]ee0 edgeK connect0.
  - by have:= bridge'G0 y; rewrite -{1}[y]nodeK ny_y -cface1 connect0.
  have cycFy1: fcycle face [:: edge y].
    by rewrite /= -(canRL nodeK nny_y) (canF_eq nodeK) ee0 fy_y eqxx.
  rewrite (fconnect_cycle cycFy1) ?inE ?eqxx //.
  by move: (xE'h w); rewrite xEy plain_orbit // mem_seq2 => /norP[_ /negPf].
pose k0 y := oapp k Color0 (pick (a y)).
have k0h w: k0 (h w) = k w.
  rewrite /k0; case: pickP => [w1 /= wFw1 | /nt_ah//]; apply: kF.
  by rewrite hF cfaceC wFw1 /xR (eq_has (same_cface wFw1)); case: (has _ _).
have k0ex: k0 x = k0 (edge x).
  rewrite /k0; case: pickP => [w /= wFx | /ae0 aex0]; last first.
    by case: pickP => // w1; rewrite aex0.
  case: pickP => /= [w1 w1Fex | /ae0/(_ w)]; last by rewrite ee0 /= wFx.
  by apply: kF; rewrite hF /xR /= cfaceC wFx /= orbCA cfaceC w1Fex.
exists k0; split=> y; last first.
  by apply/eqP; rewrite /k0 -(@eq_pick _ (a y)) // => w /=; rewrite cface1.
rewrite Excc !inE /invariant in kE *.
have [] := boolP (cedge x y).
  by rewrite plain_orbit // mem_seq2 => /pred2P[]->; rewrite ?ee0 -k0ex eqxx.
by rewrite -[~~ _]Eh => hy; rewrite -(f_iinv hy) -h_e !k0h [_ == _]kE hEcc1.
Qed.

End ContractLemmas.