Require Export SfLib.

Import SfLibmod.

(*Destination Language: STLC + notions of program, ownership, code base,
  and events to log temporarily and permanently.*)
(*
Assumptions:
1- code_bases map function names to closed lambda abstractions
   it is reflected in two places: in defining substitution [x:=s]t
   and in appear_free_in x t.
   Such an assuumption is declared in well-formed codebases!

2- Excluded middle is correct! (defined in SfLib)

*)

(*
types
T ::= Unit | T -> T
*)

Inductive ty : Type :=
  | TUnit : ty
  | TArrow : ty -> ty -> ty.

(*
terms:
t ::= x | f | \x:T.t | tt | unit | ev[f] t | lev[f] t | t;t
where x ranges over ordinary variable identifiers (id),
      f ranges over function name identifiers (fid),
      ev[f] t is the event to log function call temporarily,
      lev[f] t is the event to log function call permanently.
*)

Inductive tm : Type :=
  | tvar : id -> tm
  | tfname : fid -> tm
  | tabs : id -> ty -> tm -> tm
  | tapp : tm -> tm -> tm
  | tunit : tm
  | tev : fid -> tm -> tm
  | tlev : fid -> tm -> tm
  | tseq : tm -> tm -> tm.

Notation "t1 ';' t2" := (tseq t1 t2) (at level 15).

(*
values defined as propositions over terms:
v ::= f | \x:T.t | unit
*)

Inductive value: tm -> Prop :=
  | v_fname: forall (f: fid), value (tfname f)
  | v_abs : forall (x: id) (T: ty) (t: tm), value (tabs x T t)
  | v_unit : value tunit.

Hint Constructors value.

(*
Partial mappings:
functions from identifiers (I) to some optial value of type A.
*)

Definition partial_map (I: Type) (A:Type) := I -> option A.

Definition empty  {I A:Type} : partial_map I A := (fun _ => None).

Definition extend_id {A:Type} (parMap : partial_map id A)
                              (var:id) (val : A) :=
  fun var' => if eq_id_dec var var' then
                 Some val
              else parMap var'.

Definition extend_fid {A:Type}
                      (parMap : partial_map fid A)
                      (fname: fid)
                      (func : A) :=
  fun fname' => if eq_fid_dec fname fname' then
                   Some func
                else parMap fname'.

(*
Code base:
Partial mapping from function names to terms:
C: fid -> option tm   (or, partial_map fid tm)
*)

Definition code_base : Type := partial_map fid tm.

(*
Programs: a triple of a term, an owner and a code base.
*)
Inductive prog : Type :=
   prg : tm -> ow -> code_base -> prog.

(*
lv: ow -> nat
gives the security level of the principal (owner).
*)
Definition lv (o: ow) : nat :=
  match o with
   OId m => m
  end.

(*=====================   LOGGING POLICIES   ============================*)

(*Extending nat with variables*)
Inductive ext_nat : Type :=
  | proper_nat : nat -> ext_nat
  | nat_var :    id -> ext_nat.

(*
propositions:
p ::= LoggedCall(n,f, arg)| Call(n, f, args) |
     | n < n' | p /\ p | p <- p | forall x, p | exists x, p
     | truth | falsom.
*)

Inductive prop : Type :=
  | LoggedCall : ext_nat -> fid -> tm -> prop
  | Call       : ext_nat -> fid -> tm -> prop
  | Lt         : ext_nat -> ext_nat -> prop
  | AND        : prop -> prop -> prop
  | ARROW      : prop -> prop -> prop
  | FORALL     : id -> prop -> prop
  | EXISTS     : id -> prop -> prop
  | TOP        : prop
  | BOT        : prop.

(*
logical context as a set of props:
Delta ranges over it.
*)

Definition logical_context := list prop.

(*
logic proof theory judgment: Dela ||- p
*)
Reserved Notation " Delta '||-' p " (at level 40).

Inductive entails : logical_context -> prop -> Prop :=
  (*dummy def! not implemented!*)
  dummy_entail_constr : forall (Delta: logical_context) (p: prop),
                        Delta ||- p
  where " Delta '||-' p " := (entails Delta p).

(* negation notation*)
Definition NOT (p: prop) : prop := ARROW p BOT.

Lemma weakening :
  forall (Delta Delta': logical_context) (p: prop),
  sublist Delta Delta' ->
  Delta ||- p ->
  Delta' ||- p.

Proof.
  Admitted.

Lemma weakening_cons:
  forall (Delta: logical_context) (p p': prop),
  Delta ||- p ->
  (p'::Delta) ||- p.

Proof.
  intros.
  remember(sublist_cons2 p' Delta) as HH.
  clear HeqHH.
  apply (weakening Delta (p'::Delta) p HH H).
  Qed.

(*
logging policy event (lp_ev) is a function identifier,
for which f ranges over.

logging policy triggers (lp_trigs) is a list of function identifiers,
for which gs ranges over.

logging policy level (lp_level) is the upper bound level for owner.
*)

Definition lp_ev : Type := fid.
Definition lp_trigs : Type := list fid.
Definition lp_level : Type := nat.

(*
logging policy condition (phi ranges over it):
Call(?n, f, ?arg) /\
Call(?n'1, g1, ?arg1) /\ Lt(?n'1,?n) /\ ... /\
Call(?n'm, gm, ?argm) /\ Lt(?n'm,?n).

logging policy pattern (psi ranges over it):
Call(?n, f, ?arg) /\
Call(?n'1, g1, ?arg1) /\ Lt(?n'1,?n) /\ ... /\
Call(?n'm, gm, ?argm) /\ Lt(?n'm,?n) -> LoggedCall(?n, f, ?arg).

logging policy condition type (lp_cond):
prog -> nat -> tm -> ow -> list nat -> list tm -> prop.

logging policy pattern type (lp_patt):
prog -> nat -> tm -> ow -> list nat -> list tm -> prop.

lp_trig_condition_mk iteratively generates the section of
conditions about triggers (psi ranges over it):
Call(?n'1, g1, ?args21) /\ Lt(n'1,n) /\ ... /\
Call(?n'm, gm, ?args2m) /\ Lt(n'm,n).

lp_condition_mk generates the logging policy condition
by calling lp_trig_condition_mk.

lp_pattern_mk generates the whole logging policy pattern
by calling lp_condition_mk.
*)

Fixpoint lp_trig_condition_mk_numbered (gs: lp_trigs) (n: ext_nat) (i: nat)
         : prop :=
  match gs with
  | [] =>  TOP
  | g :: gs' => let ni := nat_var ((Id i)) in
                let argi := tvar (Id (i+1)) in
                EXISTS (Id i) (EXISTS (Id (i+1))
                (AND (Call ni g argi) (AND (Lt ni n)
                 (lp_trig_condition_mk_numbered gs' n (i+2))))
                )
  end.

Fixpoint lp_trig_condition_mk (gs: lp_trigs) (n: ext_nat) : prop :=
  lp_trig_condition_mk_numbered gs n 10.

Fixpoint lp_condition_mk (f: lp_ev) (gs: lp_trigs) (n: ext_nat) (arg: tm)
           : prop :=
  AND (Call n f arg) (lp_trig_condition_mk gs n).

Fixpoint lp_pattern_mk (f: lp_ev) (gs: lp_trigs) : prop :=
  let n := nat_var (Id 5) in
  let arg := tvar (Id 6) in
  FORALL (Id 5) (FORALL (Id 6)
  (ARROW (LoggedCall n f arg) (lp_condition_mk f gs n arg))).

(*
Eval simpl in (lp_trig_condition_mk ((FId 2)::(FId 3)::nil) (proper_nat 2)).

Eval simpl in
  (lp_condition_mk  (FId 1) ((FId 2)::(FId 3)::nil) (proper_nat 2) tunit).

Eval simpl in
  (lp_pattern_mk  (FId 1) ((FId 2)::(FId 3)::nil)).
*)

(*
logging policy refinement (kappa ranges over it):
LoggedCall(?n, f, ?arg)

logging policy refinement type (lp_refin):
nat -> tm -> prop

lp_refinement_mk generates logging policy refinement.

*)

Definition lp_refin := ext_nat -> fid -> tm -> prop.
Definition lp_refinement_mk := LoggedCall.
Check lp_refinement_mk.

(*
logging policy is a 5-ary tuple of
1) a logging event,
2) a list of logging triggers,
3) a logging policy level,
4) a logging policy pattern, and
5) a logging policy refinement.

lp ranges over logpol elements.
*)

Inductive logpol : Type :=
  lgpl : lp_ev -> lp_trigs -> lp_level -> prop -> lp_refin -> logpol.

(*
wellformedness of logging polcies
are the ones whose both pattern and refinement
are wellformed:
*)
Inductive wellformed_lp : logpol -> Prop :=
  wf_lp: forall (f: lp_ev) (gs: lp_trigs)
                (l: lp_level) (psi: prop) (kappa: lp_refin),
         (forall (gi: fid), inlist gi gs -> f <>gi) ->
         psi =  lp_pattern_mk f gs ->
         kappa =  lp_refinement_mk ->
         wellformed_lp (lgpl f gs l psi kappa).

Definition LogCondition (lp: logpol) (n: ext_nat) (arg: tm) : prop :=
  match lp with
  lgpl f gs l psi kappa => lp_condition_mk f gs n arg
  end.

Axiom logcondition_entail:
  forall (Delta: list prop) (f: lp_ev) (gs: lp_trigs) (l: lp_level)
         (psi: prop) (kappa: lp_refin) (n: nat) (arg: tm),
  Delta ||- LogCondition (lgpl f gs l psi kappa) (proper_nat n) arg ->
  inlist (Call (proper_nat n) f arg) Delta /\
  forall (gi: fid), inlist gi gs ->
  exists (ni: nat) (vi: tm), inlist (Call (proper_nat ni) gi vi) Delta /\
                             true = ble_nat ni n /\ ni <> n.

(*=====================OPERATIONAL SEMANTICS============================*)

(* Substitution: [x:=s]t defined over terms *)

Reserved Notation " '[' x ':=' s ']' t " (at level 20).

Fixpoint subst (x: id) (s t: tm) : tm :=
  match t with
  | tvar y => if eq_id_dec x y then s else (tvar y)
  | tfname f => tfname f
  | tabs y T t' => if eq_id_dec x y then
                     (tabs y T t')
                   else tabs y T ([x:=s] t')
  | tapp t1 t2 => tapp ([x:=s] t1) ([x:=s] t2)
  | tunit => tunit
  | tev f t' => tev f ([x:=s] t')
  | tlev f t' => tlev f ([x:=s] t')
  | tseq t1 t2 => tseq ([x:=s] t1)([x:=s] t2)
  end
  where "'[' x ':=' s ']' t" := (subst x s t).

(* reduction single step:
   [pr, lp]: t,n,X,L ==> t',n',X',L'
*)

Reserved Notation " '[' pr ',' lp ']:' p1 '==>' p2 " (at level 40).

Inductive step : prog -> logpol -> (tm * nat * list prop * list prop) ->
                                   (tm * nat * list prop * list prop) ->
                                   Prop :=
  | ST_AppAbs : forall (pr: prog) (lp: logpol) (x: id) (T: ty)
                       (t v: tm) (n: nat) (X L: list prop),
                wellformed_lp lp->
                value v ->
                [pr, lp]: (tapp (tabs x T t) v, n, X, L) ==>
                          (subst x v t, n+1, X, L)
  | ST_AppFId : forall (tp: tm) (lp: logpol) (o: ow)
                       (C: code_base) (f: fid) (x: id) (T: ty)
                       (v t: tm) (n: nat) (X L: list prop),
                wellformed_lp lp->
                value v ->
                C f = Some (tabs x T t) ->
                [prg tp o C, lp]: (tapp (tfname f) v, n, X, L) ==>
                                  (subst x v t, n+1, X, L)
  | ST_App1   : forall (pr: prog) (lp: logpol) (t1 t1' t2: tm) (n1 n2: nat)
                       (X X' L L': list prop),
                wellformed_lp lp->
                [pr, lp]: (t1, n1, X, L) ==> (t1', n2, X', L') ->
                [pr, lp]: (tapp t1 t2, n1, X, L) ==>
                          (tapp t1' t2, n2, X', L')
  | ST_App2   : forall (pr: prog) (lp: logpol) (v t2 t2': tm) (n1 n2: nat)
                       (X X' L L': list prop),
                wellformed_lp lp->
                value v ->
                [pr, lp]: (t2, n1, X, L) ==> (t2', n2, X', L') ->
                [pr, lp]: (tapp v t2, n1, X, L) ==>
                          (tapp v t2', n2, X', L')
  | ST_EvVal  : forall (pr: prog) (lp: logpol) (f: fid) (v: tm) (n: nat)
                       (X L: list prop),
                wellformed_lp lp->
                value v ->
                [pr, lp]: (tev f v, n, X, L) ==>
                          (tunit, n, ((Call (proper_nat (n-1)) f v)::X), L)
  | ST_Ev     : forall (pr: prog) (lp: logpol) (f: fid) (t t': tm)
                       (n n': nat) (X X' L L': list prop),
                wellformed_lp lp->
                [pr, lp]: (t, n, X, L) ==> (t', n', X', L') ->
                [pr, lp]: (tev f t, n, X, L) ==> (tev f t', n', X', L')
  | ST_LevVal1 : forall (tp: tm) (o: ow) (C: code_base) (f: lp_ev)
                 (gs: lp_trigs) (l: lp_level) (psi: prop) (kappa: lp_refin)
                 (v: tm) (n: nat) (X L: list prop),
                 wellformed_lp (lgpl f gs l psi kappa)->
                 X ||- LogCondition (lgpl f gs l psi kappa)
                                    (proper_nat (n-1)) v ->
                 value v ->
                 [(prg tp o C), (lgpl f gs l psi kappa)]:
                   (tlev f v, n, X, L) ==>
                   (tunit, n, X, ((LoggedCall (proper_nat (n-1)) f v)::L))
  | ST_LevVal2 : forall (tp: tm) (o: ow) (C: code_base) (f: lp_ev)
                 (gs: lp_trigs) (l: lp_level) (psi: prop) (kappa: lp_refin)
                 (v: tm) (n: nat) (X L: list prop),
                 wellformed_lp (lgpl f gs l psi kappa)->
                 ~ (X ||- LogCondition (lgpl f gs l psi kappa)
                                    (proper_nat (n-1)) v )->
                 value v ->
                 [(prg tp o C), (lgpl f gs l psi kappa)]:
                   (tlev f v, n, X, L) ==>
                   (tunit, n, X, L)
  | ST_Lev    : forall (pr: prog) (lp: logpol) (f: fid)
                       (t t': tm) (n n': nat) (X X' L L': list prop),
                wellformed_lp lp->
                [pr, lp]: (t, n, X, L) ==> (t', n', X', L') ->
                [pr, lp]: (tlev f t, n, X, L) ==> (tlev f t', n', X', L')
  | ST_SeqUnit: forall (pr: prog) (lp: logpol) (t: tm) (n: nat)
                       (X L: list prop),
                wellformed_lp lp->
                [pr, lp]: (tseq tunit t, n, X, L) ==> (t, n, X, L)
  | ST_Seq    : forall (pr: prog) (lp: logpol) (t1 t1' t2: tm)
                       (n n': nat) (X X' L L': list prop),
                wellformed_lp lp->
                [pr, lp]: (t1, n, X, L) ==> (t1', n', X', L') ->
                [pr, lp]: (tseq t1 t2, n, X, L) ==>
                          (tseq t1' t2, n', X', L')
  where "'[' pr ',' lp ']:' p1 '==>' p2" := (step pr lp p1 p2).

Hint Constructors step.

(*reflexive transitive closure of single step reduction*)

Reserved Notation "'[' pr ',' lp ']:' p1 '==>*' p2" (at level 40).

Inductive multistep : prog -> logpol ->
                      (tm * nat * list prop * list prop) ->
                      (tm * nat * list prop * list prop) ->
                      Prop :=
  | multi_refl: forall (pr: prog) (lp: logpol) (t: tm) (n: nat)
                       (X L: list prop),
                wellformed_lp lp ->
                [pr, lp]: (t, n, X, L) ==>* (t, n, X, L)
  | multi_step: forall (pr: prog) (lp: logpol) (t t' t'': tm)
                       (n n' n'': nat)
                       (X X' X'' L L' L'': list prop),
                wellformed_lp lp ->
                [pr, lp]: (t, n, X, L) ==> (t', n', X', L') ->
                [pr, lp]: (t', n', X', L') ==>* (t'', n'', X'', L'') ->
                [pr, lp]: (t, n, X, L) ==>* (t'', n'', X'', L'')
  where "'[' pr ',' lp ']:' p1 '==>*' p2" := (multistep pr lp p1 p2).

Lemma multistep_implies_lp_wf:
  forall (pr: prog) (lp: logpol) (t t': tm)
         (n n': nat) (X X' L L': list prop),
  [pr, lp]: (t, n, X, L) ==>* (t', n', X', L') ->
  wellformed_lp lp.

Proof.
  intros.
  inversion H.
  subst.
  assumption.
  subst.
  assumption.
  Qed.

(*=====================TYPING RULES================================*)

(* the notion free variables of a term:
   function names and unit have no free variables.
*)

Inductive appears_free_in_term : id -> tm -> Prop :=
  | afi_var   : forall (x: id),
                appears_free_in_term x (tvar x)
  | afi_abs   : forall (x y: id) (T: ty) (t: tm),
                x <> y ->
                appears_free_in_term x t ->
                appears_free_in_term x (tabs y T t)
  | afi_app1  : forall (x: id) (t1 t2: tm),
                appears_free_in_term x t1 ->
                appears_free_in_term x (tapp t1 t2)
  | afi_app2  : forall (x: id) (t1 t2: tm),
                appears_free_in_term x t2 ->
                appears_free_in_term x (tapp t1 t2)
  | afi_ev    : forall (x: id) (f: fid) (t: tm),
                appears_free_in_term x t ->
                appears_free_in_term x (tev f t)
  | afi_lev   : forall (x: id) (f: fid) (t: tm),
                appears_free_in_term x t ->
                appears_free_in_term x (tlev f t)
  | afi_seq1  : forall (x: id) (t1 t2: tm),
                appears_free_in_term x t1 ->
                appears_free_in_term x (tseq t1 t2)
  | afi_seq2  : forall (x: id) (t1 t2: tm),
                appears_free_in_term x t2 ->
                appears_free_in_term x (tseq t1 t2).

Hint Constructors appears_free_in_term.

(* the notion of closed terms *)

Definition closed_term (t: tm) : Prop :=
  ~ exists x: id, appears_free_in_term x t.

(* well-formedness of codebases: |= C *)

Reserved Notation "'|=' C" (at level 40).

Inductive wellformed_codebase: code_base -> Prop :=
  | wf_empty    : |= empty
  | wf_nonempty : forall (C: code_base) (f: fid) (t: tm),
                  |= C ->
                  C f = None ->
                  closed_term t ->
                  |= (extend_fid C f t)
  where " '|=' C " :=  (wellformed_codebase C).

Lemma wellformed_closeness:
  forall (C: code_base) (f: fid) (t: tm),
  |= C -> C f = Some t -> closed_term t.

Proof.
  intros.
  generalize dependent t.
  generalize dependent f.
  induction H.
  Case "empty".
    intros.
    unfold empty in H0.
    inversion H0.
  Case "nonempty".
    intros.
    unfold extend_fid in H2.
    destruct (eq_fid_dec f f0).
    SCase "f = f0".
      inversion H2.
      subst.
      assumption.
    SCase "f != f0".
      apply IHwellformed_codebase with f0.
      assumption.
  Qed.

(* typing context for variable identifiers (Gamma ranges over it) *)
Definition context := partial_map id ty.

(*typing rules: in each |= of codebase is also added as a premise. *)
Reserved Notation " '[' pr ']:' Gamma '|-' p 'in' T " (at level 40).

Inductive has_type : prog -> context -> tm -> ty -> Prop :=
  | T_Var   : forall (tp: tm) (o: ow) (C: code_base)
                     (Gamma: context) (x: id) (T: ty),
              |= C ->
              Gamma x = Some T ->
              [prg tp o C]: Gamma |- (tvar x) in T
  | T_FName : forall (tp: tm) (o: ow) (C: code_base)
                     (Gamma: context) (f: fid) (t: tm) (T1 T2: ty),
              |= C ->
              C f = Some t ->
              [prg tp o C]: Gamma |- t in (TArrow T1 T2) ->
              [prg tp o C]: Gamma |- (tfname f) in (TArrow T1 T2)
  | T_Abs   : forall (tp: tm) (o: ow) (C: code_base)
                     (Gamma: context) (x: id) (t: tm) (T1 T2: ty),
              |= C ->
              [prg tp o C]: extend_id Gamma x T1 |- t in T2 ->
              [prg tp o C]: Gamma |- (tabs x T1 t) in (TArrow T1 T2)
  | T_App   : forall (tp: tm) (o: ow) (C: code_base)
                     (Gamma: context) (t1 t2: tm) (T1 T2: ty),
              |= C ->
              [prg tp o C]: Gamma |- t1 in (TArrow T1 T2) ->
              [prg tp o C]: Gamma |- t2 in T1 ->
              [prg tp o C]: Gamma |- (tapp t1 t2) in T2
  | T_Unit  : forall (tp: tm) (o: ow) (C: code_base)
                     (Gamma: context),
              |= C ->
              [prg tp o C]: Gamma |- tunit in TUnit
  | T_Ev    : forall (tp: tm) (o: ow) (C: code_base)
                     (Gamma: context) (f: fid) (t: tm) (T1 T2: ty),
              |= C ->
              [prg tp o C]: Gamma |- (tfname f) in TArrow T1 T2 ->
              [prg tp o C]: Gamma |- t in T1 ->
              [prg tp o C]: Gamma |- (tev f t) in TUnit
  | T_Lev  : forall (tp: tm) (o: ow) (C: code_base)
                     (Gamma: context) (f: fid) (t: tm) (T1 T2: ty),
              |= C ->
              [prg tp o C]: Gamma |- (tfname f) in TArrow T1 T2 ->
              [prg tp o C]: Gamma |- t in T1 ->
              [prg tp o C]: Gamma |- (tlev f t) in TUnit
  | T_Seq   : forall (tp: tm) (o: ow) (C: code_base)
                     (Gamma: context) (t1 t2: tm) (T: ty),
              |= C ->
              [prg tp o C]: Gamma |- t1 in TUnit ->
              [prg tp o C]: Gamma |- t2 in T ->
              [prg tp o C]: Gamma |- tseq t1 t2 in T
  where " '[' pr ']:' Gamma '|-' p 'in' T " := (has_type pr Gamma p T).

Hint Constructors has_type.

(*=====================PROGRESS================================*)

Theorem progress:
  forall (pr: prog) (t: tm) (T: ty) (lp: logpol),
  [pr]: empty |- t in T ->
  wellformed_lp lp ->
  value t \/
  exists t' n n' X X' L L', [pr, lp]: (t, n, X, L) ==> (t', n', X', L').

Proof.
  Admitted.

(*=====================PRESERVATION================================*)

(* free variables are present in context*)

Lemma free_in_context:
  forall (x: id) (t: tm) (pr: prog) (Gamma: context) (T: ty),
  appears_free_in_term x t ->
  [pr]: Gamma |- t in T ->
  exists T': ty, Gamma x = Some T'.

Proof.
  Admitted.

Corollary typable_empty_closed:
  forall (pr: prog) (t: tm) (T: ty),
  [pr]: empty |- t in T ->
  closed_term t.

Proof.
  unfold closed_term, not.
  intros.
  inversion H0.
  remember (free_in_context x t pr empty T H1 H) as HH.
  clear HeqHH.
  inversion HH.
  rename x into T'.
  unfold empty in H2.
  inversion H2.
  Qed.

Lemma context_invariance:
  forall (Gamma Gamma': context) (pr: prog) (t: tm) (T: ty),
  [pr]: Gamma |- t in T ->
  (forall (x: id), appears_free_in_term x t -> Gamma x = Gamma' x) ->
  [pr]: Gamma' |- t in T.

Proof.
  Admitted.

Lemma substitution_preseves_typing:
  forall (pr: prog) (Gamma: context) (x: id) (t s: tm) (T S: ty),
  [pr]: extend_id Gamma x S |- t in T ->
  [pr]: empty |- s in S ->
  [pr]: Gamma |- subst x s t in T.

Proof.
  Admitted.

Lemma preservation:
  forall (pr: prog) (t t': tm) (T: ty)
         (lp: logpol) (n n': nat) (X X' L L': list prop),
  [pr]: empty |- t in T ->
  [pr, lp]: (t, n, X, L) ==> (t', n', X', L') ->
  [pr]: empty |- t' in T.

Proof.
  Admitted.

(*=====================SOUNDNESS================================*)

(* normal form programs *)
Definition normal_form (t: tm) : Prop :=
  forall (pr: prog) (lp: logpol)
         (n n': nat) (X X' L L': list prop),
  ~ exists t', [pr, lp]: (t,n, X, L) ==> (t',n', X', L').

(* stuck programs *)
Definition stuck (t: tm) : Prop :=
  (normal_form t) /\ ~ value t.

Corollary soundness:
  forall (pr: prog) (lp: logpol) (t t': tm)
         (n n': nat) (T: ty) (X X' L L': list prop),
  [pr]: empty |- t in T ->
  [pr, lp]: (t, n, X, L) ==>* (t', n', X', L') ->
  ~ stuck t'.

Proof.
  Admitted.

Lemma normalization:
  forall pr lp t n X L t' n' X' L',
  [pr, lp]: (t,n,X,L) ==> (t',n',X',L') ->
  ~ exists X'' L'',
    [pr, lp]: (t',n',X',L') ==>* (t,n,X'',L'').

Proof. Admitted.

(*========================== LOG GENERATION ======================*)

(* program generating some permanent log: pr ~~> L*)
(*modified: not to ensure being evaluated!*)
Inductive prog_gen_log : logpol -> prog -> list prop -> Prop :=
  | pgl_constr: forall (lp: logpol) (t t': tm) (o: ow) (C: code_base)
                (n: nat) (X L: list prop),
                [prg t o C, lp]: (t,0,nil,nil) ==>* (t', n, X, L) ->
                prog_gen_log lp (prg t o C) L.

Notation " '|' lp '|:' pr '~~>' L " :=
         (prog_gen_log lp pr L) (at level 14).


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj5synthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus lv0 Zero) (plus (plus lv1 lv2) (mult lv3 lv2))).
Admitted.
QuickChick conj5synthconj4.


Require Import core.Semantics.
Require Import core.Syntax.
Require Import core.modeling.ModelingSemantics.
Require Import core.modeling.ConcreteSyntax.
Require Import core.modeling.Parser.
Require Import core.Model.
Require Import core.TransformationConfiguration.
Require Import core.modeling.ModelingTransformationConfiguration.
Require Import core.properties.AdditivityRule.
Require Import String.
Require Import EqNat.
Require Import List.
Require Import Expressions.
Require Import core.utils.Utils.
Require Import PeanoNat.
Require Import Lia.

(*************************************************************)
(** * Additivity in Rule context                             *)
(*************************************************************)

Definition ConcreteTransformation_incl_rules' {tc: TransformationConfiguration} {mtc: ModelingTransformationConfiguration tc}
  (t1 t2: ConcreteTransformation) : Prop :=
  (max (map (length (A:=SourceModelClass)) (map ConcreteRule_getInTypes (ConcreteTransformation_getConcreteRules t1))   )) =
  (max (map (length (A:=SourceModelClass)) (map ConcreteRule_getInTypes (ConcreteTransformation_getConcreteRules t2))   )) /\
    subseq (map parseRule (ConcreteTransformation_getConcreteRules t1))
           (map parseRule (ConcreteTransformation_getConcreteRules t2)).

Theorem parse_eq:
  forall (tc: TransformationConfiguration) (mtc: ModelingTransformationConfiguration tc)  t1 t2,
    ConcreteTransformation_incl_rules' t1 t2 ->
      Transformation_incl_rules'' (parse t1) (parse t2).
Proof.
intros.
destruct t1 as [crs1].
revert H.
revert t2.
induction crs1.
- intros.
  unfold ConcreteTransformation_incl_rules' in H.
  destruct t2 as [crs2].
  destruct crs2 eqn: crs2_ca.
  -- simpl in H.
     unfold Transformation_incl_rules''.
     crush.
  -- simpl in H.
     unfold Transformation_incl_rules''.
     split; simpl; destruct H; auto.
- intro.
  destruct t2 as [crs2].
  induction crs2.
  -- intro.
  unfold ConcreteTransformation_incl_rules' in H.
  destruct crs1 eqn: crs1_ca.
  + simpl in H.
     unfold Transformation_incl_rules''.
     crush.
  + simpl in H.
     unfold Transformation_incl_rules''.
     split; simpl; destruct H; auto.
  -- intro. specialize (IHcrs1 (transformation (crs2))).
     unfold Transformation_incl_rules''.
     simpl.
     split.
     + unfold ConcreteTransformation_incl_rules' in H.
       simpl in H. destruct H. auto.
     + unfold ConcreteTransformation_incl_rules' in H.
       simpl in H.
       crush.
Qed.

Theorem additivity_modeling_rules' :
forall (tc: TransformationConfiguration) (mtc: ModelingTransformationConfiguration tc)
  (t1 t2: ConcreteTransformation) (sm: SourceModel),
  (ConcreteTransformation_incl_rules' t1 t2 ->
    incl (allModelElements (execute (parse t1) sm)) (allModelElements (execute (parse t2) sm))).
Proof.
intros.
specialize (additivity_rules tc (parse t1) (parse t2) sm).
specialize (parse_eq tc mtc t1 t2).
intros.
apply H1.
apply H0.
apply H.
Qed.

Lemma subseq_parseRule_eq:
  forall (tc: TransformationConfiguration) (mtc: ModelingTransformationConfiguration tc) rs1 rs2,
   subseq rs1 rs2 ->
   subseq (map parseRule rs1) (map parseRule rs2).
Proof.
intros.
induction H.
- simpl. apply s_nil.
- simpl. apply s_true. auto.
- simpl. apply s_false. auto.
Qed.

Definition ConcreteTransformation_incl_rules {tc: TransformationConfiguration} {mtc: ModelingTransformationConfiguration tc} (t1 t2: ConcreteTransformation) : Prop :=
  (max (map (length (A:=SourceModelClass)) (map ConcreteRule_getInTypes (ConcreteTransformation_getConcreteRules t1))   )) =
  (max (map (length (A:=SourceModelClass)) (map ConcreteRule_getInTypes (ConcreteTransformation_getConcreteRules t2))   )) /\
    subseq (ConcreteTransformation_getConcreteRules t1) (ConcreteTransformation_getConcreteRules t2).

Lemma ConcreteTransformation_incl_rules_eq:
  forall (tc: TransformationConfiguration) (mtc: ModelingTransformationConfiguration tc) t1 t2,
    ConcreteTransformation_incl_rules t1 t2 -> ConcreteTransformation_incl_rules' t1 t2.
Proof.
intros.
unfold ConcreteTransformation_incl_rules in H.
unfold ConcreteTransformation_incl_rules.
split.
- destruct H. auto.
- destruct H. apply subseq_parseRule_eq. auto.
Qed.

Theorem additivity_modeling_rules :
forall (tc: TransformationConfiguration) (mtc: ModelingTransformationConfiguration tc)
  (t1 t2: ConcreteTransformation) (sm: SourceModel),
  (ConcreteTransformation_incl_rules t1 t2 ->
    incl (allModelElements (execute (parse t1) sm)) (allModelElements (execute (parse t2) sm))).
Proof.
intros.
apply additivity_modeling_rules'.
apply ConcreteTransformation_incl_rules_eq.
auto.
Qed.

(* Theorem arity_incl :
forall (tc: TransformationConfiguration) (t1 t2: Transformation) (sm: SourceModel),
  ((Transformation_getArity t1) <= (Transformation_getArity t2) /\ (Transformation_getRules t1) = (Transformation_getRules t2)) ->
    incl (allModelElements (execute t1 sm)) (allModelElements (execute t2 sm)).
Admitted. *)


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj30synthconj2 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus (mult lv0 lv1) lv1) lv2) (plus (mult lv0 (plus (Succ lv1) Zero)) (plus (Succ lv1) Zero))).
Admitted.
QuickChick conj30synthconj2.


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 Bprime Cprime M Dprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Cprime A /\ (wd_ Bprime A /\ (wd_ A M /\ (wd_ M Bprime /\ (wd_ Bprime Cprime /\ (wd_ M Cprime /\ (wd_ A Dprime /\ (wd_ M Dprime /\ (col_ Dprime Bprime Cprime /\ (col_ M A Dprime /\ (col_ M Bprime Cprime /\ (col_ A C Cprime /\ col_ A B Bprime))))))))))))))) -> col_ A Bprime Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj17synthconj2 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus lv0 lv1) lv2) (plus lv2 (plus lv1 lv0))).
Admitted.
QuickChick conj17synthconj2.


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 O E Eprime U A B C Aprimeprime : Universe, ((wd_ U O /\ (wd_ U E /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ U Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ Aprimeprime C /\ (wd_ O Aprimeprime /\ (wd_ B C /\ (wd_ A Aprimeprime /\ (col_ O E U /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O U A /\ (col_ O U B /\ (col_ O U C /\ (col_ O Eprime Aprimeprime /\ (col_ B Aprimeprime C /\ col_ O Aprimeprime C))))))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Set Warnings "-notation-overridden,-parsing".
Require Import Tweetnacl.Low.Unpack25519.
Require Import Tweetnacl_verif.init_tweetnacl.

(*
sv unpack25519(gf o, const u8 *n)
{
  int i;
  FOR(i,16) o[i]=n[2*i]+((i64)n[2*i+1]<<8);
  o[15]&= (i64) 0x7fff;
}
*)

Open Scope Z.

Definition unpack25519_spec :=
 DECLARE _unpack25519
  WITH o: val, n: val, sh : share, tsh : share, contents_o : list val, contents_n : list Z
  PRE [ _o OF (tptr tlg), _n OF (tptr tuchar)]
        PROP  (writable_share tsh; readable_share sh;
                Forall (fun x => 0 <= x < Z.pow 2 8) contents_n;
                Zlength contents_n = 32;
                Zlength contents_o = 16)
        LOCAL (temp _o o; temp _n n)
        SEP   (  sh [{ n }] <<(uch32)-- mVI contents_n;
                tsh [{ o }] <<(lg16)-- contents_o)
  POST [ tvoid ]
        PROP (Forall (fun x => 0 <= x < Z.pow 2 16) (Unpack25519 contents_n))
        LOCAL()
        SEP   (  sh [{ n }] <<(uch32)-- mVI contents_n;
                tsh [{ o }] <<(lg16)--  mVI64 (Unpack25519 contents_n)).

Definition unpack25519_Inv sh tsh o n (contents_o:list val) (contents_n:list Z) :=
  EX i : Z,
   PROP  (writable_share tsh; readable_share sh;
          Forall (fun x => 0 <= x < Z.pow 2 8) contents_n;
          Zlength contents_n = 32;
          Zlength contents_o = 16;
          i >= 0)
   LOCAL (temp _o o; temp _n n)
   SEP   ( sh [{ n }] <<(uch32)-- mVI contents_n;
          tsh [{ o }] <<(lg16)--  (mVI64 (list.take (nat_of_Z i) (unpack_for 8 contents_n)) ++ (list.drop (nat_of_Z i) contents_o))).

Close Scope Z.


(* infotheo: information theory and error-correcting codes in Coq               *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later              *)
From mathcomp Require Import all_ssreflect ssralg fingroup finalg perm zmodp.
From mathcomp Require Import matrix.
From mathcomp Require Import Rstruct.
Require Import ssr_ext subgraph_partition tanner f2 Rbigop.

(******************************************************************************)
(*               Cover/partition properties of Tanner graphs                  *)
(******************************************************************************)

(* OUTLINE:
- Section tanner_rel_no_hypo.
- Section acyclic_tanner_rel.
- Section tanner_partition.
*)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Import GRing.
Local Open Scope ring_scope.

Lemma trivIsetS_f (A B : finType) (f : A -> B) (AA : {set {set A}}) (BB : {set {set B}}) :
  (forall a, a \in AA -> exists b, b \in BB /\ a = [set a' | f a' \in b]) ->
  trivIset BB -> trivIset AA.
Proof.
move=> /= Hsub.
move/trivIsetP => Hdisj.
apply/trivIsetP => /= x y Hx Hy.
rewrite -setI_eq0.
case: (Hsub _ Hx) => x' [] x'Q ->.
case: (Hsub _ Hy) => y' [] y'Q -> xy.
have {xy} : x' != y' by apply: contra xy => /eqP ?; subst y'.
move/(Hdisj _ _ x'Q y'Q).
rewrite -setI_eq0 => /eqP abs.
apply/eqP/setP => /= m0.
rewrite in_set0.
move/setP : abs => /(_ (f m0)).
rewrite in_set0 => /negbT.
rewrite inE negb_and !inE.
case/orP; move/negbTE => -> //; by rewrite andbF.
Qed.

Section tanner_rel_no_hypo.

Variables (m n : nat) (H : 'M['F_2]_(m, n)).

Local Notation "''V'" := (Vnext H).
Local Notation "''F'" := (Fnext H).
Local Notation "''V(' x ',' y ')'" := (Vgraph H x y).
Local Notation "''F(' x ',' y ')'" := (Fgraph H x y).

Lemma Vgraph_decompose n1 m0 n0 : n0 \in 'V m0 ->
  n1 \in 'V(m0, n0) -> n1 != n0 -> n1 \notin 'V m0 -> exists n1',
  n1' \in 'V m0 :\ n0 /\ exists m1, m1 \in 'F n1' :\ m0 /\
    n1 \in 'V(m1, n1').
Proof.
move=> m0n0 Hn1 n1n0 n1Vm0.
rewrite !inE (negbTE n1n0) /= in Hn1.
case/andP : Hn1 => _.
case/connectP => /= q Hq Hq'.
case/shortenP : Hq Hq' => /= p Hp Huniq pq Hp'.
destruct p as [|[?|n1'] p]; [by [] | by rewrite exceptE /= tanner_relE in Hp | ].
rewrite /= in Hp'.
rewrite /= {1}exceptE /= -andbA in Hp.
case/and3P : Hp => m0n1' n1'n0 Hp.
have n1n1' : n1 != n1'.
  apply/eqP => ?; subst n1'.
  by move: n1Vm0; rewrite VnextE sym_tanner_rel m0n1'.
destruct p as [|[m1|?] t]; [ | | by rewrite exceptE /= tanner_relE in Hp ].
  exfalso; move/negP : n1n1'; apply.
  by case: Hp' => ->.
move: Hp; rewrite /= {1}exceptE; case/andP => /and3P[/= m1n1' _ _] Hp.
exists n1'.
rewrite !inE /=.
split.
  rewrite VnextE sym_tanner_rel m0n1' andbT.
  by apply: contra n1'n0 => /eqP ->.
exists m1; split.
  rewrite in_setD1 FnextE VnextE m1n1' andbT.
  apply/eqP => ?; subst m1.
  by rewrite !inE /= eqxx /= in Huniq.
rewrite !inE /= (negbTE n1n1') /= m1n1' /=.
apply/connectP; exists t => //.
apply: (sub_path_except _ _ Hp) => //.
case/andP : Huniq => _.
rewrite -(cat1s (inr _)) -(cat1s (inl m1)).
by rewrite uniq_catCA cat_uniq => /and3P[_ _ /= /andP[]].
Qed.

End tanner_rel_no_hypo.

Section acyclic_tanner_rel.

Variables (m n : nat) (H : 'M['F_2]_(m, n)).

Local Notation "''V'" := (Vnext H).
Local Notation "''F'" := (Fnext H).
Local Notation "''V(' x ',' y ')'" := (Vgraph H x y).
Local Notation "''F(' x ',' y ')'" := (Fgraph H x y).

Hypothesis Hacyclic : acyclic (tanner_rel H).

Lemma notin_Vgraph n1 m0 n0 m1 : n0 \in 'V m0 ->
  n1 \in 'V m0 :\ n0 -> m1 \in 'F n1 :\ m0 ->
  n0 \notin 'V(m1, n1).
Proof.
move=> n0m0 Hn1 Hm1.
rewrite in_setD1 in Hn1; case/andP : Hn1 => n1n0 n1m0.
rewrite in_setD1 in Hm1; case/andP : Hm1 => m1m0 m1n1.
suff : inr n0 \notin subgraph (tanner_rel H) (inl m1) (inr n1).
  move=> ?.
  by rewrite /Vgraph inE negb_or in_set1 eq_sym n1n0 /= inE.
apply: (@notin_subgraph _ (tanner_rel H) _ _ _ _ (inl m0)) => //.
exact: sym_tanner_rel.
exact: simple_tanner_rel.
by rewrite /= -VnextE.
by rewrite /= -VnextE.
by rewrite /= -VnextE -FnextE.
Qed.

Lemma Vgraph_inclusion n1 m0 n0 m1 n2 : n0 \in 'V m0 ->
  n1 \in 'V m0 :\ n0 -> m1 \in 'F n1 :\ m0 ->
  n2 \in 'V(m1, n1) -> n2 \in 'V(m0, n0).
Proof.
move=> n0m0 Hn1 Hm1 Hn2.
rewrite !inE.
case/boolP : (n2 == n0) => //= n2n0.
rewrite -VnextE n0m0 /=.
rewrite !inE /= in Hn2.
case/orP : Hn2 => Hn2.
  move/eqP in Hn2; subst n2.
  apply connect1 => /=.
  move: (Hn1); rewrite in_setD1 exceptE /= -VnextE => /andP[_ -> /=].
  by apply: contra n2n0 => /eqP [] ->.
case/andP : Hn2 => m1n1 Hn2.
case/connectP : Hn2 => p.
case/shortenP => p' Hp' Hun p'p Hlast.
apply/connectP.
exists [:: inr n1, inl m1 & p'] => //.
rewrite /=.
rewrite !inE /= in Hn1.
case/andP : Hn1 => n1n0 Hn1.
rewrite {1 2}exceptE /= -VnextE Hn1 /= m1n1 /=.
apply/andP; split.
  by apply: contra n1n0 => /eqP [] ->.
apply/andP; split.
  rewrite andbT.
  by apply: contra n1n0 => /eqP [] ->.
apply (@sub_path_except _ _ (inr n1)) => //.
apply/negP => n0p'.
case/splitPr : n0p' => p1 p2 in Hp' Hun p'p Hlast.
suff : path.ucycle (tanner_rel H) [:: inr n0, inl m0, inr n1, inl m1 & p1].
  exact: Hacyclic.
apply: uniq_path_ucycle_extend_2 => //.
exact: sym_tanner_rel.
exact: simple_tanner_rel.
by rewrite /= -VnextE.
by rewrite /= -VnextE.
apply/eqP; case => ?; subst m1; by rewrite in_setD1 eqxx in Hm1.
rewrite -(cat1s (inr n0)) catA cats1 cat_path in Hp'; by case/andP : Hp'.
rewrite -(cat1s (inl m1)) catA cat_uniq in Hun; by case/andP : Hun.
Qed.

End acyclic_tanner_rel.

Section tanner_partition.

Variables (m n : nat).
Variable H : 'M['F_2]_(m, n).

Local Notation "''V'" := (Vnext H).
Local Notation "''F'" := (Fnext H).
Local Notation "''V(' x ',' y ')'" := (Vgraph H x y).
Local Notation "''F(' x ',' y ')'" := (Fgraph H x y).

Definition Fgraph_part_fnode (n0 : 'I_n) : {set {set 'I_m}} :=
  (fun m => 'F(m, n0)) @: ('F n0).

Hypothesis Hconnect : forall a b, connect (tanner_rel H) a b.

Lemma cover_Fgraph_part_fnode (n0 : 'I_n) : cover (Fgraph_part_fnode n0) = setT.
Proof.
apply/setP => /= m1; rewrite in_set.
apply/bigcupP => /=.
have : inl m1 \in cover ([set inr n0] |: subgraph_succ (tanner_rel H) (inr n0)).
move: (cover_subgraph_succ (tanner_rel H) (inr n0)) => /setP/(_ (inl m1)) ->.
  by rewrite inE Hconnect.
case/bigcupP => /= E HE m1_in_E.
rewrite in_setU1 in HE.
move/orP: HE => [HE | ].
  by rewrite (eqP HE) in_set1 in m1_in_E.
case/imsetP => /= p Hp HE.
rewrite HE in_set in m1_in_E.
rewrite in_set in Hp.
case: p HE Hp m1_in_E => p HE /= Hp m1_in_E; last by rewrite tanner_relE in m1_in_E.
exists [set m0 | inl m0 \in E].
  apply/imsetP => /=.
  exists p.
    by rewrite FnextE VnextE.
  apply/setP => /= m0.
  by rewrite HE !inE.
by rewrite HE !in_set.
Qed.

Definition Vgraph_part_vnode (n0 : 'I_n) : {set {set 'I_n}} :=
  (fun m => 'V(m, n0) :\ n0) @: ('F n0).

Lemma notin_Vgraph_part_vnode (n0 : 'I_n) : n0 \notin cover (Vgraph_part_vnode n0).
Proof.
apply/bigcupP => /=; case=> E /imsetP [] /= m0 Hm0 ->; by rewrite 2!inE eqxx.
Qed.

Lemma cover_Vgraph_part_vnode (n0 : 'I_n) : cover (Vgraph_part_vnode n0) = setT :\ n0.
Proof.
apply/setP => /= n1.
rewrite !inE andbT.
case/boolP : (n1 == n0) => [ /eqP -> | n1n0] /=.
  exact/negbTE/notin_Vgraph_part_vnode.
apply/bigcupP => /=.
have : inr n1 \in cover ([set inr n0] |: subgraph_succ (tanner_rel H) (inr n0)).
  by rewrite (cover_subgraph_succ (tanner_rel H) (inr n0)) inE Hconnect.
case/bigcupP => /= p.
rewrite !inE.
case/orP => [ /eqP -> | ].
  rewrite inE.
  case/eqP => abs; by rewrite abs eqxx in n1n0.
case/imsetP => /=; case=> p1; last by rewrite inE tanner_relE.
move=> Hp1 pp1 n1p.
exists ('V(p1, n0) :\ n0).
  apply/imsetP => /=.
  exists p1 => //.
  rewrite inE /= -VnextE in Hp1.
  by rewrite FnextE.
rewrite !inE n1n0 /= predU1r //.
by rewrite pp1 inE in n1p.
Qed.

Hypothesis Hacyclic : acyclic (tanner_rel H).

Lemma trivIset_Fgraph_part_fnode (n0 : 'I_n) : trivIset (Fgraph_part_fnode n0).
Proof.
have K : trivIset (subgraph_succ (tanner_rel H) (inr n0)).
  exact: trivIsetS _ (subsetUr _ _)
    (trivIset_subgraph_succ (simple_tanner_rel H) (sym_tanner_rel H) Hacyclic (inr n0)).
apply: trivIsetS_f K => /= z.
case/imsetP => /= i Hi Hz.
exists [set x | x in subgraph (tanner_rel H) (inl i) (inr n0)].
split.
  apply/imsetP.
  exists (inl i).
    by rewrite inE /= -VnextE -FnextE.
  apply/setP => /= j.
  move Hlhs : (j \in _) => [|]; first by case/imsetP : Hlhs => /= k kz ->.
  apply/esym/negbTE.
  move/negbT : Hlhs; apply contra => Hlhs.
  apply/imsetP.
  by exists j.
apply/setP => /= j.
rewrite inE.
move Hlhs : (j \in z) => [|].
  apply/esym/imsetP.
  exists (inl j) => //.
  by rewrite Hz /Fgraph inE in Hlhs.
apply/esym/negbTE.
move/negbT : Hlhs; apply contra.
case/imsetP => /= p Hp ?; subst p.
by rewrite Hz inE.
Qed.

Lemma trivIset_Vgraph_part_vnode n0 : trivIset (Vgraph_part_vnode n0).
Proof.
have : trivIset (subgraph_succ (tanner_rel H) (inr n0)).
  exact: trivIsetS _ (subsetUr _ _) (trivIset_subgraph_succ
    (simple_tanner_rel H) (sym_tanner_rel H) Hacyclic (inr n0)).
apply: trivIsetS_f => /= z.
case/imsetP => /= i Hi Hz.
exists [set x | x in (subgraph (tanner_rel H) (inl i) (inr n0))].
split.
  apply/imsetP.
  exists (inl i).
    by rewrite inE /= -VnextE -FnextE.
  apply/setP => /= j.
  move Hlhs : (j \in _) => [|]; first by case/imsetP : Hlhs => /= k kz ->.
  apply/esym/negbTE.
  move/negbT : Hlhs; apply contra => Hlhs.
  apply/imsetP.
  by exists j.
apply/setP => /= j.
move Hlhs : (j \in z) => [|].
  rewrite inE.
  apply/esym/imsetP => /=.
  exists (inr j) => //.
  rewrite Hz !inE in Hlhs.
  case/andP : Hlhs => jn0.
  case/orP => jn0'.
    by rewrite (negbTE jn0) in jn0'.
  by rewrite inE.
apply/esym/negbTE.
move/negbT : Hlhs; apply contra.
rewrite inE.
case/imsetP => /= p Hp ?; subst p.
rewrite Hz !inE.
apply/andP; split.
  apply/negP => /eqP ?; subst j.
  move: Hp; apply/negP.
  apply (root_notin_subgraph (simple_tanner_rel _)).
  by rewrite inE /= -VnextE -FnextE.
rewrite inE in Hp.
by rewrite Hp orbT.
Qed.

(* NB: Lemma Vgraph_inclusion n1 m0 n0 m1 n2 : n0 \in `V m0 ->
  n1 \in `V m0 :\ n0 -> m1 \in `F n1 :\ m0 ->
  n2 \in `V(m1, n1) -> n2 \in `V(m0, n0).
=> do not need the n2 \in `V(m0, n0) hypo
*)

Lemma disjoint_Vgraph2 m0 n0 n1 n2 m1 (m0n0 : n0 \in 'V m0) :
  n1 \in 'V m0 :\ n0 ->
  n2 \in 'V(m0, n1) :\ n1 ->
  m1 \in 'F n1 :\ m0 ->
  n2 \in 'V(m1, n1) ->
  n2 \notin 'V m0 ->
  n2 \in 'V(m0, n0) -> Logic.False.
Proof.
move=> Hn1 Hn2 Hm1 H1 H2 H3.
move: (trivIset_Vgraph_part_vnode n1).
move/trivIsetP.
move/(_ ('V(m0, n1) :\ n1) ('V(m1,n1) :\ n1)).
rewrite /Vgraph_part_vnode.
have K1 : 'V(m0, n1) :\ n1 \in [set 'V(m2, n1) :\ n1 | m2 in 'F n1].
  apply/imsetP.
  exists m0 => //.
  by move: Hn1; rewrite in_setD1 -FnextE => /andP[].
move/(_ K1).
have K2 : 'V(m1, n1) :\ n1 \in [set 'V(m2, n1) :\ n1 | m2 in 'F n1].
  apply/imsetP.
  exists m1 => //.
  rewrite inE in Hm1.
  by case/andP : Hm1.
move/(_ K2).
have K3 : 'V(m0, n1) :\ n1 != 'V(m1, n1) :\ n1.
  have K4 : n0 \in 'V(m0, n1) :\ n1.
    rewrite !inE.
    rewrite !inE in Hn1.
    case/andP : Hn1 => n1n0 m0n1.
    rewrite eq_sym n1n0 /= -VnextE (negbTE n1n0) /= m0n1 /=.
    apply/connect1.
    rewrite exceptE /= -VnextE m0n0 /=.
    by apply: contra n1n0 => /eqP[->].
  have K5 : n0 \notin 'V(m1, n1) :\ n1.
    rewrite !inE negb_and negbK negb_or /=.
    rewrite !inE in Hn1.
    case/andP : Hn1 => n1n0 m0n1.
    rewrite eq_sym (negbTE n1n0) /= negb_and.
    rewrite !inE in Hm1.
    apply/orP; right.
    apply/negP.
    case/connectP => p.
    case/shortenP => p' Hp' Hun pp' Hlast.
    suff : ucycle (tanner_rel H) (inl m0 :: inr n1 :: inl m1 :: p').
      exact: Hacyclic.
    apply: uniq_path_ucycle_extend_1 => //.
    exact: simple_tanner_rel.
    by rewrite /= -VnextE; case/andP : Hm1.
    by rewrite /= -VnextE -FnextE; case/andP : Hm1.
    rewrite rcons_path Hp' /= exceptE /= andbT -Hlast -VnextE m0n0 /=.
    apply/eqP; case => ?; subst n1.
    by rewrite in_setD1 eqxx in K4.
    rewrite rcons_uniq Hun andbT /= !inE /= negb_or.
    apply/andP; split.
      apply/eqP; case => ?; subst m1; by rewrite eqxx in Hm1.
    apply/negP => m0p.
    case/splitPr : m0p => p1 p2 in Hp' Hun pp' Hlast.
    suff : ucycle (tanner_rel H) (inl m0 :: inr n1 :: inl m1 :: p1) by apply Hacyclic.
    apply: uniq_path_ucycle_extend_1.
    exact: simple_tanner_rel.
    by rewrite /= -VnextE.
    rewrite /= -VnextE -FnextE; by case/andP : Hm1.
    rewrite -(cat1s (inl m0)) catA cat_path in Hp'.
    rewrite !cats1 in Hp'.
    by case/andP : Hp'.
    rewrite rcons_uniq.
    move: Hun.
    rewrite -cat_cons cat_uniq => /andP[->]; rewrite andbT.
    by rewrite /= negb_or -andbA => /and3P[].
  apply/eqP.
  move/setP/(_ n0).
  by rewrite K4 (negbTE K5).
move/(_ K3)/disjoint_setI0/setP/(_ n2).
rewrite inE Hn2 /= in_set0 in_setD1 H1.
rewrite in_setD1 in Hn2.
case/andP : Hn2.
by move=> -> _.
Qed.

Lemma Fgraph_injective n0 m0 m1 :
  n0 \in 'V m0 -> n0 \in 'V m1 -> 'F(m0, n0) = 'F(m1, n0) -> m0 = m1.
Proof.
move=> Hm0 Hm1 m0m1.
apply/eqP/negPn/negP => abs.
have : exists cy, (2 < size cy)%nat /\ ucycleb (tanner_rel H) cy.
  have : connect (except (tanner_rel H) (inr n0)) (inl m0) (inl m1).
    have : m0 \in 'F(m1, n0).
      by rewrite -m0m1 /Fgraph 2!inE connect0 andbT -VnextE.
    rewrite 2!inE /subgraph.
    case/andP => n0m1.
    rewrite connect_sym //; exact/symmetric_except/sym_tanner_rel.
  case/connectP => /= s H1 H2.
  case/shortenP : (H1) H2 => /= s' H1' H2' H3' H2.
  have [/= s1 [s2 s1s2]] : exists s1 s2, s' = s1 ++ inl m1 :: s2.
    have m1s : inl m1 \in s'.
      rewrite H2.
      destruct s' as [|h t].
        rewrite /= in H2.
        case: H2 => ?; subst m1; by rewrite eqxx in abs.
      by rewrite /= mem_last.
    case/(nthP (inl m0)) : m1s => i Hi im1.
    exists (take i s'), (drop i.+1 s').
    by rewrite -im1 -drop_nth // cat_take_drop.
  exists (inr n0 :: inl m0 :: s1 ++ [:: inl m1]).
  split.
    by rewrite /= size_cat /= addn1.
  apply/andP; split; last first.
    rewrite -/(uniq (inl m0 :: s')) s1s2 -cat1s catA -(cat1s (inl m1)) catA cat_uniq in H2'.
    case/andP : H2' => H2' H2''.
    rewrite cons_uniq H2' andbC /= inE /= mem_cat /= negb_or.
    apply/andP; split => //.
    apply/negP => abs'.
    have {}abs' : inr n0 \in s' by rewrite s1s2 mem_cat abs'.
    case/(nthP (inl m0)) : abs' => i Hi abs'.
    move/pathP : H1'.
    move/( _ (inl m0) _ Hi).
    by rewrite exceptE /= abs' eqxx andbA andbC.
  rewrite /cycle /=.
  rewrite -VnextE Hm0 /= rcons_path.
  apply/andP; split.
    rewrite s1s2 -cat1s catA cat_path in H1'.
    case/andP : H1' => H1' _; move: H1'.
    exact: except_path.
  by rewrite last_cat /= -VnextE.
case=> cy [] H1; exact: Hacyclic.
Qed.

Lemma Fgraph_disjoint n0 m0 m1 m2 :
  m2 \in 'F(m0, n0) -> m2 \in 'F(m1, n0) -> m0 = m1.
Proof.
move=> m3m1 m3m2.
case/boolP : (m0 == m1) => [/eqP //| m1m2].
exfalso.
move: (trivIset_Fgraph_part_fnode n0).
move/trivIsetP.
move/(_ 'F(m0, n0) 'F(m1, n0)).
have m1n1 : n0 \in 'V m0.
  apply: contraLR m3m1.
  move/Fgraph_nonempty/eqP => ->.
  by rewrite in_set0.
have m2n1 : n0 \in 'V m1.
  apply: contraLR m3m2.
  move/Fgraph_nonempty/eqP => ->.
  by rewrite in_set0.
have H1 : 'F(m0, n0) \in Fgraph_part_fnode n0.
  apply/imsetP; exists m0 => //; by rewrite FnextE.
have H2 : 'F(m1, n0) \in Fgraph_part_fnode n0.
  apply/imsetP; exists m1 => //; by rewrite FnextE.
move/(_ H1 H2) => {H1 H2}.
have HF : 'F(m0, n0) != 'F(m1, n0).
  apply: contra m1m2 => /eqP HF; apply/eqP; exact: Fgraph_injective HF.
move/(_ HF) => {HF}.
rewrite -setI_eq0 => /set0Pn; apply.
exists m2; by rewrite inE m3m1 m3m2.
Qed.

Lemma Vgraph_injective n0 m0 m1 :
  n0 \in 'V m0 -> n0 \in 'V m1 -> 'V(m0, n0) :\ n0 != set0 ->
  'V(m1, n0) :\ n0 != set0 -> 'V(m0, n0) :\ n0 = 'V(m1, n0) :\ n0 -> m0 = m1.
Proof.
move=> Hm0 Hm1 m0m1 H10 H20.
apply/eqP/negPn/negP => abs.
have : exists cy, (2 < size cy)%nat /\ ucycleb (tanner_rel H) cy.
  have : connect (except (tanner_rel H) (inr n0)) (inl m0) (inl m1).
    have : exists n1, n1 \in 'V(m1, n0) :\ n0 by apply/set0Pn.
    case=> n1 Hn1; move: (Hn1).
    rewrite !inE.
    case/andP => n1n0.
    case/orP => [/eqP ? | ]; first by subst n1; rewrite eqxx in n1n0.
    rewrite /subgraph => /andP [] n0m1 m1n1.
    have : connect (except (tanner_rel H) (inr n0)) (inl m0) (inr n1).
      move: Hn1; by rewrite -H20 !inE n1n0 /= (negbTE n1n0) /= => /andP[].
    move/connect_trans; apply.
    rewrite connect_sym //; exact/symmetric_except/sym_tanner_rel.
  case/connectP => /= s H1 H2.
  case/shortenP : (H1) H2 => /= s' H1' H2' H3' H2.
  have [/= s1 [s2 s1s2]] : exists s1 s2, s' = s1 ++ inl m1 :: s2.
    have m1s : inl m1 \in s'.
      rewrite H2.
      destruct s' as [|h t].
        rewrite /= in H2.
        case: H2 => ?; subst m1; by rewrite eqxx in abs.
      by rewrite /= mem_last.
    case/(nthP (inl m0)) : m1s => i Hi im1.
    exists (take i s'), (drop i.+1 s').
    by rewrite -im1 -drop_nth // cat_take_drop.
  exists (inr n0 :: inl m0 :: s1 ++ [:: inl m1]).
  rewrite /= size_cat /= addn1; split => //.
  apply/andP; split; last first.
    rewrite -/(uniq (inl m0 :: s')) s1s2 -cat1s catA -(cat1s (inl m1)) catA cat_uniq in H2'.
    case/andP : H2' => H2' H2''.
    rewrite cons_uniq H2' andbC /= inE /= mem_cat /= negb_or.
    apply/andP; split => //.
    apply/negP => abs'.
    have {}abs' : inr n0 \in s' by rewrite s1s2 mem_cat abs'.
    case/(nthP (inl m0)) : abs' => i Hi abs'.
    move/pathP : H1'.
    move/( _ (inl m0) _ Hi).
    by rewrite exceptE /= abs' eqxx !andbF.
  rewrite /cycle /=.
  rewrite -VnextE Hm0 /= rcons_path.
  apply/andP; split.
    rewrite s1s2 -cat1s catA cat_path in H1'.
    case/andP : H1' => H1' _; move: H1'.
    exact: except_path.
  by rewrite last_cat /= -VnextE.
case=> cy [] H1; exact: Hacyclic.
Qed.

Local Open Scope R_scope.

Lemma rprod_Fgraph_part_fnode g n0:
  \prod_(m0 < m) g m0 = \prod_(m0 in 'F n0) \prod_(m1 in 'F(m0, n0)) g m1.
Proof.
transitivity (\prod_(m0 in [set: 'I_m]) g m0).
  apply eq_bigl => /= ?; by rewrite in_set.
rewrite -(cover_Fgraph_part_fnode n0).
rewrite big_trivIset /=; last exact: trivIset_Fgraph_part_fnode.
rewrite big_imset // => //.
move=> m1 m2 Hm1 Hm2 /=.
apply Fgraph_injective => //; by rewrite -FnextE.
Qed.

Lemma disjoint_Vgraph (m0 m1 : 'I_m) (n1 n0 : 'I_n) : n1 != n0 -> m0 != m1 ->
  n1 \in 'V(m0, n0) -> n1 \notin 'V(m1, n0).
Proof.
move=> n1n0 m0m1 Hn1; apply/negP => Hm1.
have Hm0' : n0 \in 'V m0.
  apply: contraLR Hn1.
  move/Vgraph_set1 => ->; by rewrite in_set1.
have Hm1' : n0 \in 'V m1.
  apply: contraLR Hm1.
  move/Vgraph_set1 => ->; by rewrite in_set1.
have Hdiff : 'V(m0, n0) :\ n0 != 'V(m1, n0) :\ n0.
  move: m0m1; apply contra.
  move/eqP => abs; apply/eqP; move: abs.
  apply Vgraph_injective => //.
  apply/set0Pn; exists n1; by rewrite in_setD1 n1n0 Hn1.
  apply/set0Pn; exists n1; by rewrite in_setD1 n1n0 Hm1.
move: (trivIset_Vgraph_part_vnode n0).
move/trivIsetP.
move/(_ ('V(m0, n0) :\ n0) ('V(m1, n0) :\ n0)) => /= abs.
have : 'V(m0, n0) :\ n0 \in Vgraph_part_vnode n0.
  case: imsetP => // abs'.
  exfalso.
  apply abs'; exists m0 => //; by rewrite FnextE.
move/abs => {}abs.
have : 'V(m1, n0) :\ n0 \in Vgraph_part_vnode n0.
   case: imsetP => // abs'; exfalso.
   apply abs'; exists m1 => //; by rewrite FnextE.
move/abs => {}abs.
move: (abs Hdiff) => {abs}abs'.
move/disjoint_setI0 : abs' => abs'.
move: abs'; apply/eqP.
apply/set0Pn.
exists n1.
by rewrite in_setI in_setD1 n1n0 /= Hn1 /= in_setD1 n1n0 Hm1.
Qed.

Definition Fgraph_part_Fgraph m0 n0 : {set {set 'I_m}} :=
  (fun n1 => \bigcup_(m1 in 'F n1 :\ m0) 'F(m1, n1)) @: (('V m0) :\ n0).

Lemma cover_Fgraph_part_Fgraph m0 n0 : n0 \in 'V m0 ->
  cover (Fgraph_part_Fgraph m0 n0) = 'F(m0, n0) :\ m0.
Proof.
move=> Hn0.
have {Hn0}m0n0 : tanner_rel H (inl m0) (inr n0) by rewrite VnextE sym_tanner_rel in Hn0.
move: (cover_subgraph_succ2_D1 (sym_tanner_rel H) Hacyclic (simple_tanner_rel H) m0n0) => Hcover.
apply/setP => /= m1.
rewrite 2!inE.
move Hlhs : ( _ \in _ ) => [|].
  apply/esym.
  have Hm1 : inl m1 \in cover (subgraph_succ2_D1 m0n0).
    rewrite /Fgraph_part_Fgraph in Hlhs.
    case/bigcupP : Hlhs => /= i i1 i2.
    case/imsetP : i1 => /= n1 Hn1 i1.
    apply/bigcupP => /=.
    exists (inr n1 |: \bigcup_(m' in successors (tanner_rel H) (inr n1) :\ inl m0) (subgraph (tanner_rel H) m' (inr n1))).
      apply/imsetP => /=.
      exists (inr n1) => //.
      rewrite !inE /= -VnextE.
      rewrite !inE /= in Hn1.
      case/andP: Hn1 => Hn1 ->; rewrite andbT.
      by apply: contra Hn1 => /eqP Hn1; case: Hn1 => ->.
    rewrite !inE /=.
    apply/bigcupP => /=.
    rewrite i1 in i2.
    case/bigcupP : i2 => /= m2 Hm2 Hm1.
    exists (inl m2).
      rewrite !inE /=.
      rewrite !inE /= in Hm1.
      case/andP : Hm1 => -> _; rewrite andbT.
      apply/eqP => abs; case : abs => ?; subst m2.
      by rewrite !inE /= eqxx in Hm2.
    rewrite !inE /= in Hm1.
    by rewrite /subgraph !inE.
  rewrite Hcover 2!inE in Hm1.
  apply/andP; split.
    case/andP : Hm1 => Hm1 _.
    by apply: contra Hm1 => /eqP ->.
  case/andP : Hm1 => _ Hm1.
  by rewrite inE.
apply/esym/negbTE.
rewrite negb_and negbK.
case/boolP : (m1 == m0) => // m1m0 /=.
move/negbT : Hlhs; apply contra => Hlhs.
apply/bigcupP => /=.
rewrite inE in Hlhs.
rewrite /Fgraph_part_Fgraph.
rewrite !inE /= in Hlhs.
case/andP : Hlhs => Hlhs Hlhs'.
case/connectP : Hlhs' => /= p.
case/shortenP => p' Hp' Hun p'p Hlast.
case: p' Hp' Hun p'p Hlast => [|p1 p2] Hp' Hun p'p Hlast.
  rewrite /= in Hlast.
  case: Hlast => ?; subst m1.
  by rewrite eqxx in m1m0.
case: p1 Hp' Hun p'p Hlast => [|n1 Hp' Hun p'p Hlast].
  by rewrite exceptE /= tanner_relE.
exists (\bigcup_(m2 in 'F n1 :\ m0) 'F(m2, n1)).
  apply/imsetP.
  exists n1 => //.
  rewrite !inE.
  rewrite /= in Hp'.
  case/andP : Hp'.
  rewrite {1}exceptE /= -VnextE => /andP[H1 H2] _.
  rewrite H1 andbT.
  by apply: contra H2 => /eqP ->.
apply/bigcupP => /=.
case: p2 Hp' Hun p'p Hlast => [ // | [p2|p2] p'] Hp' Hun p'p Hlast; last first.
  by rewrite exceptE /= tanner_relE /= andbF in Hp'.
rewrite /= in Hp'.
case/andP : Hp' => H1 /andP [] H2 H3.
exists p2.
  rewrite !inE.
  apply/andP; split.
    apply/eqP => ?; subst p2.
    rewrite -(cat1s (inl m0)) -(cat1s (inr n1)) -[in X in _ ++ X](cat1s (inl m0)) in Hun.
    by rewrite catA uniq_catCA /= inE eqxx /= in Hun.
  by move/except_rel : H2; rewrite /= -VnextE -FnextE.
rewrite !inE.
rewrite (except_rel H2) /=.
apply/connectP; exists p' => //.
apply: sub_path_except H3 => //.
apply/negP => n1p'.
move: Hun.
rewrite -(cat1s (inl m0)) -(cat1s (inr n1)) -(cat1s (inl p2)) catA uniq_catCA.
by rewrite catA uniq_catC -!catA catA cat_uniq uniq_catC /= n1p'.
Qed.

Lemma trivIset_Fgraph_part_Fgraph m0 n0 : n0 \in 'V m0 ->
  trivIset (Fgraph_part_Fgraph m0 n0).
Proof.
move=> m0n0.
rewrite VnextE sym_tanner_rel in m0n0.
move: (@trivIset_subgraph_succ2_D1 _ _ (sym_tanner_rel H)
  Hacyclic (simple_tanner_rel H) (inl m0) (inr n0) m0n0) => K.
apply: (@trivIsetS_f _ _ inl) K => /= z.
rewrite /Fgraph_part_Fgraph.
case/imsetP => n1 Hn1 Hz.
rewrite /subgraph_succ2_D1.
exists (inr n1 |: \bigcup_(m1 in successors (tanner_rel H) (inr n1) :\ inl m0)
  (subgraph (tanner_rel H) m1 (inr n1))).
split.
  apply/imsetP => /=.
  exists (inr n1).
    rewrite !inE /= in Hn1.
    rewrite !inE /= -VnextE.
    case/andP : Hn1 => Hn1 ->.
    rewrite andbT.
    by apply: contra Hn1 => /eqP [] ->.
  by f_equal.
rewrite Hz.
apply/setP => /= m1.
apply/bigcupP.
case: ifP.
  rewrite 3!inE /=.
  case/bigcupP => /=.
  case=> [m2 Hm2 Hm1 | n2].
    exists m2 => //.
      rewrite in_setD1 FnextE.
      rewrite !inE /= -VnextE in Hm2.
      case/andP : Hm2 => Hm2 ->.
      rewrite andbT.
      by apply: contra Hm2 => /eqP ->.
    by rewrite inE.
  by rewrite !inE {2}tanner_relE.
rewrite !inE /=.
move/negbT/negP => abs' abs; apply abs' => {abs'}.
case: abs => m2 Hm Hm1.
apply/bigcupP => /=.
exists (inl m2).
  rewrite !inE /= -VnextE.
  rewrite in_setD1 FnextE in Hm.
  case/andP : Hm => Hm ->.
  rewrite andbT.
  by apply: contra Hm => /eqP [] ->.
by rewrite inE in Hm1.
Qed.

Lemma another_Fgraph_injective (m0 : 'I_m) (n0 n1 n2 : 'I_n)
  (Hn1 : n1 \in 'V m0 :\ n0) (Hn2 : n2 \in 'V m0 :\ n0) :
  'F n1 :\ m0 != set0 -> (* 'F n2 :\ m0 != set0 *)
  \bigcup_(m1 in 'F n1 :\ m0) 'F(m1, n1) = \bigcup_(m1 in 'F n2 :\ m0) 'F(m1, n2) ->
  n1 = n2.
Proof.
move=> Hset0.
move=> abs.
apply/eqP/negPn/negP => n1n2.
have {}Hset0 : \bigcup_(m1 in 'F n1 :\ m0) 'F(m1, n1) != set0.
  apply: contra Hset0; exact: bigcup_succ_set0.
case/set0Pn : Hset0 => /= m1 Habs.
move: (Habs).
case/bigcupP => /= m2 Hm2 Hm1.
rewrite !inE /= in Hm1.
case/andP : Hm1 => m2n1.
case/connectP => /= p.
case/shortenP => p' Hp' unp pp' lastp.
rewrite abs in Habs.
move: Habs.
case/bigcupP => /= m3 Hm3 Hm1'.
rewrite !inE /= in Hm1'.
case/andP : Hm1' => m3n2.
case/connectP => /= p0.
case/shortenP => p0' Hp0' unp0 p0p0' lastp0.
destruct p' as [|p'1 p'2].
  rewrite /= in lastp.
  case: lastp => ?; subst m2.
  suff : ucycle (tanner_rel H) (inr n1 :: inl m0 :: inr n2 :: inl m3 :: p0').
    exact: Hacyclic.
  apply: uniq_path_ucycle_extend_2.
  exact: sym_tanner_rel.
  exact: simple_tanner_rel.
  by [].
  by rewrite /= -VnextE; move: Hn2; rewrite in_setD1 => /andP[].
  by [].
  by rewrite /= -VnextE; move: Hn1; rewrite in_setD1 => /andP[].
  apply/eqP; case => ?; subst m3; by rewrite in_setD1 eqxx in Hm3.
  rewrite rcons_path Hp0' /= exceptE /= -lastp0 /= sym_tanner_rel m2n1 /=.
  by apply: contra n1n2 => /eqP [] ->.
  by [].
destruct p0' as [|p0'1 p0'2].
  rewrite /= in lastp0.
  case: lastp0 => ?; subst m3.
  suff : ucycle (tanner_rel H) (inr n2 :: inl m0 :: inr n1 :: inl m2 :: p'1 :: p'2).
    exact: Hacyclic.
  apply: uniq_path_ucycle_extend_3.
  exact: sym_tanner_rel.
  exact: simple_tanner_rel.
  by [].
  by move: Hp' => /= /andP[] /except_rel.
  by move: Hp' => /= /andP[] /except_rel.
  by rewrite /= -VnextE; move: Hn1; rewrite in_setD1 => /andP[].
  by rewrite /= -VnextE; move: Hn2; rewrite in_setD1 => /andP[].
  apply/eqP; case => ?; subst m2; by rewrite in_setD1 eqxx in Hm2.
  move/path_except_notin : Hp'; rewrite inE negb_or => /andP []; by rewrite eq_sym.
  by apply: contra n1n2 => /eqP [] ->.
  rewrite rcons_path; apply/andP; split.
    rewrite /= in Hp'.
    case/andP : (Hp') => Hp'1 Hp'2.
    apply: sub_path_except Hp'2.
      apply/eqP => ?; subst p'1.
      by move/andP : Hp'; rewrite exceptE /= {1}tanner_relE; case.
    apply/negP => m2p'2.
    move: unp.
    rewrite -(cat1s (inl m2)) -(cat1s p'1) uniq_catCA uniq_catC cat_uniq.
    case/andP => /andP []; by rewrite m2p'2.
  rewrite /= in lastp.
  rewrite /= exceptE /= andbT -lastp /= sym_tanner_rel m3n2 /=.
  apply/eqP; case => ?; subst m2.
  move: unp.
  by rewrite cons_uniq lastI mem_rcons inE -lastp /= eqxx.
  rewrite [p'1 :: _]lock /= -lock in unp; by case/andP : unp.
suff : ucycle (tanner_rel H)
  ((inl m1 :: rev (belast p0'1 p0'2)) ++ (inl m3 :: inr n2 :: inl m0 :: inr n1 :: inl m2 :: belast p'1 p'2)).
  apply Hacyclic; by rewrite size_cat addnC.
apply: uniq_path_ucycle_cat_extend; try assumption.
exact: sym_tanner_rel.
exact: simple_tanner_rel.
by rewrite /= -VnextE; move: Hn2; rewrite in_setD1 => /andP[].
by rewrite /= -VnextE; move: Hn1; rewrite in_setD1 => /andP[].
apply/eqP; case => ?; subst m3; by rewrite in_setD1 eqxx in Hm3.
apply/eqP; case => ?; subst m2; by rewrite in_setD1 eqxx in Hm2.
by rewrite lastp last_cons -lastI.
by rewrite lastp0 last_cons -lastI.
move: unp.
rewrite (cons_uniq (inl m2)) => /andP [] H1 H2.
rewrite cons_uniq.
apply/andP; split.
  apply: contra H1; by move/mem_belast.
rewrite lastI rcons_uniq in H2; by case/andP : H2.
move: unp0.
rewrite (cons_uniq (inl m3)) => /andP [] H1 H2.
rewrite cons_uniq.
apply/andP; split.
  apply: contra H1; by move/mem_belast.
rewrite lastI rcons_uniq in H2; by case/andP : H2.
Qed.

Lemma Vgraph_id n0 m0 n1 n1' m1 m1' n2 :
  n0 \in 'V m0 ->
  n1 \in 'V m0 :\ n0 -> n1' \in 'V m0 :\ n0 ->
  m1 \in 'F n1 :\ m0 -> m1' \in 'F n1' :\ m0 ->
  n2 \in 'V(m1, n1) ->
  n2 \in 'V(m1', n1') -> n1 = n1'.
Proof.
move=> Hn0 Hn1 Hn1' Hm1 Hm1'.
rewrite !inE.
case/orP => [/eqP ? |]; [subst n2|].
  case/orP => [/eqP ?|]; [by subst n1'|].
  case/andP => n1'm1'.
  case/connectP => /= p.
  case/shortenP => p' Hp' unp pp' lastp.
  exfalso.
  suff : path.ucycle (tanner_rel H) [:: inl m0, inr n1', inl m1' & p'].
    exact: Hacyclic.
  apply: uniq_path_ucycle_extend_1 => //.
  exact: simple_tanner_rel.
  by rewrite /= -VnextE; move: Hn1'; rewrite in_setD1 => /andP[].
  rewrite rcons_path /= Hp' /= exceptE /= -lastp andbT.
  apply/andP; split.
    by rewrite /= -VnextE; move: Hn1; rewrite in_setD1 => /andP[].
  apply/eqP; case => ?; subst n1'.
  move/path_except_notin : Hp'.
  destruct p' => //.
  rewrite /= in lastp.
  by rewrite lastI -lastp mem_rcons inE eqxx.
  rewrite rcons_uniq unp andbT inE negb_or.
  apply/andP; split.
    rewrite !inE in Hm1'.
    case/andP : Hm1' => Hm1' _.
    by apply: contra Hm1' => /eqP [] ->.
  apply/negP => Hx.
  case/splitPr : Hx => p1 p2 in Hp' unp pp' lastp.
  suff : ucycle (tanner_rel H) [:: inl m0, inr n1', inl m1' & p1].
    exact: Hacyclic.
  apply: uniq_path_ucycle_extend_1 => //.
  exact: simple_tanner_rel.
  by rewrite /= -VnextE; move: Hn1'; rewrite in_setD1 => /andP[].
  rewrite -(cat1s (inl m0)) catA cat_path in Hp'.
  rewrite cats1 in Hp'.
  by case/andP : Hp'.
  rewrite rcons_uniq.
  move: unp; rewrite -cat_cons cat_uniq => /andP[-> /=].
  by rewrite negb_or -andbA => /and3P[] ->.
case/andP => n1m1 /connectP /= [] p.
case/shortenP => p' Hp' unp pp' lastp.
case/orP => [/eqP ?|]; [subst n1'|].
  exfalso.
  suff : path.ucycle (tanner_rel H) [:: inl m0, inr n1, inl m1 & p'].
    exact: Hacyclic.
  apply: uniq_path_ucycle_extend_1 => //.
  exact: simple_tanner_rel.
  by rewrite /= -VnextE; move: Hn1; rewrite in_setD1 => /andP[].
  rewrite rcons_path Hp' /= -lastp exceptE /= andbT -VnextE.
  rewrite !inE in Hn1'.
  case/andP : Hn1' => n2n0 -> /=.
  apply/eqP; case => ?; subst n2.
  move/path_except_notin : Hp'.
  destruct p' => //.
  rewrite /= in lastp.
  by rewrite lastI mem_rcons -lastp inE eqxx.
  rewrite rcons_uniq unp andbT inE /= negb_or.
  apply/andP; split.
    apply/eqP; case => ?; subst m1.
    by rewrite in_setD1 eqxx in Hm1.
  apply/negP => Hx.
  case/splitPr : Hx => p1 p2 in Hp' unp pp' lastp.
  suff : ucycle (tanner_rel H) [:: inl m0, inr n1, inl m1 & p1] by exact: Hacyclic.
  apply: uniq_path_ucycle_extend_1 => //.
  exact: simple_tanner_rel.
  by rewrite /= -VnextE; move: Hn1; rewrite in_setD1 => /andP[].
  rewrite -(cat1s (inl m0)) catA cat_path in Hp'.
  rewrite cats1 in Hp'.
  by case/andP : Hp'.
  rewrite rcons_uniq.
  by move: unp; rewrite -cat_cons cat_uniq => /and3P[-> /=]; rewrite negb_or => /andP[->].
move: (Hm1'); rewrite !inE /= -VnextE -FnextE => /andP [] _ -> /=.
case/connectP => /= q.
case/shortenP => q' Hq' unq qq' lastq.
apply/eqP/negPn/negP => n1n1'.
case: p' Hp' unp pp' lastp => [// | p'1 p'2] Hp' unp pp' lastp.
elim/last_ind : q' Hq' unq qq' lastq => [// | q'1 q'2 _] Hq' unq qq' lastq.
rewrite last_rcons in lastq; subst q'2.
suff : ucycle (tanner_rel H) ((inr n2 :: rev q'1) ++ [:: inl m1', inr n1', inl m0, inr n1, inl m1 & belast p'1 p'2]).
  by apply Hacyclic; rewrite size_cat addnC.
apply: uniq_path_ucycle_cat_extend => //.
exact: sym_tanner_rel.
exact: simple_tanner_rel.
by rewrite /= -VnextE; move: Hn1'; rewrite in_setD1 => /andP[].
by rewrite /= -VnextE -FnextE; move: Hm1'; rewrite in_setD1 => /andP[].
by rewrite /= -VnextE; move: Hn1; rewrite in_setD1 => /andP[].
apply/eqP; case => ?; subst m1'; by rewrite in_setD1 eqxx in Hm1'.
apply/eqP; case => ?; subst m1; by rewrite in_setD1 eqxx in Hm1.
by rewrite lastp last_cons -lastI.
move: unp.
rewrite (lastI p'1) /= mem_rcons inE negb_or => /andP [] /andP [] H1 ->.
by rewrite rcons_uniq => /andP [].
move: unq.
rewrite /= mem_rcons inE negb_or => /andP [] /andP [] -> ->.
by rewrite rcons_uniq => /andP [] _ ->.
Qed.

Definition Vgraph_part_Vgraph m0 n0 : {set {set 'I_n}} :=
  (fun n1 => n1 |: (\bigcup_(m1 in 'F n1 :\ m0) ('V(m1, n1) :\ n1))) @: (('V m0) :\ n0).

Lemma cover_Vgraph_part_Vgraph m0 n0 : n0 \in 'V m0 ->
  cover (Vgraph_part_Vgraph m0 n0) = 'V(m0, n0) :\ n0.
Proof.
move=> Hn0.
have {Hn0}m0n0 : tanner_rel H (inl m0) (inr n0) by rewrite VnextE sym_tanner_rel in Hn0.
move: (cover_subgraph_succ2_D1 (sym_tanner_rel H) Hacyclic (simple_tanner_rel H) m0n0) => Hcover.
apply/setP => /= n1.
rewrite 2!inE.
move Hlhs : ( _ \in _ ) => [|].
  apply/esym.
  have Hn1 : inr n1 \in cover (subgraph_succ2_D1 m0n0).
    rewrite /Vgraph_part_Vgraph in Hlhs.
    case/bigcupP : Hlhs => /= i i1 i2.
    case/imsetP : i1 => /= n1' Hn1' i1.
    apply/bigcupP => /=.
    exists (inr n1' |: \bigcup_(m' in successors (tanner_rel H) (inr n1') :\ inl m0) (subgraph (tanner_rel H) m' (inr n1'))).
      apply/imsetP => /=.
      exists (inr n1') => //.
      rewrite !inE /= -VnextE.
      rewrite !inE /= in Hn1'.
      case/andP: Hn1' => Hn1' ->; rewrite andbT.
      by apply: contra Hn1' => /eqP Hn1'; case: Hn1' => ->.
    rewrite !inE /=.
    rewrite i1 !inE in i2.
    case/orP : i2.
      move/eqP => ->; by rewrite eqxx.
    case/bigcupP => /= m1 Hm1.
    rewrite in_setD1.
    case/andP => n1n1' Hn1.
    apply/orP; right.
    apply/bigcupP => /=.
    exists (inl m1).
      move: Hm1.
      rewrite in_setD1 /= in_setD1 inE /= -VnextE -FnextE.
      case/andP => Hm1 ->; rewrite andbT.
      by apply: contra Hm1 => /eqP [] ->.
    by rewrite inE in_set1 (negbTE n1n1') /= inE in Hn1.
  move: Hn1.
  rewrite Hcover in_setD1.
  case/andP => n1m0 Hn1.
  apply/andP; split.
    apply/eqP => ?; subst n1.
    move: Hn1.
    apply/negP/(root_notin_subgraph (simple_tanner_rel _)).
    by rewrite inE sym_tanner_rel.
  by rewrite 3!inE Hn1 orbT.
apply/esym/negbTE.
move/negbT : Hlhs; apply contra.
case/andP.
rewrite 2!inE.
move=> n1n0.
rewrite in_set1 (negbTE n1n0) orFb.
rewrite inE.
case/andP => _ Hn1.
apply/bigcupP => /=.
case/connectP : Hn1 => /= p.
case/shortenP.
case=> //.
case=> [|n2 p' Hp' Hun p'p Hlast]; first by rewrite exceptE tanner_relE.
exists (n2 |: \bigcup_(m1 in 'F n2 :\ m0) ('V(m1, n2) :\ n2)).
  apply/imsetP => /=.
  exists n2 => //.
  rewrite !inE /=.
  move: Hp'.
  rewrite /= exceptE /= -VnextE -andbA => /and3P[] -> tmp _.
  rewrite andbT.
  by apply: contra tmp => /eqP ->.
rewrite !inE.
case: (boolP (n1 == n2)) => //= n1n2.
apply/bigcupP.
case: p' Hp' Hun p'p Hlast => //.
  move=> _ _ _ [] ?; subst n2; by rewrite eqxx in n1n2.
case; last by rewrite exceptE /= tanner_relE /= andbF.
move=> m1 p' Hp' Hun p'p Hlast.
rewrite /= in Hp'.
case/andP : Hp' => H1 /andP [] H2 H3.
rewrite exceptE /= andbT -VnextE -FnextE in H2.
exists m1.
  rewrite !inE.
  case/andP : H2 => -> _.
  rewrite -(cat1s (inl m0)) -(cat1s (inr n2)) -(cat1s (inl m1)) in Hun.
  rewrite uniq_catCA uniq_catC /= in Hun.
  case/andP : Hun.
  rewrite inE negb_or.
  case/andP => Hun _ _.
  rewrite andbT.
  by apply: contra Hun => /eqP ->.
rewrite !inE (negbTE n1n2) /= -VnextE -FnextE.
case/andP : H2 => -> H2 /=.
apply/connectP; exists p' => //.
apply: sub_path_except H3 => //.
apply/negP => n2p'.
move: Hun.
rewrite -(cat1s (inl m0)) -(cat1s (inr n2)) -(cat1s (inl m1)) catA uniq_catCA.
by rewrite catA uniq_catC -!catA catA cat_uniq uniq_catC /= n2p'.
Qed.

Lemma trivIset_Vgraph_part_Vgraph m0 n0 : n0 \in 'V m0 ->
  trivIset (Vgraph_part_Vgraph m0 n0).
Proof.
move=> m0n0.
have {}m0n0 : tanner_rel H (inl m0) (inr n0) by rewrite VnextE sym_tanner_rel in m0n0.
move: (@trivIset_subgraph_succ2_D1 _ _ (sym_tanner_rel H)
  Hacyclic (simple_tanner_rel _) (inl m0) (inr n0) m0n0) => K.
apply: (@trivIsetS_f _ _ inr) K => /= z.
rewrite /Vgraph_part_Vgraph.
case/imsetP => /= n1 Hn1 Hz.
rewrite /subgraph_succ2_D1.
exists (inr n1 |: \bigcup_(m1 in successors (tanner_rel H) (inr n1) :\ inl m0)
  (@subgraph _ (tanner_rel H) m1 (inr n1))).
split.
  apply/imsetP => /=.
  exists (inr n1) => //.
  rewrite !inE /= in Hn1.
  rewrite !inE /= -VnextE.
  case/andP : Hn1 => Hn1 ->.
  rewrite andbT.
  by apply: contra Hn1 => /eqP [] ->.
rewrite Hz.
apply/setP => /= m1.
rewrite !inE.
case: (boolP (m1 == n1)) => [|m1n1] /=.
  move/eqP => ->; by rewrite eqxx.
rewrite (_ : inr m1 == _ = false) /=; last first.
  apply/negbTE.
  by apply: contra m1n1 => /eqP [] ->.
apply/bigcupP.
case: ifP.
  case/bigcupP => /=.
  case => [m2 | n2]; last by rewrite !inE {2}tanner_relE.
  rewrite 3!inE /=.
  case/andP => m2m0 m2n1 X.
  rewrite -VnextE -FnextE in m2n1.
  exists m2.
    rewrite !inE /= m2n1 andbT.
    by apply: contra m2m0 => /eqP ->.
  by rewrite in_setD1 m1n1 /= inE in_set1 (negbTE m1n1) orFb inE.
move/bigcupP => abs abs'; apply abs => {abs}.
case: abs' => m2 Hm2 Hm1 /=.
exists (inl m2).
  rewrite !inE /= -VnextE -FnextE.
  rewrite !inE /= in Hm2.
  case/andP : Hm2 => m2m0 ->.
  rewrite andbT.
  by apply: contra m2m0 => /eqP [] ->.
rewrite !inE (negbTE m1n1) /= in Hm1.
by rewrite !inE.
Qed.

Lemma Vgraph_injective3 (m0 : 'I_m) (n0 n1 n2 : 'I_n)
  (Hn1 : n1 \in 'V m0 :\ n0) (Hn2 : n2 \in 'V m0 :\ n0) :
  n1 |: (\bigcup_(m1 in 'F n1 :\ m0) ('V(m1, n1) :\ n1)) = n2 |: (\bigcup_(m1 in 'F n2 :\ m0) ('V(m1, n2) :\ n2)) ->
  n1 = n2.
Proof.
move=> abs.
apply/eqP/negPn/negP => abs'.
have [m1] : exists m1, (m1 \in 'F n1 :\ m0) && (n2 \in 'V(m1, n1) :\ n1).
  move/setP : abs.
  move/(_ n2) => abs.
  have {abs} : n2 \in n1 |: \bigcup_(m1 in 'F n1 :\ m0) ('V(m1, n1) :\ n1).
    by rewrite abs inE in_set1 eqxx.
  rewrite inE in_set1 eq_sym (negbTE abs') orFb.
  case/bigcupP => m1 Hm1 n2m1 .
  exists m1; by rewrite Hm1.
case/andP => m1n1.
rewrite in_setD1 eq_sym abs' /=.
rewrite inE.
rewrite in_set1 eq_sym (negbTE abs') /= 2!inE.
case/andP => _.
case/connectP => p.
case/shortenP => p' Hp unp pp' lastp.
suff : ucycle (tanner_rel H) [:: inl m0, inr n1, inl m1 & p'] by exact: Hacyclic.
apply: uniq_path_ucycle_extend_1.
exact: simple_tanner_rel.
by rewrite /= -VnextE; move: Hn1; rewrite in_setD1 => /andP[].
by rewrite /= -VnextE -FnextE; move: m1n1; rewrite in_setD1 => /andP[].
rewrite rcons_path Hp /= exceptE /= andbT -lastp.
apply/andP; split.
  by rewrite /= -VnextE; move: Hn2; rewrite in_setD1 => /andP[].
apply/eqP; case=> ?; subst n2; by rewrite eqxx in abs'.
rewrite rcons_uniq unp andbT inE negb_or.
apply/andP; split.
  apply/eqP; case => ?; subst m1; by rewrite in_setD1 eqxx in m1n1.
apply/negP => m0p'.
case/splitPr : m0p' => p'1 p'2 in Hp unp pp' lastp.
suff : ucycle (tanner_rel H) [:: inl m0, inr n1, inl m1 & p'1].
  exact: Hacyclic.
apply: uniq_path_ucycle_extend_1; try assumption.
exact: simple_tanner_rel.
by rewrite /= -VnextE; move: Hn1; rewrite in_setD1 => /andP[].
by rewrite /= -VnextE -FnextE; move: m1n1; rewrite in_setD1 => /andP[].
rewrite -(cat1s (inl m0)) catA cats1 cat_path in Hp; by case/andP : Hp.
rewrite rcons_uniq.
by move: unp; rewrite -cat_cons cat_uniq => /and3P[-> /=]; rewrite negb_or => /andP[->].
Qed.

End tanner_partition.