From mathcomp Require Import all_ssreflect all_algebra.
From Equations Require Import Equations.

Require Import parameters.
Require Import determinant.

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

Import Num.Theory GRing.Theory.

Section implementation.

Variable R : realFieldType.

Variable P : finType.

Variable coords : P -> R * R.

Definition E := {ffun 'I_2 -> P}.

Lemma elimI2 (P' : 'I_2 -> Prop): P' 0 -> P' 1 -> forall i, P' i.
Proof.
move=> p0 p1 [[ | [ | [ | ?]]] ci] //.
    by have /eqP -> : Ordinal ci == 0.
  by have /eqP -> : Ordinal ci == 1.
Qed.

Lemma elimI3 (P' : 'I_3 -> Prop): P' 0 -> P' 1 -> P' (1 + 1) -> forall i, P' i.
Proof.
move=> p0 p1 p2 [[ | [ | [ | ?]]] ci] //.
    by have /eqP -> : Ordinal ci == 0.
  by have /eqP -> : Ordinal ci == 1.
by have /eqP -> : Ordinal ci == (1 + 1).
Qed.

Definition oppos_edge (e : E) : E :=
  [ffun i : 'I_2 => e (i + 1)].

Lemma p1p1_I2 :
  forall (i : 'I_2), (i + 1 + 1 : 'I_2) = i.
Proof.
apply: elimI2; by apply /eqP.
Qed.

Lemma inv_oppos_edge (e : E) : (oppos_edge (oppos_edge e)) = e.
Proof.
rewrite -ffunP.
apply: elimI2; by rewrite /oppos_edge ?ffunE p1p1_I2.
Qed.

Definition T := {ffun 'I_3 -> P}.

Definition t_make (p0 p1 p2 : P) : T :=
  [ffun i : 'I_3 =>
    if val i == 0%nat then p0 else if val i == 1%nat then p1 else p2].

Hypothesis inj_triangles :
  forall (t : T), forall (i j : 'I_3), (t i) == (t j) -> i == j.

Definition triangle_area (t : T) :=
  tr_area R (coords (t 0)) (coords (t 1)) (coords (t (1 + 1))).

Variable tr : triangulation [finType of T].

Hypothesis tr_orientation :
  forall (t : T), t \in (enum tr) -> 0 < triangle_area t.

Hypothesis tr_triangulation :
  forall (t t' : T) (i j : 'I_3),
  t \in (enum tr) -> t' \in (enum tr) -> t i == t' j -> t (i + 1) == t' (j + 1) -> t == t'.

Definition edges_tr (t : T) : {ffun 'I_3 -> E} :=
  [ffun i : 'I_3 => [ffun j : 'I_2 => if val j == 0%N then t i else t (i + 1)]].

Lemma inj_edges_tr :
  forall (t : T), forall (i j : 'I_3),
    (edges_tr t i) == (edges_tr t j) -> i == j.
Proof.
move => t i j /eqP h.
rewrite !ffunE in h.
move: h.
rewrite -ffunP.
move => h.
move : (h 0).
rewrite !ffunE /=.
move => /eqP H.
apply: inj_triangles.
by apply: H.
Qed.

Definition point_in (p : P) (t : T) : bool :=
  [exists i : 'I_3, (t i) == p].

Lemma point_in_exists (p : P) (t : T) :
  (point_in p t) -> exists (i : 'I_3), (t i) = p.
Proof.
rewrite /point_in.
by apply : exists_eqP.
Qed.

Definition edge_in (e : E) (t : T) : bool :=
  [exists i : 'I_3, (edges_tr t i) == e].

Lemma edge_in_exists (e : E) (t : T) :
  (edge_in e t) -> exists (i : 'I_3), (edges_tr t i) = e.
Proof.
rewrite /edge_in.
by apply : exists_eqP.
Qed.

Lemma p10 : (0 + 1 : 'I_3) = 1.
Proof.
by [].
Qed.

Lemma p1p10 : (0 + 1 + 1 : 'I_3) = (1 + 1).
Proof.
by [].
Qed.

Lemma p1p11 : (1 + 1 + 1 : 'I_3) = 0.
Proof.
by apply /eqP.
Qed.

Lemma starter_pt_triangle_area (i : 'I_3) (t : T) :
  triangle_area t = tr_area R (coords (t i)) (coords (t (i +1))) (coords (t (i + 1 + 1))).
Proof.
move: i.
apply : elimI3.
    by rewrite p10 p1p10.
  by rewrite p1p11 (inv_cycle_tr_area R).
by rewrite p1p11 p10 -(inv_cycle_tr_area R).
Qed.

Lemma triangle_area_no_dup (t : T) (i : 'I_3):
  t i = t (i + 1) -> triangle_area t = 0.
Proof.
move => abs.
by rewrite (starter_pt_triangle_area i) abs dupl_tr_area.
Qed.

Lemma common_points (t1 t2 : T) :
  forall (i j : 'I_3),  t1 \in (enum tr) -> t2 \in (enum tr) ->
  t1 i = t2 (j + 1) -> t1 (i + 1) = t2 j -> ~ point_in (t2 (j + 1 + 1)) t1.
Proof.
move => i j t1_in t2_in h1 h2.
rewrite /point_in.
move /existsP => [] x.
rewrite -(subrK i x).
elim/elimI3: (x - i).
    rewrite add0r h1 => /eqP h3.
    have := tr_orientation t2_in.
    rewrite (triangle_area_no_dup h3).
    by rewrite Order.POrderTheory.ltxx.
  rewrite addrC h2 eq_sym -[X in (_ == t2 X)]addr0 -p1p11 !addrA=> /eqP h3.
  have := tr_orientation t2_in.
  rewrite (triangle_area_no_dup h3).
  by rewrite Order.POrderTheory.ltxx.
rewrite addrC addrA => /eqP h3.
have := tr_orientation t1_in.
rewrite (starter_pt_triangle_area i) h1 h2 h3 -(inv_cycle_tr_area R)
  (flipr_tr_area R) -(starter_pt_triangle_area j) oppr_gt0.
rewrite Order.POrderTheory.lt_gtF.
  by [].
by apply: (tr_orientation t2_in).
Qed.

Lemma p1p1p1_I3 :
  forall (i : 'I_3), (i + 1 + 1 + 1 : 'I_3) = i.
Proof.
apply: elimI3; by apply /eqP.
Qed.

Definition tr_dist (t : T) (p : P) :=
  out_circle R (coords (t 0)) (coords (t 1)) (coords (t (1 + 1))) (coords p).

Lemma starter_pt_dist (i : 'I_3) (t : T) (p : P) :
  tr_dist t p = out_circle R (coords (t i)) (coords (t (i + 1))) (coords (t (i + 1 + 1))) (coords p).
Proof.
move: i.
apply : elimI3.
    by rewrite p10 p1p10.
  by rewrite p1p11 (inv_cycle_out_circle R).
by rewrite p1p11 p10 -(inv_cycle_out_circle R).
Qed.

Lemma unique_edge :
  forall (t : T) (e : E), (t \in (enum tr)) -> (edge_in e t) ->
    forall (t' : T), (t' \in (enum tr)) -> t' != t -> ~ (edge_in e t').
Proof.
move => t e t_in.
rewrite /edge_in.
move /existsP => [] i.
move /eqP => h1.
move => t' t'_in h2.
move /existsP => [] j.
move /eqP.
rewrite -h1 /edges_tr !ffunE.
move /ffunP => H.
move : (H 0).
rewrite !ffunE /=.
move: (H 1).
rewrite !ffunE /=.
move /eqP => H1.
move /eqP => H2.
have aux : t' = t.
  apply /eqP.
  by rewrite (tr_triangulation t'_in t_in H2 H1).
rewrite -aux in h2.
move : h2.
by rewrite eq_refl.
Qed.

Fixpoint find_triangle_in_list (p : T -> bool) (tr_enum : list T) : option T :=
  match tr_enum with
  | nil => None
  | t :: tail => if (p t) then Some t else find_triangle_in_list p tail
  end.

Lemma correc_find_triangle_in_list (p : T -> bool) (tr_enum : list T) :
  forall (t : T),
  find_triangle_in_list p tr_enum = Some t -> (p t) /\ (t \in tr_enum).
Proof.
move => t.
elim: tr_enum.
  by [].
move => a l HR.
rewrite /find_triangle_in_list.
case_eq (p a).
  move => h0.
  move /Some_inj => h1.
  rewrite -h1.
  split.
    by [].
  rewrite in_cons.
  apply /orP.
  by left.
move => npa H.
have Pl : p t /\ t \in l.
  by apply: HR.
destruct Pl as [H1 H2].
have t_in_al : t \in a :: l.
  rewrite in_cons.
  apply /orP.
  by right.
by split.
Qed.

Lemma unique_result (p : T -> bool) (tr_enum : list T) :
  forall (t1 : T),
  (p t1) -> (forall (t2 : T), (t2 \in (tr_enum)) ->  t2 != t1 -> ~ (p t2)) ->
    (find_triangle_in_list p (tr_enum) = Some t1) \/ ~~ (t1 \in tr_enum).
Proof.
move => t1 h0.
elim : tr_enum.
  right.
  by rewrite in_nil.
move => a l.
case_eq (t1 == a).
move => a_eq_t1_bool HR.
  left.
  have a_eq_t1 : t1 = a.
    by apply /eqP.
  by rewrite -a_eq_t1 /find_triangle_in_list h0.
move => a_diff_t1_bool HR.
have a_diff_t1 : t1 != a.
    by rewrite a_diff_t1_bool.
case_eq (p a).
  move => h1 h2.
  have not_pa : ~ p a.
    apply: h2.
      by rewrite in_cons eq_refl.
    by rewrite eq_sym.
  move : not_pa.
  by rewrite h1.
move => npa H.
rewrite /find_triangle_in_list npa.
have not_in (x y : T) (s : list T) : ((x == y) = false) -> ((x \in y :: s) = (x \in s)).
  move => H1.
  by rewrite in_cons H1 /=.
rewrite (not_in t1 a l a_diff_t1_bool).
apply : HR.
move => t2.
case_eq (t2 == a).
  move => t2a h1 h2.
  have ta : t2 = a.
    by apply /eqP.
  by rewrite ta npa.
move => nta.
rewrite -(not_in t2 a l nta).
by apply: H.
Qed.

Definition find_triangle_of_edge (e : E) : option T :=
  find_triangle_in_list (edge_in e) (enum tr).

Lemma correc_find_triangle (e : E) (t : T) :
  find_triangle_of_edge e = Some t <-> (edge_in e t) /\ (t \in (enum tr)).
Proof.
split.
  rewrite /find_triangle_of_edge.
  by apply: correc_find_triangle_in_list.
move => H.
destruct H as [H1 H2].
have uni_edge : forall (t' : T), (t' \in (enum tr)) -> t' != t -> ~ (edge_in e t').
  by apply: unique_edge H2 H1.
have aux : (find_triangle_in_list (edge_in e) (enum tr) = Some t) \/ (~~ (t \in (enum tr))).
  by apply: unique_result.
rewrite H2 /= in aux.
rewrite /find_triangle_of_edge.
by destruct aux.
Qed.

Lemma invariant_find_triangle_of_edge :
  forall (e : E) (t : T),
    find_triangle_of_edge e = Some t -> t \in enum tr.
move => e t.
have aux : (edge_in e t) /\ (t \in enum tr) -> t \in enum tr.
  by move => [H1 H2].
move => h.
apply: aux.
by apply (correc_find_triangle e t).
Qed.

Variable target_pt : P.

Definition is_separating_edge (t : T) (i : 'I_3) :=
  0 < tr_area R (coords (t i)) (coords target_pt) (coords (t (i + 1))).

Definition separating_edge_i (t : T) (i : 'I_3) :=
  if (is_separating_edge t i) then Some (edges_tr t i)
    else if (is_separating_edge t (i + 1)) then Some (edges_tr t (i + 1))
    else if (is_separating_edge t (i + 1 + 1)) then Some (edges_tr t (i + 1 + 1))
    else None.

Definition separating_edge (t : T) :=
  separating_edge_i t 0.

Lemma separating_edge_is_separating_edge :
  forall (t : T) (i : 'I_3),
  separating_edge t = Some (edges_tr t i) -> is_separating_edge t i.
Proof.
have with_i (t : T) :
  forall (i : 'I_3),
  separating_edge_i t i = Some (edges_tr t i) -> is_separating_edge t i.
  rewrite /separating_edge_i.
  apply: elimI3.
      rewrite !p10 !p1p10.
      case: (is_separating_edge t 0).
        by [].
      case: (is_separating_edge t 1).
        move /eqP.
        by apply: inj_edges_tr.
      case: (is_separating_edge t (1 + 1)).
        move /eqP.
        by apply: inj_edges_tr.
      by [].
    rewrite p1p11.
    case: (is_separating_edge t 1).
      by [].
    case: (is_separating_edge t (1 + 1)).
      move /eqP.
      by apply: inj_edges_tr.
    case: (is_separating_edge t 0).
      move /eqP.
      by apply: inj_edges_tr.
    by [].
  rewrite p1p11 p10.
  case: (is_separating_edge t (1 + 1)).
    by [].
  case: (is_separating_edge t 0).
    move /eqP.
    by apply: inj_edges_tr.
  case: (is_separating_edge t 1).
    move /eqP.
    by apply: inj_edges_tr.
  by [].
move => t.
apply : elimI3.
    have i_0 : separating_edge t = separating_edge_i t 0.
      by [].
    rewrite i_0.
    apply: (with_i t 0).
  have i_1 :
    separating_edge t = Some (edges_tr t 1) ->
      separating_edge_i t 1 = Some (edges_tr t 1).
    rewrite /separating_edge /separating_edge_i.
    case : (is_separating_edge t 0).
      move /eqP.
      by move => /inj_edges_tr.
    rewrite p10.
    case: (is_separating_edge t 1).
      by [].
    case: (is_separating_edge t (1 + 1)).
      move /eqP.
      by move => /inj_edges_tr.
    by [].
  move => h.
  apply: (with_i t 1).
  by apply: i_1.
have i_2 :
  separating_edge t = Some (edges_tr t (1 + 1)) ->
    separating_edge_i t (1 + 1) = Some (edges_tr t (1 + 1)).
  have i_2_sub :
    separating_edge_i t 1 = Some (edges_tr t (1 + 1)) ->
      separating_edge_i t (1 + 1) = Some (edges_tr t (1 + 1)).
    rewrite /separating_edge /separating_edge_i.
    case : (is_separating_edge t 1).
      move /eqP.
      by move => /inj_edges_tr.
    case : (is_separating_edge t (1 + 1)).
      by [].
    rewrite p1p11.
    case : (is_separating_edge t 0).
      move /eqP.
      by move => /inj_edges_tr.
    by [].
  have sub_i_2 :
    separating_edge t = Some (edges_tr t (1 + 1)) ->
      separating_edge_i t 1 = Some (edges_tr t (1 + 1)).
    rewrite /separating_edge /separating_edge_i.
    rewrite p10.
    case : (is_separating_edge t 0).
      move /eqP.
      by move => /inj_edges_tr.
    case : (is_separating_edge t 1).
      move /eqP.
      by move => /inj_edges_tr.
    case : (is_separating_edge t (1 + 1)).
      by [].
    by [].
  move => h.
  apply: i_2_sub.
  by apply: sub_i_2.
move => h.
apply: (with_i t (1 + 1)).
by apply: i_2.
Qed.

Lemma separating_edge_in_triangle :
  forall (e : E) (t : T),
  separating_edge t = Some e -> edge_in e t.
Proof.
move => e t h.
rewrite /edge_in.
apply /existsP.
rewrite /separating_edge /separating_edge_i in h.
move: h.
case: (is_separating_edge t).
  move => h.
  exists 0.
  apply /eqP.
  by apply : Some_inj h.
case: (is_separating_edge t).
  move => h.
  exists 1.
  apply /eqP.
  by apply : Some_inj h.
case: (is_separating_edge t).
  move => h.
  exists (1 + 1).
  apply /eqP.
  by apply : Some_inj h.
by [].
Qed.

Definition triangle_measure (t : T) :=
  power R (coords (t 0)) (coords (t 1)) (coords (t (1 + 1))) (coords target_pt).

Lemma starter_pt_measure (i : 'I_3) (t : T) (p : P) :
  triangle_measure t = power R (coords (t i)) (coords (t (i + 1))) (coords (t (i + 1 + 1))) (coords target_pt).
Proof.
move: i.
apply : elimI3.
    by rewrite p10.
  by rewrite p1p11 (inv_cycle_power R).
by rewrite p1p11 p10 -(inv_cycle_power R).
Qed.

Hypothesis is_Delaunay_tr :
  forall (t1 t2 : T) (i : 'I_3), t1 \in (enum tr) -> t2 \in (enum tr) ->
  ( ~ point_in (t2 i) t1) -> 0 < tr_dist t1 (t2 i).

Lemma decrease_condition :
  forall (e : E) (t t' : T), (t \in enum tr) ->
  separating_edge t = Some e ->
    find_triangle_of_edge (oppos_edge e) = Some t' -> walk_lt R [finType of T] triangle_measure t' t.
Proof.
move => e t1 t2 t1_tr h1 h2.
have t2_tr : t2 \in enum tr.
  have aux : (edge_in (oppos_edge e) t2) /\ (t2 \in (enum tr)) -> (t2 \in enum tr).
    move => H.
    by destruct H as [H1 H2].
  apply: aux.
  rewrite -correc_find_triangle.
  by apply: h2.
have neighbours : exists (i j : 'I_3),
  (t1 i = t2 (j + 1)) /\ (t1 (i + 1) = t2 j) /\
  (is_separating_edge t1 i) /\ ~ point_in (t2 (j + 1 + 1)) t1.
  have e_in_t1: exists (i : 'I_3), edges_tr t1 i = e.
    apply: edge_in_exists.
    by apply: separating_edge_in_triangle h1.
  have oppos_e_in_t2: exists (i : 'I_3), edges_tr t2 i = oppos_edge e.
    apply: edge_in_exists.
    have aux : (edge_in (oppos_edge e) t2) /\ (t2 \in (enum tr)) -> edge_in (oppos_edge e) t2.
      move => H.
      by destruct H as [H1 H2].
    apply: aux.
    rewrite -correc_find_triangle.
    by apply: h2.
  destruct e_in_t1 as [i].
  have edge_is_separating : is_separating_edge t1 i.
    apply: separating_edge_is_separating_edge.
      rewrite H.
      by apply: h1.
  destruct oppos_e_in_t2 as [j].
  rewrite -H in H0.
  move: H0.
  rewrite -ffunP .
  move => H'.
  move: (H' 0).
  move: (H' 1).
  move => H0 H1.
  rewrite !ffunE /= in H0.
  rewrite !ffunE /= in H1.
  have diff_point :
    ~ point_in (t2 (j + 1 + 1)) t1.
    apply: common_points.
          by [].
        by [].
      by rewrite H0.
    by rewrite H1.
    rewrite /edge_in.
  exists i.
  exists j.
  split; by [].
rewrite /walk_lt -subr_gt0.
destruct neighbours as [i h].
destruct h as [j].
rewrite (starter_pt_measure i t1 target_pt) (starter_pt_measure (j + 1) t2 target_pt).
rewrite p1p1p1_I3.
destruct H as [H1 H2].
destruct H2 as [H2 H3].
destruct H3 as [H3 H4].
rewrite -H1 -H2.
apply: (power_decrease R).
      rewrite -(starter_pt_triangle_area i t1).
      by apply: tr_orientation.
    rewrite H1 H2.
    rewrite (inv_cycle_tr_area R).
    rewrite -(starter_pt_triangle_area j t2).
    by apply: tr_orientation.
  by apply: H3.
rewrite -(starter_pt_dist i t1).
by apply: is_Delaunay_tr.
Qed.

Definition walk_impl :=
  walk R [finType of E] [finType of T] edge_in tr
 oppos_edge separating_edge
  find_triangle_of_edge correc_find_triangle triangle_measure decrease_condition.

Lemma walk_impl_result_edge :
  forall (e : E) (t : {t : T | t \in enum tr}),
  walk_impl t = inr e -> (exists (t1 : T), edge_in (oppos_edge e) t1) /\
    (forall (t2 : T), t2 \in enum tr -> ~~ edge_in e t2).
Proof.
apply: walk_result_edge.
apply: inv_oppos_edge.
apply: separating_edge_in_triangle.
Qed.

Definition target_in_impl :=
  target_in [finType of E] [finType of T] separating_edge.

Lemma walk_impl_result_triangle :
  forall (t1 : {t : T | t \in enum tr}) (t2 : T),
  walk_impl t1 = inl t2 -> target_in_impl t2.
Proof.
by apply: walk_result_triangle.
Qed.

End implementation.


(*Shallow embedding of simple constructs from the monadic language into the store-passing logic*)
From Coq Require Import Lists.List.
From mathcomp Require Import ssreflect ssrfun ssrbool seq eqtype ssrnat.
From istari Require Import Tactics Sequence source subst_src rules_src.
From istari Require Import basic_types basic_types0 Syntax Subst SimpSub Promote Hygiene
     ContextHygiene Equivalence Rules Defined.

(*small abbreviations that will help us later*)
Definition app3 w i u l : term obj :=
 app (app (app w i) u) l.

(*quickly access the nth element of the big tuple in the comp type*)
Definition picomp1 (M: term obj) := ppi1 M.
Definition picomp2 (M: term obj) := ppi1 (ppi1 (ppi2 M) ).
Definition picomp3 (M: term obj) := ppi2 (ppi1 (ppi2 M)).
Definition picomp4 (M: term obj) := ppi2 (ppi2 M).
(********************************************)

(*useful types*)

Definition plus L R : (term obj) := sigma booltp (bite (var 0) (subst (sh 1) L)
                                           (subst (sh 1) R) ).
Definition inl L: term obj := ppair btrue L.
Definition inr R: term obj := ppair bfalse R.

Definition opt w: term obj := sigma booltp (bite (var 0) w unittp).

Definition laters A : term obj := rec (plus (shift 1 A) (fut (var 0))).
(*notice similarity w type of nat in logic*)
(********************************************)

(*useful terms*)

(*Unguarded recursion*)
Definition Yc: (term obj) := lam ((*f := 0*)
                   app
                     (lam ( (*f := 1, x := 0*)
                          let f := (var 1) in
                          let x := (var 0) in
                app f (next (app (prev x) x))
                        )
                     )
                (next
                   (lam (*f := 1, x := 0*)
                      (
                          let f := (var 1) in
                          let x := (var 0) in
                   app f (next (app (prev x) x))
                      )
                ))
).

(*Computation monad*)
Definition ret: term obj := lam (inl (var 0)).

Definition ret_a x := inl x.

Definition bind : term obj := app Yc
   (lam   ( (*f := 0*)
      lam ( (*f:= 1, x := 0*)
          lam ( (*f:= 2, x := 1, g := 0*)
              let f := (var 2) in
              let x := (var 1) in
              let g := (var 0) in
              let y := ppi2 x in
         bite (ppi1 x) (app g y)
              (let y' := prev y in
               let f' := prev f in
               inr (next (app (app f' y') g))) )
        ))).

Definition make_bind E1 E2 := app (app bind E1) E2.

(*worlds*)

Definition preworld: (term obj) := rec
                                   (arrow nattp (karrow (fut (var 0)) (arrow (fut nattp) U0))).

Definition world: (term obj) := sigma preworld nattp.

Definition len w: (term obj) := ppi2 w.

Definition nth w n: term obj := app (ppi1 w) n.

 Definition subseq w1 l1 w2 l2 :=
            prod (leq_t l1 l2)
                 (all nzero (fut preworld)
                 (*u = 0*)
                 (pi (fut nattp) (*u = 1, l = 0*)
                     (pi (nattp) (*u = 2, l = 1, i = 0*)(
                           arrow (lt_t (var 0) (subst (sh 3) l1))
                              (
                          eqtype (app3 (subst (sh 3) w1) (var 0) (var 2) (var 1))
                          (app3 (subst (sh 3) w2) (var 0) (var 2) (var 1))
                              )
                                                   )
                                           )

                 )).

 Definition make_subseq: term obj := ppair triv (lam (lam (lam triv)) ).

 Definition make_subseq_trans l1 l2 l3 M1 M2 :=
  ppair (leq_trans_fn_app l1 l2 l3
                          (ppi1 M1) (ppi1 M2)
        )
        (lam (lam (lam triv))).

 Definition make_subseq_refl l :=
  ppair (app leq_refl_fn l)
        (lam (lam (lam triv))).
 (*transitivity of subseq*)

 (*need to do refl*)

(*mysterious error Definition if_z (n: term obj) := ppi1 n. *)

(********************************************)

 (*memory store*)

 (*gettype w v is a function which, when given an index i, gives the type
  at index i in w *)
 Definition gettype w v lv: (term obj) := pi nattp ((*i = 0*)
                                           let i := var 0 in
                                           app (app (app (shift 1 w) i) (next (shift 1 v))) (next (shift 1 lv))
                                         ).

 (*the type of the store at world <w, l>*)
 Definition store w l := all nzero preworld (pi nattp (*v = 1, l v= 0*)
                                                (
                                                  (arrow (subseq (shift 2 w) (shift 2 l) (var 1) (var 0))
                                                         (gettype (shift 2 w) (var 1) (var 0))))
                                                ).

(********************************************)

(*moving terms in a world to a future world*)

 (*start here get rid of vacuous cases w program module*)
 Definition move (A: source.term) l1 l2: term obj :=
   match A with
     nattp_m => lam (lam (var 0))
   | arrow_m _ _ =>
lam ( (*m0 := 0*)
lam ( lam (
       lam ( (*m0:= 3, f := 2, l := 1, m:= 0*)
           lam (*m0:= 4, f := 3, l := 2 m:= 1 x := 0*)
             ( (*let m := var 3 in*)
               let f := var 3 in
               let l := var 2 in
             let x := var 0 in
             app (app (app f l) (make_subseq_trans (subst (sh 5) l1)
                                                   (subst (sh 5) l2)
                                                   l
                                                   (var 4)
                                                   (var 1)) (*m o m0*)

                 ) x )))))
     | comp_m _ => lam (lam (* m0= 1, c:= 0,*) ( lam (
                           lam (*m0 = 3, c:= 2, l = 1, m := 0*)
                             (lam (*m0 = 4, c:= 3, l = 2, m := 1, s := 0*)
                                (
                                  let c:= var 3 in
                                  let l:= var 2 in
                                let s := var 0 in
                                app (app (app c l)
                                         (make_subseq_trans (subst (sh 5) l1)
                                                   (subst (sh 5) l2)
                                                   l
                                                   (var 4)
                                                   (var 1))
                                    ) s
                                (*compose_sub m m0*)
                             )
                         ))))
     | reftp_m _ => lam (lam (*R := 0*)
                          (let i := ppi1 (var 0) in
                           let iltl1 := ppi1 (ppi2 (var 0)) in
                             ppair i (ppair (lt_trans_fn_app i (subst (sh 2) l1)
                                                             (subst (sh 2) l2)
                                                             iltl1
                                                             (ppi1 (var 1))
                                            )
                                        (lam triv))
                          ))
     | unittp_m  => lam (lam (var 0))
     | _ => lam (lam triv) (*not a type operator, error case*)
end.

 Definition move_app A l1 l2 (m : term obj) (x: term obj) :=
   app (app (move A l1 l2) m) x.

Opaque laters preworld U0 subseq leqtp nzero nattp world nth.

(*cons_b w l x is a preworld equal to <w, l> only with x consed onto the back*)

(*translation of source contexts to target contexts (at a given world)*)

(*makes a product type at a world out of a source context *)

Definition cons_b w l x :=lam (let i := (var 0) in
                              bite (ltb_app i (shift 1 l)) (app (shift 1 w) i) (shift 1 x)).


Require Import Coq.Logic.ProofIrrelevance.
Require Import RamifyCoq.lib.Ensembles_ext.
Require Import Coq.Lists.List.
Require Import Coq.Classes.Morphisms.
Require Import RamifyCoq.lib.Coqlib.
Require Import RamifyCoq.lib.List_ext.
Require Import RamifyCoq.lib.EquivDec_ext.
Require Import VST.msl.Coqlib2.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.path_lemmas. Import RamifyCoq.graph.path_lemmas.PathNotation.
Require Import RamifyCoq.graph.reachable_computable.
Require Import RamifyCoq.graph.reachable_ind.
Require Import RamifyCoq.graph.graph_gen.
Require Import RamifyCoq.graph.graph_relation.
Require Import RamifyCoq.graph.subgraph2.

Module SIMPLE_MARK_GRAPH.
Section SIMPLE_MARK_GRAPH.

  Context {V : Type}.
  Context {E : Type}.
  Context {EV: EqDec V eq}.
  Context {EE: EqDec E eq}.

  Section SINGLE_GRAPH_LEM.

  Context (g: PreGraph V E).

(*
  Definition reachable_sub_markedgraph (G: Gph) x: Gph :=
    Build_MarkedGraph _ _ (reachable_subgraph G x) (marked G).

  Definition unmarked (g: Gph): NodePred g := negateP (marked g).

  Lemma unmarked_spec (g: Gph): forall x, (unmarked g) x <-> ~ (marked g) x.
  Proof. apply negateP_spec. Qed.
*)
  Definition mark1 (m1 : NodePred V) (n : V) (m2 : NodePred V) : Prop :=
    vvalid g n /\ m2 n /\ forall n', n <> n' -> (m1 n' <-> m2 n').

  Definition mark (m1 : NodePred V) (root : V) (m2 : NodePred V) : Prop :=
    (forall n,  g |= root ~o~> n satisfying (negateP m1) -> m2 n) /\
    (forall n, ~g |= root ~o~> n satisfying (negateP m1) -> (m1 n <-> m2 n)).

  Inductive mark_list: NodePred V -> list V -> NodePred V -> Prop :=
  | mark_list_nil: forall m m0, (m ~=~ m0)%NodePred -> mark_list m nil m0
  | mark_list_cons: forall m m0 m1 v vs, mark m v m0 -> mark_list m0 vs m1 -> mark_list m (v :: vs) m1
  .

  Lemma mark1_marked: forall m1 root m2,
                        mark1 m1 root m2 ->
                        forall n, m1 n -> m2 n.
  Proof.
    intros. destruct H as [? [? ?]].
    destruct_eq_dec root n.
    subst. auto. specialize (H2 n H3). tauto.
  Qed.

  (* The first subtle lemma *)
  Lemma mark1_unmarked : forall m1 root m2 n,
    mark1 m1 root m2 ->
    g |= root ~o~> n satisfying (negateP m1) ->
    n = root \/ exists child, edge g root child /\ g |= child ~o~> n satisfying (negateP m2).
  Proof.
    intros. rewrite reachable_acyclic in H0. destruct H0 as [p [? ?]]. destruct p as [v p].
    assert (v = root) by (destruct H1 as [[? _] _]; simpl in H1; auto). subst v. destruct p.
    + left. destruct H1 as [[? ?] _]. simpl in H2. auto.
    + right. exists (dst g e). change (root, e :: p) with (path_glue (root, e :: nil) (dst g e, p)) in H1.
      apply (reachable_by_path_split_glue g) with (n := dst g e) in H1. 2: red; simpl; auto.
      destruct H1. split.
      - destruct H1 as [_ [[? [? [? ?]]] _]]. hnf. subst root. rewrite step_spec. do 2 (split; auto). exists e; auto.
      - exists (dst g e, p). destruct H2 as [? [? ?]]. split; [|split]; auto.
        rewrite path_prop_equiv in H4 |-* ; auto. rewrite epath_to_vpath_cons_eq in H0. 2: destruct H1 as [_ [[? _] _]]; auto.
        apply NoDup_cons_2 in H0. rewrite in_path_eq_epath_to_vpath in H0; auto. intros. specialize (H4 _ H5).
        destruct H as [? [? ?]]. rewrite negateP_spec in H4 |- *. rewrite <- H7; auto.
        intro. apply H0. subst; auto.
  Qed.

  (* Not the best name in the world... *)
  Lemma mark1_reverse_unmark: forall m1 root m2,
    mark1 m1 root m2 ->
    forall n1 n2,
      g |= n1 ~o~> n2 satisfying (negateP m2) ->
      g |= n1 ~o~> n2 satisfying (negateP m1).
  Proof.
    intros. destruct H0 as [p [? ?]]. exists p. split; trivial.
    destruct H1. destruct H as [? [? ?]].
    split. auto.
    rewrite path_prop_equiv in H2 |- *; auto.
    intros. specialize (H2 _ H5). specialize (H4 n).
    spec H4. intro. subst n. hnf in H3. hnf in H2. apply H2; auto.
    rewrite negateP_spec in H2 |- *; tauto.
  Qed.

  Lemma mark_exists: forall m x,
    vvalid g x ->
    ReachDecidable g x (negateP m) ->
    {m': NodePred V | mark m x m'}.
  Proof.
    intros. destruct ((node_pred_dec (negateP m)) x).
    + exists (existT (fun P => forall x, {P x} + {~ P x})
                     (fun y => g |= x ~o~> y satisfying (negateP m) \/ (m) y)
                     (fun y => sumbool_dec_or (X y) (node_pred_dec (m) y))).
      split.
      - intros; subst; hnf. auto.
      - split; intros; subst; simpl in *; tauto.
    + exists (m). split; intros.
      - destruct H0 as [path ?].
        apply (reachable_by_path_In g _ _ _ _ x) in H0.
        hnf in H0. tauto. destruct H0 as [[? _] _]. destruct path; simpl in H0; inversion H0. hnf; left; auto.
      - reflexivity.
  Qed.

  Lemma mark1_exists: forall m x, vvalid g x -> {m': NodePred V | mark1 m x m'}.
  Proof.
    intros. destruct ((node_pred_dec m) x).
    + exists m. split; auto. split; [exact a |]. intros; reflexivity.
    + assert (forall y, {y = x \/ m y} + {~ (y = x \/ m y)}).
      1: {
        intros.
        apply sumbool_dec_or.
        + apply equiv_dec.
        + apply node_pred_dec.
      }
      exists (existT _ (fun y => y = x \/ m y) X). split.
      * auto.
      * split; [simpl; auto |].
        intros; simpl.
        assert (n' <> x) by congruence. tauto.
  Qed.

  (* The second subtle lemma.  Maybe needs a better name? *)
  Lemma mark_unmarked: forall m1 root m2 n1 n2,
                         vvalid g root ->
                         ReachDecidable g root (negateP m1)->
                         mark m1 root m2 ->
                         g |= n1 ~o~> n2 satisfying (negateP m1) ->
                         (g |= n1 ~o~> n2 satisfying (negateP m2)) \/ (m2 n2).
  Proof.
    intros until n2. intros HH ENUMC; intros. destruct H0 as [p ?].
    (* This was a very handy LEM. *)
    destruct (exists_list_dec _ (epath_to_vpath g p) (fun n => g |= root ~o~> n satisfying (negateP m1))) as [?H | ?H].
    1: apply ENUMC.
    + right. destruct H as [? _]. apply H.
      destruct H1 as [n [? ?]]. apply reachable_by_trans with n; trivial.
      rewrite in_path_eq_epath_to_vpath in H1. 2: destruct H0 as [_ [? _]]; auto.
      destruct (reachable_by_path_split_in g _ _ _ _ _ H0 H1) as [p1 [p2 [? [? ?]]]].
      exists p2. trivial.
    + left. exists p. destruct H0. split; trivial. clear H0.
      destruct H2. destruct H as [_ ?]. split; auto.
      rewrite path_prop_equiv in H2 |-* ; auto.
      intros x ?. specialize (H2 x H3). specialize (H x).
      spec H. intro. apply H1. exists x. rewrite in_path_eq_epath_to_vpath; auto.
      rewrite negateP_spec in H2 |- *; tauto.
  Qed.

  Lemma mark_unmarked_strong: forall m1 root m2 n1 n2,
                                vvalid g root ->
                                ReachDecidable g root (negateP m1) ->
                                mark m1 root m2 ->
                                g |= n1 ~o~> n2 satisfying (negateP m1) ->
                                Decidable (g |= n1 ~o~> n2 satisfying (negateP m2)).
  Proof.
    intros.
    pose proof mark_unmarked _ _ _ _ _ H X H0 H1.
    destruct (node_pred_dec (m2) n2); [| left; tauto].
    right.
    intro.
    rewrite reachable_by_eq_subgraph_reachable in H3.
    apply reachable_foot_valid in H3.
    simpl in H3.
    destruct H3.
    rewrite negateP_spec in H4; tauto.
  Qed.

  Lemma mark_invalid: forall m1 root m2,
                         ~ vvalid g root ->
                         mark m1 root m2 ->
                         (m1 ~=~ m2)%NodePred.
  Proof.
    intros.
    destruct H0 as [? ?].
    intro; intros.
    apply H1.
    intro.
    apply reachable_by_head_valid in H2.
    tauto.
  Qed.

  Lemma mark_invalid_refl: forall m root,
                         ~ vvalid g root ->
                         mark m root m.
  Proof.
    intros.
    split.
    + intros.
      apply reachable_by_head_valid in H0.
      tauto.
    + intros.
      reflexivity.
  Qed.

  Lemma mark_marked_root: forall (m1: NodePred V) root m2,
                         m1 root ->
                         mark m1 root m2 ->
                         (m1 ~=~ m2)%NodePred.
  Proof.
    intros.
    destruct H0 as [? ?].
    intro; intros.
    apply H1.
    intro.
    rewrite reachable_by_eq_subgraph_reachable in H2.
    apply reachable_head_valid in H2.
    simpl in H2.
    unfold predicate_vvalid in H2.
    rewrite negateP_spec in H2.
    tauto.
  Qed.

  Lemma mark_marked_root_refl: forall (m: NodePred V) root,
                         m root ->
                         mark m root m.
  Proof.
    intros.
    split.
    + intros.
      apply reachable_by_head_prop in H0.
      rewrite negateP_spec in H0.
      tauto.
    + intros.
      reflexivity.
  Qed.

  Lemma mark_marked: forall m1 root m2,
                       mark m1 root m2 ->
                       ReachDecidable g root (negateP m1) ->
                       forall n, m1 n -> m2 n.
  Proof.
    intros. destruct H as [? ?].
    destruct (X n). auto. specialize (H1 n n0). tauto.
  Qed.

  Lemma mark_marked_strong:
    forall m1 root m2 n,
      mark m1 root m2 ->
      ReachDecidable g root (negateP m1) ->
      g |= root ~o~> n satisfying (negateP m1) \/ m1 n ->
      m2 n.
  Proof.
    intros.
    destruct H0; [| eapply mark_marked; eauto].
    destruct H.
    eapply H; eauto.
  Qed.

  (* Maybe a better name? *)
  Lemma mark_reverse_unmarked: forall m1 root m2,
                                 mark m1 root m2 ->
                                 forall n1 n2,
                                 ReachDecidable g root (negateP m1) ->
                                 g |= n1 ~o~> n2 satisfying (negateP m2) ->
                                 g |= n1 ~o~> n2 satisfying (negateP m1).
  Proof.
    intros.
    eapply reachable_by_weaken; [| eauto].
    change (@app_node_pred _ (negateP m2)) with (Complement _ (projT1 m2)).
    change (@app_node_pred _ (negateP m1)) with (Complement _ (projT1 m1)).
    apply Complement_Included_rev.
    intro; apply mark_marked with (root := root); auto.
  Qed.

  Lemma mark_reverse_unmarked_strong:
    forall m1 root m2,
      mark m1 root m2 ->
      forall n1 n2,
      ReachDecidable g root (negateP m1) ->
      g |= n1 ~o~> n2 satisfying (negateP m2) ->
      (predicate_partialgraph g (Complement _ (reachable_by g root (negateP m1)))) |= n1 ~o~> n2 satisfying (negateP m1).
  Proof.
    intros.
    rewrite reachable_by_eq_partialgraph_reachable.
    rewrite partial_partialgraph.
    rewrite <- reachable_by_eq_partialgraph_reachable.
    eapply reachable_by_weaken; [| eauto].
    change (@app_node_pred _ (negateP m2)) with (Complement _ (projT1 m2)).
    change (@app_node_pred _ (negateP m1)) with (Complement _ (projT1 m1)).
    rewrite Intersection_Complement.
    apply Complement_Included_rev.
    intro x; unfold Ensembles.In.
    rewrite Union_spec.
    apply mark_marked_strong; auto.
  Qed.

  Lemma mark_preserved_reach_decidable: forall m1 root m2 x,
    vvalid g root ->
    ReachDecidable g x (negateP m1) ->
    ReachDecidable g root (negateP m1) ->
    mark m1 root m2 ->
    ReachDecidable g x (negateP m2).
  Proof.
    intros. intro. destruct (X y).
    + apply (mark_unmarked_strong m1 root); auto.
    + right. intro. apply n. apply (mark_reverse_unmarked _ root m2); auto.
  Qed.

  Lemma ind_RV_DEC: forall (P: NodePred V -> list V -> NodePred V -> Prop),
    (forall m m', (m ~=~ m')%NodePred -> P m nil m') ->
    (forall m v m' l m'',
      P m' l m'' ->
      forall
        (R_DEC: forall x, In x (v :: l) -> ReachDecidable g x (negateP m))
        (V_DEC: forall x, In x (v :: l) -> Decidable (vvalid g x)),
      mark m v m' ->
      mark_list m' l m'' ->
      P m (v :: l) m'') ->
    (forall m l m',
      (forall x, In x l -> ReachDecidable g x (negateP m)) ->
      (forall x, In x l -> Decidable (vvalid g x)) ->
      mark_list m l m' ->
      P m l m').
  Proof.
    intros P H_nil IH m l m' R_DEC V_DEC ?.
    induction H.
    + apply H_nil; auto.
    + apply (IH m v m0 vs m1); auto.
      apply IHmark_list.
      - destruct (V_DEC v (or_introl eq_refl)) as [?H | ?H].
        * intros.
          apply (mark_preserved_reach_decidable m v); auto.
          1: apply R_DEC; right; auto.
          1: apply R_DEC; left; auto.
        * pose proof mark_invalid m v m0 H1 H.
          intros.
          apply (ReachDecidable_si g g (negateP m)); [reflexivity | | apply R_DEC; right; auto].
          hnf in H2 |- *; clear - H2.
          intros; specialize (H2 x).
          rewrite !negateP_spec; tauto.
      - intros; apply V_DEC; right; auto.
  Qed.

  Lemma mark_list_marked: forall m1 l m2
    (R_DEC: forall x, In x l -> ReachDecidable g x (negateP m1))
    (V_DEC: forall x, In x l -> Decidable (vvalid g x)),
    mark_list m1 l m2 ->
    forall n : V, m1 n -> m2 n.
  Proof.
    apply (ind_RV_DEC (fun m1 l m2 => forall n : V, m1 n -> m2 n)).
    + intros.
      rewrite <- (H n).
      auto.
    + intros.
      apply H.
      apply (mark_marked m v m'); auto.
      apply R_DEC; left; auto.
  Qed.

  Lemma mark_list_get_marked: forall m1 l m2
    (R_DEC: forall x, In x l -> ReachDecidable g x (negateP m1))
    (V_DEC: forall x, In x l -> Decidable (vvalid g x)),
    mark_list m1 l m2 ->
    forall z n,
    In z l ->
    g |= z ~o~> n satisfying (negateP m1) ->
    m2 n.
  Proof.
    apply (ind_RV_DEC (fun m1 l m2 =>
            forall z n : V, In z l -> g |= z ~o~> n satisfying (negateP m1) -> m2 n)).
    + intros.
      inversion H0.
    + intros.
      destruct H2.
      - subst z. apply (mark_list_marked m' l m''); auto.
        * intros.
          apply (mark_preserved_reach_decidable m v m'); auto.
          1: apply reachable_by_head_valid in H3; auto.
          1: apply R_DEC; right; auto.
          1: apply R_DEC; left; auto.
        * intros; apply V_DEC; right; auto.
        * destruct H0 as [? _]; auto.
      - destruct (V_DEC v (or_introl eq_refl)).
        1: {
          apply (mark_unmarked m v m') in H3; auto; [| apply R_DEC; left; auto].
          destruct H3.
          + apply (H z); auto.
          + apply (mark_list_marked m' l); auto.
            - intros.
              apply (mark_preserved_reach_decidable m v m'); auto.
              * apply R_DEC; right; auto.
              * apply R_DEC; left; auto.
            - intros; apply V_DEC; right; auto.
        }
        1: {
          pose proof (mark_invalid m v m' n0 H0).
          apply (H z); auto.
          erewrite si_reachable_by in H3; [exact H3 | reflexivity |].
          hnf in H4 |- *; clear - H4.
          intros.
          specialize (H4 x).
          rewrite !negateP_spec.
          tauto.
        }
  Qed.

  Lemma mark_list_preserve_marked: forall m1 l m2
    (R_DEC: forall x, In x l -> ReachDecidable g x (negateP m1))
    (V_DEC: forall x, In x l -> Decidable (vvalid g x)),
    mark_list m1 l m2 ->
    forall n,
    (forall x, In x l -> ~ g |= x ~o~> n satisfying (negateP m1)) ->
    (m1 n <-> m2 n).
  Proof.
    apply (ind_RV_DEC (fun m1 l m2 =>
            forall n,
           (forall x, In x l -> ~ g |= x ~o~> n satisfying (negateP m1)) ->
           (m1 n <-> m2 n))).
    + intros. apply H.
    + intros.
      rewrite <- H.
      - destruct H0 as [_ ?].
        apply H0, H2.
        left; auto.
      - intros.
        intro.
        apply (mark_reverse_unmarked m v m') in H4; [| auto | apply R_DEC; left; auto].
        apply (H2 x); auto.
        right; auto.
  Qed.

  Lemma mark_mark1_mark: forall m1 root l m2 m3
    (R_DEC: forall x, In x l -> ReachDecidable g x (negateP m2))
    (V_DEC: forall x, In x l -> Decidable (vvalid g x)),
    vvalid g root -> (negateP m1) root ->
    step_list g root l ->
    mark1 m1 root m2 ->
    mark_list m2 l m3 ->
    mark m1 root m3.
  Proof.
    intros. split; intros.
    + apply (mark1_unmarked _ _ _ _ H2) in H4. destruct H4.
      - subst n. destruct H2 as [_ [? _]].
        eapply mark_list_marked; eauto.
      - destruct H4 as [z [? ?]]. unfold edge in H4; rewrite <- (H1 z) in H4. destruct H4 as [_ [_ ?]].
        eapply mark_list_get_marked; eauto.
    + assert (m1 n <-> m2 n). {
        destruct H2 as [? [? ?]].
        apply H6. intro. apply H4. subst. apply reachable_by_refl; auto.
      } rewrite H5.
      assert (forall x, In x l -> ~ g |= x ~o~> n satisfying (negateP m2)). {
        intros. intro.
        destruct (V_DEC x H6).
        + apply (mark1_reverse_unmark m1 root) in H7; auto.
          apply H4. apply H1 in H6.
          apply edge_reachable_by with x; auto.
          unfold edge; auto.
        + apply reachable_by_head_valid in H7; tauto.
      }
      eapply mark_list_preserve_marked; eauto.
  Qed.

  Lemma mark_func: forall m root m1 m2 (R_DEC: ReachDecidable g root (negateP m)),
                     mark m root m1 ->
                     mark m root m2 ->
                     (m1 ~=~ m2)%NodePred.
  Proof.
    intros.
    intro; intros.
    destruct H as [? ?].
    destruct H0 as [? ?].
    destruct (R_DEC n).
    - specialize (H n r). specialize (H0 n r). tauto.
    - specialize (H2 n n0). specialize (H1 n n0). tauto.
  Qed.

  Lemma mark1_mark_list_vi: forall m1 root l m2 m3 m4
                                   (R_DEC: forall x, In x l -> ReachDecidable g x (negateP m2))
                                   (V_DEC: forall x, In x l -> Decidable (vvalid g x))
                                   (R_DEC': ReachDecidable g root (negateP m1)),
                              vvalid g root -> (negateP m1) root ->
                              step_list g root l ->
                              mark1 m1 root m2 ->
                              mark_list m2 l m3 ->
                              mark m1 root m4 ->
                              (m3 ~=~ m4)%NodePred.
  Proof.
    intros. assert (mark m1 root m3).
    apply (mark_mark1_mark _ _ l m2); auto.
    apply (mark_func m1 root); auto.
  Qed.

  Lemma mark_marked_reachable_conflict: forall m1 root m2 n
    (R_DEC: ReachDecidable g root (negateP m1)),
    mark m1 root m2 ->
    Included (reachable_by g n (negateP m2)) (Complement _ (reachable_by g root (negateP m1))).
  Proof.
    intros.
    intro n'; unfold Ensembles.In; intros.
    eapply mark_reverse_unmarked_strong in H0; [| eauto | eauto].
    apply reachable_by_is_reachable in H0.
    rewrite <- reachable_by_eq_partialgraph_reachable in H0.
    apply reachable_by_foot_prop in H0.
    auto.
  Qed.

  Lemma mark_list_marked_reachable_conflict: forall m1 l m2
    (R_DEC: forall x, In x l -> ReachDecidable g x (negateP m1))
    (V_DEC: forall x, In x l -> Decidable (vvalid g x)),
    mark_list m1 l m2 ->
    forall n,
    Included (reachable_by g n (negateP m2)) (Complement _ (reachable_by_through_set g l (negateP m1))).
  Proof.
    intros.
    intro n'; unfold Complement, Ensembles.In; intros.
    intros [? [? ?]].
    pose proof mark_list_get_marked _ _ _ R_DEC V_DEC H x n' H1.
    apply reachable_by_foot_prop in H0.
    change ((negateP m2) n') with (~ (m2 n')) in H0.
    tauto.
  Qed.

(*

  Lemma mark_unreachable: forall g1 root g2,
    mark g1 root g2 ->
    forall n, ~ (reachable g1 root n) -> @node_label _ _ _ g1 n = @node_label _ _ _ g2 n.
  Proof.
    intros. destruct H as [? [? ?]].
    apply H2.
    intro. apply H0.
    generalize (reachable_by_subset_reachable g1 root unmarked n); intro.
    intuition.
  Qed.

  Lemma mark_unreachable_subgraph:
    forall g1 root g2, mark g1 root g2 -> (unreachable_subgraph g1 (root :: nil)) -=- (unreachable_subgraph g2 (root :: nil)).
  Proof.
    intros. generalize H; intro. split; [|split]; intros; destruct H as [? [? ?]]; specialize (H v); destruct H. simpl.
    unfold unreachable_valid. split; intros; destruct H4; split. rewrite <- H. apply H4. intro; apply H5; clear H5.
    unfold reachable_through_set in *. destruct H6 as [s [? ?]]. exists s. split; auto. apply in_inv in H5. destruct H5. subst.
    destruct H0 as [? _]. apply si_sym in H0. apply (si_reachable _ _ s H0). auto. inversion H5. rewrite H. auto.
    intro; apply H5; clear H5. destruct H6 as [s [? ?]]. exists s. split; auto. apply in_inv in H5. destruct H5. subst.
    destruct H0 as [? _]. apply (si_reachable _ _ s H0). auto. inversion H5. simpl in H1. hnf in H1. destruct H1.
    assert (~ (reachable g1 root v)). intro; apply H5; clear H5. exists root. split. apply in_eq. auto.
    apply (mark_unreachable _ _ _ H0 v H6). auto.
  Qed.

*)

  End SINGLE_GRAPH_LEM.

  Instance mark1_proper: Proper (structurally_identical ==> node_pred_equiv ==> eq ==> node_pred_equiv ==> iff) mark1.
  Proof.
    hnf; intros g1 g2 Hg.
    do 3 (hnf; intros).
    subst.
    revert g1 g2 x y x1 y1 Hg H H1.
    assert (forall g1 g2 x y x1 y1, g1 ~=~ g2 -> x ~=~ y%NodePred -> x1 ~=~ y1%NodePred -> mark1 g1 x y0 x1 -> mark1 g2 y y0 y1);
      [| intros; split; apply H; auto; symmetry; auto].
    unfold mark1.
    intros.
    rewrite (H1 y0) in H2.
    rewrite (proj1 H) in H2.
    split; [| split]; try tauto.
    destruct H2 as [_ [_ ?]].
    intros; specialize (H2 n').
    rewrite (H0 n'), (H1 n') in H2.
    tauto.
  Qed.

  Lemma mark_proper_strong: forall (g g': PreGraph V E) m1 root m2,
    ((predicate_partialgraph g (reachable_by g root (negateP m1))) ~=~
    (predicate_partialgraph g' (reachable_by g' root (negateP m1)))) ->
    (mark g m1 root m2 <-> mark g' m1 root m2).
  Proof.
    assert (forall (g g': PreGraph V E) m1 root m2,
    ((predicate_partialgraph g (reachable_by g root (negateP m1))) ~=~
    (predicate_partialgraph g' (reachable_by g' root (negateP m1)))) ->
    mark g m1 root m2 -> mark g' m1 root m2).
    2: intros; split; apply H; auto; symmetry; auto.
    unfold mark; intros.
    split; intros; destruct H0.
    + apply H0.
      pose proof partialgraph_si_node_prop n g g' _ _ H.
      spec H3.
      1: {
        intros ? ?.
        apply reachable_by_foot_valid in H4.
        auto.
      }
      spec H3.
      1: {
        intros ? ?.
        apply reachable_by_foot_valid in H4.
        auto.
      }
      tauto.
    + apply H2.
      pose proof partialgraph_si_node_prop n g g' _ _ H.
      spec H3.
      1: {
        intros ? ?.
        apply reachable_by_foot_valid in H4.
        auto.
      }
      spec H3.
      1: {
        intros ? ?.
        apply reachable_by_foot_valid in H4.
        auto.
      }
      tauto.
  Qed.

  Lemma mark_list_proper_strong: forall (g g': PreGraph V E) m1 l m2
    (R_DEC: forall x, In x l -> ReachDecidable g x (negateP m1))
    (V_DEC: forall x, In x l -> Decidable (vvalid g x))
    (R_DEC': forall x, In x l -> ReachDecidable g' x (negateP m1))
    (V_DEC': forall x, In x l -> Decidable (vvalid g' x)),
    ((predicate_partialgraph g (reachable_by_through_set g l (negateP m1))) ~=~
    (predicate_partialgraph g' (reachable_by_through_set g' l (negateP m1)))) ->
    (mark_list g m1 l m2 <-> mark_list g' m1 l m2).
  Proof.
    intros.
    assert (forall (g: PreGraph V E) m1 l m2
    (R_DEC: forall x, In x l -> ReachDecidable g x (negateP m1))
    (V_DEC: forall x, In x l -> Decidable (vvalid g x)),
    mark_list g m1 l m2 ->
    forall (g': PreGraph V E),
    ((predicate_partialgraph g (reachable_by_through_set g l (negateP m1))) ~=~
    (predicate_partialgraph g' (reachable_by_through_set g' l (negateP m1)))) ->
    mark_list g' m1 l m2).
    2: intros; split; intros; eapply H0; eauto; symmetry; eauto; reflexivity.
    intro.
    apply (ind_RV_DEC g0 (fun m l m' => forall g'0 : PreGraph V E,
   (predicate_partialgraph g0 (reachable_by_through_set g0 l (negateP m))) ~=~
   (predicate_partialgraph g'0 (reachable_by_through_set g'0 l (negateP m))) ->
   mark_list g'0 m l m')); intros.
    + constructor.
      auto.
    + econstructor.
      - pose proof mark_proper_strong g0 g'0 m v m'.
        spec H4; [| rewrite <- H4; auto].
        eapply si_stronger_partialgraph with (p := (reachable_by g0 v (negateP m))); [| | exact H3]; intros.
        * assert (g0 |= v ~o~> v0 satisfying (negateP m) ->
            reachable_by_through_set g0 (v :: l0) (negateP m) v0); [intro | tauto].
          exists v; split; [simpl |]; auto.
        * pose proof reachable_by_partialgraph_reachable_by_equiv g0 (reachable_by_through_set g0 (v :: l0) (negateP m)) (negateP m) v.
          spec H5; [intro; intros; exists v; split; [simpl |]; auto |].
          pose proof reachable_by_partialgraph_reachable_by_equiv g'0 (reachable_by_through_set g'0 (v :: l0) (negateP m)) (negateP m) v.
          spec H6; [intro; intros; exists v; split; [simpl |]; auto |].
          rewrite H3 in H5.
          rewrite <- H5 in H6.
          clear H5.
          rewrite Same_set_spec in H6.
          specialize (H6 v0).
          assert (g'0 |= v ~o~> v0 satisfying (negateP m) ->
            reachable_by_through_set g'0 (v :: l0) (negateP m) v0); [intro | tauto].
          exists v; split; [simpl |]; auto.
      - apply H0.
        eapply si_stronger_partialgraph with (p := (reachable_by_through_set g0 l0 (negateP m'))); [| | eauto]; intros.
        * assert (reachable_by_through_set g0 l0 (negateP m') v0 ->
            reachable_by_through_set g0 (v :: l0) (negateP m) v0); [intro | tauto].
          destruct H4 as [vv [? ?]]; exists vv; split; [simpl |]; auto.
          eapply reachable_by_weaken; [| eauto].
          apply Complement_Included_rev; intro; eapply mark_marked; [eauto |].
          apply R_DEC0; simpl; auto.
        * assert (reachable_by_through_set g'0 l0 (negateP m') v0 <->
            reachable_by_through_set g0 l0 (negateP m') v0).
          1: {
            apply ex_iff; intro.
            apply and_iff_compat_l_weak; intro.
            pose proof reachable_by_partialgraph_reachable_by_equiv g0 (reachable_by_through_set g0 (v :: l0) (negateP m)) (negateP m') x.
            spec H5.
            1: {
              intro; intros; exists x.
              split; [simpl; auto |].
              eapply reachable_by_weaken; eauto.
              apply Complement_Included_rev; intro; eapply mark_marked; [eauto |].
              apply R_DEC0; simpl; auto.
            }
            pose proof reachable_by_partialgraph_reachable_by_equiv g'0 (reachable_by_through_set g'0 (v :: l0) (negateP m)) (negateP m') x.
            spec H6.
            1: {
              intro; intros; exists x.
              split; [simpl; auto |].
              eapply reachable_by_weaken; eauto.
              apply Complement_Included_rev; intro; eapply mark_marked; [eauto |].
              apply R_DEC0; simpl; auto.
            }
            rewrite H3 in H5.
            rewrite <- H5 in H6.
            rewrite Same_set_spec in H6.
            clear H5; apply H6.
          }
          assert (reachable_by_through_set g'0 l0 (negateP m') v0 ->
            reachable_by_through_set g'0 (v :: l0) (negateP m) v0); [clear H4; intro | tauto].
          destruct H4 as [vv [? ?]]; exists vv; split; [simpl |]; auto.
          eapply reachable_by_weaken; [| eauto].
          apply Complement_Included_rev; intro; eapply mark_marked; [eauto |].
          apply R_DEC0; simpl; auto.
  Qed.

  Instance mark_proper: Proper (structurally_identical ==> node_pred_equiv ==> eq ==> node_pred_equiv ==> iff) mark.
  Proof.
    hnf; intros g1 g2 Hg.
    do 3 (hnf; intros).
    subst.
    revert g1 g2 x y x1 y1 Hg H H1.
    assert (forall g1 g2 x y x1 y1, g1 ~=~ g2 -> x ~=~ y%NodePred -> x1 ~=~ y1%NodePred -> mark g1 x y0 x1 -> mark g2 y y0 y1);
      [| intros; split; apply H; auto; symmetry; auto].
    unfold mark.
    intros; destruct H2.
    split.
    + intros.
      rewrite <- (H1 n); apply H2; auto.
      rewrite si_reachable_by; [exact H4 | auto |].
      hnf; intros.
      rewrite !negateP_spec; specialize (H0 x0); tauto.
    + intros.
      rewrite <- (H0 n), <- (H1 n); apply H3; auto.
      rewrite si_reachable_by; [exact H4 | auto |].
      hnf; intros.
      rewrite !negateP_spec; specialize (H0 x0); tauto.
  Qed.

  Instance mark_list_proper: Proper (structurally_identical ==> node_pred_equiv ==> eq ==> node_pred_equiv ==> iff) mark_list.
  Proof.
    hnf; intros g1 g2 Hg.
    do 3 (hnf; intros).
    subst.
    revert g1 g2 x y x1 y1 Hg H H1.
    assert (forall g1 g2 x y x1 y1, g1 ~=~ g2 -> x ~=~ y%NodePred -> x1 ~=~ y1%NodePred -> mark_list g1 x y0 x1 -> mark_list g2 y y0 y1);
      [| intros; split; apply H; auto; symmetry; auto].
    intros; subst.
    revert g2 y y1 H H0 H1; induction H2; intros.
    + apply mark_list_nil.
      rewrite <- H1, <- H2, H; reflexivity.
    + apply mark_list_cons with m0.
      - rewrite <- H0, <- H1; auto.
      - apply IHmark_list; [auto | reflexivity | auto].
  Qed.

End SIMPLE_MARK_GRAPH.
End SIMPLE_MARK_GRAPH.

Existing Instances SIMPLE_MARK_GRAPH.mark1_proper SIMPLE_MARK_GRAPH.mark_proper SIMPLE_MARK_GRAPH.mark_list_proper.

Module MarkGraph.

Class MarkGraphSetting (DV: Type) := {
  label_marked: DV -> Prop;
  label_mark: DV -> DV;
  label_unmark: DV -> DV;
  marked_dec: forall x, {label_marked x} + {~ label_marked x};
  label_mark_sound: forall x, ~ label_marked x -> label_marked (label_mark x);
  label_unmark_sound: forall x, label_marked x -> ~ label_marked (label_unmark x)
}.

Section MarkGraph.

Context {V E: Type}.
Context {EV: EqDec V eq}.
Context {EE: EqDec E eq}.
Context {DV DE DG: Type}.
Context {MGS: MarkGraphSetting DV}.
Context {P: LabeledGraph V E DV DE DG -> Type}.

Notation Graph := (GeneralGraph V E DV DE DG P).
Local Coercion pg_lg : LabeledGraph >-> PreGraph.
Local Coercion lg_gg : GeneralGraph >-> LabeledGraph.

Definition marked (g: Graph) : NodePred V.
  refine (existT _ (fun v => label_marked (vlabel g v)) _).
  intros.
  apply marked_dec.
Defined.

Definition unmarked (g: Graph) (v: V) : Prop := negateP (marked g) v.

Definition mark1 (g1 : Graph) (n : V) (g2 : Graph) : Prop :=
  g1 ~=~ g2 /\
  vvalid g1 n /\
  marked g2 n /\
  forall n', n <> n' -> (marked g1 n' <-> marked g2 n').

Definition mark (g1 : Graph) (root : V) (g2 : Graph) : Prop :=
  g1 ~=~ g2 /\
  (forall n, g1 |= root ~o~> n satisfying (unmarked g1) -> marked g2 n) /\
  (forall n, ~ g1 |= root ~o~> n satisfying (unmarked g1) -> (marked g1 n <-> marked g2 n)).

Inductive mark_list: Graph -> list V -> Graph -> Prop :=
| mark_list_nil: forall g, mark_list g nil g
| mark_list_cons: forall (g g0 g1: Graph) v vs, mark g v g0 -> mark_list g0 vs g1 -> mark_list g (v :: vs) g1
.

Definition inj (g: Graph): NodePred V.
  exists (fun v => label_marked (vlabel g v)).
  intros; apply marked_dec.
Defined.
(*
Instance inj_proper: Proper ((fun (g1 g2: Graph) => (g1 ~=~ g2)%LabeledGraph) ==> node_pred_equiv) inj.
Proof.
  hnf; intros.
  intro; simpl.
  destruct H as [_ [? _]].
  rewrite H.
  tauto.
Defined.
*)
Lemma mark1_inj: forall (g1 g2: Graph) (v: V), mark1 g1 v g2 <-> (g1 ~=~ g2 /\ SIMPLE_MARK_GRAPH.mark1 g1 (inj g1) v (inj g2)).
Proof.
  intros.
  unfold mark1, SIMPLE_MARK_GRAPH.mark1.
  simpl.
  unfold marked.
  tauto.
Qed.

Lemma mark_inj: forall (g1 g2: Graph) (v: V), mark g1 v g2 <-> (g1 ~=~ g2 /\ SIMPLE_MARK_GRAPH.mark g1 (inj g1) v (inj g2)).
Proof.
  intros.
  unfold mark, SIMPLE_MARK_GRAPH.mark.
  simpl.
  unfold marked.
  tauto.
Qed.

Lemma mark_list_inj: forall (g1 g2: Graph) (vs: list V), mark_list g1 vs g2 -> (g1 ~=~ g2 /\ SIMPLE_MARK_GRAPH.mark_list g1 (inj g1) vs (inj g2)).
Proof.
  intros.
  induction H.
  - split; [reflexivity |].
    constructor.
    reflexivity.
  - rewrite mark_inj in H.
    split; [transitivity g0; tauto |].
    apply SIMPLE_MARK_GRAPH.mark_list_cons with (inj g0); [tauto |].
    rewrite (proj1 H); tauto.
Qed.

Lemma vertex_update_mark1: forall (g1: Graph) x (g2: Graph),
  g1 ~=~ g2 ->
  vvalid g1 x ->
  unmarked g1 x ->
  vlabel g2 x = label_mark (vlabel g1 x) ->
  (forall y, x <> y -> vlabel g2 y = vlabel g1 y) ->
  (forall e, elabel g2 e = elabel g1 e) ->
  mark1 g1 x g2.
Proof.
  intros.
  split; [| split; [| split]]; auto.
  + simpl.
    rewrite H2.
    apply label_mark_sound.
    apply H1.
  + intros y HH; specialize (H3 y HH). clear - H3.
    simpl.
    rewrite H3.
    reflexivity.
Qed.

Lemma mark_invalid_refl: forall (g: Graph) root, ~ vvalid g root -> mark g root g.
Proof.
  intros.
  pose proof SIMPLE_MARK_GRAPH.mark_invalid_refl g (inj g) root H.
  rewrite -> mark_inj.
  split; [reflexivity | auto].
Qed.

Lemma mark_marked_root_refl: forall (g: Graph) root, marked g root -> mark g root g.
Proof.
  intros.
  pose proof SIMPLE_MARK_GRAPH.mark_marked_root_refl g (inj g) root H.
  rewrite -> mark_inj.
  split; [reflexivity | auto].
Qed.

Lemma mark_marked: forall (g1: Graph) root (g2: Graph),
  mark g1 root g2 ->
  ReachDecidable g1 root (unmarked g1) ->
  forall n, marked g1 n -> marked g2 n.
Proof.
  intros.
  rewrite mark_inj in H.
  destruct H.
  apply SIMPLE_MARK_GRAPH.mark_marked with (n0 := n) in H1; auto.
Qed.

Lemma mark1_mark_list_mark: forall (g1: Graph) root l (g2 g3: Graph)
  (R_DEC: forall x, In x l -> ReachDecidable g2 x (unmarked g2))
  (V_DEC: forall x, In x l -> Decidable (vvalid g1 x))
  (R_DEC': ReachDecidable g1 root (unmarked g1)),
  vvalid g1 root ->
  (unmarked g1) root ->
  step_list g1 root l ->
  mark1 g1 root g2 ->
  mark_list g2 l g3 ->
  mark g1 root g3.
Proof.
  intros.
  rewrite mark1_inj in H2.
  apply mark_list_inj in H3.
  rewrite mark_inj.
  split; [transitivity g2; tauto |].
  apply SIMPLE_MARK_GRAPH.mark_mark1_mark with l (inj g2); auto.
  + intros.
    eapply ReachDecidable_si; [symmetry; exact (proj1 H2) | | eauto].
    intro; intros.
    unfold unmarked; rewrite negateP_spec; simpl.
    reflexivity.
  + tauto.
  + rewrite <- (proj1 H2) in H3 at 2; tauto.
Qed.

End MarkGraph.
End MarkGraph.

(*
Module WeakMarkGraph.

Class MarkGraphSetting (DV: Type) := {
  label_marked: DV -> Prop;
  label_mark: DV -> DV;
  label_unmark: DV -> DV;
  marked_dec: forall x, {label_marked x} + {~ label_marked x};
  label_mark_sound: forall x, ~ label_marked x -> label_marked (label_mark x);
  label_unmark_sound: forall x, label_marked x -> ~ label_marked (label_unmark x)
}.

Section WeakMarkGraph.

Context {V E: Type}.
Context {EV: EqDec V eq}.
Context {EE: EqDec E eq}.
Context {DV DE: Type}.
Context {MGS: MarkGraphSetting DV}.
Context {P: LabeledGraph V E DV DE -> Type}.

Notation Graph := (GeneralGraph V E DV DE P).

Definition marked (g: Graph) : NodePred V.
  refine (existT _ (fun v => label_marked (vlabel g v)) _).
  intros.
  apply marked_dec.
Defined.

Definition unmarked (g: Graph) : NodePred V := negateP (marked g).

Hypothesis R_DEC: forall (g: Graph) x, vvalid g x -> ReachDecidable g x (unmarked g).

Lemma R_DEC': forall (g: Graph) x, Decidable (vvalid g x /\ unmarked g x) -> ReachDecidable g x (unmarked g).
Proof.
  intros.
  destruct H.
  + apply R_DEC; tauto.
  + right.
    intro.
    apply n; split.
    - apply reachable_by_head_valid in H; auto.
    - apply reachable_by_head_prop in H.
      auto.
Qed.

Definition mark1 (g1 : Graph) (n : V) (g2 : Graph) : Prop :=
  g1 ~=~ g2 /\
  vvalid g1 n /\
  marked g2 n /\
  forall n', n <> n' -> (marked g1 n' <-> marked g2 n').

Definition mark (g1 : Graph) (root : V) (g2 : Graph) : Prop :=
  (predicate_partialgraph g1 (Complement _ (reachable_by g1 root (unmarked g1)))) ~=~
  (predicate_partialgraph g2 (Complement _ (reachable_by g1 root (unmarked g1)))) /\
  (forall n, g1 |= root ~o~> n satisfying (unmarked g1) -> marked g2 n) /\
  (forall n, ~ g1 |= root ~o~> n satisfying (unmarked g1) -> (marked g1 n <-> marked g2 n)).

Inductive mark_list: Graph -> list V -> Graph -> Prop :=
| mark_list_nil: forall (g g0: Graph), (g ~=~ g0)%LabeledGraph -> mark_list g nil g0
| mark_list_cons: forall (g g0: Graph) g1 v vs, mark g v g0 -> mark_list g0 vs g1 -> mark_list g (v :: vs) g1
.

Definition inj (g: Graph): NodePred V.
  exists (fun v => label_marked (vlabel g v)).
  intros; apply marked_dec.
Defined.

Instance inj_proper: Proper ((fun (g1 g2: Graph) => (g1 ~=~ g2)%LabeledGraph) ==> node_pred_equiv) inj.
Proof.
  hnf; intros.
  intro; simpl.
  destruct H as [_ [? _]].
  rewrite H.
  tauto.
Defined.

Lemma V_DEC_mark: forall (g1 g2: Graph) (root: V) n,
  mark g1 root g2 ->
  Decidable (vvalid g1 root /\ unmarked g1 root) ->
  Decidable (vvalid g1 n /\ unmarked g1 n) ->
  Decidable (vvalid g2 n /\ unmarked g2 n).
Proof.
  intros.
  apply R_DEC' in H0.
  destruct (H0 n); [right |].
  + destruct H as [_ [? _]].
    apply H in r.
    unfold unmarked; rewrite negateP_spec.
    tauto.
  + destruct H as [? [_ ?]].
    destruct H as [H _]; specialize (H n); specialize (H2 _ n0).
    simpl in H; unfold predicate_vvalid, Complement, Ensembles.In in H.
    destruct H1 as [H1 | H1]; [left | right];
    unfold unmarked in *; rewrite negateP_spec in H1 |- *;
    tauto.
Qed.

Lemma mark1_inj: forall (g1 g2: Graph) (v: V), mark1 g1 v g2 <-> (g1 ~=~ g2 /\ SIMPLE_MARK_GRAPH.mark1 g1 (inj g1) v (inj g2)).
Proof.
  intros.
  unfold mark1, SIMPLE_MARK_GRAPH.mark1.
  simpl.
  unfold marked.
  tauto.
Qed.

Lemma mark_inj: forall (g1 g2: Graph) (v: V),
  mark g1 v g2 <->
  ((predicate_partialgraph g1 (Complement _ (reachable_by g1 v (unmarked g1)))) ~=~
   (predicate_partialgraph g2 (Complement _ (reachable_by g1 v (unmarked g1)))) /\
   SIMPLE_MARK_GRAPH.mark g1 (inj g1) v (inj g2)).
Proof.
  intros.
  unfold mark, SIMPLE_MARK_GRAPH.mark.
  simpl.
  unfold marked.
  tauto.
Qed.

Lemma mark_reverse_unmarked_strong: forall (g1 g2: Graph) n1 n2 root,
  mark g1 root g2 ->
  ReachDecidable g1 root (unmarked g1) ->
  g2 |= n1 ~o~> n2 satisfying (unmarked g2) ->
  (predicate_partialgraph g1 (Complement _ (reachable_by g1 root (unmarked g1)))) |= n1 ~o~> n2 satisfying (unmarked g1).
Proof.
  intros.
  eapply reachable_by_weaken with (Q := Complement _ (Union _ (reachable_by g1 root (unmarked g1)) (marked g1))) in H0.
  + rewrite <- Intersection_Complement in H0.
    rewrite reachable_by_eq_partialgraph_reachable in H0.
    rewrite <- partial_partialgraph in H0.
    destruct H.
    rewrite <- H in H0.
    rewrite <- reachable_by_eq_partialgraph_reachable in H0.
    auto.
  + apply Complement_Included_rev.
    intro; unfold Ensembles.In.
    rewrite Union_spec.
    apply SIMPLE_MARK_GRAPH.mark_marked_strong; auto.
    rewrite mark_inj in H.
    destruct H; auto.
Qed.

Lemma mark_reverse_unmarked: forall (g1 g2: Graph) n1 n2 root,
  mark g1 root g2 ->
  ReachDecidable g1 root (unmarked g1) ->
  g2 |= n1 ~o~> n2 satisfying (unmarked g2) ->
  g1 |= n1 ~o~> n2 satisfying (unmarked g1).
Proof.
  intros.
  eapply mark_reverse_unmarked_strong in H0; eauto.
  rewrite reachable_by_eq_partialgraph_reachable in H0.
  rewrite partial_partialgraph in H0.
  rewrite <- reachable_by_eq_partialgraph_reachable in H0.
  eapply reachable_by_weaken; [| exact H0].
  intro; unfold Ensembles.In; rewrite Intersection_spec.
  tauto.
Qed.

Lemma mark_list_inj: forall (g1 g2: Graph) (vs: list V)
  (V_DEC: forall x, In x vs -> Decidable (vvalid g1 x)),
  mark_list g1 vs g2 ->
  ((predicate_partialgraph g1 (Complement _ (reachable_by_through_set g1 vs (unmarked g1)))) ~=~
   (predicate_partialgraph g2 (Complement _ (reachable_by_through_set g1 vs (unmarked g1))))) /\
  SIMPLE_MARK_GRAPH.mark_list g1 (inj g1) vs (inj g2).
Proof.
  intros.
  assert (forall x : V, In x vs -> Decidable (vvalid g1 x /\ unmarked g1 x)).
  1: {
    intros.
    apply sumbool_dec_and; [apply V_DEC; auto |].
    apply node_pred_dec.
  }
  clear V_DEC; rename X into V_DEC.
  induction H.
  - split; [destruct H; rewrite <- H; reflexivity |].
    constructor.
    apply inj_proper; auto.
  - spec IHmark_list.
    1: {
      intros.
      eapply V_DEC_mark; [exact H | |]; apply V_DEC; simpl; auto.
    }
    rewrite mark_inj in H.
    split;
    [transitivity (predicate_partialgraph g0 (Complement _ (reachable_by_through_set g (v :: vs) (unmarked g)))) |].
    * eapply si_stronger_partialgraph_simple; [| destruct H; eassumption].
      apply Complement_Included_rev.
      hnf; intros.
      exists v; split; [simpl; tauto |].
      auto.
    * eapply si_stronger_partialgraph_simple.
      2: destruct IHmark_list; exact H1.
      apply Complement_Included_rev.
      hnf; intros.
      destruct H1 as [v0 [? ?]].
      exists v0; split; [simpl; auto |].
      eapply mark_reverse_unmarked; eauto.
      apply R_DEC', V_DEC.
      simpl; auto.
    * destruct IHmark_list.
      econstructor.
      1: destruct H as [_ H]; exact H.
      erewrite SIMPLE_MARK_GRAPH.mark_list_proper_strong; [exact H2 | | | | |].
Abort.

(*
Lemma vertex_update_mark1: forall (g1: Graph) x (g2: Graph),
  g1 ~=~ g2 ->
  vvalid g1 x ->
  unmarked g1 x ->
  vlabel g2 x = label_mark (vlabel g1 x) ->
  (forall y, x <> y -> vlabel g2 y = vlabel g1 y) ->
  (forall e, elabel g2 e = elabel g1 e) ->
  mark1 g1 x g2.
Proof.
  intros.
  split; [| split; [| split]]; auto.
  + simpl.
    rewrite H2.
    apply label_mark_sound.
    apply H1.
  + intros y HH; specialize (H3 y HH). clear - H3.
    simpl.
    rewrite H3.
    reflexivity.
Qed.

Lemma mark_invalid_refl: forall (g: Graph) root, ~ vvalid g root -> mark g root g.
Proof.
  intros.
  pose proof SIMPLE_MARK_GRAPH.mark_invalid_refl g (inj g) root H.
  rewrite -> mark_inj.
  split; [reflexivity | auto].
Qed.

Lemma mark_marked_root_refl: forall (g: Graph) root, marked g root -> mark g root g.
Proof.
  intros.
  pose proof SIMPLE_MARK_GRAPH.mark_marked_root_refl g (inj g) root H.
  rewrite -> mark_inj.
  split; [reflexivity | auto].
Qed.

Lemma mark_marked: forall (g1: Graph) root (g2: Graph),
  mark g1 root g2 ->
  ReachDecidable g1 root (unmarked g1) ->
  forall n, marked g1 n -> marked g2 n.
Proof.
  intros.
  rewrite mark_inj in H.
  destruct H.
  apply SIMPLE_MARK_GRAPH.mark_marked with (n0 := n) in H1; auto.
Qed.

Lemma mark1_mark_list_mark: forall (g1: Graph) root l (g2 g3: Graph)
  (R_DEC: forall x, In x l -> ReachDecidable g2 x (unmarked g2))
  (V_DEC: forall x, In x l -> Decidable (vvalid g1 x))
  (R_DEC': ReachDecidable g1 root (unmarked g1)),
  vvalid g1 root ->
  (unmarked g1) root ->
  step_list g1 root l ->
  mark1 g1 root g2 ->
  mark_list g2 l g3 ->
  mark g1 root g3.
Proof.
  intros.
  rewrite mark1_inj in H2.
  apply mark_list_inj in H3.
  rewrite mark_inj.
  split; [transitivity g2; tauto |].
  apply SIMPLE_MARK_GRAPH.mark_mark1_mark with l (inj g2); auto.
  + intros.
    eapply ReachDecidable_si; [symmetry; exact (proj1 H2) | | eauto].
    intro; intros.
    unfold unmarked; rewrite negateP_spec; simpl.
    reflexivity.
  + tauto.
  + rewrite <- (proj1 H2) in H3 at 2; tauto.
Qed.
*)
End WeakMarkGraph.
End WeakMarkGraph.
*)


Require Import Equations.Init.
Require Import Equations.Equations.

Require Import Coq.Lists.List.
Import ListNotations.

Require Import PeanoNat.
Require Import Psatz.

Require Export Parser.Option.

(* Basic list rewrites *)
Ltac list_rewrites := rewrite List.app_nil_l in * || rewrite List.app_nil_r in *.
Hint Extern 1 => list_rewrites : list_rewrites.

Definition sublist { T } (xs1 xs2: list T) := exists pre post,
  app (app pre xs1) post = xs2.

Lemma sublist_refl: forall T (xs: list T), sublist xs xs.
Proof.
  unfold sublist; intros; eauto with list_rewrites.
Qed.

Lemma sublist_right: forall T (xs ys: list T),
  sublist xs (xs ++ ys).
Proof.
  unfold sublist; lights.
  exists nil, ys; eauto with datatypes.
Qed.

Lemma sublist_left: forall T (xs ys: list T),
  sublist xs (ys ++ xs).
Proof.
  unfold sublist; lights.
  exists ys, nil; eauto with datatypes.
Qed.

Lemma sublist_trans: forall T (xs ys zs: list T),
  sublist xs ys ->
  sublist ys zs ->
  sublist xs zs.
Proof.
  unfold sublist; lights.
  exists (pre ++ pre0), (post0 ++ post); repeat light || rewrite app_assoc.
Qed.

Lemma sublist_right_right: forall T (xs ys zs: list T),
  sublist xs ys ->
  sublist xs (ys ++ zs).
Proof.
  intros; eauto using sublist_trans, sublist_right.
Qed.

Lemma sublist_right_left: forall T (xs ys zs: list T),
  sublist xs ys ->
  sublist xs (zs ++ ys).
Proof.
  intros; eauto using sublist_trans, sublist_left.
Qed.

Lemma sublist_nil: forall T (xs: list T),
  sublist xs nil ->
  xs = nil.
Proof.
  unfold sublist; destruct xs; lights.
  destruct pre; lights.
Qed.

Ltac t_sublist_nil :=
  match goal with
  | H: sublist ?xs nil |- _ =>
    pose proof (sublist_nil _ _ H); clear H
  end.

Ltac t_app_inv :=
  match goal with
  | H: ?l ++ _ = ?l ++ _ |- _ => apply app_inv_head in H
  | H: _ ++ ?l = _ ++ ?l |- _ => apply app_inv_tail in H
  end.

Lemma app_eq_nil_equiv:
  forall A (xs xs': list A), xs ++ xs' = [] <-> (xs = [] /\ xs' = []).
Proof.
  lights; apply app_eq_nil in H; lights.
Qed.

Ltac t_app_eq_nil :=
  rewrite app_eq_nil_equiv in * ||
  match goal with
  | H: nil = _ ++ _ |- _ =>
    apply eq_sym in H; rewrite app_eq_nil_equiv in H
  end.

Ltac app_cons_destruct :=
  match goal with
  | H: ?xs1 ++ _ = ?xs2 :: _ |- _ => is_var xs1; is_var xs2; destruct xs1
  | H: ?xs1 :: _ = ?xs2 ++ _ |- _ => is_var xs1; is_var xs2; destruct xs2
  end.

Definition when {A: Type} (b : bool) (xs : list A) : list A :=
  if b then xs else nil.

Definition when_opt {A B : Type} (opt : option A) (xs : list B) : list B :=
  if opt then xs else nil.

Definition when_sum { A B: Prop } { C : Type } (sum : { A } + { B }) (xs : list C) : list C :=
  if sum then xs else nil.

Lemma Forall_app:
  forall T (P: T -> Prop) (l1: list T) (l2: list T),
    Forall P (l1 ++ l2) <-> (Forall P l1 /\ Forall P l2).
Proof.
  induction l1; repeat light || invert_pred Forall || rewrite_any || constructor.
Qed.

Ltac lists :=
  unfold when in * ||
  unfold when_opt in * ||
  unfold when_sum in * ||
  list_rewrites ||
  (rewrite in_app_iff in *) ||
  (rewrite Forall_app in *) ||
  t_app_eq_nil ||
  t_app_inv ||
  t_sublist_nil.

Hint Extern 1 => lists: lists.

Lemma split_in:
  forall T (xs: list T) (t: T),
    In t xs ->
    exists pre post,
      xs = pre ++ t :: post.
Proof.
  induction xs; repeat light || instantiate_any; eauto with lists datatypes.
Qed.

Ltac t_split_in :=
  match goal with
  | H: In ?t ?xs |- _ =>
    is_var xs;
    pose proof (split_in _ _ _ H)
  end.

Lemma app_cons_in:
  forall T (ys1 ys2 xs: list T) t,
    xs = ys1 ++ t :: ys2 ->
    In t xs.
Proof.
  induction ys1; repeat light; eauto with datatypes.
Qed.

(*  Two cases:                          *)
(*  *     [      xs1  ] [  xs2 ]        *)
(*        [ ys1 ] t [    ys2   ]        *)
(*   or                                 *)
(*  *     [  xs1  ]  [      xs2      ]  *)
(*        [       ys1    ] t [  ys2  ]  *)
Lemma app_app_cons:
  forall T (ys1 ys2 xs1 xs2: list T) t,
    xs1 ++ xs2 = ys1 ++ t :: ys2 ->
    (exists mid,
        (xs1 = ys1 ++ t :: mid /\ mid ++ xs2 = ys2) \/
        (ys1 = xs1 ++ mid /\ mid ++ t :: ys2 = xs2)).
Proof.
  induction ys1; repeat light || app_cons_destruct || instantiate_any || invert_constructor_equalities;
    eauto.
Qed.

Lemma forallb_forall_false:
  forall (A : Type) (f : A -> bool) (l : list A),
    forallb f l = false <-> (exists x : A, In x l /\ f x = false).
Proof.
  induction l;
    repeat light || bools; eauto.
Qed.

Definition disjoint { T } (eq_dec: forall n m: T, { n = m } + { ~ n = m }) xs ys : bool :=
  forallb (fun x => forallb (fun y => if (eq_dec x y) then false else true) ys) xs.

Theorem disjoint_true_spec_1 : forall T eq_dec (xs ys: list T),
  disjoint eq_dec xs ys = true ->
  (forall x, In x xs -> In x ys -> False).
Proof.
  unfold disjoint; induction xs;
    repeat light || bools || eapply_any || rewrite forallb_forall in * || instantiate_any || nats || destruct_match.
Qed.

Theorem disjoint_true_spec_2 : forall T eq_dec (xs ys: list T),
  (forall x y, In x xs -> In y ys -> x <> y) ->
  disjoint eq_dec xs ys = true.
Proof.
  unfold disjoint; induction xs;
    repeat light || bools || eapply_any || rewrite forallb_forall in * || instantiate_any || nats || destruct_match;
    eauto with exfalso.
Qed.

Theorem disjoint_true_spec : forall T eq_dec (xs ys: list T),
  (forall x y, In x xs -> In y ys -> x <> y) <->
  disjoint eq_dec xs ys = true.
Proof.
  lights; eauto using disjoint_true_spec_1, disjoint_true_spec_2.
Qed.

Theorem disjoint_false_spec_1 : forall T eq_dec (xs ys: list T),
  disjoint eq_dec xs ys = false ->
  exists k,
  In k xs /\
  In k ys.
Proof.
  unfold disjoint; induction xs;
    repeat light || bools || nats || destruct_match || rewrite forallb_forall_false in *;
    eauto.
Qed.

Theorem disjoint_false_spec_2 : forall T eq_dec (xs ys: list T),
  (exists k, In k xs /\ In k ys) ->
  disjoint eq_dec xs ys = false.
Proof.
  unfold disjoint; induction xs;
    repeat light || bools || nats || destruct_match || rewrite forallb_forall_false in *;
    eauto.

  - left; eexists; lights; eauto; repeat light || bools || nats || destruct_match.
  - right; eexists; lights; eauto.
    apply forallb_forall_false; lights.
    eexists; lights; eauto.
    repeat bools || nats || light || destruct_match.
Qed.

Theorem disjoint_false_spec: forall T eq_dec (xs ys: list T),
  (exists k, In k xs /\ In k ys) <->
  disjoint eq_dec xs ys = false.
Proof.
  lights; eauto using disjoint_false_spec_1, disjoint_false_spec_2.
Qed.

Ltac t_disjoint :=
  rewrite <- disjoint_false_spec in * ||
  rewrite <- disjoint_true_spec in *.

Ltac clear_in_dec :=
  match goal with
  | H: in_dec _ _ _ = _ |- _ => clear H
  end.

Lemma app_sep {A : Type}: forall (xs1 ys1 xs2 ys2 : list A),
  xs1 ++ ys1 = xs2 ++ ys2 ->
  (exists z zs,
    xs1 ++ z :: zs = xs2 /\
    ys1 = z :: zs ++ ys2) \/
  (xs1 = xs2 /\ ys1 = ys2) \/
  (exists z zs,
    xs1 = xs2 ++ z :: zs /\
    z :: zs ++ ys1 = ys2).
Proof.
  induction xs1; destruct xs2; repeat light || instantiate_any || invert_constructor_equalities;
    eauto with lights.
Qed.

Hint Extern 1 => t_sublist_nil: sublist.
Hint Immediate sublist_right_right: sublist.
Hint Immediate sublist_right_left: sublist.
Hint Immediate sublist_trans: sublist.
Hint Immediate sublist_left: sublist.
Hint Immediate sublist_right: sublist.
Hint Immediate sublist_refl: sublist.

Program Definition head { T } (l: list T) (pre: ~(l = [])) :=
  match l with
  | [] => _
  | x :: _ => x
  end.

Program Definition tail { T } (l: list T) (pre: ~(l = [])) :=
  match l with
  | [] => _
  | _ :: xs => xs
  end.

(* a, a + 1, ..., b - 1 *)
Equations (noind) range (a: nat) (b: nat): list nat by wf (b - a) lt :=
  range a b :=
    if (Compare_dec.ge_dec a b)
    then []
    else a :: range (S a) b.

Next Obligation. lia. Qed.

Opaque range.

Fail Next Obligation. (* no more obligations for range *)

Ltac range_def := rewrite range_equation_1 in *.

Lemma range_spec':
  forall n a b k,
    b - a < n ->
      (In k (range a b) <-> (a <= k /\ k < b)).
Proof.
  induction n;
    repeat light; try lia;
    range_def;
      repeat light || destruct_match ||
        match goal with
        | IHn: forall a b k, _, H: In ?k (range ?a ?b) |- _ =>
          unshelve epose proof (IHn a b k _); clear IHn
        | IHn: forall a b k, _ |- context[In ?k (range ?a ?b)] =>
          unshelve epose proof (IHn a b k _); clear IHn
        end;
    eauto with lia.

  destruct (Nat.eq_dec a k);
    repeat light;
    eauto with lia.
Qed.

Lemma range_spec:
  forall a b k,
    In k (range a b) <-> a <= k /\ k < b.
Proof.
  eauto using range_spec'.
Qed.

Lemma incl_more { A }:
  forall l1 l2: list A, forall x,
      NoDup l1 ->
      ~In x l1 ->
      In x l2 ->
      incl l1 l2 ->
      List.length l1 < List.length l2.
Proof.
  intros.
  unshelve epose proof (@NoDup_incl_length A (x :: l1) l2 _ _);
    repeat light || constructor || apply incl_cons.
Qed.

Lemma incl_nil:
  forall T (l: list T), incl [] l.
Proof.
  unfold incl; lights.
Qed.

Lemma fold_left_move:
  forall A B (f: A -> B -> A) (l: list B) b a,
    fold_left f (l ++ [ b ]) a =
    f (fold_left f l a) b.
Proof.
  induction l;
    repeat light.
Qed.

Lemma fold_left_invariant' { A B }:
  forall (P: A -> list B -> Prop) (f: A -> B -> A) (l'' l' l: list B) a0,
    l = l' ++ l'' ->
    P (fold_left f l' a0) l' ->
    (forall a b l' l'', l = l' ++ b :: l'' -> P a l' -> P (f a b) (l' ++ [ b ])) ->
    P (fold_left f l'' (fold_left f l' a0)) l.
Proof.
  induction l''; repeat light || lists.

  unshelve epose proof (IHl'' (l' ++ [ a ]) _ a0 eq_refl _ _);
    repeat light ||
           rewrite fold_left_move in * ||
           rewrite <- app_assoc in * ||
           unshelve eauto.
Qed.

Lemma fold_left_invariant { A B }:
  forall (P: A -> list B -> Prop) (f: A -> B -> A) (l: list B) a0,
    P a0 [] ->
    (forall a b l' l'', l = l' ++ b :: l'' -> P a l' -> P (f a b) (l' ++ [ b ])) ->
    P (fold_left f l a0) l.
Proof.
  intros.
  eapply (fold_left_invariant' _ _ l [] l);
    eauto.
Qed.

Lemma obvious_in:
  forall A (l1 l2: list A) x,
    In x (l1 ++ x :: l2).
Proof.
  induction l1; repeat light.
Qed.

Lemma not_in_prefix:
  forall A (l1 l2: list A) x,
    NoDup (l1 ++ x :: l2) ->
    In x l1 ->
    False.
Proof.
  induction l1; repeat light || invert_pred NoDup; eauto using obvious_in.
Qed.

Lemma app_comm_cons2:
  forall A (l1 l2: list A) (a: A), l1 ++ a :: l2 = (l1 ++ [ a ]) ++ l2.
Proof.
  repeat light || rewrite <- app_assoc.
Qed.

Ltac map_ext_in :=
  match goal with
  | H: context[map ?f ?l] |- context[map ?g ?l] =>
    rewrite (map_ext_in f g l) in H
  end.

Lemma fold_left_or_else':
  forall X T l x t opt,
    fold_left (fun (acc : option T) (f : X -> option T) => or_else acc (f x)) l opt = Some t ->
    opt = Some t \/ exists f, In f l /\ f x = Some t.
Proof.
  induction l;
    repeat light || instantiate_any || options || destruct_match;
    eauto.
Qed.

Lemma fold_left_or_else:
  forall X T l x t,
    fold_left (fun (acc : option T) (f : X -> option T) => or_else acc (f x)) l None = Some t ->
    exists f, In f l /\ f x = Some t.
Proof.
  intros.
  pose proof (fold_left_or_else' _ _ _ _ _ _ H); lights.
Qed.

Lemma fold_left_not_none:
  forall A B (fs: list (A -> option B)) v x,
    fold_left (fun acc f => or_else acc (f x)) fs (Some v) = None ->
    False.
Proof.
  induction fs; lights.
Qed.

Lemma fold_left_not_none2:
  forall A B (fs: list (A -> option B)) f v x opt,
    In f fs ->
    f x = Some v ->
    fold_left (fun acc f => or_else acc (f x)) fs opt = None ->
    False.
Proof.
  induction fs; repeat light || rewrite_any || options || destruct_match;
    eauto using fold_left_not_none.
Qed.

Lemma fold_is_some:
  forall A B fs (f: A -> option B) opt x,
    is_some (f x) ->
    In f fs ->
    is_some (fold_left (fun acc f => or_else acc (f x)) fs opt).
Proof.
  induction fs; repeat light || options || destruct_match || rewrite_any;
    eauto using fold_left_not_none.

  unshelve epose proof (IHfs f _ x _ _); repeat light || destruct_match.
Qed.

Ltac rewrite_nil :=
  match goal with
  | H: _ = [] |- _ => rewrite H in *
  end.


From stdpp Require Import base list.
From Autosubst Require Export Autosubst.
Require Export Utf8_core.
From fae_gtlc_mu.backtranslation.implication_consistencies.help_lemmas Require Import intermediate upper_bound.
From fae_gtlc_mu.cast_calculus Require Export types types_notations types_lemmas consistency consistency_lemmas.
Require Import Relation_Operators.
Require Import Transitive_Closure.
From Coq.Wellfounded Require Import Lexicographic_Product Union.
From Coq.Program Require Import Wf.

Lemma smart_lookup (l : list (type * type)) (x : type * type) : (sum { i : nat & l !! i = Some x } (x ∉ l)).
Proof.
  destruct (decide (x ∈ l)).
  - left.
    induction l.
    + exfalso. inversion e.
    + destruct (decide (x = a)).
      * rewrite e0. by exists 0.
      * destruct (decide (x ∈ l)).
        destruct (IHl e0). exists (S x0). by simpl.
        exfalso. inversion e. simplify_eq. by apply n0.
  - by right.
Qed.

Definition lexord : relation (@sigT nat (fun _ => nat)) :=
  (lexprod _ _ lt (fun _ => lt)).

Lemma ord_left n n' m m' : n < n' → lexord (existT n m) (existT n' m').
Proof.
  intros. by apply left_lex.
Qed.

Lemma ord_right n n' m m' : n ≤ n' → m < m' → lexord (existT n m) (existT n' m').
Proof.
  intros.
  destruct (decide (n < n')).
  - by apply left_lex.
  - assert (triv : n = n'). lia. rewrite triv. clear triv.
    by apply right_lex.
Qed.

Fixpoint size (τ : type) : nat :=
  match τ with
  | TUnit => 1
  | TProd τ1 τ2 => size τ1 + size τ2
  | TSum τ1 τ2 => size τ1 + size τ2
  | TArrow τ1 τ2 => size τ1 + size τ2
  | TRec τ => S (size τ)
  | TVar x => 1
  | TUnknown => 1
  end.

Lemma size_gt_0 τ : 0 < size τ.
Proof. induction τ; simpl; lia. Qed.

Definition size_pair (p : type * type) : nat :=
  match p with | pair x x0 => size x + size x0 end.

Require Import JMeq.

(** TODO; remove program fixpoint... *)

(* Lemma struct_validity (A : list (type * type)) (pA : Forall (fun p => Closed p.1 ∧ Closed p.2) A) *)
(*       τ (pτC : Closed τ) τ' (pτ'C : Closed τ') (pStand : consistency τ τ') : alternative_consistency_pre A τ τ'. *)
(* Proof. *)

Inductive Cat : type → Type :=
  | CUnknown : Cat TUnknown
  | CGroundUnit : Ground TUnit → Cat TUnit
  | CGroundProd : Ground (TProd TUnknown TUnknown) → Cat (TProd TUnknown TUnknown)
  | CGroundSum : Ground (TSum TUnknown TUnknown) → Cat (TSum TUnknown TUnknown)
  | CGroundArrow : Ground (TArrow TUnknown TUnknown) → Cat (TArrow TUnknown TUnknown)
  | CGroundRec : Ground (TRec TUnknown) → Cat (TRec TUnknown)
  | CProd τ1 τ2 : (τ1 ≠ TUnknown ∨ τ2 ≠ TUnknown) → Cat (TProd τ1 τ2)
  | CSum τ1 τ2 : (τ1 ≠ TUnknown ∨ τ2 ≠ TUnknown) → Cat (TSum τ1 τ2)
  | CArrow τ1 τ2 : (τ1 ≠ TUnknown ∨ τ2 ≠ TUnknown) → Cat (TArrow τ1 τ2)
  | CRec τ : (τ ≠ TUnknown) → Cat (TRec τ)
  | CVar i : Cat (TVar i).

Lemma categorize (τ : type) : Cat τ.
Proof.
  destruct τ; try by do 2 constructor.
  - destruct (decide (τ1 = ⋆)); simplify_eq.
    destruct (decide (τ2 = ⋆)); simplify_eq.
    constructor. constructor. constructor; auto. constructor; auto.
  - destruct (decide (τ1 = ⋆)); simplify_eq.
    destruct (decide (τ2 = ⋆)); simplify_eq.
    constructor. constructor. constructor; auto. constructor; auto.
  - destruct (decide (τ1 = ⋆)); simplify_eq.
    destruct (decide (τ2 = ⋆)); simplify_eq.
    constructor. constructor. constructor; auto. constructor; auto.
  - destruct (decide (τ = ⋆)); simplify_eq.
    constructor. constructor. constructor; auto.
Qed.

Program Fixpoint struct_validity (A : list (type * type)) (pA : Forall (fun p => Closed p.1 ∧ Closed p.2) A) τ (pτC : Closed τ) τ' (pτ'C : Closed τ') (pStand : consistency_open τ τ')
        {measure (existT (upper_bound A τ τ') (size_pair (τ , τ'))) lexord} : alternative_consistency_pre A τ τ' :=
  match pStand with
  | GenSymUnit => consp_BaseBase A
  | GenSymUnknownL τr => _
  | GenSymUnknownR τl => _
  | GenSymProd τ1 τ1' τ2 τ2' s1 s2 =>
    consp_TProdTProd A τ1 τ1' τ2 τ2'
                     (struct_validity A pA τ1 ltac:(simplify_eq; by apply (TProd_closed1 pτC)) τ1' ltac:(simplify_eq; by apply (TProd_closed1 pτ'C)) s1)
                     (struct_validity A pA τ2 ltac:(simplify_eq; by apply (TProd_closed2 pτC)) τ2' ltac:(simplify_eq; by apply (TProd_closed2 pτ'C)) s2)
  | GenSymSum τ1 τ1' τ2 τ2' s1 s2 =>
    consp_TSumTSum A τ1 τ1' τ2 τ2'
                     (struct_validity A pA τ1 ltac:(simplify_eq; by apply (TSum_closed1 pτC)) τ1' ltac:(simplify_eq; by apply (TSum_closed1 pτ'C)) s1)
                     (struct_validity A pA τ2 ltac:(simplify_eq; by apply (TSum_closed2 pτC)) τ2' ltac:(simplify_eq; by apply (TSum_closed2 pτ'C)) s2)
  | GenSymArrow τ1 τ1' τ2 τ2' s1 s2 =>
    consp_TArrowTArrow A τ1 τ1' τ2 τ2'
                     (struct_validity A pA τ1' ltac:(simplify_eq; by apply (TArrow_closed1 pτ'C)) τ1 ltac:(simplify_eq; by apply (TArrow_closed1 pτC)) (consistency_open_sym s1))
                     (struct_validity A pA τ2 ltac:(simplify_eq; by apply (TArrow_closed2 pτC)) τ2' ltac:(simplify_eq; by apply (TArrow_closed2 pτ'C)) s2)
  | GenSymVar i => ltac:(simplify_eq; exfalso; apply (no_var_is_closed i pτC))
  | GenSymRec τ τ' P => _
    (* match decide (exists (i : nat), A !! i = Some (TRec τ , TRec τ')) with *)
    (* | left pYes => atomic_UseRecursion A τ τ' _ _ *)
    (* | right pNo => exposeRecursiveCAll A τ τ' _ (struct_validity ((TRec τ, TRec τ') :: A) τ.[TRec τ/] ltac:(simplify_eq; by apply (TRec_closed_unfold pτC)) τ'.[TRec τ'/] ltac:(simplify_eq; by apply (TRec_closed_unfold pτ'C)) (consistency_unfold P)) *)
    (* end *)
  end.

Next Obligation.
Proof.
  intros; simplify_eq.
  destruct (categorize τ'); (try (by apply consp_StarTGround)); try apply consp_StarStar.
  - apply consp_GroundProdTau; auto.
    apply (struct_validity A pA TUnknown pτC τ1 (TProd_closed1 pτ'C) (GenSymUnknownL τ1)).
    { simpl. apply ord_right. apply upper_bound_le_unknown_prod1. pose (p := size_gt_0 τ2). lia. }
    apply (struct_validity A pA TUnknown pτC τ2 (TProd_closed2 pτ'C) (GenSymUnknownL τ2)).
    { simpl. apply ord_right. apply upper_bound_le_unknown_prod2. pose (p := size_gt_0 τ1). lia. }
  - apply consp_GroundSumTau; auto.
    apply (struct_validity A pA TUnknown pτC τ1 (TSum_closed1 pτ'C) (GenSymUnknownL τ1)).
    { simpl. apply ord_right. apply upper_bound_le_unknown_sum1. pose (p := size_gt_0 τ2). lia. }
    apply (struct_validity A pA TUnknown pτC τ2 (TSum_closed2 pτ'C) (GenSymUnknownL τ2)).
    { simpl. apply ord_right. apply upper_bound_le_unknown_sum2. pose (p := size_gt_0 τ1). lia. }
  - apply consp_GroundArrowTau; auto.
    apply (struct_validity A pA τ1 (TArrow_closed1 pτ'C) TUnknown pτC (GenSymUnknownR τ1)).
    { simpl. apply ord_right. apply upper_bound_le_unknown_arrow_con. pose (p := size_gt_0 τ2). lia. }
    apply (struct_validity A pA TUnknown pτC τ2 (TArrow_closed2 pτ'C) (GenSymUnknownL τ2)).
    { simpl. apply ord_right. apply upper_bound_le_unknown_arrow_cov.  pose (p := size_gt_0 τ1). lia. }
  - destruct (smart_lookup A (TRec TUnknown , TRec τ)) as [[i p] | np].
    + by apply (consp_GroundRecTauUseCall A τ i).
    + apply consp_GroundRecTauExposeCall; auto.
      apply (struct_validity ((TRec TUnknown, TRec τ) :: A)). constructor; simpl; auto. split; auto. done. done. apply (TRec_closed_unfold pτ'C).
      assert (H : TUnknown = TUnknown.[TRec TUnknown/]). by asimpl. rewrite H.
      apply GenSymUnknownL.
      { simpl. apply ord_left. apply upper_bound_lt_star_rec; auto. }
  - exfalso. apply (no_var_is_closed i pτ'C).
Qed.

Next Obligation.
  intros; simplify_eq.
  destruct (categorize τ); (try (by apply consp_TGroundStar)); try apply consp_StarStar.
  - apply consp_TauGroundProd; auto.
    apply (struct_validity A pA τ1 (TProd_closed1 pτC) TUnknown pτ'C (GenSymUnknownR τ1)).
    { simpl. apply ord_right. apply upper_bound_le_prod_unknown1. pose (p := size_gt_0 τ2). lia. }
    apply (struct_validity A pA τ2 (TProd_closed2 pτC) TUnknown pτ'C (GenSymUnknownR τ2)).
    { simpl. apply ord_right. apply upper_bound_le_prod_unknown2. pose (p := size_gt_0 τ1). lia. }
  - apply consp_TauGroundSum; auto.
    apply (struct_validity A pA τ1 (TSum_closed1 pτC) TUnknown pτ'C (GenSymUnknownR τ1)).
    { simpl. apply ord_right. apply upper_bound_le_sum_unknown1. pose (p := size_gt_0 τ2). lia. }
    apply (struct_validity A pA τ2 (TSum_closed2 pτC) TUnknown pτ'C (GenSymUnknownR τ2)).
    { simpl. apply ord_right. apply upper_bound_le_sum_unknown2. pose (p := size_gt_0 τ1). lia. }
  - apply consp_TauGroundArrow; auto.
    apply (struct_validity A pA TUnknown pτ'C τ1 (TArrow_closed1 pτC) (GenSymUnknownL τ1)).
    { simpl. apply ord_right. apply upper_bound_le_arrow_unknown_con. pose (p := size_gt_0 τ2). lia. }
    apply (struct_validity A pA τ2 (TArrow_closed2 pτC) TUnknown pτ'C (GenSymUnknownR τ2)).
    { simpl. apply ord_right. apply upper_bound_le_arrow_unknown_cov. pose (p := size_gt_0 τ1). lia. }
  - destruct (smart_lookup A (TRec τ , TRec TUnknown)) as [[i p] | np].
    + by apply (consp_TauGroundRecUseCall A τ i).
    + apply consp_TauGroundRecExposeCall; auto.
      apply (struct_validity ((TRec τ, TRec TUnknown) :: A)). constructor; simpl; auto. split; auto. done. apply (TRec_closed_unfold pτC). done.
      assert (H : TUnknown = TUnknown.[TRec TUnknown/]). by asimpl.
      apply GenSymUnknownR.
      { apply ord_left. apply upper_bound_lt_rec_star; auto. }
  - exfalso. apply (no_var_is_closed i pτC).
Qed.

Next Obligation. Proof. intros; simplify_eq. apply ord_right. apply upper_bound_le_prod1. simpl. pose (p := size_gt_0 τ2). lia. Qed.
Next Obligation. Proof. intros; simplify_eq. apply ord_right. apply upper_bound_le_prod2. simpl. pose (p := size_gt_0 τ1). lia. Qed.
Next Obligation. Proof. intros; simplify_eq. apply ord_right. apply upper_bound_le_sum1. simpl. pose (p := size_gt_0 τ2). lia. Qed.
Next Obligation. Proof. intros; simplify_eq. apply ord_right. apply upper_bound_le_sum2. simpl. pose (p := size_gt_0 τ1). lia. Qed.

(** TArrow *)

Next Obligation.
Proof.
  intros; simplify_eq.
  apply ord_right. apply upper_bound_le_arrow_l. simpl.
  pose (p := size_gt_0 τ2). lia.
Qed.

Next Obligation.
Proof.
  intros; simplify_eq.
  apply ord_right. apply upper_bound_le_arrow_r.
  simpl. pose (p1 := size_gt_0 τ1). lia.
Qed.

(** TRec *)

Next Obligation.
Proof.
  intros.
  destruct (smart_lookup A (TRec τ , TRec τ')) as [[i p] | np].
  + by apply (consp_TRecTRecUseCall A τ τ' i).
  + apply consp_TRecTRecExposeCall; auto.
    simplify_eq.
    apply (struct_validity ((TRec τ, TRec τ') :: A)). constructor; simpl; auto. apply (TRec_closed_unfold pτC). apply (TRec_closed_unfold pτ'C).
    (* apply (struct_validity ((TRec τ, TRec τ') :: A) τ.[TRec τ/] (TRec_closed_unfold pτC) τ'.[TRec τ'/] (TRec_closed_unfold pτ'C)). *)
    by apply consistency_open_unfold.
    { apply ord_left. apply upper_bound_lt_rec_rec; auto. }
Qed.

(** WF *)

Next Obligation.
Proof.
  apply measure_wf.
  apply wf_lexprod.
  apply lt_wf. intros _.
  apply lt_wf.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Y P Z Q Qprime Cprime X : Universe, ((wd_ A Y /\ (wd_ P Y /\ (wd_ Q Y /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ P Q /\ (wd_ A Z /\ (wd_ B Y /\ (wd_ Y Qprime /\ (wd_ Qprime Cprime /\ (wd_ Y Z /\ (wd_ Z X /\ (wd_ C Y /\ (wd_ P C /\ (wd_ Y Cprime /\ (col_ P Y Q /\ (col_ P Y C /\ (col_ P Q C /\ (col_ Z Y X /\ (col_ Qprime Y Cprime /\ (col_ Q Z Qprime /\ (col_ A Y Z /\ (col_ B A Y /\ col_ X C Cprime)))))))))))))))))))))))) -> col_ Y Q C)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Aprime Cprime P Q : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Aprime Cprime /\ (wd_ P Q /\ (wd_ A Aprime /\ (wd_ B Cprime /\ (wd_ C Cprime /\ (wd_ A P /\ (wd_ A Q /\ (wd_ B Aprime /\ (wd_ Cprime A /\ (wd_ Cprime Cprime /\ (col_ Aprime P Q /\ (col_ Cprime P Q /\ (col_ A B C /\ col_ C B Cprime)))))))))))))))) -> col_ Cprime A C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import CtxFibrancy.Overture CtxFibrancy.Path_eq.

Record IsEquiv {A B} {FibA: Fibrant A} {FibB: Fibrant B} (f: A -> B) :=
  { equiv_inv : B -> A ;
    eisretr : f o equiv_inv == idmap;
    eissect : equiv_inv o f == idmap;
    eisadj :  ∀ x : A, eisretr (f x) = ap f (eissect x) }.

Arguments equiv_inv {_ _ _ _ _} _ _.
Arguments eisretr {_ _ _ _ _} _ _.
Arguments eissect {_ _ _ _ _} _ _.
Arguments eisadj {_ _ _ _ _} _ _.

Definition isequiv_adjointify {A B} {FibA: Fibrant A} {FibB: Fibrant B} {f: A -> B}
           (g: B -> A) : f o g == idmap -> g o f == idmap -> IsEquiv f.
Proof.
  intros isretr issect. use Build_IsEquiv.
  exact g. exact isretr.
  exact (λ x, ap g (ap f (issect x)^) @ ap g (isretr (f x)) @ issect x).
  intro a; cbn.
  apply moveR_M1.
  repeat (rew ap_pp; rew concat_p_pp); rew (ap_compose _ _ _)^.
  rew (concat_pA1 (fun b => (isretr b)^) (ap f (issect a)^)).
  repeat rew concat_pp_p; rew ap_V; apply moveL_Vp; rew concat_p1.
  rew concat_p_pp; rew (ap_compose _ _ _)^.
  rew (concat_pA1 (fun b => (isretr b)^) (isretr (f a))).
  rew concat_pV; rew concat_1p.
  exact 1.
Defined.
(* Qed. *)

Definition isequiv_compose {A B C} {FibA: Fibrant A} {FibB: Fibrant B} {FibC: Fibrant C}
           {f: A -> B} (Hf: IsEquiv f) {g: B -> C} (Hg: IsEquiv g)
  : IsEquiv (compose g f).
Proof.
  use isequiv_adjointify.
  exact ((equiv_inv Hf) o (equiv_inv Hg)).
  exact (fun c => ap g (eisretr _ (equiv_inv Hg c)) @ eisretr _ c).
  exact (fun a => ap _ (eissect _ (f a)) @ eissect _ a).
Defined.

Definition cancelR_isequiv {A B C} {FibA: Fibrant A} {FibB: Fibrant B} {FibC: Fibrant C}
           (f : A -> B) {g : B -> C}
           {Hf: IsEquiv f} {Hgf: IsEquiv (g o f)}
  : IsEquiv g.
Proof.
  use isequiv_adjointify.
  exact (f o (equiv_inv Hgf)).
  intro x; cbn. exact (eisretr Hgf x).
  intro x; cbn.
  ref (ap (λ x, f (equiv_inv Hgf (g x))) (eisretr Hf x)^ @ _).
  ref (ap f (eissect Hgf _) @ _).
  apply eisretr.
Defined.

Definition cancelL_isequiv {A B C} {FibA: Fibrant A} {FibB: Fibrant B} {FibC: Fibrant C}
           (g : B -> C) {f : A -> B}
           {Hg: IsEquiv g} {Hgf: IsEquiv (g o f)}
  : IsEquiv f.
Proof.
  use isequiv_adjointify.
  exact ((equiv_inv Hgf) o g).
  intro x; cbn.
  ref ((eissect Hg _)^ @ _).
  ref (ap (equiv_inv Hg) (eisretr Hgf _) @ _).
  apply eissect.
  intro x; cbn. exact (eissect Hgf x).
Defined.


(** This files extends the implementation of finite over [positive] to finite
maps whose keys range over Coq's data type of binary naturals [N]. *)
From stdpp Require Import pmap mapset.
From stdpp Require Export prelude fin_maps.
From stdpp Require Import options.

Local Open Scope N_scope.

Record Nmap (A : Type) : Type := NMap { Nmap_0 : option A; Nmap_pos : Pmap A }.
Arguments Nmap_0 {_} _ : assert.
Arguments Nmap_pos {_} _ : assert.
Arguments NMap {_} _ _ : assert.

Instance Nmap_eq_dec `{EqDecision A} : EqDecision (Nmap A).
Proof.
 refine (λ t1 t2,
  match t1, t2 with
  | NMap x t1, NMap y t2 => cast_if_and (decide (x = y)) (decide (t1 = t2))
  end); abstract congruence.
Defined.
Instance Nempty {A} : Empty (Nmap A) := NMap None ∅.
Global Opaque Nempty.
Instance Nlookup {A} : Lookup N A (Nmap A) := λ i t,
  match i with
  | N0 => Nmap_0 t
  | Npos p => Nmap_pos t !! p
  end.
Instance Npartial_alter {A} : PartialAlter N A (Nmap A) := λ f i t,
  match i, t with
  | N0, NMap o t => NMap (f o) t
  | Npos p, NMap o t => NMap o (partial_alter f p t)
  end.
Instance Nto_list {A} : FinMapToList N A (Nmap A) := λ t,
  match t with
  | NMap o t =>
     from_option (λ x, [(0,x)]) [] o ++ (prod_map Npos id <$> map_to_list t)
  end.
Instance Nomap: OMap Nmap := λ A B f t,
  match t with NMap o t => NMap (o ≫= f) (omap f t) end.
Instance Nmerge: Merge Nmap := λ A B C f t1 t2,
  match t1, t2 with
  | NMap o1 t1, NMap o2 t2 => NMap (f o1 o2) (merge f t1 t2)
  end.
Instance Nfmap: FMap Nmap := λ A B f t,
  match t with NMap o t => NMap (f <$> o) (f <$> t) end.

Instance: FinMap N Nmap.
Proof.
  split.
  - intros ? [??] [??] H. f_equal; [apply (H 0)|].
    apply map_eq. intros i. apply (H (Npos i)).
  - by intros ? [|?].
  - intros ? f [? t] [|i]; simpl; [done |]. apply lookup_partial_alter.
  - intros ? f [? t] [|i] [|j]; simpl; try intuition congruence.
    intros. apply lookup_partial_alter_ne. congruence.
  - intros ??? [??] []; simpl; [done|]. apply lookup_fmap.
  - intros ? [[x|] t]; unfold map_to_list; simpl.
    + constructor.
      * rewrite elem_of_list_fmap. by intros [[??] [??]].
      * by apply (NoDup_fmap _), NoDup_map_to_list.
    + apply (NoDup_fmap _), NoDup_map_to_list.
  - intros ? t i x. unfold map_to_list. split.
    + destruct t as [[y|] t]; simpl.
      * rewrite elem_of_cons, elem_of_list_fmap.
        intros [? | [[??] [??]]]; simplify_eq/=; [done |].
        by apply elem_of_map_to_list.
      * rewrite elem_of_list_fmap; intros [[??] [??]]; simplify_eq/=.
        by apply elem_of_map_to_list.
    + destruct t as [[y|] t]; simpl.
      * rewrite elem_of_cons, elem_of_list_fmap.
        destruct i as [|i]; simpl; [intuition congruence |].
        intros. right. exists (i, x). by rewrite elem_of_map_to_list.
      * rewrite elem_of_list_fmap.
        destruct i as [|i]; simpl; [done |].
        intros. exists (i, x). by rewrite elem_of_map_to_list.
  - intros ?? f [??] [|?]; simpl; [done|]; apply (lookup_omap f).
  - intros ??? f ? [??] [??] [|?]; simpl; [done|]; apply (lookup_merge f).
Qed.

(** * Finite sets *)
(** We construct sets of [N]s satisfying extensional equality. *)
Notation Nset := (mapset Nmap).
Instance Nmap_dom {A} : Dom (Nmap A) Nset := mapset_dom.
Instance: FinMapDom N Nmap Nset := mapset_dom_spec.