Module minimal_Gallina_introduction.

Variable x : Prop.
Variables A B : Prop.
Variable t2 : Prop.

Check A -> B : Prop.
(* NB: we will see later why this holds *)
Check A -> B : Set.                         (* 補足説明：Set でもある。 *)

Check (fun y => y -> y) : Prop -> Prop.
Definition t1_oops := fun y => y -> y.
Check t1_oops.
Definition t1 := fun y : Prop => y -> y.
Check t1.
Check t1 A : Prop.

Fail Check (fun y : Prop => y -> y) -> B.
(* NB: we will see later why this does not hold *)

End minimal_Gallina_introduction.

Require Import ssreflect.

Module propositions_as_types_example.

Lemma hilbertS (A B C : Prop) :
  (A -> B -> C) -> (A -> B) -> A -> C.
Show Proof.
move=> H1.
Show Proof. (* observe the effect of move=> on the proof-term *)
move=> H2.
move=> H3.
cut B. (* NB: this is a traditional Coq tactic, seldom used in practice *)
cut A.
assumption.
assumption.
cut A.
assumption.
assumption.
Show Proof.
Qed.

Definition hilbertS_proof :=
  fun (A B C : Prop) (H1 : A -> B -> C) (H2 : A -> B) (H3 : A) =>
    (fun H : B => (fun H0 : A => H1 H0) H3 H) ((fun H : A => H2 H) H3).

Lemma hilbertS_direct_proof (A B C : Prop) :
  (A -> B -> C) -> (A -> B) -> A -> C.
exact (hilbertS_proof A B C).
Qed.

Lemma hilbertS_in_practice (A B C : Prop) :
  (A -> B -> C) -> (A -> B) -> A -> C.
move=> H1.
move=> H2.
move=> H3.
apply H1.
exact H3.
apply H2.
exact H3.
Show Proof.
Qed.

Definition hilbertS_in_practice_proof :=
  fun (A B C : Prop) (H1 : A -> B -> C) (H2 : A -> B) (H3 : A) =>
    H1 H3 (H2 H3).

Goal hilbertS_proof = hilbertS_in_practice_proof.
reflexivity.
Qed.

End propositions_as_types_example.

Module move_and_apply_tactics.

Lemma modus_ponens : forall P Q : Prop, (P -> Q) -> P -> Q.
Show Proof.
move=> P.
Show Proof.
move: P.
Show Proof.
move=> P Q PQ p.
apply: PQ.
done.
Qed.

Goal forall P Q : Prop, (forall R : Prop, R -> Q) -> P -> Q.
Proof.
move=> P Q rq p.
Fail apply rq.
apply: rq p.
(*
compare with:
refine (rq _ _).
exact p.
*)
Qed.

Lemma exo0 : forall P : Prop, P -> P.
Proof.
Abort.

Lemma exo1 : forall P Q : Prop, P -> (P -> Q) -> Q.
Proof.
Abort.

Lemma exo2 : forall P : Prop, (P -> P) -> P -> P.
Proof.
Abort.

(* transitivity of implication *)
Lemma exo3 P Q R : (P -> Q) -> (Q -> R) -> P -> R.
Proof.
Abort.

End move_and_apply_tactics.

Section logical_connectives.

Print True.
Check True.
Check I.

Goal True.
apply: I.
Qed.

Print False.

Goal True -> False.
case.
Abort.                                      (* OK *)

Check False_ind.

Goal False -> 1 = 0.
case.
Qed.

Print and.
Print and_ind.
Print and_rect.

Goal forall P Q, P /\ Q -> Q /\ P.
move=> P Q.
case.
move=> p q.
split.
exact q.
exact p.
Qed.

Print or.
Print or_ind.

Check (or_intror False I).
About or_intror.
Check (@or_intror False True I).
Check (@or_intror False _ I).
Check (@or_intror _ _ I).
Check (@or_intror _ _ I) :  False \/ True.

Goal forall A B, A \/ B -> B \/ A.
move=> A B.
  case=> [a | b].
  right.
  exact a.
left.
exact b.
Qed.

End logical_connectives.

Lemma exo4 : False \/ True.
Proof.
Abort.

Lemma exo5 : forall A B C : Prop, A /\ B <-> B /\ A.
Proof.
Abort.

Lemma exo6 (A B C : Prop) : A /\ B /\ C ->
  (A /\ B) /\ C.
Proof.
Abort.

Section Set_Prop.

Check nat.

Goal 0 = 1 -> False.
move=> abs.
discriminate.
Qed.

Goal (exists n : nat, True) -> nat.
Fail case.
(*  Error: Case analysis on sort Set is not allowed for inductive definition ex *)
Abort.

Goal {n : nat | True} -> nat.
case.
move=> m _.
exact m.
Undo 1.
by apply: m.                                (* 補足 *)
Qed.

Goal forall n m : nat, n = m /\ n <> m -> nat.
move=> n m.
case => nm nm'.
exact O.
Undo 1.
by apply: O.                                (* 補足 *)
Qed.

(* 追加 *)
Goal nat.
apply: 10.
Qed.

End Set_Prop.

Section product_formation.

(* Prop, Set, Type 自体は、Type の型を持つ。 *)
Fail Check Prop : Prop.
Fail Check Set : Prop.
Fail Check Type : Prop.

Fail Check Prop : Set.
Fail Check Set : Set.
Fail Check Type : Set.

Check Prop : Type.
Check Set : Type.
Check Type : Type.
Set Printing Universes.
Check Prop : Type.                          (* Top.43 *)
Check Set : Type.                           (* Top.44 *)
Check Type : Type.                          (* Top.45 *)
Unset Printing Universes.

(* rule Prop-Prop *)
Fail Check Prop -> Prop : Prop.
Fail Check Prop -> Prop : Set.
Check Prop -> Prop : Type.
(* rule Set-Prop *)
Fail Check Set -> Prop : Prop.
Fail Check Set -> Prop : Set.
Check Set -> Prop : Type.
(* rule Type-Prop *)
Fail Check Type -> Prop : Prop.
Fail Check Type -> Prop : Set.
Check Type -> Prop : Type.

(* rule Prop-Set *)
Fail Check Prop -> Set : Prop.
Fail Check Prop -> Set : Set.
Check Prop -> Set : Type.
(* rule Set-Set *)
Fail Check Set -> Set : Prop.
Fail Check Set -> Set : Set.
Check Set -> Set : Type.
(* rule Type-Set *)
Fail Check Type -> Set : Prop.
Fail Check Type -> Set : Set.
Check Type -> Set : Type.

(* rule Prop-Type *)
Fail Check Prop -> Type : Prop.
Fail Check Prop -> Type : Set.
Check Prop -> Type : Type.
(* rule Set-Type *)
Fail Check Set -> Type : Prop.
Fail Check Set -> Type : Set.
Check Set -> Type : Type.
(* rule Type-Type *)
Fail Check Type -> Type : Prop.
Fail Check Type -> Type : Set.
Check Type -> Type : Type.

(* Prop, Set, Type の要素の関係 *)
(* Prop <= Set <= Type *)
Variable P0 : Prop.
Variable S0 : Set.
Variable T0 : Type.

Check P0 : Prop.
Check P0 : Set.
Check P0 : Type.

Fail Check S0 : Prop.
Check S0 : Set.
Check S0 : Type.

Fail Check T0 : Prop.
Fail Check T0 : Set.
Check T0 : Type.

Variables P1 : Prop.
(* rule Prop-Prop *)
Check P0 -> P1 : Prop.
Check P0 -> P1 : Set.
Check P0 -> P1 : Type.
(* rule Set-Prop *)
Check S0 -> P1 : Prop.
Check S0 -> P1 : Set.
Check S0 -> P1 : Type.
(* rule Type-Prop *)
Check T0 -> P1 : Prop.
Check T0 -> P1 : Set.
Check T0 -> P1 : Type.

Variables S1 : Set.
(* rule Prop-Set *)
Fail Check P0 -> S1 : Prop.
Check P0 -> S1 : Set.
Check P0 -> S1 : Type.
(* rule Set-Set *)
Fail Check S0 -> S1 : Prop.
Check S0 -> S1 : Set.
Check S0 -> S1 : Type.
(* rule Type-Set *)
Fail Check T0 -> S1 : Prop.
Fail Check T0 -> S1 : Set.
Check T0 -> S1 : Type.

Variables T1 : Type.
(* rule Prop-Type *)
Fail Check P0 -> T1 : Prop.
Fail Check P0 -> T1 : Set.
Check P0 -> T1 : Type.
(* rule Set-Type *)
Fail Check S0 -> T1 : Prop.
Fail Check S0 -> T1 : Set.
Check S0 -> T1 : Type.
(* rule Type-Type *)
Fail Check T0 -> T1 : Prop.
Fail Check T0 -> T1 : Set.
Check T0 -> T1 : Type.

(* nat は、S0 と同じ。 *)
Fail Check (nat -> nat) : Prop.
Check (nat -> nat) : Set.
Check (nat -> nat) : Type.

(* forall A : Prop なるAは、P0 の場合と同じ。 *)
(* forall A : Set なるAは、S0 の場合と同じ。 *)
(* forall A : Type なるAは、T0 の場合と同じ。 *)
Check (forall A : Prop, A -> A) : Prop.
Check (forall A : Prop, A -> A) : Set.
Check (forall A : Prop, A -> A) : Type.
Fail Check (forall A : Set, A -> A) : Prop.
Fail Check (forall A : Set, A -> A) : Set.
Check (forall A : Set, A -> A) : Type.
Fail Check (forall A : Type, A -> A) : Prop.
Fail Check (forall A : Type, A -> A) : Set.
Check (forall A : Type, A -> A) : Type.

(* ふつうにPropであるもの。 *)
Check (forall x : nat, 0 <= x) : Prop.
Check (forall x : nat, x = x)  : Prop.
Check (forall A : Prop, A -> A) : Prop.
Check (forall P : nat -> Prop, P O -> exists n : nat , P n) : Prop.

(* これより複雑なものは、Typeの型を持つ。 *)
Check (nat -> Prop) : Type.
Check ((Prop -> Prop) -> Prop) : Type.
Check (forall P : nat -> Prop, Prop) : Type.

End product_formation.


(*
B3. Pebbling with Flow Networks
===============================
*)

From graph_pebbling Require Import A_primitives B1_graph_pebbling.

Section Pebble_Flow.

Context `{graph_G : Basic_Graph G, pebb_G : Pebbling_Graph G}.

Notation V := (V G).
Notation E := (E G).
Notation weight := (weight G).
Notation ω := (uncurry weight).
Notation conf := (conf G).
Notation flow := (V * V -> nat).
Notation vertices := (enum V).

Definition flux (d : V -> V * V) (f : flow) := summation (f ∘ d <$> vertices).
Definition x_in : V -> V -> V * V := (λ v, (., v)).
Definition x_out : V -> V -> V * V := (λ v, (v ,.)).

Global Arguments x_in _ _ /.
Global Arguments x_out _ _ /.

Notation inflow v := (flux (x_in v)).
Notation outflow v := (flux (x_out v)).
Notation total_inflow f := (summation ((λ v, inflow v f) <$> vertices)).
Notation total_outflow f := (summation ((λ v, outflow v f) <$> vertices)).

Definition excess (v : V) (c : conf) (f : flow) :=
  c v + inflow v f - outflow v (ω .* f).

Record feasible (c : conf) (f : flow) : Prop := {
  feasible_support : ∀ u v, f (u, v) > 0 -> E u v;
  feasible_excess : ∀ v, outflow v (ω .* f) ≤ c v + inflow v f;
}.

Inductive flow_step : conf * flow -> conf * flow -> Prop :=
  flow_one_pebble (c c' : conf) (f f' : flow) (u v : V)
  (H_edge : E u v)
  (H_conf : weight u v ≤ c u)
  (H_flow : 1 ≤ f (u, v))
  (R_conf : c' = alter S v (alter (subtract (weight u v)) u c))
  (R_flow : f' = alter (subtract 1) (u, v) f) :
  flow_step (c, f) (c', f').

Global Instance : Step (conf * flow) := flow_step.

Definition realized c f :=
  ∀ v, excess v c f ≤ c v.

Definition realizable (c : conf) (f : flow) :=
  ∃ c' f', (c, f) -->* (c', f') ∧ realized c' f'.

Definition unidirectional (f : flow) :=
  ∀ u v, f (u, v) = 0 ∨ f (v, u) = 0.

Section Equivalence.

Section Helper_lemmas.

Global Instance inj_x_in v : Inj eq eq (x_in v).
Proof. intros ? ?; cbn; congruence. Qed.

Global Instance inj_x_out v : Inj eq eq (x_out v).
Proof. intros ? ?; cbn; congruence. Qed.

Lemma flux_bound d v f :
  flux d f ≥ f (d v).
Proof.
apply elem_of_summation, elem_of_list_fmap.
eexists; split; [done|apply elem_of_enum].
Qed.

Lemma weight_cases f u v :
  (∀ u v, f (u, v) > 0 -> E u v) ->
  f (u, v) = 0 ∨ weight u v > 1.
Proof.
intros H; dec (f (u, v) = 0); [left; done|].
assert (Hf : f (u, v) > 0) by lia.
eapply H, pebbling_weight_gt1 in Hf; right; done.
Qed.

Lemma outflow_bound v f :
  (∀ u v, f (u, v) > 0 -> E u v) ->
  outflow v (ω .* f) ≥ outflow v f.
Proof.
intros H; apply summation_le; intros u _; cbn.
apply (weight_cases f v u) in H; nia.
Qed.

Lemma flow_mul_alter `{distr : LeftDistr _ _ (=) Nat.mul g}
  (f1 f2 : flow) e n :
  f1 .* alter (g n) e f2 = alter (g (f1 e * n)) e (f1 .* f2).
Proof.
extensionality e'; cbn; dec (e = e');
simpl_alter; cbn; done.
Qed.

Lemma flux_sub d f1 f2 :
  f2 .≤ f1 -> flux d (f1 .- f2) = flux d f1 - flux d f2.
Proof.
intros H; unfold flux; rewrite right_distr_compose_lift2.
apply summation_sub; intros v _; apply H.
Qed.

Section Alter.

Context `{l_domi : LeftDominant _ P (+)}.
Context `{l_comm : CondLeftComm _ (=) P g (+)}.

Variable f : flow.
Variable d : V -> V * V.
Hypothesis inj_d : Inj (=) (=) d.

Lemma flux_alter v e :
  d v = e -> P (f e) -> flux d (alter g e f) = g (flux d f).
Proof.
unfold flux; rewrite ?list_fmap_compose.
intros <- H; apply foldr_alter. done.
- apply elem_of_list_fmap_1, elem_of_enum.
- apply NoDup_fmap; [done|apply NoDup_enum].
Qed.

Lemma flux_alter_ne e :
  (∀ v, d v ≠ e) -> flux d (alter g e f) = flux d f.
Proof.
unfold flux; rewrite ?list_fmap_compose.
intros; f_equal; apply fmap_no_alter; intros H_in.
apply elem_of_list_fmap in H_in as (v & Hv & _); eapply H; done.
Qed.

End Alter.

End Helper_lemmas.

Ltac done_or_nia := try (done || nia).

Ltac rw_flux_ne := rewrite flux_alter_ne;
  [|unfold x_in, x_out; congruence].

Ltac rw_inflow w u := rewrite flux_alter with (d:=x_in w)(v:=u); cbn;
  [|apply inj_x_in|done_or_nia|done_or_nia].

Ltac rw_outflow w u := rewrite flux_alter with (d:=x_out w)(v:=u); cbn;
  [|apply inj_x_out|done_or_nia|done_or_nia].

Ltac rw_conf := repeat (rewrite fn_lookup_alter in * ||
  (rewrite fn_lookup_alter_ne in *; [|done_or_nia])).

Ltac flow_cases u v w :=
  replace S with ((+) 1) by done; rewrite ?flow_mul_alter;
  dec (w = u); [dec (v = u)|dec (w = v)]; rw_conf;
    [rw_inflow u u; rw_outflow u u
    |rw_outflow u v; rw_flux_ne
    |rw_inflow v u; rw_flux_ne
    |repeat rw_flux_ne]; cbn in *; lia || nia.

Ltac flux_le v abbr H_supp :=
  unfold abbr, outflow, inflow; rewrite ?right_distr_compose_lift2;
  apply summation_le; intros u _; cbn;
  lia || nia || apply (weight_cases _ v u) in H_supp; nia.

Lemma flow_step_pebble_step c c' f f' :
  (c, f) --> (c', f') -> c --> c'.
Proof. inversion_clear 1; eapply one_pebble_step; done. Qed.

Lemma flow_step_feasible c c' f f' :
  (c, f) --> (c', f') -> feasible c f -> feasible c' f'.
Proof.
inversion_clear 1; intros [H1f H2f]; split.
- intros x y; dec ((x, y) = (u, v)); [done|]; simpl_alter; apply H1f.
- intros w; assert (Hw := H2f w); subst; flow_cases u v w.
Qed.

Lemma flow_step_excess c c' f f' w :
  (c, f) --> (c', f') -> excess w c f = excess w c' f'.
Proof.
inversion 1; subst; unfold excess;
assert (H_out := flux_bound (x_out u) v (ω .* f));
assert (H_in := flux_bound (x_in v) u f); cbn in H_in, H_out, H_conf;
flow_cases u v w.
Qed.

Lemma flow_balance f :
  total_inflow f = total_outflow f.
Proof.
unfold flux, compose, x_in, x_out; rewrite ?summation_lprod.
erewrite list_fmap_ext with (g:=f ∘ swap); [|intros i [] _; done].
erewrite list_fmap_ext with (g:=f)(f:=uncurry _); [|intros i [] _; done].
apply summation_Permutation, submseteq_Permutation_length_eq.
- rewrite ?fmap_length, ?prod_length; done.
- rewrite list_fmap_compose; apply submseteq_fmap, NoDup_submseteq.
  + apply NoDup_fmap. apply inj_swap. apply NoDup_lprod; apply NoDup_enum.
  + intros; apply elem_of_list_fmap in H as ([u v] & -> & _); cbn.
    apply elem_of_lprod; apply elem_of_enum.
Qed.

Lemma minimum_weight_outflow u f :
  outflow u f > 0 -> ∃ v, f (u, v) > 0 ∧
  weight u v * outflow u f ≤ outflow u (ω .* f).
Proof.
unfold outflow; generalize vertices as vs;
induction vs as [|v vs]; cbn; intros; [lia|].
dec (summation (f ∘ x_out u <$> vs) = 0).
exists v; lia. destruct IHvs as (w & H1 & H2); [lia|].
dec (0 < f (u, v) ∧ weight u v < weight u w);
[exists v|exists w]; cbn in *; nia.
Qed.

Theorem pebble_flow_realizable c f :
  feasible c f -> realizable c f.
Proof.
revert c f; apply (induction_ltof1 _ size (λ c, ∀ f, _ -> _)); unfold ltof.
intros c IH f [H1f H2f].
(* 1. Find a vertex r where the excess is not realized: inflow r > outflow r *)
destruct (decide (realized c f)) as [Hr|Hr]. exists c, f; split; done.
apply not_forall_exists in Hr as [r Hx]; unfold excess in Hx.
assert (Ho := outflow_bound r f H1f);
assert (Hr : inflow r f > outflow r f) by lia; clear Hx.
(* 2. Find complementary vertex s using flow balance: inflow s < outflow s *)
destruct (decide (∀ s, outflow s f ≤ inflow s f)) as [Hs|Hs]; [exfalso|].
{ assert (H3f := flow_balance f).
  assert (H4f : total_outflow f < total_inflow f).
  apply summation_lt with (x:=r); try done; apply elem_of_enum. lia. }
(* 3. Determine a minimum weight outflow edge of s. *)
apply not_forall_exists in Hs as [s Hs]; assert (H1s := H2f s);
assert (H2s : outflow s f > inflow s f) by lia; clear Hs;
assert (Hc : size c ≥ c s) by apply size_lwb.
destruct (minimum_weight_outflow s f) as (t & H1t & H2t); [lia|].
(* 4. Add one flow step and solve using induction hypothesis. *)
pose (c1 := alter S t (alter (subtract (weight s t)) s c));
pose (f1 := alter (subtract 1) (s, t) f);
assert (H_step : (c, f) --> (c1, f1)).
- apply flow_one_pebble with (u:=s)(v:=t).
  apply H1f; done. nia. lia. done. done.
- destruct IH with (y:=c1)(f:=f1) as (c' & f' & H1 & H2).
  + eapply pebble_step_size, flow_step_pebble_step, H_step.
  + eapply flow_step_feasible; done.
  + exists c', f'; split; [|done]. eapply rtc_l; done.
Qed.

Theorem pebble_flow_sound t c f :
  feasible c f -> solvable G t (excess t c f) c.
Proof.
intros; destruct (pebble_flow_realizable c f) as (c' & f' & H1 & H2); [done|].
exists c'; split.
- replace c with (c, f).1 by done;
  replace c' with (c', f').1 by done.
  apply @rtc_congruence with (R:=step); [|done].
  intros [] []; apply flow_step_pebble_step.
- replace (excess t c f) with (excess t c' f'); [apply H2|].
  eapply rtc_congruence with (f:=λ p, excess t p.1 p.2), unwrap_rtc in H1.
  done. intros [] []; apply flow_step_excess.
Qed.

Theorem pebble_flow_complete t n c :
  solvable G t n c -> ∃ f, feasible c f ∧ n ≤ excess t c f.
Proof.
intros (c' & Hc & Hn); induction Hc as [c|c1 c2 c'].
- (* Base: zero flow. *)
  exists (const 0); repeat split; cbn; intros. lia. all: unfold excess, flux;
  rewrite list_fmap_ext with (f:=(_.*_)∘_)(g:=const 0); cbn;
  rewrite ?summation_fmap_const; lia.
- (* Step: add one flow unit. *)
  apply IHHc in Hn as (f2 & [H1f2 H2f2] & Hn); clear IHHc; inversion_clear H.
  exists (alter S (u, v) f2); repeat split.
  + intros x y; dec ((x, y) = (u, v)); [done|]; simpl_alter; apply H1f2.
  + intros w; assert (Hw := H2f2 w); subst; flow_cases u v w.
  + unfold excess in *; subst; flow_cases u v t.
Qed.

Theorem pebble_flow_unidirectional c f :
  feasible c f -> ∃ f', feasible c f' ∧ unidirectional f' ∧
  ∀ v, excess v c f ≤ excess v c f'.
Proof.
intros [H_supp H_excess]; exists (f .- lift_min f (f ∘ swap));
repeat split; intros.
- apply H_supp; cbn in *; lia.
- rewrite left_distr, ?flux_sub; repeat intro; cbn; [|lia|nia].
  assert (Hv := H_excess v); pose (g := lift_min f (f ∘ swap));
  assert (outflow v (ω .* g) ≥ inflow v g) by flux_le v g H_supp.
  unfold g in *; lia.
- intros u v; clia.
- unfold excess; rewrite left_distr, ?flux_sub; repeat intro; cbn; [|nia|lia].
  pose (g := lift_min f (f ∘ swap));
  assert (inflow v f ≥ inflow v g) by flux_le v g H_supp.
  assert (outflow v (ω .* f) ≥ outflow v (ω .* g)) by flux_le v g H_supp.
  assert (outflow v (ω .* g) ≥ inflow v g) by flux_le v g H_supp.
  unfold g in *; lia.
Qed.

Corollary pebble_flow_spec t n c :
  (∃ c', c -->* c' ∧ n ≤ c' t) ↔
  (∃ f, feasible c f ∧ unidirectional f ∧ n ≤ excess t c f).
Proof.
split.
- intros H; apply pebble_flow_complete in H as (f & Hf & Ht).
  apply pebble_flow_unidirectional in Hf as (f' & H1 & H2 & H3).
  exists f'; split; [done|split]; [done|etrans]; done.
- intros (f & Hf & _ & Ht); apply (pebble_flow_sound t c) in Hf.
  destruct Hf as (c' & H1 & H2); exists c'; split; [done|etrans]; done.
Qed.

End Equivalence.

End Pebble_Flow.

Notation flow G := (V G * V G -> nat).
Notation inflow v := (flux (x_in v)).
Notation outflow v := (flux (x_out v)).

Global Arguments excess _ {_}.
Global Arguments feasible _ {_}.
Global Arguments realized _ {_}.
Global Arguments realizable _ {_}.
Global Arguments unidirectional {_}.


From Coq Require Import Eqdep_dec List.
Require Map.

(** MapSig implements a Map interface for [sig] types (that is, dependent pairs [{x: A| P x}]). *)

Section MapSig.

Context {Key: Type}
        {KeyEqDec: forall x y: Key, {x = y} + {x <> y}}
        {KeyIsGood: Key -> bool}
        {Value: Type}
        {M: Type}
        (MInst: Map.class KeyEqDec Value M).

Definition t := { m: M | forall key: Key, match Map.lookup m key with
                                          | Some _ => KeyIsGood key = true
                                          | None => True
                                          end }.

Definition key_sig := { key: Key | KeyIsGood key = true }.

Lemma key_sig_eq {a b: key_sig}
                 (H: proj1_sig a = proj1_sig b):
  a = b.
Proof.
destruct a as (x, p).
destruct b as (y, q).
cbn in H. subst y.
f_equal.
apply eq_proofs_unicity.
decide equality.
Qed.

Lemma key_sig_eq_dec_helper {a b: key_sig} (NE: proj1_sig a <> proj1_sig b):
  a <> b.
Proof.
intro H. subst b. contradiction.
Qed.

Definition key_sig_eq_dec (a b: key_sig)
: {a = b} + {a <> b}
:= match KeyEqDec (proj1_sig a) (proj1_sig b) as k return _ = k -> _ with
   | left e =>fun E => left (key_sig_eq e)
   | right n => fun E => right (key_sig_eq_dec_helper n)
   end eq_refl.

Definition lookup (m: t) (k: key_sig)
: option Value
:= Map.lookup (proj1_sig m) (proj1_sig k).

Definition is_empty (m: t)
: bool
:= Map.is_empty (proj1_sig m).

Lemma is_empty_ok (m: t):
    is_empty m = true
     <->
    forall key: key_sig,
      lookup m key = None.
Proof.
unfold is_empty. unfold lookup.
rewrite Map.is_empty_ok.
assert (MOk := proj2_sig m). cbn in MOk.
split. { intros H key. apply H. }
intros H key.
assert (MOkKey := MOk key).
remember (Map.lookup (proj1_sig m) key) as v.
destruct v. 2:trivial.
assert (A := (H (exist _ key MOkKey))). cbn in A.
rewrite Heqv. rewrite A. trivial.
Qed.

Local Lemma empty_spec (key: Key):
   match Map.lookup Map.empty key with
   | Some _ => KeyIsGood key = true
   | None => True
   end.
Proof.
now rewrite Map.empty_lookup.
Qed.

Definition empty
: t
:= exist _ Map.empty empty_spec.

Lemma empty_ok: is_empty empty = true.
Proof.
unfold is_empty. cbn. now rewrite Map.empty_ok.
Qed.

Local Lemma insert_spec (m: t) (key: key_sig) (value: Value) (query: Key):
    match Map.lookup (Map.insert (proj1_sig m) (proj1_sig key) value) query with
    | Some _ => KeyIsGood query = true
    | None => True
    end.
Proof.
rewrite Map.insert_ok.
destruct (KeyEqDec (proj1_sig key) query).
{ subst query. apply (proj2_sig key). }
exact (proj2_sig m query).
Qed.

Definition insert (m: t) (key: key_sig) (value: Value)
: t
:= exist _ (Map.insert (proj1_sig m) (proj1_sig key) value) (insert_spec m key value).

Lemma insert_ok (m: t) (key: key_sig) (value: Value) (x: key_sig):
  lookup (insert m key value) x
   =
  if key_sig_eq_dec key x
    then Some value
    else lookup m x.
Proof.
unfold lookup. unfold insert. cbn. rewrite Map.insert_ok.
unfold key_sig_eq_dec.
remember (KeyEqDec (proj1_sig key) (proj1_sig x)) as e.
now destruct e.
Qed.

Local Lemma remove_spec (m: t) (key: key_sig) (query: Key):
    match Map.lookup (Map.remove (proj1_sig m) (proj1_sig key)) query with
    | Some _ => KeyIsGood query = true
    | None => True
    end.
Proof.
rewrite Map.remove_ok.
destruct (KeyEqDec (proj1_sig key) query). { trivial. }
exact (proj2_sig m query).
Qed.

Definition remove (m: t) (key: key_sig)
: t
:= exist _ (Map.remove (proj1_sig m) (proj1_sig key)) (remove_spec m key).

Lemma remove_ok (m: t) (key: key_sig) (x: key_sig):
  lookup (remove m key) x
   =
  if key_sig_eq_dec key x
    then None
    else lookup m x.
Proof.
unfold lookup. unfold remove. cbn. rewrite Map.remove_ok.
unfold key_sig_eq_dec.
remember (KeyEqDec (proj1_sig key) (proj1_sig x)) as e.
now destruct e.
Qed.

Local Lemma mark_helper_head {l : list (Key * Value)}
                             {h: Key * Value}
                             {t: list (Key * Value)}
                             (Ok : Forall (fun kv : Key * Value => KeyIsGood (fst kv) = true) l)
                             (E: l = h :: t):
  KeyIsGood (fst h) = true.
Proof.
subst l. inversion Ok. assumption.
Qed.

Local Lemma mark_helper_tail {l : list (Key * Value)}
                             {h: Key * Value}
                             {t: list (Key * Value)}
                             (Ok : Forall (fun kv : Key * Value => KeyIsGood (fst kv) = true) l)
                             (E: l = h :: t):
  Forall (fun kv : Key * Value => KeyIsGood (fst kv) = true) t.
Proof.
subst l. inversion Ok. assumption.
Qed.

Fixpoint mark (l: list (Key * Value))
              (Ok: Forall (fun kv: Key * Value => KeyIsGood (fst kv) = true) l)
: list (key_sig * Value)
:= match l as l' return l = l' -> _ with
   | nil => fun _ => nil
   | cons h t => fun E => cons (exist _ (fst h) (mark_helper_head Ok E), snd h)
                               (mark t (mark_helper_tail Ok E))
   end eq_refl.

Lemma mark_map_proj1_sig (l: list (Key * Value))
                         (Ok: Forall (fun kv: Key * Value => KeyIsGood (fst kv) = true) l):
  map (@proj1_sig _ _) (map fst (mark l Ok)) = map fst l.
Proof.
induction l. { easy. }
cbn. f_equal. apply IHl.
Qed.

Local Lemma items_helper (m: t):
  Forall (fun kv : Key * Value => KeyIsGood (fst kv) = true)
         (Map.items (proj1_sig m)).
Proof.
assert (MOk := proj2_sig m).
assert (Ok: forall key: Key,
              match Map.alist_lookup KeyEqDec (Map.items (proj1_sig m)) key with
              | Some value => Map.lookup (proj1_sig m) key = Some value
              | None => True
              end).
{
  intro key.
  rewrite<- Map.items_ok.
  now destruct Map.lookup.
}
assert (ND := Map.items_nodup (proj1_sig m)).
induction (Map.items (proj1_sig m)); constructor.
{ (* goal: KeyIsGood (fst a) = true *)
  assert (MOkA := MOk (fst a)).
  assert (OkA := Ok (fst a)).
  destruct a as (key, value). cbn in *.
  destruct (KeyEqDec key key). 2:contradiction.
  now destruct (Map.lookup (proj1_sig m) key).
}
apply IHl. 2:{ now inversion ND. }
intro query. cbn in Ok.
assert (Q := Ok query).
destruct a as (key, value).
destruct (KeyEqDec query key). 2:{ exact Q. }
subst query.
cbn in ND.
inversion ND.
rewrite (Map.alist_lookup_not_in KeyEqDec l key) by assumption.
trivial.
Qed.

Definition items (m: t) := mark (Map.items (proj1_sig m)) (items_helper m).

Lemma items_ok (m: t) (key: key_sig):
  lookup m key = Map.alist_lookup key_sig_eq_dec (items m) key.
Proof.
unfold lookup. rewrite Map.items_ok. unfold items.
remember (items_helper m) as F. clear HeqF. revert F.
induction (Map.items (proj1_sig m)); intro F. { easy. }
cbn. destruct a as (k, v). destruct key as (query, QueryIsGood).
unfold key_sig_eq_dec. cbn in *.
remember (KeyEqDec query k) as e. destruct e. { trivial. }
apply IHl.
Qed.

Lemma key_sig_list_not_in {l: list key_sig} {key: key_sig}
                          (H: ~ In (proj1_sig key) (map (@proj1_sig _ _) l)):
  ~ In key l.
Proof.
induction l. { easy. }
intro I. inversion I; subst; cbn in *; tauto.
Qed.

Lemma key_sig_list_nodup {l: list key_sig}
                         (H: NoDup (map (@proj1_sig _ _) l)):
  NoDup l.
Proof.
induction l. { constructor. }
constructor.
{
  inversion H. subst.
  induction l. { easy. }
  apply key_sig_list_not_in.
  assumption.
}
apply IHl. now inversion H.
Qed.

Lemma items_nodup (m: t):
  NoDup (map fst (items m)).
Proof.
apply key_sig_list_nodup.
unfold items.
rewrite mark_map_proj1_sig.
apply Map.items_nodup.
Qed.

Local Lemma merge_spec (newer older: t) (key: Key):
  match Map.lookup (Map.merge (proj1_sig newer) (proj1_sig older)) key with
  | Some _ => KeyIsGood key = true
  | None => True
  end.
Proof.
rewrite Map.merge_ok.
assert (OkN := proj2_sig newer key).
assert (OkO := proj2_sig older key).
now destruct (Map.lookup (proj1_sig newer) key).
Qed.

Definition merge (newer older: t)
: t
:= exist _ (Map.merge (proj1_sig newer) (proj1_sig older)) (merge_spec newer older).

Lemma merge_ok (newer older: t) (key: key_sig):
    lookup (merge newer older) key
     =
    match lookup newer key with
    | Some value => Some value
    | None => lookup older key
    end.
Proof.
unfold lookup. cbn.
rewrite Map.merge_ok.
trivial.
Qed.

Local Lemma map_endo_spec (m: t) (f: Value -> Value) (key: Key):
  match Map.lookup (Map.map_endo (proj1_sig m) f) key with
  | Some _ => KeyIsGood key = true
  | None => True
  end.
Proof.
rewrite Map.map_endo_ok.
assert (C := proj2_sig m key).
now destruct Map.lookup.
Qed.

Definition map_endo (m: t) (f: Value -> Value)
: t
:= exist _ (Map.map_endo (proj1_sig m) f) (map_endo_spec m f).

Lemma map_endo_ok (m: t) (f: Value -> Value) (key: key_sig):
   lookup (map_endo m f) key = match lookup m key with
                               | Some value => Some (f value)
                               | None => None
                               end.
Proof.
unfold map_endo. unfold lookup. cbn.
apply Map.map_endo_ok.
Qed.

Instance instance: Map.class key_sig_eq_dec Value t
:= {| Map.lookup      := lookup
    ; Map.is_empty    := is_empty
    ; Map.is_empty_ok := is_empty_ok
    ; Map.empty       := empty
    ; Map.empty_ok    := empty_ok
    ; Map.insert      := insert
    ; Map.insert_ok   := insert_ok
    ; Map.remove      := remove
    ; Map.remove_ok   := remove_ok
    ; Map.items       := items
    ; Map.items_ok    := items_ok
    ; Map.items_nodup := items_nodup
    ; Map.merge       := merge
    ; Map.merge_ok    := merge_ok
    ; Map.map_endo    := map_endo
    ; Map.map_endo_ok := map_endo_ok
   |}.

End MapSig.


Require Import Coq.Lists.List.
Require Import Coq.Lists.ListSet.
Require Import Coq.Bool.Bool.
Require Import Coq.funind.Recdef. (* https://github.com/AbsInt/CompCert/pull/191 *)

Require Import Aniceto.Graphs.Graph.
Require Import Aniceto.Pair.
Require Import Aniceto.List.
Require Import Aniceto.Sig.
Require Import Aniceto.ListSet.

Set Implicit Arguments.

Section FGRAPHS.

Variable V:Type.

Variable eq_dec : forall (v1 v2:V), {v1 = v2} + {v1 <> v2}.

Let edge := (V*V)%type.
Let fgraph := list edge.

Definition Edge := (fun g e => @List.In edge e g).

Let in_nil:
  forall v,
  Graph.In (Edge nil) v -> False.
Proof.
  intros.
  repeat (try inversion H; destruct H).
Qed.

Notation In v g := (Graph.In (Edge g) v).

Lemma edge_spec:
  forall g e,
  Edge g e <-> List.In e g.
Proof.
  intros.
  simpl.
  tauto.
Qed.

Let in_cons:
  forall v e g,
  Graph.In (Edge g) v ->
  Graph.In (Edge (e :: g)) v.
Proof.
  unfold Edge.
  intros.
  inversion H.
  destruct H0.
  eauto using List.in_cons, in_def.
Qed.

Lemma pred_in_cycle:
  forall v w E,
  Cycle E w ->
  In v w ->
  exists v', E (v', v) /\ Edge w (v', v).
Proof.
  intros.
  destruct H0 as ((v1, v2), (Hin, Hpin)).
  assert (Hw : Walk E w).
  inversion H; auto.
  inversion Hpin.
  - subst; simpl in *.
    apply Graph.pred_in_cycle with (v1:=v1) (v2:=v2) in H.
    destruct H as (v3, H).
    exists v3.
    intuition.
    + apply in_edge with (w:=w); repeat auto.
    + auto.
  - subst; simpl in *.
    exists v1.
    intuition.
    apply in_edge with (w:=w); repeat auto.
Qed.

Lemma succ_in_cycle:
  forall v w E,
  Cycle E w ->
  In v w ->
  exists v', E (v, v') /\ Edge w (v, v').
Proof.
  intros.
  destruct H0 as ((v1, v2), (Hin, Hpin)).
  assert (Hw : Walk E w).
  inversion H; auto.
  inversion Hpin.
  - subst; simpl in *.
    exists v2.
    intuition.
    apply in_edge with (w:=w); repeat auto.
  - subst; simpl in *.
    apply Graph.succ_in_cycle with (v1:=v1) (v2:=v2) in H.
    destruct H as (v3, H).
    exists v3.
    intuition.
    + apply in_edge with (w:=w); repeat auto.
    + auto.
Qed.

Definition mem (v:V) (g:fgraph) : bool :=
  existsb (fun e => pair_mem eq_dec v e) g.

Lemma mem_prop:
  forall v g,
  mem v g = true ->
  In v g.
Proof.
  intros.
  unfold mem in *.
  apply existsb_exists in H.
  destruct H as (x, (x_in_g, mem_in_x)).
  apply pair_mem_prop in mem_in_x.
  eauto using in_def.
Qed.

Lemma mem_from_prop:
  forall v g,
  In v g ->
  mem v g = true.
Proof.
  intros.
  destruct H as (e, (e_in_g, v_in_e)).
  unfold mem.
  rewrite existsb_exists.
  exists e.
  eauto using pair_mem_from_prop.
Qed.

Lemma incl_to_subgraph:
  forall g g',
  incl g g' -> subgraph (Edge g) (Edge g').
Proof.
  unfold Edge, Graph.subgraph.
  eauto.
Qed.

Lemma subgraph_to_incl:
  forall g g',
  subgraph (Edge g) (Edge g') ->  incl g g'.
Proof.
  intros.
  unfold Graph.subgraph in *.
  unfold incl.
  assumption.
Qed.

Lemma subgraph_incl:
  forall g g',
  incl g g' <-> subgraph (Edge g) (Edge g').
Proof.
  split; auto using incl_to_subgraph, subgraph_to_incl.
Qed.

Lemma subgraph_filter:
  forall g f,
  subgraph (Edge (filter f g)) (Edge g).
Proof.
  intros.
  assert (Hx := filter_incl f g).
  auto using subgraph_incl.
Qed.

Lemma walk_is_subgraph:
  forall g w,
  Walk (Edge g) w ->
  subgraph (Edge w) (Edge g).
Proof.
  intros.
  unfold Graph.subgraph.
  intros.
  eauto using (in_edge _ H).
Qed.

Lemma subgraph_cons:
  forall (g:fgraph) e,
  subgraph (Edge g) (Edge (cons e g)).
Proof.
  unfold Graph.subgraph, Edge.
  eauto using List.in_cons.
Qed.

Lemma cycle_add:
  forall (g:fgraph) e w,
  Cycle (Edge g) w ->
  Cycle (Edge (cons e g)) w.
Proof.
  intros.
  eauto using subgraph_cycle, subgraph_cons.
Qed.

Inductive HasIncoming : fgraph -> V -> Prop :=
  has_incoming_def:
    forall v v' g,
    Edge g (v', v) ->
    HasIncoming g v.

Lemma has_incoming_cons:
  forall e g v,
  HasIncoming g v ->
  HasIncoming (e :: g) v.
Proof.
  intros.
  inversion H. subst.
  unfold Edge in *.
  apply List.in_cons with (a:=e) in H0.
  eauto using has_incoming_def.
Qed.

Inductive HasOutgoing : fgraph -> V -> Prop :=
  has_outgoing_def:
    forall v v' g,
    Edge g (v, v') ->
    HasOutgoing g v.

Lemma has_outgoing_cons:
  forall e g v,
  HasOutgoing g v ->
  HasOutgoing (e :: g) v.
Proof.
  intros.
  inversion H. subst.
  unfold Edge in *.
  apply List.in_cons with (a:=e) in H0.
  eauto using has_outgoing_def.
Qed.

Definition has_incoming (g:fgraph) (v:V) : bool :=
  existsb (fun e => if eq_dec v (snd e) then true else false) g.

Lemma has_incoming_prop:
  forall g v,
  has_incoming g v = true ->
  HasIncoming g v.
Proof.
  intros.
  unfold has_incoming in H.
  apply existsb_exists in H.
  destruct H as (x, (x_in_g, v_in_x)).
  destruct x as (v1, v2).
  simpl in *.
  destruct (eq_dec v v2).
  - subst.
    eauto using has_incoming_def.
  - inversion v_in_x.
Qed.

Lemma has_incoming_from_prop:
  forall g v,
  HasIncoming g v ->
  has_incoming g v = true.
Proof.
  intros.
  unfold has_incoming.
  apply existsb_exists.
  inversion H.
  subst.
  exists (v', v).
  split.
  assumption.
  - simpl.
    destruct (eq_dec v v).
    auto.
    contradiction n.
    trivial.
Qed.

Lemma has_incoming_in_snd:
  forall e w,
  List.In e w ->
  HasIncoming w (snd e).
Proof.
  intros.
  destruct e.
  simpl.
  eauto using has_incoming_def.
Qed.

(** Checks if an edge is in the graph. *)

Lemma is_edge_dec : forall e es, {Edge e es} + {~ Edge e es}.
Proof.
  intros.
  destruct (in_dec (@edge_eq_dec V eq_dec) es e); auto.
Defined.

Lemma in_edge_dec: forall (v:V) es, {Graph.In (Edge es) v } + {~ Graph.In (Edge es) v }.
Proof.
  intros.
  remember (existsb (fun (e:V*V)=>
    if (eq_dec (fst e) v) then true else
    if (eq_dec (snd e) v) then true else false
  ) es).
  symmetry in Heqb.
  destruct b.
  - rewrite existsb_exists in Heqb.
    left.
    destruct Heqb as ((v1,v2), (Hi, He)); simpl in *.
    destruct (eq_dec v1 v). {
      subst.
      eauto using in_left.
    }
    destruct (eq_dec v2 v). {
      subst.
      eauto using in_right.
    }
    inversion He.
  - right; unfold not; intros.
    apply existsb_Forall in Heqb.
    rewrite Forall_forall in *.
    destruct H as (e, (He,Hi)).
    apply Heqb in He.
    destruct e as (v1,v2); simpl in *.
    destruct Hi; simpl in *; subst.
    + destruct (eq_dec v1 v1);
      inversion He;
      contradiction n; trivial.
    + destruct (eq_dec v1 v2). {
        inversion He.
      }
      destruct (eq_dec v2 v2). {
        inversion He.
      }
      contradiction n0; trivial.
Defined.

Definition rm_sources (g:fgraph) :=
  feedback_filter (edge_eq_dec eq_dec) (fun g' e => has_incoming g' (fst e)) g.

Lemma rm_sources_incl:
  forall g,
  incl (rm_sources g) g.
Proof.
  intros.
  unfold rm_sources.
  apply feedback_filter_incl.
Qed.

Lemma rm_sources_subgraph:
  forall g,
  subgraph (Edge (rm_sources g)) (Edge g).
Proof.
  intros.
  apply subgraph_incl.
  apply rm_sources_incl.
Qed.

Lemma rm_sources_in:
  forall v g,
  In v (rm_sources g) ->
  In v g.
Proof.
  intros.
  eauto using subgraph_in, rm_sources_subgraph.
Qed.

Lemma rm_sources_has_incoming:
  forall g v,
  In v (rm_sources g) ->
  HasIncoming (rm_sources g) v.
Proof.
  intros.
  unfold Edge, rm_sources in *.
  destruct H as (e, (e_in_g, v_in_e)).
  assert (Hx := e_in_g).
  apply feedback_filter_in_f in e_in_g.
  apply has_incoming_prop in e_in_g.
  inversion v_in_e.
  - rewrite <- H in e_in_g.
    assumption.
  - remember (feedback_filter (edge_eq_dec eq_dec) _) as rm_g.
    destruct e as (v1, v2).
    simpl in *.
    rewrite <- H in *.
    eauto using has_incoming_def.
Qed.

Lemma filter_edge_in:
  forall e f g,
  Edge g e ->
  f e = true ->
  Edge (filter f g) e.
Proof.
  intros.
  apply filter_In.
  intuition.
Qed.

Lemma filter_vertex_in:
  forall v e f g,
  pair_In v e ->
  Edge g e ->
  f e = true ->
  In v (filter f g).
Proof.
  intros.
  unfold Graph.In.
  exists e.
  intuition.
  auto using filter_edge_in.
Qed.

Let edge_incl:
  forall g g' e,
  Edge g' e ->
  incl g' g ->
  Edge g e.
Proof.
  intros.
  unfold Edge in *.
  auto.
Qed.

Lemma has_outgoing_filter:
  forall g v,
  let fg := (fun e : V * V => has_incoming g (fst e)) in
  In v (filter fg g) ->
  HasOutgoing g v ->
  HasOutgoing (filter fg g) v.
Proof.
  intros.
  inversion H.
  subst.
  destruct H1.
  destruct x.
  inversion H2.
  - simpl in H3.
    rewrite H3 in *.
    eauto using has_outgoing_def.
  - simpl in H3. subst.
    (* let's check the edge in the original graph *)
    inversion H0; subst; clear H0.
    remember (fg (v1, v')) as b.
    symmetry in Heqb.
    destruct b.
    + eauto using has_outgoing_def, filter_edge_in.
    + (* absurd case *)
      unfold fg in Heqb.
      simpl in Heqb.
      assert (Hx: has_incoming g v1 = true). {
        assert (Hi: incl (filter fg g) g) by auto using filter_incl.
        eauto using has_incoming_from_prop, has_incoming_def.
      }
      rewrite Hx in Heqb.
      inversion Heqb.
Qed.

Lemma has_outgoing_rm_incl:
  forall v g,
  HasOutgoing g v ->
  In v (rm_sources g) ->
  HasOutgoing (rm_sources g) v.
Proof.
  intros.
  unfold rm_sources in *.
  remember (fun (g' : list (V * V)) e => has_incoming g' (fst e)) as f.
  functional induction (feedback_filter (edge_eq_dec eq_dec) f g).
  - assumption.
  - rename l into g.
    remember (fun (g' : list (V * V)) (e0 : V * V) => _) as f.
    remember (fun e : V * V => _ ) as ff.
    apply IHl; auto.
    rewrite Heqff.
    apply has_outgoing_filter; auto.
    inversion H0.
    destruct H1.
    exists x.
    intuition.
    unfold Edge in *.
    apply feedback_filter_in in H1.
    subst.
    assumption.
Qed.

Lemma forall_inv:
  forall (v:V) g (e:edge) P,
  Forall (Edge (e :: g)) P  ->
  Forall (Edge g) P.
Proof.
  intros.
  apply subgraph_forall with (E':= Edge (e :: g));
  auto using incl_to_subgraph, incl_tl, incl_refl.
Qed.

Definition AllOutgoing g : Prop := Forall (Edge g) (fun v => HasOutgoing g v).

Lemma all_outgoing_in:
  forall v g,
  In v g ->
  AllOutgoing g ->
  HasOutgoing g v.
Proof.
  intros.
  unfold AllOutgoing in *.
  unfold Forall in *.
  auto.
Qed.

Lemma all_outgoing_rm_incl:
  forall g,
  AllOutgoing g ->
  AllOutgoing (rm_sources g).
Proof.
  intros.
  unfold AllOutgoing in *.
  unfold Forall in *.
  unfold Graph.Forall in *.
  intros.
  apply has_outgoing_rm_incl; auto.
  apply rm_sources_in in H0; auto.
Qed.

Definition AllIncoming g : Prop := Forall (Edge g) (fun v => HasIncoming g v).

(* Returns all incoming edges *)
Fixpoint get_incoming (g:fgraph) v : list edge :=
  match g with
    | e :: g' =>
      let res := get_incoming g' v in
      if eq_dec (snd e) v
      then e :: res
      else res
    | nil => nil
  end.

Lemma get_incoming_inv:
  forall v1 v2 v g,
  List.In (v1, v2) (get_incoming g v) ->
  v2 = v.
Proof.
  intros.
  induction g.
  - simpl in H. inversion H.
  - destruct a.
    simpl in H.
    destruct (eq_dec v3 v); auto.
    subst.
    inversion H; auto.
    inversion H0.
    trivial.
Qed.

Lemma all_incoming_prop:
  forall v v' g,
  Edge g (v', v) ->
  List.In (v', v) (get_incoming g v).
Proof.
  intros.
  induction g.
  - inversion H. (* absurd *)
  - destruct a.
    simpl.
    destruct (eq_dec v1 v).
    + subst.
      destruct H.
      * inversion H.
        subst.
        apply in_eq.
      * apply IHg in H; clear IHg.
        auto using List.in_cons.
    + apply IHg.
      inversion H; trivial.
      inversion H0.
      subst.
      contradiction n; trivial.
Qed.

Lemma all_incoming_from_prop:
  forall e g v,
  List.In e (get_incoming g v) ->
  Edge g e.
Proof.
  intros.
  induction g.
  - simpl in H. inversion H.
  - simpl in H.
    destruct a.
    simpl in H.
    destruct (eq_dec v1 v).
    + inversion H.
      * inversion H0; subst.
        apply List.in_eq.
      * apply IHg in H0.
        unfold Edge in *.
        auto using List.in_cons.
    + apply IHg in H.
      unfold Edge in *.
      auto using List.in_cons.
Qed.

Lemma subgraph_get_incoming:
  forall g v,
  subgraph (Edge (get_incoming g v)) (Edge g).
Proof.
  intros.
  unfold subgraph.
  unfold Graph.subgraph.
  intros.
  eauto using all_incoming_from_prop.
Qed.

Lemma has_incoming_neq_nil:
  forall g v,
  HasIncoming g v <->
  get_incoming g v <> nil.
Proof.
  intros.
  split.
  + intros.
    inversion H.
    subst.
    apply all_incoming_prop in H0.
    remember (get_incoming g v).
    destruct l.
    - inversion H0.
    - intuition.
      inversion H1.
  + intros.
    remember (get_incoming g v) as g'.
    destruct g'.
    - contradiction H; trivial.
    - assert (List.In e (get_incoming g v)). {
        rewrite <- Heqg';
        apply in_eq.
      }
      assert (Hx := H0).
      destruct e.
      apply get_incoming_inv in H0.
      subst.
      eauto using has_incoming_def, all_incoming_from_prop.
Qed.

Lemma all_incoming_in:
  forall v g,
  In v g ->
  AllIncoming g ->
  HasIncoming g v.
Proof.
  intros.
  unfold AllIncoming in *.
  unfold Forall in *.
  auto.
Qed.

Lemma all_incoming_rm_incl:
  forall g,
  AllOutgoing g ->
  AllIncoming (rm_sources g).
Proof.
  intros.
  unfold AllOutgoing in *.
  unfold AllIncoming.
  unfold Forall in *.
  unfold Graph.Forall in *.
  auto using rm_sources_has_incoming.
Qed.

Lemma rm_filter_nonempty:
  forall g,
  AllOutgoing g ->
  let fg := fun (e:edge) => has_incoming g (fst e) in
  (exists v, In v g) ->
  exists v, In v (filter fg g).
Proof.
  intros.
  destruct H0 as (v, H0).
  inversion H0.
  destruct H1.
  destruct x as (vi, vo).
  assert (vo_out: HasOutgoing g vo) by eauto using all_outgoing_in, in_right.
  inversion vo_out.
  subst.
  exists v'.
  apply filter_vertex_in with (e:=(vo, v')); repeat auto.
  apply pair_in_right.
  unfold fg.
  simpl.
  eauto using has_incoming_from_prop, has_incoming_def.
Qed.

Let subgraph_forall_filter:
  forall P f g,
  Forall (Edge g) P ->
  Forall (Edge (filter f g)) P.
Proof.
  intros.
  eauto using subgraph_forall, subgraph_filter.
Qed.

Let rm_sources_nonempty':
  forall g,
  let g' := (rm_sources g) in
  AllOutgoing g ->
  (exists v, In v g) ->
  AllOutgoing g' ->
  AllIncoming g' ->
  exists v', In v' g'.
Proof.
  intros.
  unfold rm_sources in *.
  remember (fun (g' : list (V * V)) (e : V * V) => _) as fg.
  functional induction (feedback_filter (edge_eq_dec eq_dec) fg g); auto.
  unfold g' in *.
  rename l into g.
  remember (feedback_filter _ _)  as  gf.
  apply IHl; auto.
  - unfold AllOutgoing.
    unfold Forall.
    unfold Graph.Forall.
    intros.
    (* -- *)
    unfold AllOutgoing in H.
    unfold Forall in H.
    inversion H3.
    destruct H4.
    unfold Edge in *.
    apply filter_in in H4.
    apply has_outgoing_filter; auto.
    apply H.
    exists x.
    auto.
  - subst.
    auto using rm_filter_nonempty.
Qed.

Lemma nonempty_exists_vertex:
  forall g,
  g <> nil <->
  exists v, In v g.
Proof.
  intros.
  split.
  + intros; destruct g.
    - contradiction H.
      trivial.
    - destruct e.
      exists v.
      unfold Edge in *.
      eauto using in_left, List.in_eq.
  + intros.
    intuition.
    destruct H.
    inversion H.
    destruct H1.
    subst.
    inversion H1.
Qed.

Lemma rm_sources_nonempty:
  forall g,
  AllOutgoing g ->
  g <> nil ->
  AllOutgoing (rm_sources g) ->
  AllIncoming (rm_sources g) ->
  rm_sources g <> nil.
Proof.
  intros.
  apply nonempty_exists_vertex in H0.
  apply nonempty_exists_vertex.
  auto using rm_sources_nonempty'.
Qed.

Theorem exists_has_incoming:
  forall g,
  AllOutgoing g ->
  g <> nil ->
  exists (g':fgraph),
  subgraph (Edge g') (Edge g) /\
  AllOutgoing g' /\
  AllIncoming g' /\
  g' <> nil.
Proof.
  intros.
  exists (rm_sources g).
  assert (Ha : AllOutgoing (rm_sources g)).
  apply all_outgoing_rm_incl; assumption.
  assert (Hb : AllIncoming (rm_sources g)).
  apply all_incoming_rm_incl; assumption.
  split.
  - unfold rm_sources.
    unfold subgraph.
    apply feedback_filter_incl.
  - repeat split; auto using rm_sources_nonempty.
Qed.

Definition prepend (w:list edge) (g:fgraph) : option edge :=
  match w with
    | e :: _ =>
      match (get_incoming g (fst e)) with
        | e :: _ => Some e
        | nil => None
      end
    | nil => None
  end.

Lemma prepend_walk:
  forall g w e,
  Walk (Edge g) w ->
  prepend w g = Some e ->
  Linked e w.
Proof.
  intros.
  destruct w.
  - unfold Linked. auto.
  - simpl in H0.
    destruct p.
    simpl in *.
    remember (get_incoming g v).
    destruct l.
    inversion H0.
    destruct e0.
    assert (List.In (v1, v2) (get_incoming g v)).
    rewrite <- Heql. apply in_eq.
    apply get_incoming_inv in H1.
    destruct e.
    inversion H0.
    subst.
    unfold Linked.
    auto.
Qed.

Lemma prepend_edge:
  forall g w e,
  prepend w g = Some e ->
  Edge g e \/ Edge w e.
Proof.
  intros.
  destruct w.
  - simpl in *.
    destruct g.
    * inversion H.
    * inversion H; intuition; apply List.in_eq.
  - simpl in *.
    destruct e0.
    simpl in *.
    remember (get_incoming g v).
    destruct l.
    + inversion H.
    + inversion H; subst; clear H.
      assert (List.In e (get_incoming g v)). {
        rewrite <- Heql.
        apply in_eq.
      }
      left.
      assert (Hs: subgraph (Edge (get_incoming g v)) (Edge g))
      by auto using subgraph_get_incoming.
      auto using (subgraph_edge _ Hs).
Qed.

Fixpoint cut (v:V) (w:list edge) :=
  match w with
    | nil => nil
    | e :: w' =>
      if eq_dec v (snd e)
      then e :: nil
      else e :: (cut v w')
  end.

Lemma starts_with_cons_inv:
  forall e w (v:V),
  StartsWith (e :: w) v ->
  fst e = v.
Proof.
  intros.
  destruct H.
  destruct H as (w', (H1, H2)).
  inversion H1.
  auto.
Qed.

Lemma starts_with_cons:
  forall e w (v:V),
  fst e = v ->
  StartsWith (e :: w) v.
Proof.
  intros.
  unfold StartsWith.
  exists e.
  exists w.
  intuition.
Qed.

Lemma cut_starts_with:
  forall v v' w,
  StartsWith w v ->
  StartsWith (cut v' w) v.
Proof.
  intros.
  destruct w.
  - repeat (destruct H; try inversion H).
  - simpl.
    destruct (eq_dec v' (snd p));
    (apply starts_with_cons_inv in H;
      auto using starts_with_cons).
Qed.

Lemma cut_ends_with:
  forall v w,
  HasIncoming w v ->
  EndsWith (cut v w) v.
Proof.
  intros.
  induction w.
  - inversion H. inversion H0.
  - inversion H.
    subst.
    apply in_inv in H0.
    destruct H0.
    + destruct a.
      inversion H0; subst; clear H0.
      exists (v', v).
      intuition.
      simpl.
      destruct (eq_dec v v).
      * apply end_nil.
      * assert (v = v); auto.
        apply f in H0; inversion H0.
    + apply has_incoming_def in H0.
      apply IHw in H0.
      destruct H0.
      destruct H0.
      simpl.
      destruct (eq_dec v (snd a)).
      * destruct x; destruct a.
        simpl in *; subst.
        exists (v2, v3).
        simpl.
        intuition.
        apply end_nil.
      * exists x.
        intuition.
        apply end_cons; auto.
Qed.

Lemma cut_is_linked:
  forall a v w,
  Linked a w ->
  Linked a (cut v w).
Proof.
  intros.
  induction w.
  - auto.
  - simpl.
    destruct (eq_dec v (snd a0)).
    + inversion H.
      auto.
    + auto.
Qed.

Lemma cut_is_walk:
  forall g w v,
  Walk (Edge g) w ->
  Walk (Edge g) (cut v w).
Proof.
  intros.
  induction w.
  - simpl. assumption.
  - inversion H.
    subst.
    apply IHw in H2.
    simpl.
    destruct (eq_dec v (snd a)).
    + apply edge_to_walk; auto.
    + apply walk_cons; auto using cut_is_linked.
Qed.

Definition sublen (p:(list edge * fgraph)) :=
  let (w, g) := p in
  length w - length g.

Section FIND_CYCLE.

Variable g:fgraph.

Definition IsWalkOf w := Walk (Edge g) w /\ NoDup w.

Definition WalkOf := { w : list edge | Walk (Edge g) w /\ NoDup w /\ w <> nil}.

Lemma prepend_edge2:
  forall w g e,
  prepend w g = Some e ->
  Walk (Edge g) w ->
  Edge g e.
Proof.
  intros.
  apply prepend_edge in H.
  destruct H; auto.
  simpl in *.
  assert (Hs: subgraph (Edge w) (Edge g0)) by auto using walk_is_subgraph.
  auto using (subgraph_edge _ Hs).
Qed.

Lemma prepend_edge3:
  forall w g e,
  prepend w g = Some e ->
  subgraph (Edge w) (Edge g) ->
  List.In e g.
Proof.
  intros.
  apply prepend_edge in H.
  unfold  Edge in *.
  intuition.
Qed.

Definition ConsOf (w:list edge) := {e: edge | Walk (Edge g) (e :: w) }.

Definition CycleOf := { c:list edge | Cycle (Edge g) c}.

Definition BuildCycle w := { v: V | HasIncoming w v /\ StartsWith w v }.

Lemma choose_option:
  forall {A} (o:option A),
  sum {x | o = Some x} {_:option A | o = None} .
Proof.
  intros.
  destruct o.
  - refine (inl (Sig_yes a)).
    auto.
  - refine (inr (Sig_yes None)).
    auto.
Defined.

Lemma choose_prepend:
  forall w,
  option {e | prepend w g = Some e}.
Proof.
  intros.
  remember (prepend w g).
  destruct o.
  - refine (Some (Sig_yes e)).
    auto.
  - refine None.
Defined.

Lemma next_edge_ok:
  forall (w:WalkOf) (e:{e | prepend (Sig_take w) g = Some e}),
  ConsOf (Sig_take w).
Proof.
  intros.
  destruct e as (e, H).
  destruct w as (w, (H1, (H2, H3))).
  refine (Sig_yes e).
  apply walk_cons.
  auto.
  intuition.
  apply prepend_edge2 with (w:=w).
  auto.
  intuition.
  apply prepend_walk with (g:=g).
  intuition.
  auto.
Defined.

Definition next_edge (w:WalkOf) : option (ConsOf (Sig_take w)) :=
  match choose_option (prepend (Sig_take w) g) with
    | inl e => Some (next_edge_ok w e)
    | inr _ => None
  end.

Lemma next_edge_nil_inv:
  forall w,
  next_edge w = None ->
  prepend (Sig_take w) g = None.
Proof.
  intros.
  destruct w.
  unfold next_edge in H.
  remember (choose_option (prepend x g)).
  destruct s.
  + inversion H.
  + destruct s.
    assumption.
Qed.

Lemma starts_with_linked:
  forall (e:edge) w,
  w <> nil ->
  Linked e w ->
  StartsWith w (snd e).
Proof.
  intros.
  destruct e.
  compute in H.
  destruct w.
  destruct H. trivial.
  destruct p.
  compute in H0.
  simpl.
  subst.
  apply starts_with_cons.
  auto.
Qed.

Definition try_prepend: forall (w:WalkOf) (e:ConsOf (Sig_take w)),
 sum WalkOf (BuildCycle (Sig_take w)).
Proof.
  intros.
  destruct e as (e, H).
  destruct w as (w, (H1, (H2,H3))).
  destruct (in_dec (edge_eq_dec eq_dec) e w).
  - refine (inr (Sig_yes (snd e))).
    split.
    + apply has_incoming_in_snd.
      assumption.
    + inversion H; subst.
      destruct e.
      destruct w.
      inversion i.
      apply starts_with_linked.
      * intuition.
      * assumption.
  - refine (inl (Sig_yes (e :: w))).
    intuition.
    apply NoDup_cons; repeat auto.
    inversion H0.
Defined.

Definition lendiff (w:WalkOf) :=
  set_length (edge_eq_dec eq_dec) g - set_length (edge_eq_dec eq_dec) (Sig_take w).

Definition build_cycle: forall (w:WalkOf) (v:BuildCycle (Sig_take w)), CycleOf.
Proof.
  intros.
  destruct w as (w, (?, ?)).
  destruct v as (v, (?, ?)).
  refine (Sig_yes (cut v w)).
  apply cycle_def2 with (v:=v);
  auto using cut_starts_with, cut_ends_with, cut_is_walk.
Defined.

Function find_cycle (w:WalkOf)
  { measure lendiff } : option CycleOf :=
  match next_edge w with
    | Some e =>
      match try_prepend w e with
        | inr v => Some (build_cycle w v)
        | inl w' => find_cycle w'
      end
    | None => None
  end.
Proof.
  intros.
  simpl in *.
  destruct e as ((?,?), ?).
  destruct w as (?, (?, (?,?))).
  simpl in *.
  destruct (in_dec (edge_eq_dec eq_dec) (v, v0)); inversion teq0.
  destruct w' as (?, (?,(?,?))).
  inversion H0.
  unfold lendiff.
  auto using (set_length_minus _ _ (walk_is_subgraph w0)).
Defined.

Lemma find_cycle_total:
  forall (w:WalkOf),
  AllIncoming g ->
  g <> nil ->
  exists w', find_cycle w = Some w'.
Proof.
  intros.
  functional induction (find_cycle w).
  - destruct w as (?, (?, (?, ?))).
    destruct v as (?, (?, ?)).
    eauto.
  - auto.
  - apply next_edge_nil_inv in e.
    destruct w as (w, (Hw1, (?, Hw3))).
    destruct w.
    { contradiction Hw3; trivial. (* absurd *) }
    simpl in e.
    remember (get_incoming g (fst e0)).
    destruct l; inversion e;  clear e.
    apply all_incoming_in with (v:=fst e0) in H.
    rewrite has_incoming_neq_nil in H.
    contradiction H; auto.
    unfold Graph.In.
    exists e0.
    destruct e0.
    split; try (inversion Hw1; subst); auto using pair_in_left.
Qed.

End FIND_CYCLE.

Theorem all_pos_idegree_impl_cycle:
  forall g (w:list edge),
  AllIncoming g ->
  g <> nil ->
  exists w, Cycle (Edge g) w.
Proof.
  intros.
  destruct g.
  contradiction H0; trivial.
  assert (Walk (Edge (e::g)) (e::nil)).
  assert (Edge (e::g) e).
  apply in_eq.
  apply edge_to_walk.
  assumption.
  assert (w':WalkOf (e::g)). {
    refine (Sig_yes (e::nil)).
    intuition.
    apply NoDup_cons.
    auto.
    apply NoDup_nil.
    inversion H2.
  }
  assert (Hg : exists c, find_cycle w' = Some c) by (
    apply find_cycle_total; repeat auto).
  destruct Hg as ((x,?), Hg).
  eauto.
Qed.

Theorem all_pos_odegree_impl_cycle:
  forall g,
  g <> nil ->
  AllOutgoing g ->
  exists w, Cycle (Edge g) w.
Proof.
  intros.
  destruct (exists_has_incoming H0 H) as
  (g', (H1, (H2, (H3, H4)))).
  apply all_pos_idegree_impl_cycle in H3; repeat auto.
  destruct H3.
  exists x.
  eauto using subgraph_cycle.
Qed.
End FGRAPHS.

Arguments subgraph: default implicits.
Arguments HasIncoming: default implicits.
Arguments HasOutgoing: default implicits.

Section Edge.

  Lemma in_incl:
    forall {A:Type} (x:A) es es',
    Graph.In (Edge es) x ->
    incl es es' ->
    Graph.In (Edge es') x.
  Proof.
    intros.
    apply in_impl with (E:=Edge es); auto.
  Qed.
End Edge.

Section Restriction.
  Variable A:Type.
  Variable eq_dec:
    forall (x y:A), { x = y } + { x <> y }.

  Let vertex_mem (vs:list A) (x:A) := ListSet.set_mem eq_dec x vs.

  Let edge_mem vs (e:A*A) := let (x,y) := e in andb (vertex_mem vs x) (vertex_mem vs y).

  Definition restriction vs es := filter (edge_mem vs) es.

  Lemma restriction_incl:
    forall vs es,
    incl (restriction vs es) es.
  Proof.
    intros.
    unfold restriction.
    auto using List.filter_incl.
  Qed.

  Let vertex_mem_true_to_prop:
    forall x l,
    vertex_mem l x = true ->
    List.In x l.
  Proof.
    unfold vertex_mem.
    intros.
    apply ListSet.set_mem_correct1 in H.
    auto.
  Qed.

  Let vertex_mem_false_to_prop:
    forall x l,
    vertex_mem l x = false ->
    ~ List.In x l.
  Proof.
    unfold vertex_mem.
    intros.
    apply ListSet.set_mem_complete1 in H.
    auto.
  Qed.

  Let edge_mem_true_to_prop:
    forall rs x1 x2,
    edge_mem rs (x1, x2) = true ->
    List.In x1 rs /\ List.In x2 rs.
  Proof.
    unfold edge_mem.
    intros.
    remember (vertex_mem _ x1) as b1.
    remember (vertex_mem _ x2) as b2.
    symmetry in Heqb1; symmetry in Heqb2.
    destruct b1, b2; subst; try inversion H.
    auto using vertex_mem_true_to_prop.
  Qed.

  Let edge_mem_false_to_prop:
    forall rs x1 x2,
    edge_mem rs (x1, x2) = false ->
    ~ List.In x1 rs \/ ~ List.In x2 rs.
  Proof.
    unfold edge_mem.
    intros.
    rewrite Bool.andb_false_iff in H.
    destruct H;
    eauto using vertex_mem_false_to_prop.
  Qed.

  Let edge_mem_true_from_prop:
    forall rs x1 x2,
    List.In x1 rs ->
    List.In x2 rs ->
    edge_mem rs (x1, x2) = true.
  Proof.
    intros.
    remember (edge_mem _ _).
    symmetry in Heqb.
    destruct b; auto.
    apply edge_mem_false_to_prop in Heqb.
    destruct Heqb; contradiction.
  Qed.

  Let restriction_inv_edge:
    forall x1 x2 rs es,
    List.In (x1, x2) (restriction rs es) ->
    List.In x1 rs /\ List.In x2 rs.
  Proof.
    unfold restriction.
    intros.
    apply filter_In in H.
    destruct H.
    auto.
  Qed.

  Lemma restriction_in_1:
    forall rs es x,
    Graph.In (Edge (restriction rs es)) x ->
    List.In x rs.
  Proof.
    unfold Edge.
    intros.
    destruct H as ((x1,x2),(He,inP)).
    apply restriction_inv_edge in He.
    destruct He.
    destruct inP; simpl in *; subst; auto.
  Qed.

  Lemma restriction_in_2:
    forall x1 x2 rs es,
    List.In (x1, x2) es ->
    List.In x1 rs ->
    List.In x2 rs ->
    List.In (x1, x2) (restriction rs es).
  Proof.
    unfold restriction.
    intros.
    apply List.filter_true_to_in; auto.
  Qed.

End Restriction.

Section ConsEdge.
  Variable A:Type.

  Let edge_inv_neq:
    forall (e' e:A*A) es,
    Edge (e' :: es) e ->
    e' <> e ->
    Edge es e.
  Proof.
    unfold Edge.
    intros.
    apply in_cons_neq in H; auto.
  Qed.

  Lemma walk_inv_not_in_walk:
    forall w (e:A*A) es,
    ~ List.In e w ->
    Walk (Edge (e :: es)) w ->
    Walk (Edge es) w.
  Proof.
    induction w; intros. {
      auto using walk_nil.
    }
    inversion H0; subst; clear H0.
    destruct H4. {
      subst.
      contradiction H; auto using in_eq.
    }
    assert (~ List.In e w) by intuition.
    apply walk_cons; eauto.
  Qed.

  Lemma walk2_inv_not_in_walk:
    forall e es (x:A) y w,
    ~ List.In e w ->
    Walk2 (Edge (e :: es)) x y w ->
    Walk2 (Edge es) x y w.
  Proof.
    intros.
    inversion H0; subst.
    eauto using walk2_def, walk_inv_not_in_walk.
  Qed.

  Lemma walk_inv_in_edges:
    forall w (e:A*A) es,
    List.In e es ->
    Walk (Edge (e :: es)) w ->
    Walk (Edge es) w.
  Proof.
    induction w; intros. {
      auto using walk_nil.
    }
    inversion H0; subst; clear H0.
    apply IHw in H3; auto.
    destruct H4; subst; auto using walk_cons.
  Qed.

  Lemma edge_cons:
    forall es (e:A*A) e',
    Edge es e ->
    Edge (e' :: es) e.
  Proof.
    unfold Edge in *.
    auto using in_cons.
  Qed.

  Lemma reaches_cons:
    forall (x:A) y e es,
    Reaches (Edge es) x y ->
    Reaches (Edge (e :: es)) x y.
  Proof.
    eauto using reaches_impl, edge_cons.
  Qed.

  Let walk2_inv_cons:
    forall w (x:A) y z es,
    Walk2 (Edge ((z,y) :: es)) x y w ->
    z = x \/ exists w', Walk2 (Edge es) x y w' \/ Walk2 (Edge es) x z w'.
  Proof.
    induction w; intros. {
      apply walk2_nil_inv in H; contradiction.
    }
    destruct w. {
      destruct a as (x', y').
      assert (x'=x) by eauto using walk2_inv_eq_fst; subst.
      assert (y'=y) by eauto using walk2_inv_eq_snd; subst.
      apply walk2_inv_cons in H.
      destruct H as (v2, (Heq, He)).
      symmetry in Heq; inversion Heq; subst; clear Heq.
      inversion He; subst; clear He. {
        inversion H; subst.
        intuition.
      }
      eauto using edge_to_walk2.
    }
    apply walk2_inv in H.
    destruct H as (v, (Heq, (He, Hw))).
    subst.
    destruct He. {
      inversion H; subst; clear H.
      intuition.
    }
    apply IHw in Hw;auto.
    destruct Hw as [?|(w',Hx)]. {
      subst.
      eauto using edge_to_walk2.
    }
    destruct Hx. {
      eauto using walk2_cons.
    }
    eauto using walk2_cons.
  Qed.

  Lemma reaches_inv_cons_2:
    forall (x:A) y z es,
    Reaches (Edge ((z,y) :: es)) x y ->
    z = x \/ Reaches (Edge es) x y \/ Reaches (Edge es) x z.
  Proof.
    intros.
    destruct H.
    apply walk2_inv_cons in H.
    destruct H as [?|(w',[?|?])]; eauto using reaches_def.
  Qed.

  Lemma reaches_impl_cons:
    forall es e (x:A) y,
    Reaches (Edge es) x y ->
    Reaches (Edge (e :: es)) x y.
  Proof.
    intros.
    apply reaches_impl with (E:=Edge es); auto; intros.
    unfold Edge in *.
    auto using in_cons.
  Qed.

End ConsEdge.

Section RmEdge.
  Import Aniceto.Pair.
  Import Aniceto.List.

  Variable A:Type.
  Variable eq_dec: forall (x y:A), {x = y} + {x <> y}.

  Definition rm_edge e es := remove (edge_eq_dec eq_dec) e es.

  Lemma rm_edge_in_neq:
    forall e es e',
    List.In e' es ->
    e' <> e ->
    List.In e' (rm_edge e es).
  Proof.
    intros.
    unfold rm_edge.
    auto using remove_in_neq.
  Qed.

  Lemma edge_rm_edge_to_edge:
    forall e e' es,
    Edge (rm_edge e es) e' ->
    Edge es e'.
  Proof.
    unfold Edge in *; simpl in *.
    unfold rm_edge in *.
    eauto using remove_in.
  Qed.

End RmEdge.


From Coq Require Import ssreflect.
From stdpp Require Import prelude.
From LS2NF Require Import grammar sub_derive.

Section ambiguity.

  Context {Σ N : Type}.
  Implicit Type t s T : @tree Σ N.

  Open Scope grammar_scope.

  (* similarity *)

  (* assume input trees have same root and word *)

  Definition similar t1 t2 : Prop :=
    match t1, t2 with
    | ε_tree _, ε_tree _ => True
    | token_tree R1 tk1, token_tree R2 tk2 => tk1 = tk2
    | unary_tree R1 t1, unary_tree R2 t2 => root t1 = root t2
    | binary_tree R1 tA1 tB1, binary_tree R2 tA2 tB2 =>
        root tA1 = root tA2 ∧ root tB1 = root tB2 ∧ word tA1 = word tA2
    | _, _ => False
    end.

  Lemma similar_refl :
    Reflexive similar.
  Proof.
    intros t. by destruct t.
  Qed.

  Context `{!EqDecision Σ} `{!EqDecision N}.
  Context (G : grammar Σ N).

  (* standard notion of ambiguity *)
  Definition derive_amb A w : Prop :=
    ∃ t1 t2, t1 ▷ A ={G}=> w ∧ t2 ▷ A ={G}=> w ∧ t1 ≠ t2.

  (* local ambiguity *)
  Definition local_amb A w : Prop :=
    ∃ H h, reachable G (A, w) (H, h) ∧
      ∃ t1 t2, t1 ▷ H ={G}=> h ∧ t2 ▷ H ={G}=> h ∧ ¬ (similar t1 t2).

  (* first direction : local ambiguous -> derivation ambiguous *)

  Fixpoint replace T t s :=
    match T with
    | unary_tree A t1 =>
      if bool_decide (T = t) then Some s else
      t1' ← replace t1 t s; Some (unary_tree A t1')
    | binary_tree A tl tr =>
      if bool_decide (T = t) then Some s else
      match replace tl t s with
      | Some tl' => Some (binary_tree A tl' tr)
      | None => tr' ← replace tr t s; Some (binary_tree A tl tr')
      end
    | _ => if bool_decide (T = t) then Some s else None
    end.

  Lemma bind_Some_is_Some A B (f : A → B) mx :
    is_Some (mx ≫= (λ x, Some (f x))) ↔ is_Some mx.
  Proof.
    unfold is_Some. setoid_rewrite bind_Some. naive_solver.
  Qed.

  Lemma replace_Some T t s :
    subtree t T → is_Some (replace T t s).
  Proof.
    induction T as [?|??|?? IHt|?? IHt1 ? IHt2] => Ht /=.
    - apply subtree_ε_inv in Ht as ->. by case_bool_decide.
    - apply subtree_token_inv in Ht as ->. by case_bool_decide.
    - apply subtree_unary_inv in Ht as [->|?]; case_bool_decide => //.
      apply bind_Some_is_Some. by apply IHt.
    - apply subtree_binary_inv in Ht as [->|[Ht|Ht]]; case_bool_decide => //; case_match => //.
      + apply IHt1 in Ht. by invert Ht.
      + apply bind_Some_is_Some. by apply IHt2.
  Qed.

  Local Ltac simpl_bind_eq_Some :=
    repeat match goal with
    | |- Some _ = Some _ → _ =>
      let H := fresh in intros H; apply Some_inj in H; revert H
    | |- _ ≫= (λ _, Some _) = Some _ → _ =>
      let H := fresh in rewrite bind_Some; intros [? [? H]]; revert H
    | |- (_, _) = (_, _) → _ => inversion 1; subst
    | |- _ = _ → _ => intros ?; subst
    end.

  Lemma replace_id T t s :
    replace T t s = Some T → s = t.
  Proof.
    induction T => /=.
    all: case_bool_decide; try case_match; simpl_bind_eq_Some => //.
    all: naive_solver.
  Qed.

  Lemma replace_witness T t s T' A w H h :
    T ▷ A ={G}=> w →
    t ▷ H ={G}=> h →
    s ▷ H ={G}=> h →
    replace T t s = Some T' →
    T' ▷ A ={G}=> w.
  Proof.
    intros [? [? HT]] [? [? ?]] ?.
    generalize dependent T'.
    generalize dependent w.
    generalize dependent A.
    induction T as [?|??|? ? IHT|?? IHT1 ? IHT2] => T' w ? A ? /=.
    all: case_bool_decide; try case_match; simpl_bind_eq_Some => //=.
    all: invert HT.
    - specialize (IHT (ltac:(done)) _ (ltac:(reflexivity)) _ (ltac:(reflexivity)) _ (ltac:(done))) as [Hr [Hw ?]].
      repeat split => //=.
      econstructor => //; rewrite ?Hr ?Hw; eauto.
    - specialize (IHT1 (ltac:(done)) _ (ltac:(reflexivity)) _ (ltac:(reflexivity)) _ (ltac:(done))) as [Hr [Hw ?]].
      repeat split => //=. { by rewrite Hw. }
      econstructor => //; rewrite ?Hr ?Hw; eauto.
    - specialize (IHT2 (ltac:(done)) _ (ltac:(reflexivity)) _ (ltac:(reflexivity)) _ (ltac:(done))) as [Hr [Hw ?]].
      repeat split => //=. { by rewrite Hw. }
      econstructor => //; rewrite ?Hr ?Hw; eauto.
  Qed.

  Lemma replace_subtree T t s T' :
    replace T t s = Some T' → subtree s T'.
  Proof.
    generalize dependent T'.
    induction T as [?|??|?? IHt|?? IHt1 ? IHt2] => T' /=.
    all: case_bool_decide; try case_match; simpl_bind_eq_Some => //=.
    - eapply rtc_r; first by apply IHt. constructor.
    - eapply rtc_r; first by apply IHt1. constructor.
    - eapply rtc_r; first by apply IHt2. constructor.
  Qed.

  Lemma local_amb_implies_derive_amb A w :
    local_amb A w → derive_amb A w.
  Proof.
    intros [H [h [Hr [t1 [t2 [Ht1 [Ht2 Hnot]]]]]]].
    apply reachable_spec in Hr; last by exists t1.
    specialize (Hr _ Ht1) as [t [Ht Hsub]].
    edestruct (replace_Some _ _ t2 Hsub) as [t' ?].
    exists t', t. split; last (split; first done).
    - eapply replace_witness; last done. all: done.
    - intros <-.
      have ? : t2 = t1 by eapply replace_id; eauto.
      subst. apply Hnot, similar_refl.
  Qed.

  (* second direction : derivation ambiguous -> local ambiguous *)

  (* diff two trees with same root and sentence *)
  Fixpoint diff t1 t2 :=
    match t1, t2 with
    | ε_tree _, ε_tree _ => None
    | token_tree _ _, token_tree _ _ =>
      (* tokens must be eq, so no diff *)
      None
    | unary_tree _ t1', unary_tree _ t2' =>
      (* sentences must be eq, so just compare root *)
      if bool_decide (root t1' = root t2')
      then diff t1' t2'
      else Some (t1, t2)
    | binary_tree _ tl1 tr1, binary_tree _ tl2 tr2 =>
      if bool_decide (root tl1 = root tl2 ∧ root tr1 = root tr2 ∧ word tl1 = word tl2)
      then
        match diff tl1 tl2 with
        | Some p => Some p
        | None => diff tr1 tr2
        end
      else Some (t1, t2)
    | _, _ => Some (t1, t2)
    end.

  Lemma diff_None t1 t2 :
    root t1 = root t2 →
    word t1 = word t2 →
    t1 = t2 ↔ diff t1 t2 = None.
  Proof.
    intros. split.
    - intros <-.
      induction t1 => //=.
      all: case_bool_decide => //; try case_match; eauto.
      naive_solver.
    - generalize dependent t2.
      induction t1 => t2.
      all: destruct t2 => //=; do 2 (inversion 1; subst).
      all: try case_bool_decide; try case_match => //=.
      all: inversion 1; subst; try done; naive_solver.
  Qed.

  Lemma diff_Some_inv t1 t2 t1' t2' :
    root t1 = root t2 →
    word t1 = word t2 →
    diff t1 t2 = Some (t1', t2') →
    root t1' = root t2' ∧ word t1' = word t2'.
  Proof.
    generalize dependent t2.
    induction t1 as [?|??|?? IHt|? t11 IHt1 t12 IHt2] => t2.
    all: destruct t2 as [?|??|??|? t21 t22] => //= -> Hw.
    all: try case_bool_decide; try case_match.
    all: simpl_bind_eq_Some => //.
    3: have Heq : word t11 = word t21 by naive_solver.
    3: rewrite Heq in Hw.
    all: naive_solver.
  Qed.

  Lemma diff_result_not_similar t1 t2 t1' t2' :
    diff t1 t2 = Some (t1', t2') → ¬ (similar t1' t2').
  Proof.
    generalize dependent t2.
    induction t1 => t2 /=.
    all: repeat case_match; try case_bool_decide => //.
    all: simpl_bind_eq_Some => //=.
    all: naive_solver.
  Qed.

  Lemma diff_result_subtree t1 t2 t1' t2' :
    diff t1 t2 = Some (t1', t2') → subtree t1' t1 ∧ subtree t2' t2.
  Proof.
    generalize dependent t2.
    induction t1 as [?|??|?? IHt|?? IHt1 ? IHt2] => t2 /=.
    all: repeat case_match; try case_bool_decide => //.
    all: simpl_bind_eq_Some => //=.
    1: edestruct IHt; eauto.
    2: edestruct IHt1; eauto.
    3: edestruct IHt2; eauto.
    all: split; etrans; eauto.
    all: apply rtc_once; constructor.
  Qed.

  Lemma derive_amb_implies_local_amb A w :
    derive_amb A w → local_amb A w.
  Proof.
    intros [t1 [t2 [[Hr1 [Hw1 ?]] [[? [? ?]] ?]]]].
    have [[t1' t2'] Hdiff] : is_Some (diff t1 t2).
    { apply not_eq_None_Some. intros Hcontra. apply diff_None in Hcontra => //.
      all: congruence. }
    have [Hsub1 Hsub2] := (diff_result_subtree _ _ _ _ Hdiff).
    have Ht1' : t1' ▷ root t1' ={G}=> word t1'.
    { repeat split. eapply subtree_valid; eauto. }
    exists (root t1'), (word t1'). split.
    - apply reachable_spec; first by exists t1'.
      intros t' Ht'.
      edestruct (replace_Some _ _ t' Hsub1) as [T ?].
      exists T. split; last eapply replace_subtree; eauto.
      eapply replace_witness. 2: apply Ht1'. 2: apply Ht'. 2: eauto.
      by repeat split.
    - exists t1', t2'.
      have [? ?] : root t1' = root t2' ∧ word t1' = word t2'.
      { eapply diff_Some_inv; last eauto. all: congruence. }
      repeat split => //. eapply subtree_valid; eauto.
      eapply diff_result_not_similar; eauto.
  Qed.

  (* To sum up *)

  Theorem derive_amb_iff_local_amb A w :
    derive_amb A w ↔ local_amb A w.
  Proof.
    split; [ apply derive_amb_implies_local_amb
           | apply local_amb_implies_derive_amb ].
  Qed.

End ambiguity.

Arguments similar {_} {_}.


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

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

Print Assumptions sub.


(** Coq coding by choukh, Nov 2021 **)

Require Import BBST.Theory.Ordinal.
Require Import BBST.Theory.OrdinalOperation.
Require Import BBST.Arith.Nat.
Require Import BBST.Arith.Ord.

Local Hint Immediate ω为序数集 : core.
Local Hint Resolve 𝐎𝐍为传递类 一为序数 :core.

Definition 左迭代 := λ α, 序数递归 α (幂运算 α).
Notation "α ^^ᴸ β" := (左迭代 α β) (at level 25) : 序数算术域.

Theorem 左迭代为序数运算 : ∀ α β ⋵ 𝐎𝐍, α ^^ᴸ β ⋵ 𝐎𝐍.
Proof. intros. apply 序数运算的递归为序数运算; auto. Qed.
Local Hint Resolve 左迭代为序数运算 : core.

Theorem 左迭代零次 : ∀α ⋵ 𝐎𝐍, α ^^ᴸ 0 = α.
Proof. intros. apply 序数递归_0; auto. Qed.

Theorem 左迭代后继次 : ∀ α β ⋵ 𝐎𝐍, α ^^ᴸ β⁺ = α ^ (α ^^ᴸ β).
Proof. intros. apply 序数递归_后继; auto. Qed.

Theorem 左迭代极限次 : ∀α ⋵ 𝐎𝐍, 极限处连续 (左迭代 α).
Proof. intros. apply 序数递归_极限; auto. Qed.

Lemma 左迭代有限递增 : ∀α ⋵ 𝐎𝐍, 1 ∈ α → 有限递增 (左迭代 α).
Proof with auto.
  intros α Hα H1 n Hn. 归纳 n.
  - rewrite 左迭代后继次, 左迭代零次... apply 幂运算放大...
  - rewrite 左迭代后继次, 左迭代后继次... apply 幂运算保序...
Qed.

Fact 左迭代有限保序 : ∀α ⋵ 𝐎𝐍, 1 ∈ α → 有限保序 (左迭代 α).
Proof with auto.
  intros α Hα H1 n Hn m. 归纳 n; intro Hmn. 空集归谬.
  apply 后继除去 in Hmn as [].
  - apply 序数传递 with (α ^^ᴸ n)... apply 左迭代有限递增...
  - subst. apply 左迭代有限递增...
Qed.

Lemma 左迭代ω次为极限 : ∀α ⋵ 𝐎𝐍, 1 ∈ α → α ^^ᴸ ω ⋵ 𝐋𝐈𝐌.
Proof with auto.
  intros α Hα H1. split... rewrite 左迭代极限次... 外延.
  - apply 并集除去 in H as [β [Hβ H]].
    apply 集族并除去 in Hβ as [n [Hn Hβ]].
    apply 集族并介入 with n... apply 序数传递 with β...
  - apply 集族并除去 in H as [n [Hn H]].
    apply 并集介入 with (α ^^ᴸ n)...
    apply 集族并介入 with n⁺. apply 极限序数有其任意元素的后继...
    apply 左迭代有限递增...
Qed.

Lemma 仅零之左迭代为零 : ∀ α β ⋵ 𝐎𝐍, α ^^ᴸ β = 0 → α = 0.
Proof with eauto.
  intros α Hα. 超限归纳 β Hβ. 超限讨论 β; intros Heq.
  - rewrite 左迭代零次 in Heq...
  - rewrite 左迭代后继次 in Heq... apply 幂为零 in Heq...
  - rewrite 左迭代极限次 in Heq... apply 集族并为零 in Heq as []... exfalso...
Qed.

Lemma 左迭代在ω后继处不递增 : ∀α ⋵ 𝐎𝐍, 1 ∈ α → α ^^ᴸ ω⁺ = α ^^ᴸ ω.
Proof with auto.
  intros α Hα H1. rewrite 左迭代后继次, 极限次幂, 左迭代极限次...
  2: apply 左迭代ω次为极限...
  2: { intros H. apply 仅零之左迭代为零 in H... apply 大于一的序数不为零 with α... }
  外延.
  - apply 集族并除去 in H as [β [Hβ Hx]].
    apply 集族并除去 in Hβ as [n [Hn Hβ]].
    apply 集族并介入 with n⁺... apply 序数传递 with (α ^ β)...
    rewrite 左迭代后继次... apply 幂运算保序...
  - apply 集族并除去 in H as [n [Hn Hx]].
    apply 集族并介入 with (α ^^ᴸ n).
    apply 集族并介入 with n⁺... apply 左迭代有限递增...
    apply 序数传递 with (α ^^ᴸ n)... rewrite <- 左迭代后继次... apply 左迭代有限递增...
Qed.

Theorem 左迭代在ω次之后不变 : ∀α ⋵ 𝐎𝐍, 1 ∈ α → ∀β ⋵ 𝐎𝐍, ω ∈ β → α ^^ᴸ β = α ^^ᴸ ω.
Proof with auto.
  intros α Hα H1. 超限归纳 β; intros H. 超限讨论 β. 空集归谬.
  - apply 后继除去 in H as []...
    + rewrite 左迭代后继次, 归纳假设, <- 左迭代后继次, 左迭代在ω后继处不递增...
    + subst... apply 左迭代在ω后继处不递增...
  - rewrite 左迭代极限次... 外延. 2: apply 集族并介入 with ω...
    apply 集族并除去 in H2 as [γ [Hγ Hx]]. assert (Hγo: γ ⋵ 𝐎𝐍). eauto.
    destruct (序数三歧 γ Hγo ω) as [|[]]... subst... 2: rewrite <- (归纳假设 γ)...
    apply 序数传递 with (α ^^ᴸ γ)... rewrite (左迭代极限次 α Hα ω)...
    apply 集族并介入 with γ⁺... apply 左迭代有限递增...
Qed.

Definition 右迭代 := λ α, 序数递归 α (λ ξ, ξ ^ α).
Notation "α ^^ᴿ β" := (右迭代 α β) (at level 25) : 序数算术域.

Theorem 右迭代为序数运算 : ∀ α β ⋵ 𝐎𝐍, α ^^ᴿ β ⋵ 𝐎𝐍.
Proof. intros. apply 序数运算的递归为序数运算; auto. Qed.
Local Hint Resolve 右迭代为序数运算 : core.

Theorem 右迭代零次 : ∀α ⋵ 𝐎𝐍, α ^^ᴿ 0 = α.
Proof. intros. apply 序数递归_0; auto. Qed.

Theorem 右迭代后继次 : ∀ α β ⋵ 𝐎𝐍, α ^^ᴿ β⁺ = (α ^^ᴿ β) ^ α.
Proof. intros. apply 序数递归_后继; auto. Qed.

Theorem 右迭代极限次 : ∀α ⋵ 𝐎𝐍, 极限处连续 (右迭代 α).
Proof. intros. apply 序数递归_极限; auto. Qed.

Lemma 右迭代于一 : ∀α ⋵ 𝐎𝐍, 1 ^^ᴿ α = 1.
Proof with auto.
  超限归纳. 超限讨论 α.
  - rewrite 右迭代零次...
  - rewrite 右迭代后继次, 一次幂...
  - rewrite 右迭代极限次... 外延.
    + apply 集族并除去 in H as [β [Hβ H]]. rewrite 归纳假设 in H...
    + simpl in H. apply 后继除去 in H as []... 空集归谬. subst.
      apply 集族并介入 with ∅... rewrite 右迭代零次... simpl...
Qed.

Theorem 右迭代化简 : ∀ α β ⋵ 𝐎𝐍, α ≠ 0 → α ^^ᴿ β = α ^ (α ^ β).
Proof with auto.
  intros α Hα.
  排中 (α = 1) as [|H1]. {
    intros β Hβ H1. subst. rewrite 右迭代于一, 底数为一的幂...
  }
  超限归纳 β Hβ. intros Hα0. 超限讨论 β.
  - rewrite 右迭代零次, 零次幂, 一次幂...
  - rewrite 右迭代后继次, 归纳假设, <- 指数积运算律, 后继次幂...
  - rewrite 右迭代极限次, 极限次幂...
    2: apply 幂为极限_右...
    2: intros H; apply 幂为零 in H...
    外延.
    + apply 集族并除去 in H as [γ [Hγ H]]. assert (Hγo: γ ⋵ 𝐎𝐍). eauto.
      apply 集族并介入 with (α ^ γ)... apply 幂运算保序... rewrite <- 归纳假设...
    + apply 集族并除去 in H as [γ [Hγ Hx]]. rewrite 极限次幂 in Hγ...
      apply 集族并除去 in Hγ as [δ [Hδ Hγ]].
      assert (Hγo: γ ⋵ 𝐎𝐍). eauto.
      assert (Hoδ: δ ⋵ 𝐎𝐍). eauto.
      apply 集族并介入 with δ... rewrite 归纳假设...
      apply 序数传递 with (α ^ γ)... apply 幂运算保序...
Qed.

(* α ^ α ^ ... ^ α ^ τ *)
Definition 顶迭代 := λ α β τ, 序数递归 τ (幂运算 α) β.
Notation "α ^^ᵀ β" := (顶迭代 α β) (at level 25) : 序数算术域.

Theorem 顶迭代为序数运算 : ∀ τ α β ⋵ 𝐎𝐍, (α ^^ᵀ β) τ ⋵ 𝐎𝐍.
Proof. intros. apply 序数运算的递归为序数运算; auto. Qed.
Local Hint Resolve 顶迭代为序数运算 : core.

Theorem 顶迭代零次 : ∀ τ α ⋵ 𝐎𝐍, (α ^^ᵀ 0) τ = τ.
Proof. intros. apply 序数递归_0; auto. Qed.

Theorem 顶迭代后继次 : ∀ τ α β ⋵ 𝐎𝐍, (α ^^ᵀ β⁺) τ = α ^ (α ^^ᵀ β) τ.
Proof. intros. apply 序数递归_后继; auto. Qed.

Theorem 顶迭代极限次 : ∀ τ α ⋵ 𝐎𝐍, 极限处连续 (λ β, (α ^^ᵀ β) τ).
Proof. intros. apply 序数递归_极限; auto. Qed.

Theorem 顶迭代一次 : ∀ τ α ⋵ 𝐎𝐍, (α ^^ᵀ 1) τ = α ^ τ.
Proof. intros. simpl. rewrite 顶迭代后继次, 顶迭代零次; auto. Qed.

Lemma 顶迭代有限弱递增 : ∀ τ α ⋵ 𝐎𝐍, 1 ∈ α → 有限弱递增 (λ k, (α ^^ᵀ k) τ).
Proof with auto.
  intros τ Hτ α Hα H1 n Hn. 归纳 n.
  - rewrite 顶迭代零次, 顶迭代一次... apply 幂运算弱放大...
  - rewrite 顶迭代后继次, 顶迭代后继次... apply 幂运算保序_弱右...
Qed.

Fact 顶迭代有限弱保序 : ∀ τ α ⋵ 𝐎𝐍, 1 ∈ α → 有限弱保序 (λ k, (α ^^ᵀ k) τ).
Proof with auto.
  intros τ Hτ α Hα H1 n Hn m. 归纳 n; intro Hmn. 空集归谬.
  apply 后继除去 in Hmn as [].
  - apply 序数传递_弱 with ((α ^^ᵀ n) τ)... apply 顶迭代有限弱递增...
  - subst. apply 顶迭代有限弱递增...
Qed.

Lemma 有限顶迭代小于左迭代 : ∀α ⋵ 𝐎𝐍, 1 ∈ α → ∀τ ∈ α, ∀n ∈ ω, (α ^^ᵀ n) τ ∈ α ^^ᴸ n.
Proof with auto.
  intros α Hα H1 τ Hτα n Hn.
  assert (Hτ: τ ⋵ 𝐎𝐍). eauto.
  归纳 n.
  - rewrite 顶迭代零次, 左迭代零次...
  - rewrite 顶迭代后继次, 左迭代后继次... apply 幂运算保序...
Qed.

Lemma 有限左迭代小于后继顶迭代 : ∀α ⋵ 𝐎𝐍, ∀τ ∈ α, 1 ∈ τ → ∀n ∈ ω, α ^^ᴸ n ∈ (α ^^ᵀ n⁺) τ.
Proof with auto.
  intros α Hα τ Hτα H1 n Hn.
  assert (Hτ: τ ⋵ 𝐎𝐍). eauto.
  assert (H1α: 1 ∈ α). apply 序数传递 with τ...
  归纳 n.
  - rewrite 顶迭代一次, 左迭代零次... apply 幂运算放大...
  - rewrite 顶迭代后继次, 左迭代后继次... apply 幂运算保序...
Qed.

Theorem 无限顶迭代等于左迭代 : ∀α ⋵ 𝐎𝐍, ∀τ ∈ α, 1 ∈ τ → (α ^^ᵀ ω) τ = α ^^ᴸ ω.
Proof with auto.
  intros α Hα τ Hτα H1.
  assert (Hτ: τ ⋵ 𝐎𝐍). eauto.
  assert (H1α: 1 ∈ α). apply 序数传递 with τ...
  rewrite 顶迭代极限次, 左迭代极限次...
  外延; apply 集族并除去 in H as [n [Hn H]].
  - apply 集族并介入 with n... apply 序数传递 with ((α ^^ᵀ n) τ)... apply 有限顶迭代小于左迭代...
  - apply 集族并介入 with n⁺... apply 序数传递 with (α ^^ᴸ n)... apply 有限左迭代小于后继顶迭代...
Qed.


(** * Propositions with a distinguished representation of [True], [False], [and], [or], and [impl] *)
(** This allows for something between [bool] and [Prop], where we can
    computationally reduce things like [True /\ True], but can still
    express equality of types. *)
Require Import Coq.Setoids.Setoid.
Require Import Coq.Program.Tactics.
Require Import Crypto.Util.Notations.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.DestructHyps.
Require Import Crypto.Util.Tactics.BreakMatch.

Declare Scope reified_prop_scope.
Delimit Scope reified_prop_scope with reified_prop.
Inductive reified_Prop := rTrue | rFalse | rAnd (x y : reified_Prop) | rOr (x y : reified_Prop) | rImpl (x y : reified_Prop) | rForall {T} (f : T -> reified_Prop) | rEq {T} (x y : T) | inject (_ : Prop).
Bind Scope reified_prop_scope with reified_Prop.

Fixpoint to_prop (x : reified_Prop) : Prop
  := match x with
     | rTrue => True
     | rFalse => False
     | rAnd x y => to_prop x /\ to_prop y
     | rOr x y => to_prop x \/ to_prop y
     | rImpl x y => to_prop x -> to_prop y
     | @rForall _ f => forall x, to_prop (f x)
     | @rEq _ x y => x = y
     | inject x => x
     end.

Coercion reified_Prop_of_bool (x : bool) : reified_Prop
  := if x then rTrue else rFalse.

Definition and_reified_Prop (x y : reified_Prop) : reified_Prop
  := match x, y with
     | rTrue, x
     | x, rTrue
       => x
     | rFalse, _
     | _, rFalse
       => rFalse
     | rEq T a b, rEq T' a' b' => rEq (a, a') (b, b')
     | x', y' => rAnd x' y'
     end.
Definition or_reified_Prop (x y : reified_Prop) : reified_Prop
  := match x, y with
     | rTrue, _
     | _, rTrue
       => rTrue
     | rFalse, x
     | x, rFalse
       => x
     | x', y' => rOr x' y'
     end.
Definition impl_reified_Prop (x y : reified_Prop) : reified_Prop
  := match x, y with
     | rTrue, y => y
     | _, rTrue => rTrue
     | rFalse, _ => rTrue
     | rImpl x rFalse, rFalse => x
     | x', y' => rImpl x' y'
     end.

Infix "/\" := and_reified_Prop : reified_prop_scope.
Infix "\/" := or_reified_Prop : reified_prop_scope.
Infix "->" := impl_reified_Prop : reified_prop_scope.
Infix "=" := rEq : reified_prop_scope.
Notation "~ P" := (P -> rFalse)%reified_prop : reified_prop_scope.
Notation "∀  x .. y , P" := (rForall (fun x => .. (rForall (fun y => P%reified_prop)) .. ))
                              (at level 200, x binder, y binder, right associativity) : reified_prop_scope.

Definition reified_Prop_eq (x y : reified_Prop)
  := match x, y with
     | rTrue, _ => y = rTrue
     | rFalse, _ => y = rFalse
     | rAnd x0 x1, rAnd y0 y1
       => x0 = y0 /\ x1 = y1
     | rAnd _ _, _ => False
     | rOr x0 x1, rOr y0 y1
       => x0 = y0 /\ x1 = y1
     | rOr _ _, _ => False
     | rImpl x0 x1, rImpl y0 y1
       => x0 = y0 /\ x1 = y1
     | rImpl _ _, _ => False
     | @rForall Tx fx, @rForall Ty fy
       => exists pf : Tx = Ty,
                      forall x, fx x = fy (eq_rect _ (fun t => t) x _ pf)
     | rForall _ _, _ => False
     | @rEq Tx x0 x1, @rEq Ty y0 y1
       => exists pf : Tx = Ty,
                      eq_rect _ (fun t => t) x0 _ pf = y0
                      /\ eq_rect _ (fun t => t) x1 _ pf = y1
     | rEq _ _ _, _ => False
     | inject x, inject y => x = y
     | inject _, _ => False
     end.

Section rel.
  Local Ltac t :=
    cbv;
    repeat (match goal with |- forall x, _ => intro end (* work around broken Ltac [match] in 8.4 that diverges on things under binders *)
            || break_match
            || break_match_hyps
            || intro
            || (simpl in * )
            || intuition try congruence
            || (exists eq_refl)
            || eauto
            || (subst * )
            || apply conj
            || destruct_head' ex
            || solve [ apply reflexivity
                     | apply symmetry; eassumption
                     | eapply transitivity; eassumption ] ).

  Global Instance Reflexive_reified_Prop_eq : Reflexive reified_Prop_eq.
  Proof. t. Qed.
  Global Instance Symmetric_reified_Prop_eq : Symmetric reified_Prop_eq.
  Proof. t. Qed.
  Global Instance Transitive_reified_Prop_eq : Transitive reified_Prop_eq.
  Proof. t. Qed.
  Global Instance Equivalence_reified_Prop_eq : Equivalence reified_Prop_eq.
  Proof. split; exact _. Qed.
End rel.

Definition reified_Prop_leq_to_eq (x y : reified_Prop) : x = y -> reified_Prop_eq x y.
Proof. intro; subst; simpl; reflexivity. Qed.

Ltac inversion_reified_Prop_step :=
  let do_on H := apply reified_Prop_leq_to_eq in H; unfold reified_Prop_eq in H in
  match goal with
  | [ H : False |- _ ] => solve [ destruct H ]
  | [ H : (_ = _ :> reified_Prop) /\ (_ = _ :> reified_Prop) |- _ ] => destruct H
  | [ H : ?x = ?x :> reified_Prop |- _ ] => clear H
  | [ H : exists pf : _ = _ :> Type, forall x, _ = _ :> reified_Prop |- _ ]
    => destruct H as [? H]; subst; simpl @eq_rect in H
  | [ H : ?x = _ :> reified_Prop |- _ ] => is_var x; subst x
  | [ H : _ = ?y :> reified_Prop |- _ ] => is_var y; subst y
  | [ H : rTrue = rFalse |- _ ] => solve [ inversion H ]
  | [ H : rFalse = rTrue |- _ ] => solve [ inversion H ]
  | [ H : rTrue = _ |- _ ] => do_on H; progress subst
  | [ H : rFalse = _ |- _ ] => do_on H; progress subst
  | [ H : rAnd _ _ = _ |- _ ] => do_on H
  | [ H : rOr _ _ = _ |- _ ] => do_on H
  | [ H : rImpl _ _ = _ |- _ ] => do_on H
  | [ H : rForall _ = _ |- _ ] => do_on H
  | [ H : rEq _ _ = _ |- _ ] => do_on H
  | [ H : inject _ = _ |- _ ] => do_on H
  end.
Ltac inversion_reified_Prop := repeat inversion_reified_Prop_step.

Lemma to_prop_and_reified_Prop x y : to_prop (x /\ y) <-> (to_prop x /\ to_prop y).
Proof.
  destruct x, y; simpl; try tauto.
  { split; intro H; inversion H; subst; repeat split. }
Qed.

(** Remove all possibly false terms in a reified prop *)
Fixpoint trueify (p : reified_Prop) : reified_Prop
  := match p with
     | rTrue => rTrue
     | rFalse => rTrue
     | rAnd x y => rAnd (trueify x) (trueify y)
     | rOr x y => rOr (trueify x) (trueify y)
     | rImpl x y => rImpl x (trueify y)
     | rForall T f => rForall (fun x => trueify (f x))
     | rEq T x y => rEq x x
     | inject x => inject True
     end.

Lemma trueify_true : forall p, to_prop (trueify p).
Proof.
  induction p; simpl; auto.
Qed.


(*
 * Copyright (C) BedRock Systems Inc. 2020-21
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *
 *)
Require Import bedrock.lang.algebra.telescopes.
Require Export iris.bi.telescopes.
Require Export bedrock.lang.bi.prelude.
Require iris.proofmode.class_instances.
Import ChargeNotation.

#[local] Set Universe Polymorphism.
#[local] Set Printing Universes.
#[local] Set Printing Coercions.

(** Analogues of [bi_texist] and [bi_tforall], with extra universe
polymorphism and a slightly different interface. *)
Fixpoint tbi_exist@{X Z Y} {PROP : bi} {t : tele@{X}}
  : forall (P : tele_fun@{X Z Y} t PROP), PROP :=
  match t as t0 return ((t0 -t> PROP) → PROP) with
  | [tele] => fun x : PROP => x
  | @TeleS X binder =>
    fun P : (∀ x : X, binder x -t> PROP) => Exists x : X, tbi_exist (P x)
  end.

Fixpoint tbi_forall@{X Z Y} {PROP : bi} {t : tele@{X}}
  : forall (P : tele_fun@{X Z Y} t PROP), PROP :=
  match t as t0 return ((t0 -t> PROP) → PROP) with
  | [tele] => fun x : PROP => x
  | @TeleS X binder =>
    fun P : (∀ x : X, binder x -t> PROP) => Forall x : X, tbi_forall (P x)
  end.

(** Small improvements to [bi_tforall], [bi_texist] *)
Section telescopes.
  Context {PROP : bi} {TT : tele}.

  (** Enable, e.g., [f_equiv] on proofmode goals [(∀.. x, P) -∗ ∀.. x, Q]. *)
  #[global] Instance bi_tforall_mono' :
    Proper (pointwise_relation _ (⊢) ==> (⊢)) (@bi_tforall PROP TT).
  Proof. intros f1 f2 Hf. rewrite !bi_tforall_forall. solve_proper. Qed.

  #[global] Instance bi_texist_mono' :
    Proper (pointwise_relation _ (⊢) ==> (⊢)) (@bi_texist PROP TT).
  Proof. intros f1 f2 Hf. rewrite !bi_texist_exist. solve_proper. Qed.

  (** Enable, e.g., [f_equiv] on goals [(∀.. x, P) -∗ ∀.. x, Q]. *)
  #[global] Instance bi_tforall_flip_mono' :
    Proper (
      pointwise_relation _ (flip (⊢)) ==>
      (flip (⊢))
    ) (@bi_tforall PROP TT).
  Proof. intros f1 f2 Hf. rewrite !bi_tforall_forall. solve_proper. Qed.

  #[global] Instance bi_texist_flip_mono' :
    Proper (pointwise_relation _ (⊢) ==> (⊢)) (@bi_texist PROP TT).
  Proof. intros f1 f2 Hf. rewrite !bi_texist_exist. solve_proper. Qed.
End telescopes.

Section tele_fun_quantifiers.
  Context {PROP : bi}.
  Implicit Types t : tele.

  Lemma tbi_exist_bi_texist {t} (P : t -t> PROP) : tbi_exist P -|- ∃.. x, tele_app P x.
  Proof. induction t as [|?? IH]; simpl; first done. f_equiv=>x. by rewrite IH. Qed.
  Lemma bi_texist_tbi_exist {t} (R : t -> PROP) : (∃.. x, R x) -|- tbi_exist (tele_bind R).
  Proof. rewrite tbi_exist_bi_texist. f_equiv=>x. by rewrite tele_app_bind. Qed.

  (** Avoid the preceding lemmas which would unduly constrain universe [Y]. *)
  Lemma tbi_exist_exist@{X Z Y} {t : tele@{X}} (P : tele_fun@{X Z Y} t PROP) :
    tbi_exist P -|- Exists x, tele_app P x.
  Proof.
    induction t as [|B bnd IH]; simpl; split'.
    - by rewrite -(bi.exist_intro TargO).
    - apply bi.exist_elim=>x. by rewrite (tele_arg_O_inv x).
    - apply bi.exist_elim=>b. rewrite IH. apply bi.exist_elim=>ys.
      by rewrite -(bi.exist_intro (TargS b ys)).
    - apply bi.exist_elim=>ys. destruct (tele_arg_S_inv ys) as (b & arg & ->). simpl.
      rewrite -(bi.exist_intro b) IH. by rewrite -(bi.exist_intro arg).
  Qed.

  Lemma tbi_exist_mono@{X Z Y} {t : tele@{X}} (P1 P2 : tele_fun@{X Z Y} t PROP) :
    tele_fun_pointwise@{X Z Y} (⊢) P1 P2 -> tbi_exist P1 ⊢ tbi_exist P2.
  Proof. intros. rewrite !tbi_exist_exist. solve_proper. Qed.

  Lemma tbi_exist_ne@{X Z Y} {t : tele@{X}} n (P1 P2 : tele_fun@{X Z Y} t PROP) :
    tele_fun_pointwise@{X Z Y} (dist n) P1 P2 ->
    dist n (tbi_exist P1) (tbi_exist P2).
  Proof. intros. rewrite !tbi_exist_exist. solve_proper. Qed.

  Lemma tbi_exist_proper@{X Z Y} {t : tele@{X}} (P1 P2 : tele_fun@{X Z Y} t PROP) :
    tele_fun_pointwise@{X Z Y} equiv P1 P2 ->
    equiv (tbi_exist P1) (tbi_exist P2).
  Proof. intros. rewrite !tbi_exist_exist. solve_proper. Qed.

  Lemma tbi_forall_bi_tforall {t} (P : t -t> PROP) : tbi_forall P -|- ∀.. x, tele_app P x.
  Proof. induction t as [|?? IH]; simpl; first done. f_equiv=>x. by rewrite IH. Qed.
  Lemma bi_tforall_tbi_forall {t} (R : t -> PROP) : (∀.. x, R x) -|- tbi_forall (tele_bind R).
  Proof. rewrite tbi_forall_bi_tforall. f_equiv=>x. by rewrite tele_app_bind. Qed.

  Lemma tbi_forall_forall@{X Z Y} {t : tele@{X}} (P : tele_fun@{X Z Y} t PROP) :
    tbi_forall P -|- Forall x, tele_app P x.
  Proof.
    induction t as [|B bnd IH]; simpl; split'.
    - apply bi.forall_intro=>x. by rewrite tele_app_bind.
    - by rewrite (bi.forall_elim TargO).
    - apply bi.forall_intro=>ys. destruct (tele_arg_S_inv ys) as (b & arg & ->).
      simpl. by rewrite (bi.forall_elim b) IH (bi.forall_elim arg).
    - apply bi.forall_intro=>b. rewrite IH. apply bi.forall_intro=>ys.
      by rewrite (bi.forall_elim (TargS b ys)).
  Qed.

  Lemma tbi_forall_mono@{X Z Y} {t : tele@{X}} (P1 P2 : tele_fun@{X Z Y} t PROP) :
    tele_fun_pointwise@{X Z Y} (⊢) P1 P2 -> tbi_forall P1 ⊢ tbi_forall P2.
  Proof. intros. rewrite !tbi_forall_forall. solve_proper. Qed.

  Lemma tbi_forall_ne@{X Z Y} {t : tele@{X}} n (P1 P2 : tele_fun@{X Z Y} t PROP) :
    tele_fun_pointwise@{X Z Y} (dist n) P1 P2 ->
    dist n (tbi_forall P1) (tbi_forall P2).
  Proof. intros. rewrite !tbi_forall_forall. solve_proper. Qed.

  Lemma tbi_forall_proper@{X Z Y} {t : tele@{X}} (P1 P2 : tele_fun@{X Z Y} t PROP) :
    tele_fun_pointwise@{X Z Y} equiv P1 P2 ->
    equiv (tbi_forall P1) (tbi_forall P2).
  Proof. intros. rewrite !tbi_forall_forall. solve_proper. Qed.

  #[global] Instance: Params (@tbi_exist) 2 := {}.
  #[global] Instance tbi_exist_ne' t : NonExpansive (@tbi_exist PROP t).
  Proof. repeat intro. by apply tbi_exist_ne. Qed.
  #[global] Instance tbi_exist_proper' t : Proper (equiv ==> equiv) (@tbi_exist PROP t).
  Proof. repeat intro. by apply tbi_exist_proper. Qed.
  #[global] Instance tbi_exist_mono' {t} :
    Proper (tele_fun_pointwise (⊢) ==> (⊢)) (@tbi_exist PROP t).
  Proof. repeat intro. by apply tbi_exist_mono. Qed.
  #[global] Instance tbi_exist_flip_mono' {t} :
    Proper (tele_fun_pointwise (⊢) --> flip (⊢)) (@tbi_exist PROP t).
  Proof. repeat intro. by apply tbi_exist_mono. Qed.

  #[global] Instance: Params (@tbi_forall) 2 := {}.
  #[global] Instance tbi_forall_ne' t : NonExpansive (@tbi_forall PROP t).
  Proof. repeat intro. by apply tbi_forall_ne. Qed.
  #[global] Instance tbi_forall_proper' t : Proper (equiv ==> equiv) (@tbi_forall PROP t).
  Proof. repeat intro. by apply tbi_forall_proper. Qed.
  #[global] Instance tbi_forall_mono' {t} :
    Proper (tele_fun_pointwise (⊢) ==> (⊢)) (@tbi_forall PROP t).
  Proof. repeat intro. by apply tbi_forall_mono. Qed.
  #[global] Instance tbi_forall_flip_mono' {t} :
    Proper (tele_fun_pointwise (⊢) --> flip (⊢)) (@tbi_forall PROP t).
  Proof. repeat intro. by apply tbi_forall_mono. Qed.

  Section proofmode.
    Import proofmode.classes.

    #[global] Instance tbi_exist_into_exist t (P : t -> PROP) name :
      AsIdentName P name -> IntoExist (tbi_exist (tele_bind P)) P name.
    Proof.
      rewrite /IntoExist=>?. rewrite tbi_exist_exist.
      f_equiv=>x. by rewrite tele_app_bind.
    Qed.
    #[global] Instance tbi_exist_from_exist t (P : t -> PROP) :
      FromExist (tbi_exist (tele_bind P)) P.
    Proof.
      rewrite /FromExist. rewrite tbi_exist_exist.
      f_equiv=>x. by rewrite tele_app_bind.
    Qed.

    #[global] Instance tbi_forall_into_forall t (P : t -> PROP) :
      IntoForall (tbi_forall (tele_bind P)) P.
    Proof.
      rewrite /IntoForall. rewrite tbi_forall_forall.
      f_equiv=>x. by rewrite tele_app_bind.
    Qed.
    #[global] Instance tbi_forall_from_forall t (P : t -> PROP) name :
      AsIdentName P name -> FromForall (tbi_forall (tele_bind P)) P name.
    Proof.
      rewrite /FromForall=>?. rewrite tbi_forall_forall.
      f_equiv=>x. by rewrite tele_app_bind.
    Qed.
  End proofmode.

End tele_fun_quantifiers.
#[global] Hint Opaque tbi_exist tbi_forall : typeclass_instances.

(** On [Import], hide IPM instances related to telescopic quantifiers.
    Those instances can impose spurious universe constraints when
    proving universe polymorphic lemmas about [tbi_exist],
    [tbi_forall]. For example, [iDestruct] on a hypothesis of the form
    [tbi_exist@{X Z Y} (tele_bind ...)] uses the [IntoExist] instance
    for [bi_texist] with the side-effect of constraining universe [Y]
    to being below a small universe like [Type.0]. *)
Module disable_proofmode_telescopes.
  #[export] Remove Hints
    class_instances.into_exist_texist class_instances.from_exist_texist
    class_instances.into_forall_tforall class_instances.from_forall_tforall
    tbi_exist_into_exist tbi_exist_from_exist
    tbi_forall_into_forall tbi_forall_from_forall
  : typeclass_instances.
End disable_proofmode_telescopes.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Relations.Relation_Definitions.
Require Import Crypto.Tactics.VerdiTactics.
Require Import Crypto.Util.Logic.

Section Relations.
  Definition option_eq {A} eq (x y : option A) :=
    match x with
    | None    => y = None
    | Some ax => match y with
                 | None => False
                 | Some ay => eq ax ay
                 end
    end.

  Local Ltac t :=
    cbv; repeat (break_match || intro || intuition congruence ||
                 solve [ apply reflexivity
                       | apply symmetry; eassumption
                       | eapply transitivity; eassumption ] ).

  Global Instance Reflexive_option_eq {T} {R} {Reflexive_R:@Reflexive T R}
    : Reflexive (option_eq R). Proof. t. Qed.

  Global Instance Transitive_option_eq {T} {R} {Transitive_R:@Transitive T R}
    : Transitive (option_eq R). Proof. t. Qed.

  Global Instance Symmetric_option_eq {T} {R} {Symmetric_R:@Symmetric T R}
    : Symmetric (option_eq R). Proof. t. Qed.

  Global Instance Equivalence_option_eq {T} {R} {Equivalence_R:@Equivalence T R}
    : Equivalence (option_eq R). Proof. split; exact _. Qed.
End Relations.

Global Instance Proper_option_rect_nd_changebody
      {A B:Type} {RB:relation B} {a:option A}
  : Proper (pointwise_relation _ RB ==> RB ==> RB) (fun S N => option_rect (fun _ => B) S N a).
Proof. cbv; repeat (intro || break_match); intuition. Qed.

(* FIXME: there used to be a typeclass resolution hint here, something like
  Hint Extern 1 (Proper _ (@option_rect ?A (fun _ => ?B))) => exact (@Proper_option_rect_nd_changebody A B _ _) : typeclass_instances.
 but I could not get it working after generalizing [RB] from [Logic.eq] ~ andreser *)

Global Instance Proper_option_rect_nd_changevalue
      {A B RA RB} some {Proper_some: Proper (RA==>RB) some}
  : Proper (RB ==> option_eq RA ==> RB) (@option_rect A (fun _ => B) some).
Proof. cbv; repeat (intro || break_match || f_equiv || intuition congruence). Qed.

Lemma option_rect_false_returns_true_iff
      {T} {R} {reflexiveR:Reflexive R}
      (f:T->bool) {Proper_f:Proper(R==>eq)f} (o:option T) :
  option_rect (fun _ => bool) f false o = true <-> exists s:T, option_eq R o (Some s) /\ f s = true.
Proof.
  unfold option_rect; break_match; logic; [ | | congruence .. ].
  { repeat esplit; simpl; easy. }
  { match goal with [H : f _ = true |- f _ = true ] =>
                    solve [rewrite <- H; eauto] end. }
Qed.

Lemma option_rect_false_returns_true_iff_eq
      {T} (f:T->bool) (o:option T) :
  option_rect (fun _ => bool) f false o = true <-> exists s:T, Logic.eq o (Some s) /\ f s = true.
Proof. unfold option_rect; break_match; logic; congruence. Qed.

Lemma option_rect_option_map : forall {A B C} (f:A->B) some none v,
    option_rect (fun _ => C) (fun x => some (f x)) none v = option_rect (fun _ => C) some none (option_map f v).
Proof.
  destruct v; reflexivity.
Qed.

Lemma option_rect_function {A B C S' N' v} f
  : f (option_rect (fun _ : option A => option B) S' N' v)
    = option_rect (fun _ : option A => C) (fun x => f (S' x)) (f N') v.
Proof. destruct v; reflexivity. Qed.

(*
Ltac commute_option_rect_Let_In := (* pull let binders out side of option_rect pattern matching *)
  idtac;
  lazymatch goal with
  | [ |- ?LHS = option_rect ?P ?S ?N (Let_In ?x ?f) ]
    => (* we want to just do a [change] here, but unification is stupid, so we have to tell it what to unfold in what order *)
    cut (LHS = Let_In x (fun y => option_rect P S N (f y))); cbv beta;
    [ set_evars;
      let H := fresh in
      intro H;
      rewrite H;
      clear;
      abstract (cbv [Let_In]; reflexivity)
    | ]
  end.
*)

Ltac replace_option_match_with_option_rect :=
  idtac;
  lazymatch goal with
  | [ |- _ = ?RHS :> ?T ]
    => lazymatch RHS with
       | match ?a with None => ?N | Some x => @?S x end
         => replace RHS with (option_rect (fun _ => T) S N a) by (destruct a; reflexivity)
       end
  end.

Ltac simpl_option_rect := (* deal with [option_rect _ _ _ None] and [option_rect _ _ _ (Some _)] *)
  repeat match goal with
         | [ |- context[option_rect ?P ?S ?N None] ]
           => change (option_rect P S N None) with N
         | [ |- context[option_rect ?P ?S ?N (Some ?x) ] ]
           => change (option_rect P S N (Some x)) with (S x); cbv beta
         end.

Definition option_leq_to_eq {A} (x y : option A) : x = y -> option_eq eq x y.
Proof. destruct x; intro; subst; simpl; reflexivity. Defined.

Definition option_eq_to_leq {A} (x y : option A) : option_eq eq x y -> x = y.
Proof.
  destruct x, y; simpl;
    try solve [ intros []
              | apply f_equal
              | reflexivity
              | apply eq_sym ].
Defined.

Lemma option_leq_to_eq_to_leq {A x y} v : @option_eq_to_leq A x y (@option_leq_to_eq A x y v) = v.
Proof.
  destruct x; subst; simpl; reflexivity.
Qed.

Lemma option_eq_to_leq_to_eq {A x y} v : @option_leq_to_eq A x y (@option_eq_to_leq A x y v) = v.
Proof.
  compute in *.
  repeat first [ progress subst
               | progress break_match
               | reflexivity ].
Qed.

Lemma UIP_None {A} (p q : @None A = @None A) : p = q.
Proof.
  rewrite <- (option_leq_to_eq_to_leq p), <- (option_leq_to_eq_to_leq q); simpl; reflexivity.
Qed.

Definition invert_Some {A} (x : option A) : match x with
                                            | Some _ => A
                                            | None => unit
                                            end
  := match x with
     | Some x' => x'
     | None => tt
     end.

Lemma invert_eq_Some {A x y} (p : Some x = Some y) : { pf : x = y | @option_eq_to_leq A (Some x) (Some y) pf = p }.
Proof.
  refine (exist _ _ (option_leq_to_eq_to_leq _)).
Qed.

Ltac inversion_option_step :=
  match goal with
  | [ H : Some _ = Some _ |- _ ] => apply option_leq_to_eq in H; unfold option_eq in H
  | [ H : Some _ = Some _ |- _ ]
    => let H' := fresh in
       rename H into H';
       destruct (invert_eq_Some H') as [H ?]; subst H'
  | [ H : None = Some _ |- _ ] => solve [ inversion H ]
  | [ H : Some _ = None |- _ ] => solve [ inversion H ]
  | [ H : None = None |- _ ] => clear H
  | [ H : None = None |- _ ]
    => assert (eq_refl = H) by apply UIP_None; subst H
  end.

Ltac inversion_option := repeat inversion_option_step.