(*
abhishek@brixpro:~/parametricity/reflective-paramcoq/test-suite$ ./coqid.sh indFunArg
*)

Require Import SquiggleEq.terms.

Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Require Import ReflParam.PIWNew.

Require Import Template.Template.

Require Import ReflParam.matchR. (* shadows Coq.Init.Datatypes.list *)
Require Import List.
(* Run TemplateProgram (mkIndEnv "indTransEnv" ["ReflParam.matchR.Vec"]). *)

Inductive Vec (C : Set) : nat -> Set :=
| vnil : Vec C 0
| vcons : forall n : nat, C -> Vec C n -> Vec C (n+1).

Definition Coq_Init_Datatypes_nat_RR0 :=
(fix Coq_Init_Datatypes_nat_RR0 (H H0 : nat) {struct H} : Prop :=
   match H with
   | 0%nat => match H0 with
              | 0%nat => I = I
              | S _ => False
              end
   | S x =>
       match H0 with
       | 0%nat => False
       | S x0 => {_ : Coq_Init_Datatypes_nat_RR0 x x0 & I = I}
       end
   end).

Notation nat_RR := Coq_Init_Datatypes_nat_RR0.

Arguments existT : clear implicits.
Arguments eq_refl : clear implicits.

Definition S_RRInv:=
(fun (H H0 : nat) (sigt_R : {_ : Coq_Init_Datatypes_nat_RR0 H H0 & I = I})
   (retTyp_R : {_ : Coq_Init_Datatypes_nat_RR0 H H0 & I = I} -> Set)
   (_ : forall H1 : Coq_Init_Datatypes_nat_RR0 H H0,
        retTyp_R
          (existT (Coq_Init_Datatypes_nat_RR0 H H0)
             (fun _ : Coq_Init_Datatypes_nat_RR0 H H0 => I = I) H1
             (eq_refl True I))) => fiat (retTyp_R sigt_R)).

Definition S_RR :=
(fun (H H0 : nat) (H1 : Coq_Init_Datatypes_nat_RR0 H H0) =>
 existT (Coq_Init_Datatypes_nat_RR0 H H0) (fun _ : Coq_Init_Datatypes_nat_RR0 H H0 => I = I)
   H1 (eq_refl True I))
.

Fixpoint Coq_Init_Nat_add_RR (n1 n2 : nat) (n_R : nat_RR n1 n2) (m1 m2 : nat) (m_R : nat_RR m1 m2):
nat_RR (n1 + m1) (n2 + m2) :=
let reT := fun n1 n2 => nat_RR n1 n2 -> nat_RR (n1 + m1) (n2 + m2) in
(match n1 return reT n1 n2 with
| 0 =>
  match n2 return reT 0 n2 with
  | 0 => fun _ => m_R
  | S _ => fun n_R => False_rect _ n_R
  end
| S p1 =>
  match n2 return reT (S p1) n2 with
  | 0 => fun n_R => False_rect _ n_R
  | S p2 => fun n_R =>
             let n_R := projT1 n_R in
             S_RR _ _ (Coq_Init_Nat_add_RR p1 p2 n_R m1 m2 m_R)
  end
end) n_R.

Notation add_RR := Coq_Init_Nat_add_RR.
Definition O_RR := (eq_refl True I).

Inductive Vec_cons_RR  (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop)
(Vec_RR: forall H H0 : nat, nat_RR H H0 -> Vec C₁ H -> Vec C₂ H0 -> Set)
(n₁ n₂ : nat)
(H : C₁) (H0 : C₂)
(H1 : Vec C₁ n₁) (H2 : Vec C₂ n₂) : nat_RR (n₁ +1) (n₂+1) -> Prop :=
| Vec_cons_RR_cc: forall (cr:C_R H H0) (n_R : nat_RR n₁ n₂),
                    Vec_RR n₁ n₂ n_R H1 H2 ->
       Vec_cons_RR C₁ C₂ C_R Vec_RR n₁ n₂ H H0 H1 H2
        (Coq_Init_Nat_add_RR n₁ n₂ n_R 1 1 (S_RR 0 0 O_RR)).

(*
Coq_Init_Datatypes_nat_RR0_paramConstr_1 is defined
(fun (sigt_R : I = I) (retTyp_R : I = I -> Set) (_ : retTyp_R (eq_refl True I)) =>
 fiat (retTyp_R sigt_R))
Coq_Init_Datatypes_nat_RR0_paramConstr_0_paramInv is defined
*)

(*
Require Import Top.nat.
Run TemplateProgram (genParamInd [] false true true true "ReflParam.matchR.Vec").
*)

Definition one_RR : nat_RR 1 1.
simpl. eexists; eauto.
Defined.

(* fails termination check *)
Definition Vec_RR :=
(fix
 ReflParam_matchR_Vec_RR0 (C C₂ : Set) (C_R : C -> C₂ -> Prop) (H H0 : nat)
                          (H1 : nat_RR H H0) (H2 : Vec C H) (H3 : Vec C₂ H0) {struct H2} :
   Prop :=
   let reT n1 n2 := forall (nr : nat_RR n1 n2), Prop in
   (match H2 in Vec _ n1 return reT n1 H0 with
   | vnil _ => match H3 in Vec _ n2 return reT 0 n2  with
               | vnil _ => fun nr => nr = O_RR
               | vcons _ _ _ _ => fun _ => False
               end
   | vcons _ n x x0 =>
       match H3 with
       | vnil _ => fun _ => False
       | vcons _ n₂ x1 x2 =>
       fun nr =>
       Vec_cons_RR C C₂ C_R (ReflParam_matchR_Vec_RR0 C C₂ C_R) n n₂ x x1 x0 x2 nr
       end
   end) H1
    ).

 (*success!*)
(*
(fun (C C₂ : Set) (C_R : C -> C₂ -> Prop) (n n₂ : nat) (H : C) (H0 : C₂)
   (H1 : Vec C n) (H2 : Vec C₂ n₂)
   (sigt : {n_R : Coq_Init_Datatypes_nat_RR0 n n₂ &
           {_ : C_R H H0 & {_ : ReflParam_matchR_Vec_RR0 C C₂ C_R n n₂ n_R H1 H2 & True}}})
   (retTyp : Set)
   (rett : forall n_R : Coq_Init_Datatypes_nat_RR0 n n₂,
           C_R H H0 -> ReflParam_matchR_Vec_RR0 C C₂ C_R n n₂ n_R H1 H2 -> retTyp) =>
 let n_R := projT1 sigt in
 let H3 := projT1 (projT2 sigt) in let H4 := projT1 (projT2 (projT2 sigt)) in rett n_R H3 H4)
*)

Print vcons_RR.

Declare ML Module "paramcoq".
Parametricity Recursive Vec_rect.

Definition vnil_RR (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop) :
 Vec_RR C₁ C₂ C_R 0 0 O_RR (vnil C₁) (vnil C₂).
Proof.
  simpl. reflexivity.
Defined.

Definition vcons_RR  (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop) (n₁ n₂ : nat) (n_R : nat_RR n₁ n₂)
  (H : C₁) (H0 : C₂) (c_R : C_R H H0) (H1 : Vec C₁ n₁) (H2 : Vec C₂ n₂)
  (v_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R H1 H2):
  Vec_RR C₁ C₂ C_R (n₁ + 1) (n₂ + 1) (add_RR _ _ n_R 1 1 one_RR)
         (vcons C₁ n₁ H H1) (vcons C₂ n₂ H0 H2).
Proof.
  simpl.
  exists n_R. exists c_R. exists v_R. reflexivity.
Defined.

Require Import SquiggleEq.tactics.

Fixpoint Vec_rect_RR (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop) (P₁ : forall n : nat, Vec C₁ n -> Set)
         (P₂ : forall n : nat, Vec C₂ n -> Set)
         (P_R : forall (n₁ n₂ : nat) (n_R : nat_RR n₁ n₂)
                  (v₁ : Vec C₁ n₁) (v₂ : Vec C₂ n₂),
                Vec_RR C₁ C₂ C_R n₁ n₂ n_R v₁ v₂ -> P₁ n₁ v₁ -> P₂ n₂ v₂ -> Set)
         (f₁ : P₁ 0 (vnil C₁))
         (f₂ : P₂ 0 (vnil C₂))
       (f_R: P_R 0 0 O_RR (vnil C₁) (vnil C₂) (vnil_RR C₁ C₂ C_R) f₁ f₂)
         (f₁0 : forall (n : nat) (c : C₁) (v : Vec C₁ n),
                P₁ n v -> P₁ (n + 1) (vcons C₁ n c v))
         (f₂0 : forall (n : nat) (c : C₂) (v : Vec C₂ n),
                P₂ n v -> P₂ (n + 1) (vcons C₂ n c v))
       (f0_R: forall (n₁ n₂ : nat) (n_R : nat_RR n₁ n₂) (c₁ : C₁)
          (c₂ : C₂) (c_R : C_R c₁ c₂) (v₁ : Vec C₁ n₁) (v₂ : Vec C₂ n₂)
          (v_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R v₁ v₂) (H : P₁ n₁ v₁)
          (H0 : P₂ n₂ v₂),
        P_R n₁ n₂ n_R v₁ v₂ v_R H H0 ->
        P_R (n₁ + 1) (n₂ + 1)
          (add_RR n₁ n₂ n_R 1 1 one_RR)
          (vcons C₁ n₁ c₁ v₁) (vcons C₂ n₂ c₂ v₂)
          (vcons_RR C₁ C₂ C_R n₁ n₂ n_R c₁ c₂ c_R v₁ v₂ v_R)
          (f₁0 n₁ c₁ v₁ H) (f₂0 n₂ c₂ v₂ H0))
       (n₁ n₂ : nat) (n_R : nat_RR n₁ n₂) (v₁ : Vec C₁ n₁)
         (v₂ : Vec C₂ n₂) (v_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R v₁ v₂) {struct v₁} :
       P_R n₁ n₂ n_R v₁ v₂ v_R (Vec_rect C₁ P₁ f₁ f₁0 n₁ v₁) (Vec_rect C₂ P₂ f₂ f₂0 n₂ v₂).
Proof.
  revert v_R.
  revert n_R.
  destruct v₁;
   destruct v₂; intros.
  - simpl. clear f₁0 f₂0 f0_R. simpl in v_R. unfold vnil_RR in f_R. simpl in f_R.
    subst. assumption.
  - simpl in v_R. apply False_rect. assumption.
  - simpl in v_R. apply False_rect. assumption.
  - simpl. simpl in *. exrepnd. simpl.
    Arguments existT {A} {P} x p.
    simpl. rename v_R0 into peq.
    subst. simpl. apply f0_R.
    apply Vec_rect_RR; assumption.
Defined.

       (*
vcons_RR =
fun (C C₂ : Set) (C_R : C -> C₂ -> Prop) (n n₂ : nat)
  (n_R : Coq_Init_Datatypes_nat_RR0 n n₂) (H : C) (H0 : C₂) (H1 : C_R H H0)
  (H2 : Vec C n) (H3 : Vec C₂ n₂) (H4 : ReflParam_matchR_Vec_RR0 C C₂ C_R n n₂ n_R H2 H3) =>
existT n_R (existT H1 (existT H4 I))
*)

(* Notation Vec_RR := ReflParam_matchR_Vec_RR0. *)
(* Notation vcons_RR := ReflParam_matchR_Vec_RR0_paramConstr_1. *)

(*Definition vcons_RR {C₁ C₂ : Set} {C_R : C₁ -> C₂ -> Prop}
(n₁ n₂ : nat) (n_R : nat_RR n₁ n₂)
 (H : C₁) (H0 : C₂) (c_R: C_R H H0)
 (H1 : Vec C₁ n₁) (H2 : Vec C₂ n₂)
 (v_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R H1 H2):
  Vec_RR C₁ C₂ C_R (S n₁) (S n₂) (S_RR n₁ n₂ n_R)
  (vcons C₁ n₁ H H1) (vcons C₂ n₂ H0 H2) :=
  existT
  (fun n_R0 : nat_RR n₁ n₂ =>
   {_ : C_R H H0 & {_ : Vec_RR C₁ C₂ C_R n₁ n₂ n_R0 H1 H2 & True}}) n_R
  (existT (fun _ : C_R H H0 => {_ : Vec_RR C₁ C₂ C_R n₁ n₂ n_R H1 H2 & True}) c_R
     (existT (fun _ : Vec_RR C₁ C₂ C_R n₁ n₂ n_R H1 H2 => True) v_R I)).
*)
(*
Proof.
simpl. eexists; eexists; eauto.
Defined.
*)

Require Import SquiggleEq.UsefulTypes.
Fixpoint ReflParam_matchR_vAppend_RR (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop) (n₁ n₂ : nat)
   (n_R : nat_RR n₁ n₂) (m₁ m₂ : nat) (m_R : nat_RR m₁ m₂)
   (vl₁ : Vec C₁ n₁) (vl₂ : Vec C₂ n₂)
   (vl_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R vl₁ vl₂)
   (vr₁ : Vec C₁ m₁) (vr₂ : Vec C₂ m₂)
   (vr_R : Vec_RR C₁ C₂ C_R m₁ m₂ m_R vr₁ vr₂) {struct vl₁ }:
    Vec_RR C₁ C₂ C_R (n₁ + m₁) (n₂ + m₂) (add_RR n₁ n₂ n_R m₁ m₂ m_R)
         (vAppend vl₁ vr₁) (vAppend vl₂ vr₂).
refine (
let reT := fun n₁ vl₁ n₂ vl₂ =>
forall n_R: nat_RR n₁ n₂,
Vec_RR C₁ C₂ C_R n₁ n₂ n_R vl₁ vl₂
->
Vec_RR C₁ C₂ C_R (n₁ + m₁) (n₂ + m₂) (add_RR n₁ n₂ n_R m₁ m₂ m_R)
         (vAppend vl₁ vr₁) (vAppend vl₂ vr₂)  in
(match vl₁ in Vec _ n₁ return reT n₁ vl₁ n₂ vl₂ with
| vnil _ =>
  match vl₂ in (Vec _ n₂) return reT 0 (vnil _) n₂ vl₂ with
  | vnil _ => fun _ _ => vr_R
  | vcons _ _ _ _ => fun _ v_R => False_rect _ v_R
  end

| vcons _ n₁ hl₁ tl₁ =>
  match vl₂ in (Vec _ n₂) return reT (S n₁) (vcons _ n₁ hl₁ tl₁) n₂ vl₂ with
  | vnil _ =>  fun _ v_R => False_rect _ v_R
  | vcons _ _ hl₂ tl₂ => fun _ v_R =>
    let n_R := projT2 v_R in
    let v_R := projT2 v_R in
    let hl_R := projT1 v_R in
    let tl_R := projT1 (projT2 v_R) in
    let peq := projT2 (projT2 v_R) in
    let old := (vcons_RR _ _ C_R _ _ _ _ _ hl_R _ _
     (ReflParam_matchR_vAppend_RR _ _ _ _ _ _ _ _ _ _ _ tl_R  _ _ vr_R))
    in _
  end
end) n_R vl_R).
simpl vAppend. simpl add_RR.
rewrite peq. exact old.
Defined.

Definition Vec_rect_type :=
forall (C : Set) (P : forall n : nat, Vec C n -> Set),
       P 0 (vnil C) ->
       (forall (n : nat) (c : C) (v : Vec C n), P n v -> P (S n) (vcons C n c v)) ->
       forall (n : nat) (v : Vec C n), P n v.

Require Import SquiggleEq.tactics.

Notation vAppend_RR := ReflParam_matchR_vAppend_RR.

Print sigT_rect.

Print ReflParam_matchR_Vec_RR0.

Definition vAppend2_RR3 (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop) (m₁ m₂ : nat)
  (m_R : nat_RR m₁ m₂)
  (cdef₁ : C₁) (cdef₂ : C₂) (cdef_R : C_R cdef₁ cdef₂)
  (vr₁ : Vec C₁ m₁) (vr₂ : Vec C₂ m₂) (vr : Vec_RR C₁ C₂ C_R m₁ m₂ m_R vr₁ vr₂):
  C_R (vAppend2  cdef₁ vr₁) (vAppend2 cdef₂ vr₂) :=
(
let reT n1 n2 v1 v2 (* indices and values. move the _Rs to the body, as Pi args  *) :=
      forall (nr: nat_RR n1 n2)
        (vapr: Vec_RR C₁ C₂ C_R n1 n2 nr v1 v2),
     C_R match v1 with
      | vnil _ => cdef₁
      | vcons _ _ hl _ => hl
      end match v2 with
          | vnil _ => cdef₂
          | vcons _ _ hl _ => hl
          end in

(* the "as vap1" part cannot be inlined.
"vAppend vr₁ vr₁" has type "Vec C₁ (m₁ + m₁)" while vap1 has type "Vec C₁ n1"
*)
match vAppend vr₁ vr₁ as vap1 in Vec _ n1
  return reT n1 (m₂+m₂)(*prime of index of discriminee *)
      vap1 (vAppend vr₂ vr₂) (* prime of discriminee*)
with
| vnil _ =>
    match vAppend vr₂ vr₂ as vap2 in Vec _ n2
      return reT O (*index of this constr:vnil*) n2 (* from in *)
          (vnil _) vap2
      with
      | vnil _ => fun (nr : nat_RR 0 0) (_ : Vec_RR C₁ C₂ C_R 0 0 nr (vnil C₁) (vnil C₂))  => cdef_R
      | vcons _ n2 hl2 v2 =>
        fun (nr : nat_RR 0 (S n2))
          (vr0 : Vec_RR C₁ C₂ C_R 0 (S n2) nr (vnil C₁) (vcons C₂ n2 hl2 v2))
        => False_rect
            (*reT 0 (S n2) (vnil C₁) (vcons C₂ n2 hl2 v2) nr vr0 -- then strip the 2 pis*)
            _ vr0 (* always the last lambda *)
      end
| vcons _ n1 hl tl =>
    match vAppend vr₂ vr₂ as vap2 in Vec _ n2
      return reT (S n1) (*index of this constr*) n2 (* from in *)
          (vcons _ _ hl tl) vap2
      with
      | vnil _ => fun _ vr => False_rect _ vr
      | vcons _ _ hl _ => fun _ v_R =>
    let v_R := projT2 v_R in
    let hl_R := projT1 v_R in
    let tl_R := projT1 (projT2 v_R)
        in hl_R
      end

end (add_RR m₁ m₂ m_R m₁ m₂ m_R)
  (vAppend_RR _ _ _ _ _ _ _ _ vr _ _ vr)
).
Check indTransEnv.
Run TemplateProgram (genParam indTransEnv false true "vAppend2"). (* success!*)
Print vAppend2_RR.

(*
vAppend2_RR =
fun (C C₂ : Set) (C_R : C -> C₂ -> Prop) (m m₂ : nat) (m_R : nat_RR m m₂)
  (cdef : C) (cdef₂ : C₂) (cdef_R : C_R cdef cdef₂) (vr : Vec C m)
  (vr₂ : Vec C₂ m₂) (vr_R : Vec_RR C C₂ C_R m m₂ m_R vr vr₂) =>
match
  vAppend vr vr as vapx in (Vec _ n)
  return
    (forall n_R : nat_RR n (m₂ + m₂),
     Vec_RR C C₂ C_R n (m₂ + m₂) n_R vapx (vAppend vr₂ vr₂) ->
     C_R match vapx with
         | vnil _ => cdef
         | vcons _ _ hl _ => hl
         end match vAppend vr₂ vr₂ with
             | vnil _ => cdef₂
             | vcons _ _ hl₂ _ => hl₂
             end)
with
| vnil _ =>
    match
      vAppend vr₂ vr₂ as vapx₂ in (Vec _ n₂)
      return
        (forall n_R : nat_RR 0 n₂,
         Vec_RR C C₂ C_R 0 n₂ n_R (vnil C) vapx₂ ->
         C_R cdef match vapx₂ with
                  | vnil _ => cdef₂
                  | vcons _ _ hl₂ _ => hl₂
                  end)
    with
    | vnil _ =>
        fun (n_R : nat_RR 0 0) (vapx_R : Vec_RR C C₂ C_R 0 0 n_R (vnil C) (vnil C₂)) =>
        ReflParam_matchR_Vec_RR0_paramConstr_0_paramInv C C₂ C_R vapx_R
          (C_R match vnil C with
               | vnil _ => cdef
               | vcons _ _ hl _ => hl
               end match vnil C₂ with
                   | vnil _ => cdef₂
                   | vcons _ _ hl₂ _ => hl₂
                   end) cdef_R
    | vcons _ n'₂ hl₂ tl₂ =>
        fun (n_R : nat_RR 0 (S n'₂))
          (vapx_R : Vec_RR C C₂ C_R 0 (S n'₂) n_R (vnil C) (vcons C₂ n'₂ hl₂ tl₂)) =>
        False_rectt
          (C_R match vnil C with
               | vnil _ => cdef
               | vcons _ _ hl _ => hl
               end
             match vcons C₂ n'₂ hl₂ tl₂ with
             | vnil _ => cdef₂
             | vcons _ _ hl₂0 _ => hl₂0
             end) vapx_R
    end
| vcons _ n' hl tl =>
    match
      vAppend vr₂ vr₂ as vapx₂ in (Vec _ n₂)
      return
        (forall n_R : nat_RR (S n') n₂,
         Vec_RR C C₂ C_R (S n') n₂ n_R (vcons C n' hl tl) vapx₂ ->
         C_R hl match vapx₂ with
                | vnil _ => cdef₂
                | vcons _ _ hl₂ _ => hl₂
                end)
    with
    | vnil _ =>
        fun (n_R : nat_RR (S n') 0)
          (vapx_R : Vec_RR C C₂ C_R (S n') 0 n_R (vcons C n' hl tl) (vnil C₂)) =>
        False_rectt
          (C_R match vcons C n' hl tl with
               | vnil _ => cdef
               | vcons _ _ hl0 _ => hl0
               end match vnil C₂ with
                   | vnil _ => cdef₂
                   | vcons _ _ hl₂ _ => hl₂
                   end) vapx_R
    | vcons _ n'₂ hl₂ tl₂ =>
        fun (n_R : nat_RR (S n') (S n'₂))
          (vapx_R : Vec_RR C C₂ C_R (S n') (S n'₂) n_R (vcons C n' hl tl)
                      (vcons C₂ n'₂ hl₂ tl₂)) =>
        ReflParam_matchR_Vec_RR0_paramConstr_1_paramInv C C₂ C_R n' n'₂ hl hl₂ tl tl₂ vapx_R
          (C_R match vcons C n' hl tl with
               | vnil _ => cdef
               | vcons _ _ hl0 _ => hl0
               end
             match vcons C₂ n'₂ hl₂ tl₂ with
             | vnil _ => cdef₂
             | vcons _ _ hl₂0 _ => hl₂0
             end)
          (fun (n'_R : nat_RR n' n'₂) (hl_R : C_R hl hl₂)
             (_ : Vec_RR C C₂ C_R n' n'₂ n'_R tl tl₂) => hl_R)
    end
end (add_RR m m₂ m_R m m₂ m_R) (vAppend_RR m m₂ m_R m m₂ m_R vr vr₂ vr_R vr vr₂ vr_R)
     : forall (C C₂ : Set) (C_R : C -> C₂ -> Prop) (m m₂ : nat)
         (m_R : nat_RR m m₂) (cdef : C) (cdef₂ : C₂),
       C_R cdef cdef₂ ->
       forall (vr : Vec C m) (vr₂ : Vec C₂ m₂),
       Vec_RR C C₂ C_R m m₂ m_R vr vr₂ ->
       C_R match vAppend vr vr with
           | vnil _ => cdef
           | vcons _ _ hl _ => hl
           end match vAppend vr₂ vr₂ with
               | vnil _ => cdef₂
               | vcons _ _ hl₂ _ => hl₂
               end
*)


(**************************************************************************
* TLC: A library for Coq                                                  *
* Option data-structure
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibReflect.
Generalizable Variables A.

(** Fixing implicit arguments *)

Arguments Some {A}.
Arguments None {A}.

(* ********************************************************************** *)
(** * Inhabited and comparable *)

Instance option_inhab : forall A, Inhab (option A).
Proof using. intros. apply (prove_Inhab None). Qed.

Definition option_compare `{Comparable A} (o1 o2 : option A) :=
  match o1, o2 with
  | None, None => true
  | Some v1, Some v2 => decide (v1 = v2)
  | _, _ => false
  end.

Global Instance option_comparable : forall `{Comparable A},
  Comparable (option A).
Proof using.
  intros.
  applys (comparable_beq option_compare).
  destruct x; destruct y; simpl; rew_refl; iff; auto_false*; congruence.
Qed.

(* ********************************************************************** *)
(** * Operations and their properties *)

(* ---------------------------------------------------------------------- *)
(** ** Definitions *)

(** [is_some o] holds when [o] is of the form [Some x] *)

Definition is_some A (o:option A) :=
  match o with
  | None => false
  | Some _ => true
  end.

(** [unsome_default d o] returns the content of the option, and returns [d]
    in case the option in [None]. *)

Definition unsome_default A d (o:option A) :=
  match o with
  | None => d
  | Some x => x
  end.

(** [unsome o] returns the content of the option, and returns an arbitrary
    value in case the option in [None]. *)

Definition unsome `{Inhab A} :=
  unsome_default arbitrary.

(** [map f o] takes an option and returns an option, and maps the function
    [f] to the content of the option if it has one. *)

Definition map A B (f : A -> B) o :=
  match o with
  | None => None
  | Some x => Some (f x)
  end.

(** [map_on o f] is the same as [map f o], only the arguments are swapped. *)

Definition map_on A B o (f : A -> B) :=
  map f o.

(** [apply f o] optionnaly applies a function of type [A -> option B] *)
(* --todo: find a more explicit name *)

Definition apply A B (f : A -> option B) o :=
  match o with
  | None => None
  | Some x => f x
  end.

(** [apply_on o f] is the same as [apply f o] *)

Definition apply_on A B o (f : A -> option B) :=
  apply f o.

(* ---------------------------------------------------------------------- *)
(** ** Properties *)

Lemma apply_on_inv : forall A B (f : A->option B) x y,
  apply_on x f = Some y ->
  exists z, x = Some z /\ f z = Some y.
Proof using. destruct x; simpl; introv H; inverts* H. Qed.

Arguments apply_on_inv [A B f x y].

Lemma apply_on_inv_none : forall A B (f : A->option B) x,
  apply_on x f = None ->
  x = None \/ exists y, x = Some y /\ f y = None.
Proof. destruct x; simpl; introv H; inverts* H. Qed.

Lemma map_inv : forall A B (f : A->B) x y,
  map f x = Some y ->
  exists z, x = Some z /\ y = f z.
Proof using. destruct x; simpl; introv H; inverts* H. Qed.

Arguments map_inv [A B f x y].

Lemma map_on_inv : forall A B (f : A->B) x y,
  map_on x f = Some y ->
  exists z, x = Some z /\ y = f z.
Proof using. destruct x; simpl; introv H; inverts* H. Qed.

Arguments map_on_inv [A B f x y].

Lemma option_map_none_inv : forall A B (f : A -> B) o,
  map f o = None -> o = None.
Proof. introv E. destruct~ o; tryfalse. Qed.


From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From BitBlasting Require Import QFBV CNF BBCommon.
From ssrlib Require Import ZAriths Tactics.
From nbits Require Import NBits.

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

(* ===== bit_blast_full_adder ===== *)

Definition bit_blast_full_adder1 g a1 a2 cin :=
  let (g', r) := gen g in
  let (g'', cout) := gen g' in
  let sum_cs := [::
        [:: neg_lit r; a1; a2; cin];
          [:: neg_lit r; neg_lit a1; neg_lit a2; cin];
          [:: neg_lit r; neg_lit a1; a2; neg_lit cin];
          [:: neg_lit r; a1; neg_lit a2; neg_lit cin];
        [:: r; neg_lit a1; a2; cin];
          [:: r; a1; neg_lit a2; cin];
          [:: r; a1; a2; neg_lit cin];
          [:: r; neg_lit a1; neg_lit a2; neg_lit cin]
      ] in
  let cout_cs := [::
        [:: neg_lit cout; a1; a2];
          [:: neg_lit cout; a1; cin];
          [:: neg_lit cout; a2; cin];
        [:: cout; neg_lit a1; neg_lit a2];
          [:: cout; neg_lit a1; a2; neg_lit cin];
          [:: cout; a1; neg_lit a2; neg_lit cin]
      ] in
  (g'', catrev sum_cs cout_cs, cout, r).

Definition mk_env_full_adder1 E g a1 a2 cin :=
  let (g', r) := gen g in
  let (g'', cout) := gen g' in
  let sum_cs := [::
        [:: neg_lit r; a1; a2; cin];
          [:: neg_lit r; neg_lit a1; neg_lit a2; cin];
          [:: neg_lit r; neg_lit a1; a2; neg_lit cin];
          [:: neg_lit r; a1; neg_lit a2; neg_lit cin];
        [:: r; neg_lit a1; a2; cin];
          [:: r; a1; neg_lit a2; cin];
          [:: r; a1; a2; neg_lit cin];
          [:: r; neg_lit a1; neg_lit a2; neg_lit cin]
      ] in
  let cout_cs := [::
        [:: neg_lit cout; a1; a2];
          [:: neg_lit cout; a1; cin];
          [:: neg_lit cout; a2; cin];
        [:: cout; neg_lit a1; neg_lit a2];
          [:: cout; neg_lit a1; a2; neg_lit cin];
          [:: cout; a1; neg_lit a2; neg_lit cin]
      ] in
  let E' := env_upd E (var_of_lit r)
                    (xorb (xorb (interp_lit E a1) (interp_lit E a2))
                          (interp_lit E cin)) in
  let E'' := env_upd E' (var_of_lit cout)
                     (((interp_lit E a1) && (interp_lit E a2))
                      || ((xorb (interp_lit E a1) (interp_lit E a2))
                            && (interp_lit E cin))) in
  (E'', g'', catrev sum_cs cout_cs, cout, r).

Lemma bit_blast_full_adder1_correct1 :
  forall g b1 b2 bcin E l1 l2 lcin g' cs lcout lr ,
    bit_blast_full_adder1 g l1 l2 lcin = (g', cs, lcout, lr) ->
    enc_bit E l1 b1 -> enc_bit E l2 b2 -> enc_bit E lcin bcin ->
    interp_cnf E (add_prelude cs) ->
    enc_bit E lr (xorb (xorb b1 b2) bcin) /\
    enc_bit E lcout ((b1 && b2) || ((xorb b1 b2) && bcin)).
Proof.
  rewrite /bit_blast_full_adder1 /=.
  move=> g b1 b2 bcin E l1 l2 lcin g' cs lcout lr.
  case => _ <- <- <-. move=> {g' cs lcout lr}.
  rewrite /enc_bit /=.
  repeat (rewrite add_prelude_cons !add_prelude_singleton !interp_clause_cons).
  rewrite !interp_lit_neg_lit /=.
  move=> /eqP -> /eqP -> /eqP -> H. split_andb_hyps. split.
  - move: {H13 H14 H15 H16 H17 H18} H19 H20 H21 H22 H23 H24 H25 H26.
      by case: (E g); case: b1; case: b2; case: bcin.
  - move: H13 H14 H15 H16 H17 H18 {H19 H20 H21 H22 H23 H24 H25 H26}.
      by case: (E (g + 1)%positive); case: b1; case: b2; case: bcin.
Qed.

Lemma bit_blast_full_adder1_correct2 :
  forall g b1 b2 bcin bcout br E l1 l2 lcin g' cs lcout lr,
    bit_blast_full_adder1 g l1 l2 lcin = (g', cs, lcout, lr) ->
    enc_bit E l1 b1 -> enc_bit E l2 b2 -> enc_bit E lcin bcin ->
    interp_cnf E (add_prelude cs) ->
    bool_adder bcin b1 b2 = (bcout, br) ->
    enc_bit E lr br /\
    enc_bit E lcout bcout.
Proof.
  rewrite /bit_blast_full_adder1 /=.
  move=> g b1 b2 bcin bcout br E l1 l2 lcin g' cs lcout lr.
  case => _ <- <- <-. move=> {g' cs lcout lr}.
  rewrite /enc_bit /=.
  repeat (rewrite add_prelude_cons !add_prelude_singleton !interp_clause_cons).
  rewrite !interp_lit_neg_lit /=.
  move=> /eqP -> /eqP -> /eqP -> H. split_andb_hyps. move=> Hadd. split.
  - move: Hadd {H13 H14 H15 H16 H17 H18} H19 H20 H21 H22 H23 H24 H25 H26.
    rewrite /bool_adder.
      by case: (E g); case: b1; case: b2; case: bcin; case; move=> _ <- /=.
  - move: Hadd H13 H14 H15 H16 H17 H18 {H19 H20 H21 H22 H23 H24 H25 H26}.
      by case: (E (g + 1)%positive); case: b1; case: b2; case: bcin;
        case; move=> <- _.
Qed.

Fixpoint bit_blast_full_adder_zip g lcin lp : generator * cnf * literal * word :=
  match lp with
  | [::] => (g, [::], lcin, [::])
  | (l1, l2) :: tl =>
    let '(g_hd, cs_hd, lcout_hd, lrs_hd) := bit_blast_full_adder1 g l1 l2 lcin in
    let '(g_tl, cs_tl, lcout_tl, lrs_tl) := bit_blast_full_adder_zip g_hd lcout_hd tl in
    (g_tl, catrev cs_hd cs_tl, lcout_tl, lrs_hd :: lrs_tl)
  end.

Definition bit_blast_full_adder g lcin ls1 ls2 :=
  bit_blast_full_adder_zip g lcin (extzip_ff ls1 ls2).

Fixpoint mk_env_full_adder_zip E g lcin lp : env * generator * cnf * literal * word :=
  match lp with
  | [::] => (E, g, [::], lcin, [::])
  | (l1, l2) :: tl =>
    let '(E_hd, g_hd, cs_hd, lcout_hd, lrs_hd) := mk_env_full_adder1 E g l1 l2 lcin in
    let '(E_tl, g_tl, cs_tl, lcout_tl, lrs_tl) := mk_env_full_adder_zip E_hd g_hd lcout_hd tl in
    (E_tl, g_tl, catrev cs_hd cs_tl, lcout_tl, lrs_hd::lrs_tl)
  end.

Definition mk_env_full_adder E g lcin ls1 ls2 :=
  mk_env_full_adder_zip E g lcin (extzip_ff ls1 ls2).

Lemma bit_blast_full_adder_zip_size_ss lsp lcin g g' cs lrs lcout :
  bit_blast_full_adder_zip g lcin lsp = (g', cs, lcout, lrs) -> size lsp = size lrs.
Proof.
  elim: lsp lcin g g' cs lrs lcout => [| lhd ltl IH] lcin g g' cs lrs lcout.
  - rewrite/=. by case => _ _ _ <-.
  - rewrite/=. case lhd => [lhd1 lhd2].
    case Hbbfa : (bit_blast_full_adder_zip (g + 1 + 1)%positive (Pos (g + 1)%positive) ltl)
    => [[[gtl cstl] lcouttl] lrstl]. case => _ _ _ <-. by rewrite (IH _ _ _ _ _ _ Hbbfa).
Qed.

Lemma bit_blast_full_adder_size_max ls1 ls2 lcin g g' cs lrs lcout :
  bit_blast_full_adder g lcin ls1 ls2 = (g', cs, lcout, lrs) ->
  maxn (size ls1) (size ls2) = size lrs.
Proof.
  move=> Hbb. move: (bit_blast_full_adder_zip_size_ss Hbb) => Hszip.
  rewrite size_extzip in Hszip. assumption.
Qed.

Lemma bit_blast_full_adder_size_ss ls1 ls2 lcin g g' cs lrs lcout :
  bit_blast_full_adder g lcin ls1 ls2 = (g', cs, lcout, lrs) ->
  size ls1 = size ls2 -> size ls1 = size lrs.
Proof.
  move=> Hbb Hs. rewrite -(bit_blast_full_adder_size_max Hbb).
  rewrite Hs maxnn. reflexivity.
Qed.

Lemma bit_blast_full_adder_zip_correct E g bp bcin bcout lp lcin lcout g' cs lrs brs :
  bit_blast_full_adder_zip g lcin lp = (g', cs, lcout, lrs) ->
  enc_bits E (unzip1 lp) (unzip1 bp) -> enc_bits E (unzip2 lp) (unzip2 bp) ->
  enc_bit E lcin bcin -> interp_cnf E (add_prelude cs) ->
  adcB bcin (unzip1 bp) (unzip2 bp) = (bcout, brs) ->
  enc_bit E lcout bcout /\ enc_bits E lrs brs.
Proof.
  elim: lp E g bp bcin bcout lcin lcout g' cs lrs brs =>
  [|[l1_hd l2_hd] lp_tl IH] E g bp bcin bcout lcin lcout g' cs lrs brs.
  - rewrite !enc_bits_nil_l. case => _ <- <- <- /eqP -> /eqP -> Henclcin _ /=.
    rewrite /adcB /full_adder/=. case => <- <-.
    split; [exact Henclcin| rewrite !enc_bits_nil_l/=; auto].
  - rewrite /bit_blast_full_adder_zip (lock bit_blast_full_adder1) /= -!lock -/bit_blast_full_adder_zip.
    dcase (bit_blast_full_adder1 g l1_hd l2_hd lcin) => [[[[g_hd] cs_hd] lcout_hd] lrs_hd] Hfadd1.
    dcase (bit_blast_full_adder_zip g_hd lcout_hd lp_tl) => [[[[g_tl] cs_tl] lcout_tl] lrs_tl] Hfaddz.
    case => _ <- <- <- /=.
    case : bp => [| [bp_hd1 bp_hd2] bp_tl] //=.
    rewrite !enc_bits_cons. move => /andP [Henchd1 Henctl1] /andP [Henchd2 Henctl2] Henclcin.
    rewrite add_prelude_catrev => /andP [Haphd Haptl].
    rewrite /adcB /=.
    case Hfaddhd : (full_adder bcin (bp_hd1 :: unzip1 bp_tl) (bp_hd2 :: unzip2 bp_tl)) => [bcout_hd brs_hd].
    move : Hfaddhd.
    rewrite /full_adder /=.
    case Hbaddhd : (bool_adder bcin bp_hd1 bp_hd2) => [bbcout_hd bbrs_hd].
    case Hfaddzhd : (full_adder_zip bbcout_hd (zip (unzip1 bp_tl) (unzip2 bp_tl)))
                      => [bbcout_tl bbrs_tl].
    case => <- <-. case => <- <-.
    move : (bit_blast_full_adder1_correct2 Hfadd1 Henchd1 Henchd2 Henclcin Haphd Hbaddhd) => [Henclrshd Henclcouthd].
    rewrite enc_bits_cons Henclrshd andTb.
    move : Hfaddzhd.
    replace (full_adder_zip bbcout_hd (zip (unzip1 bp_tl) (unzip2 bp_tl))) with
        (full_adder bbcout_hd (unzip1 bp_tl) (unzip2 bp_tl)) by auto.
    replace (full_adder bbcout_hd (unzip1 bp_tl) (unzip2 bp_tl)) with
        (adcB bbcout_hd (unzip1 bp_tl) (unzip2 bp_tl)) by auto.
    move => Hfaddzhd.
    exact : (IH _ _ _ _ _ _ _ _ _ _ _ Hfaddz Henctl1 Henctl2 Henclcouthd Haptl Hfaddzhd).
Qed.

Lemma bit_blast_full_adder_correct E g ls1 ls2 bcin bs1 bs2 lcin g' cs lrs brs lcout bcout:
  bit_blast_full_adder g lcin ls1 ls2 = (g', cs, lcout, lrs) ->
  enc_bits E ls1 bs1 -> enc_bits E ls2 bs2 -> enc_bit E lcin bcin ->
  interp_cnf E (add_prelude cs) -> adcB bcin bs1 bs2 = (bcout, brs) ->
  size ls1 = size ls2 ->
  enc_bit E lcout bcout /\ enc_bits E lrs brs.
Proof.
  rewrite /bit_blast_full_adder => Hbbfadd Henc1 Henc2 Hencin Hcs HadcB Hszeq.
  move : (enc_bits_size Henc1) (enc_bits_size Henc2) => Hsz1 Hsz2.
  move : (add_prelude_enc_bit_tt Hcs) => Henctt.
  move : HadcB.
  assert (bs1 = (unzip1 (extzip0 bs1 bs2))) as Hbs1; [rewrite unzip1_extzip_ss; [auto|rewrite -Hsz1-Hsz2; exact Hszeq]|].
  assert (bs2 = (unzip2 (extzip0 bs1 bs2))) as Hbs2; [rewrite unzip2_extzip_ss; [auto|rewrite -Hsz1-Hsz2; exact Hszeq]|].
  rewrite Hbs2.
  replace (adcB bcin bs1 (unzip2 (extzip0 bs1 bs2))) with (adcB bcin (unzip1 (extzip0 bs1 bs2)) (unzip2 (extzip0 bs1 bs2))); [|rewrite <- Hbs1; auto].
  move => HadcB.
  exact : (bit_blast_full_adder_zip_correct Hbbfadd
                                            (enc_bits_unzip1_extzip Henctt Henc1 Henc2)
                                            (enc_bits_unzip2_extzip Henctt Henc1 Henc2)
                                            Hencin Hcs HadcB).
Qed.

Corollary bit_blast_full_adder_correct1 E g ls1 ls2 bcin bs1 bs2 lcin g' cs lrs brs lcout bcout :
  bit_blast_full_adder g lcin ls1 ls2 = (g', cs, lcout, lrs) ->
  enc_bits E ls1 bs1 -> enc_bits E ls2 bs2 -> enc_bit E lcin bcin ->
  interp_cnf E (add_prelude cs) ->
  adcB bcin bs1 bs2 = (bcout, brs) ->
  size ls1 = size ls2 ->
  enc_bits E lrs brs.
Proof.
  move=> Hblast Henc1 Henc2 Hencin Hcs Hbrs Hszeq.
  move: (bit_blast_full_adder_correct Hblast Henc1 Henc2 Hencin Hcs Hbrs Hszeq).
  move=> [H1 H2]; exact: H2.
Qed.

Corollary bit_blast_full_adder_correct2 E g ls1 ls2 bcin bs1 bs2 lcin g' cs lrs brs lcout bcout :
  bit_blast_full_adder g lcin ls1 ls2 = (g', cs, lcout, lrs) ->
  enc_bits E ls1 bs1 -> enc_bits E ls2 bs2 -> enc_bit E lcin bcin ->
  interp_cnf E (add_prelude cs) ->
  adcB bcin bs1 bs2 = (bcout, brs) ->
  size ls1 = size ls2 ->
  enc_bit E lcout bcout.
Proof.
  move=> Hblast Henc1 Henc2 Hencin Hcs Hbrs Hszeq.
  move: (bit_blast_full_adder_correct Hblast Henc1 Henc2 Hencin Hcs Hbrs Hszeq).
  move=> [H1 H2]; exact: H1.
Qed.

Lemma mk_env_full_adder1_is_bit_blast_full_adder1 E g l1 l2 lcin E' g' cs lcout lrs :
  mk_env_full_adder1 E g l1 l2 lcin = (E', g', cs, lcout, lrs) ->
  bit_blast_full_adder1 g l1 l2 lcin = (g', cs, lcout, lrs).
Proof.
  rewrite /mk_env_full_adder1 /bit_blast_full_adder1; intros.
  dite_hyps; dcase_hyps; subst; reflexivity.
Qed.

Lemma mk_env_full_adder_zip_is_bit_blast_full_adder_zip E g lp lcin E' g' cs lcout lrs :
  mk_env_full_adder_zip E g lcin lp = (E', g', cs, lcout, lrs) ->
  bit_blast_full_adder_zip g lcin lp = (g', cs, lcout, lrs).
Proof.
  elim : lp E g lcin lcout E' g' cs lrs =>
  [|[l1_hd l2_hd] lp_tl IH] E g lcin lcout E' g' cs lrs.
  - by case => _ <- <- <- <-.
  - rewrite /bit_blast_full_adder_zip (lock bit_blast_full_adder1) /mk_env_full_adder_zip (lock mk_env_full_adder1)/= -!lock -/bit_blast_full_adder_zip -/mk_env_full_adder_zip.
    dcase (mk_env_full_adder1 E g l1_hd l2_hd lcin) => [[[[[E_hd] g_hd] cs_hd] lcout_hd] lrs_hd] Henv1.
    dcase (mk_env_full_adder_zip E_hd g_hd lcout_hd lp_tl) => [[[[[E_tl] g_tl] lcout_tl] cs_tl] lrs_tl] Henvzip.
    case => _ <- <- <- <-. rewrite (mk_env_full_adder1_is_bit_blast_full_adder1 Henv1).
    by rewrite (IH _ _ _ _ _ _ _ _ Henvzip).
Qed.

Lemma mk_env_full_adder_is_bit_blast_full_adder E g l1 l2 lcin E' g' cs lcout lrs :
  mk_env_full_adder E g lcin l1 l2 = (E', g', cs, lcout, lrs) ->
  bit_blast_full_adder g lcin l1 l2 = (g', cs, lcout, lrs).
Proof.
  exact : mk_env_full_adder_zip_is_bit_blast_full_adder_zip.
Qed.

Lemma mk_env_full_adder1_newer_gen E g l1 l2 lcin E' g' cs lrs lcout:
  mk_env_full_adder1 E g l1 l2 lcin = (E', g', cs, lcout, lrs) -> (g <=? g')%positive.
Proof.
  rewrite /mk_env_full_adder1.
  case => _ <- _ _ _. rewrite -Pos.add_assoc; exact : pos_leb_add_diag_r.
Qed.

Lemma mk_env_full_adder_zip_newer_gen E g lp lcin E' g' cs lrs lcout :
  mk_env_full_adder_zip E g lcin lp = (E', g', cs, lcout, lrs) -> (g <=? g')%positive.
Proof.
  elim: lp E g lcin E' g' cs lrs lcout => [| [l1_hd l2_hd] lp_tl IH] E g lcin E' g' cs lrs lcout.
  - case => _ <- _ _ _. exact: Pos.leb_refl.
  - rewrite /mk_env_full_adder_zip (lock mk_env_full_adder1)/= -!lock -/mk_env_full_adder_zip.
    dcase (mk_env_full_adder1 E g l1_hd l2_hd lcin) => [[[[[E_hd] g_hd] cs_hd] lcout_hd] lrs_hd] Henv1.
    dcase (mk_env_full_adder_zip E_hd g_hd lcout_hd lp_tl) => [[[[[E_tl] g_tl] cs_tl] lcout_tl] lrs_tl] Henvzip.
    case => _ <- _ _ _. apply : (pos_leb_trans (mk_env_full_adder1_newer_gen Henv1)).
    exact : (IH _ _ _ _ _ _ _ _ Henvzip).
Qed.

Lemma mk_env_full_adder_newer_gen E g l1 l2 lcin E' g' cs lrs lcout:
  mk_env_full_adder E g lcin l1 l2 = (E', g', cs, lcout, lrs) -> (g <=? g')%positive.
Proof.
  rewrite /mk_env_full_adder => Henv.
  by apply mk_env_full_adder_zip_newer_gen with E (extzip_ff l1 l2) lcin E' cs lrs lcout.
Qed.

Lemma mk_env_full_adder1_newer_res E g l1 l2 lcin E' g' cs lrs lcout:
  mk_env_full_adder1 E g l1 l2 lcin = (E', g', cs, lcout, lrs) -> newer_than_lit g' lrs.
Proof.
  rewrite /mk_env_full_adder1.
  case => _ <- _ _ <-. rewrite /newer_than_lit/newer_than_var -Pos.add_assoc; exact : pos_ltb_add_diag_r.
Qed.

Lemma mk_env_full_adder_zip_newer_res  E g lp lcin E' g' cs lrs lcout:
  mk_env_full_adder_zip E g lcin lp = (E', g', cs, lcout, lrs) ->
  newer_than_lits g' lrs.
Proof.
  elim : lp E g lcin E' g' cs lrs lcout => [| [l1_hd l2_hd] lp_tl IH] E g lcin E' g' cs lrs lcout.
  - by case => _ <- _ _ <-.
  - rewrite /mk_env_full_adder_zip (lock mk_env_full_adder1)/= -!lock -/mk_env_full_adder_zip.
    dcase (mk_env_full_adder1 E g l1_hd l2_hd lcin) => [[[[[E_hd] g_hd] cs_hd] lcout_hd] lrs_hd] Henv1.
    dcase (mk_env_full_adder_zip E_hd g_hd lcout_hd lp_tl) => [[[[[E_tl] g_tl] cs_tl] lcout_tl] lrs_tl] Henvzip.
    case => _ <- _ _ <-.
    move : (mk_env_full_adder_zip_newer_gen Henvzip) => Hgle.
    move : (mk_env_full_adder1_newer_res Henv1) => Hntlghdlrshd.
    rewrite newer_than_lits_cons. apply/andP; split.
    exact : (newer_than_lit_le_newer Hntlghdlrshd Hgle).
    exact : (IH _ _ _ _ _ _ _ _ Henvzip).
Qed.

Lemma mk_env_full_adder_newer_res  E g l1 l2 lcin E' g' cs lrs lcout:
  mk_env_full_adder E g lcin l1 l2 = (E', g', cs, lcout, lrs) -> newer_than_lits g' lrs.
Proof.
  rewrite /mk_env_full_adder => Henv.
  by apply mk_env_full_adder_zip_newer_res with E g (extzip_ff l1 l2) lcin E' cs lcout.
Qed.

Lemma mk_env_full_adder1_newer_cout E g l1 l2 lcin E' g' cs lrs lcout:
  mk_env_full_adder1 E g lcin l1 l2 = (E', g', cs, lcout, lrs) ->
  (*newer_than_lit g lcin ->*) newer_than_lit g' lcout.
Proof.
  rewrite /mk_env_full_adder1. case => _ <- _ <- _.
  rewrite /newer_than_lit/newer_than_var /=. exact : pos_ltb_add_diag_r.
Qed.

Lemma mk_env_full_adder_zip_newer_cout  E g lp lcin E' g' cs lrs lcout:
  mk_env_full_adder_zip E g lcin lp = (E', g', cs, lcout, lrs) ->
  newer_than_lit g lcin -> newer_than_lit g' lcout.
Proof.
  elim : lp E g lcin E' g' cs lrs lcout => [| [l1_hd l2_hd] lp_tl IH] E g lcin E' g' cs lrs lcout.
  - by case => _ <- _ <- _.
  - rewrite /mk_env_full_adder_zip (lock mk_env_full_adder1)/= -!lock -/mk_env_full_adder_zip.
    dcase (mk_env_full_adder1 E g l1_hd l2_hd lcin) => [[[[[E_hd] g_hd] cs_hd] lcout_hd] lrs_hd] Henv1.
    dcase (mk_env_full_adder_zip E_hd g_hd lcout_hd lp_tl) => [[[[[E_tl] g_tl] cs_tl] lcout_tl] lrs_tl] Henvzip.
    case => _ <- _ <- _ Hglcin.
    move : (mk_env_full_adder1_newer_cout Henv1) => Hghdlcout.
    exact : (IH _ _ _ _ _ _ _ _ Henvzip Hghdlcout).
Qed.

Lemma mk_env_full_adder_newer_cout  E g l1 l2 lcin E' g' cs lrs lcout:
  mk_env_full_adder E g lcin l1 l2 = (E', g', cs, lcout, lrs) ->
  newer_than_lit g lcin -> newer_than_lit g' lcout.
Proof.
  rewrite /mk_env_full_adder => Henv Hntlcin.
  by apply mk_env_full_adder_zip_newer_cout with E g (extzip_ff l1 l2) lcin E' cs lrs.
Qed.

Lemma mk_env_full_adder1_newer_cnf E g l1 l2 lcin E' g' cs lrs lcout:
  mk_env_full_adder1 E g l1 l2  lcin = (E', g', cs, lcout, lrs) ->
  newer_than_lit g l1 -> newer_than_lit g l2 -> newer_than_lit g lcin ->
  newer_than_cnf g' cs.
Proof.
  rewrite /mk_env_full_adder1.
  - case => _ <- <- _ _ Hl1 Hl2 Hlcin.
    move : (pos_ltb_add_diag_r g (1+1)) => Hgg2; rewrite Pos.add_assoc in Hgg2.
    move : (newer_than_lit_lt_newer Hl1 Hgg2) => Hg2l1.
    move : (newer_than_lit_lt_newer Hl2 Hgg2) => Hg2l2.
    move : (newer_than_lit_lt_newer Hlcin Hgg2) => Hg2lcin.
    by rewrite /= !newer_than_lit_neg Hg2l1 Hg2l2 Hg2lcin /= /newer_than_lit/newer_than_var/= pos_ltb_add_diag_r Hgg2 .
Qed.

Lemma mk_env_full_adder_zip_newer_cnf  E g lp lcin E' g' cs lrs lcout:
  mk_env_full_adder_zip E g lcin lp = (E', g', cs, lcout, lrs) ->
  newer_than_lits g (unzip1 lp) -> newer_than_lits g (unzip2 lp) ->
  newer_than_lit g lcin -> newer_than_cnf g' cs.
Proof.
  elim : lp E g lcin E' g' cs lrs lcout => [| [l1_hd l2_hd] lp_tl IH] E g lcin E' g' cs lrs lcout.
  - by case => _ <- <- _ _.
  - rewrite /mk_env_full_adder_zip (lock mk_env_full_adder1)/= -!lock -/mk_env_full_adder_zip.
    dcase (mk_env_full_adder1 E g l1_hd l2_hd lcin) => [[[[[E_hd] g_hd] cs_hd] lcout_hd] lrs_hd] Henv1.
    dcase (mk_env_full_adder_zip E_hd g_hd lcout_hd lp_tl) => [[[[[E_tl] g_tl] cs_tl] lcout_tl] lrs_tl] Henvzip.
    case => _ <- <- _ _ . move => /andP [Hntl1hd Hntl1tl] /andP [Hntl2hd Hntl2tl] Hntlcin.
    rewrite newer_than_cnf_catrev.
    move : (mk_env_full_adder1_newer_cnf Henv1 Hntl1hd Hntl2hd Hntlcin) => Hntcgtl.
    move : (mk_env_full_adder1_newer_gen Henv1) => Hgghd.
    move : (mk_env_full_adder_zip_newer_gen Henvzip) => Hghdgtl.
    apply /andP; split.
    exact : (newer_than_cnf_le_newer Hntcgtl Hghdgtl).
    move : (newer_than_lits_le_newer Hntl1tl Hgghd) => Hntlghd1.
    move : (newer_than_lits_le_newer Hntl2tl Hgghd) => Hntlghd2.
    move : (newer_than_lit_le_newer Hntlcin Hgghd) => Hntlghdcin.
    move : (mk_env_full_adder1_newer_cout Henv1) => Hntlcout.
    exact : (IH _ _ _ _ _ _ _ _ Henvzip Hntlghd1 Hntlghd2 Hntlcout).
Qed.

Lemma mk_env_full_adder_newer_cnf  E g l1 l2 lcin E' g' cs lrs lcout:
  mk_env_full_adder E g lcin l1 l2 = (E', g', cs, lcout, lrs) ->
  newer_than_lits g l1 -> newer_than_lits g l2 ->
  newer_than_lit g lcin -> newer_than_lit g lit_ff -> newer_than_cnf g' cs.
Proof.
  rewrite /mk_env_full_adder => Henv Hntl1 Hntl2 Hntlcin Hff .
  apply mk_env_full_adder_zip_newer_cnf with E g (extzip_ff l1 l2) lcin E' lrs lcout .
  - done .
  - rewrite unzip1_extzip newer_than_lits_cat Hntl1 newer_than_lits_copy // .
  - rewrite unzip2_extzip newer_than_lits_cat Hntl2 newer_than_lits_copy // .
  - done .
Qed.

Lemma mk_env_full_adder1_preserve E g l1 l2 lcin E' g' cs lrs lcout:
  mk_env_full_adder1 E g l1 l2 lcin = (E', g', cs, lcout, lrs) ->
  env_preserve E E' g.
Proof.
  rewrite /mk_env_full_adder1/=. case => <- _ _ _ _.
  apply (@env_preserve_trans _ (env_upd E g
          (xorb (xorb (interp_lit E l1) (interp_lit E l2))
                (interp_lit E lcin)))).
  - exact: env_upd_eq_preserve.
  - apply env_upd_newer_preserve; by apply newer_than_var_add_diag_r.
Qed.

Lemma mk_env_full_adder_zip_preserve E g lp lcin E' g' cs lrs lcout:
  mk_env_full_adder_zip E g lcin lp = (E', g', cs, lcout, lrs) ->
  env_preserve E E' g.
Proof.
  elim : lp E g lcin E' g' cs lrs lcout => [| [l1_hd l2_hd] lp_tl IH] E g lcin E' g' cs lrs lcout.
  - by case => <- _ _ _ _.
  - rewrite /mk_env_full_adder_zip (lock mk_env_full_adder1)/= -!lock -/mk_env_full_adder_zip.
    dcase (mk_env_full_adder1 E g l1_hd l2_hd lcin) => [[[[[E_hd] g_hd] cs_hd] lcout_hd] lrs_hd] Henv1.
    dcase (mk_env_full_adder_zip E_hd g_hd lcout_hd lp_tl) => [[[[[E_tl] g_tl] cs_tl] lcout_tl] lrs_tl] Henvzip.
    case => <- _ _ _ _.
    move : (mk_env_full_adder1_preserve Henv1) => HEEhd.
    move : (IH _ _ _ _ _ _ _ _ Henvzip) => HEhdEtl.
    move : (mk_env_full_adder1_newer_gen Henv1) => Hgghd.
    exact : (env_preserve_trans HEEhd (env_preserve_le HEhdEtl Hgghd)).
Qed.

Lemma mk_env_full_adder_preserve E g l1 l2 lcin E' g' cs lrs lcout:
  mk_env_full_adder E g l1 l2 lcin = (E', g', cs, lcout, lrs) ->
  env_preserve E E' g.
Proof.
  exact : mk_env_full_adder_zip_preserve.
Qed.

Lemma mk_env_full_adder1_sat E g l1 l2 lcin E' g' cs lrs lcout:
  mk_env_full_adder1 E g l1 l2 lcin = (E', g', cs, lcout, lrs) ->
  newer_than_lit g l1 -> newer_than_lit g l2 -> newer_than_lit g lcin ->
  interp_cnf E' cs.
Proof.
  move => Hadd1 Hntl1 Hntl2 Hntlcin.
  move : (pos_ltb_add_diag_r g 1) => Hgg1.
  move : (newer_than_lit_lt_newer Hntl1 Hgg1) => Hntl1g1.
  move : (newer_than_lit_lt_newer Hntl2 Hgg1) => Hntl2g1.
  move : (newer_than_lit_lt_newer Hntlcin Hgg1) => Hntlcing1.
  move : (Pos.succ_discr g) => Hneqsucc.
  move : Hadd1.
  rewrite /mk_env_full_adder1. case => <- _ <- _ _ .
  case Hintl1 : (interp_lit E l1); case Hintl2: (interp_lit E l2);case Hintlcin :(interp_lit E lcin); rewrite/= !orbF andbT;
    rewrite !interp_lit_env_upd_neq;
    try (apply newer_than_lit_neq; rewrite newer_than_lit_neg; done);
    try (apply newer_than_lit_neq; done);
    try (rewrite !interp_lit_neg_lit Hintl1 Hintl2 Hintlcin/= !orbF !orbT !andTb andbT /env_upd/= !eq_refl Pos.add_1_r;
       case Heqsucc: (Pos.succ g == g); try done; rewrite (eqP Heqsucc) in Hneqsucc; done).
  rewrite !interp_lit_neg_lit Hintl1 Hintl2 Hintlcin/= !orbF !orbT !andTb /env_upd/=!eq_refl Pos.add_1_r; case Heqsucc: (Pos.succ g == g); try done; rewrite (eqP Heqsucc) in Hneqsucc; done.
Qed.

Lemma mk_env_full_adder_zip_sat E g lp lcin E' g' cs lrs lcout:
  mk_env_full_adder_zip E g lcin lp = (E', g', cs, lcout, lrs) ->
  newer_than_lits g (unzip1 lp) -> newer_than_lits g (unzip2 lp) -> newer_than_lit g lcin ->
  interp_cnf E' cs.
Proof.
  elim : lp E g lcin E' g' cs lrs lcout => [| [l1_hd l2_hd] lp_tl IH] E g lcin E' g' cs lrs lcout.
  - by case => <- _ <- _ _.
  - rewrite /mk_env_full_adder_zip (lock mk_env_full_adder1)/= -!lock -/mk_env_full_adder_zip.
    dcase (mk_env_full_adder1 E g l1_hd l2_hd lcin) => [[[[[E_hd] g_hd] cs_hd] lcout_hd] lrs_hd] Henv1.
    dcase (mk_env_full_adder_zip E_hd g_hd lcout_hd lp_tl) => [[[[[E_tl] g_tl] cs_tl] lcout_tl] lrs_tl] Henvzip.
    case => <- _ <- _ _ /andP [Hntl1hd Hntl1tl] /andP [Hntl2hd Hntl2tl] Hntlcin.
    move : (mk_env_full_adder1_sat Henv1 Hntl1hd Hntl2hd Hntlcin) => Hsat1.
    move : (mk_env_full_adder_zip_preserve Henvzip) => HEhdEtl.
    move : (mk_env_full_adder1_newer_gen Henv1)=> Hgghd.
    move : (mk_env_full_adder1_newer_cout Henv1) => Hntlcoutghd.
    move : (newer_than_lits_le_newer Hntl1tl Hgghd) => Hntl1tlghd.
    move : (newer_than_lits_le_newer Hntl2tl Hgghd) => Hntl2tlghd.
    move : (mk_env_full_adder1_newer_cnf Henv1 Hntl1hd Hntl2hd Hntlcin) => Hncnf1.
    rewrite interp_cnf_catrev.
    apply /andP; split.
  - by rewrite (env_preserve_cnf HEhdEtl Hncnf1).
  - exact : (IH _ _ _ _ _ _ _ _ Henvzip Hntl1tlghd Hntl2tlghd Hntlcoutghd).
Qed.

Lemma mk_env_full_adder_sat  E g l1 l2 lcin E' g' cs lrs lcout:
  mk_env_full_adder E g lcin l1 l2 = (E', g', cs, lcout, lrs) ->
  newer_than_lits g l1 -> newer_than_lits g l2 -> newer_than_lit g lcin -> newer_than_lit g lit_ff ->
  interp_cnf E' cs.
Proof.
  rewrite /mk_env_full_adder => Henv Hntl1 Hntl2 Hntlcin Hgff.
  apply mk_env_full_adder_zip_sat with
      E g (extzip_ff l1 l2) lcin g' lrs lcout .
  - done .
  - rewrite unzip1_extzip newer_than_lits_cat
            newer_than_lits_copy; last done.
    apply /andP; done .
  - rewrite unzip2_extzip newer_than_lits_cat
            newer_than_lits_copy; last done.
    apply /andP; done .
  - done .
Qed.

(* ===== bit_blast_add ===== *)

Definition bit_blast_add g ls1 ls2 : generator * cnf * word :=
  let '(g', cs, cout, lrs) := bit_blast_full_adder g lit_ff ls1 ls2 in
  (g', cs, lrs).

Lemma bit_blast_add_size_max ls1 ls2 g g' cs lrs :
  bit_blast_add g ls1 ls2 = (g', cs, lrs) -> maxn (size ls1) (size ls2) = size lrs.
Proof.
  rewrite /bit_blast_add.
  dcase (bit_blast_full_adder g lit_ff ls1 ls2) => [[[[ga csa] couta] lrsa] Hbbfa].
  case => _ _ <-. exact: (bit_blast_full_adder_size_max Hbbfa).
Qed.

Lemma bit_blast_add_size_ss ls1 ls2 g g' cs lrs :
  bit_blast_add g ls1 ls2 = (g', cs, lrs) -> size ls1 = size ls2 -> size ls1 = size lrs.
Proof.
  move=> Hbb Hs. rewrite -(bit_blast_add_size_max Hbb).
  rewrite Hs maxnn. reflexivity.
Qed.

Lemma bit_blast_add_correct :
  forall g bs1 bs2 E ls1 ls2 br g' cs lrs,
    bit_blast_add g ls1 ls2 = (g', cs, lrs) ->
    enc_bits E ls1 bs1 ->
    enc_bits E ls2 bs2 ->
    addB bs1 bs2 = br->
    interp_cnf E (add_prelude cs) ->
    size ls1 = size ls2 ->
    enc_bits E lrs br.
Proof.
  move=> g bs1 bs2 E ls1 ls2 br g' cs lrs.
  rewrite /bit_blast_add. case HadcB: (adcB false bs1 bs2) => [obcout obrs].
  case Hblast: (bit_blast_full_adder g lit_ff ls1 ls2) => [[[og ocs] olcout] olrs].
  case=> _ <- <- => Henc1 Henc2 <- Hcs Hszeq.
  move : (add_prelude_enc_bit_ff Hcs) => Hff.
  move : (bit_blast_full_adder_correct1 Hblast Henc1 Henc2 Hff Hcs HadcB Hszeq).
  by rewrite /addB HadcB.
Qed.

Definition mk_env_add E (g: generator) ls1 ls2 : env * generator * cnf * word :=
  let '(E', g', cs, cout, lrs) := mk_env_full_adder E g lit_ff ls1 ls2 in
  (E', g', cs, lrs).

Lemma mk_env_add_is_bit_blast_add :
  forall E g  ls1 ls2 E' g' cs lrs,
    mk_env_add E g ls1 ls2 = (E', g', cs, lrs) ->
    bit_blast_add g ls1 ls2 = (g', cs, lrs).
Proof.
  move => E g ls1 ls2 E' g' cs lrs.
  rewrite /mk_env_add/bit_blast_add.
  case Hmk: (mk_env_full_adder E g lit_ff ls1 ls2 ) => [[[[E'0 g'0] cs0] cout] lrs0].
  move : (mk_env_full_adder_is_bit_blast_full_adder Hmk) => Hbb.
  rewrite Hbb. move =>[] _ <- <- <-.
  done.
Qed.

Lemma mk_env_add_newer_gen :
  forall E g ls1 ls2 E' g' cs lrs,
    mk_env_add E g ls1 ls2 = (E', g', cs, lrs) ->
    (g <=? g')%positive.
Proof.
  move => E g ls1 ls2 E' g' cs lrs.
  rewrite /mk_env_add.
  case Hmk: (mk_env_full_adder E g lit_ff ls1 ls2) => [[[[E'0 g'0] cs0] cout] lrs0]. move => [] _ <- _ _.
  apply (mk_env_full_adder_newer_gen Hmk).
Qed.

Lemma mk_env_add_newer_res :
  forall E g ls1 ls2 E' g' cs lrs,
    mk_env_add E g ls1 ls2 = (E', g', cs, lrs) ->
    newer_than_lits g' lrs.
Proof.
  move => E g ls1 ls2 E' g' cs lrs.
  rewrite /mk_env_add.
  case Hmk: (mk_env_full_adder E g lit_ff ls1 ls2) => [[[[E'0 g'0] cs0] cout] lrs0]. move => [] _ <- _ <-.
  apply (mk_env_full_adder_newer_res Hmk).
Qed.

Lemma mk_env_add_newer_cnf:
  forall E g ls1 ls2 E' g' cs lrs,
    mk_env_add E g ls1 ls2 = (E', g', cs, lrs) ->
    newer_than_lits g ls1 ->
    newer_than_lits g ls2 ->
    newer_than_lit g lit_ff ->
    newer_than_cnf g' cs.
Proof.
  move => E g ls1 ls2 E' g' cs lrs.
  rewrite /mk_env_add.
  case Hmk: (mk_env_full_adder E g lit_ff ls1 ls2) => [[[[E'0 g'0] cs0] cout] lrs0]. move => [] _ <- <- _ .
  move => Hls1 Hls2 Hff .
  apply (mk_env_full_adder_newer_cnf Hmk Hls1 Hls2 Hff Hff) .
Qed.

Lemma mk_env_add_preserve :
  forall E g ls1 ls2 E' g' cs lrs,
    mk_env_add E g ls1 ls2 = (E', g', cs, lrs) ->
    env_preserve E E' g.
Proof.
  move => E g ls1 ls2 E' g' cs lrs.
  rewrite /mk_env_add.  case Hmk: (mk_env_full_adder E g lit_ff ls1 ls2) => [[[[E'0 g'0] cs0] cout] lrs0]. move => [] <- _ _ _.
  apply (mk_env_full_adder_preserve Hmk).
Qed.

Lemma mk_env_add_sat :
  forall E g ls1 ls2 E' g' cs lrs,
    mk_env_add E g ls1 ls2 = (E', g', cs, lrs) ->
    newer_than_lits g ls1 ->  newer_than_lits g ls2 -> newer_than_lit g lit_ff ->
    interp_cnf E' cs.
Proof.
  move => E g ls1 ls2 E' g' cs lrs.
  rewrite /mk_env_add.  case Hmk: (mk_env_full_adder E g lit_ff ls1 ls2) => [[[[E'0 g'0] cs0] cout] lrs0]. move => [] <- _ <- _.
  move => Hgls1 Hgls2 Hgff .
  apply (mk_env_full_adder_sat Hmk Hgls1 Hgls2 Hgff Hgff).
Qed.

Lemma mk_env_full_adder1_env_equal E1 E2 g l1 l2 cin E1' E2' g1' g2' cs1 cs2 cout1 cout2 lr1 lr2 :
  env_equal E1 E2 ->
  mk_env_full_adder1 E1 g l1 l2 cin = (E1', g1', cs1, cout1, lr1) ->
  mk_env_full_adder1 E2 g l1 l2 cin = (E2', g2', cs2, cout2, lr2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ cout1 = cout2 /\ lr1 = lr2.
Proof.
  rewrite /mk_env_full_adder1 => Heq. dcase (gen g) => [[g1 r1] Hg1].
  dcase (gen g1) => [[g2 r2] Hg2]. case=> ? ? ? ? ?; case=> ? ? ? ? ?; subst.
  repeat split. rewrite (env_equal_interp_lit l1 Heq) (env_equal_interp_lit l2 Heq)
                        (env_equal_interp_lit cin Heq).
  apply: env_equal_upd. apply: env_equal_upd. assumption.
Qed.

Lemma mk_env_full_adder_zip_env_equal E1 E2 g cin lsp E1' E2' g1' g2' cs1 cs2 cout1 cout2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_full_adder_zip E1 g cin lsp = (E1', g1', cs1, cout1, lrs1) ->
  mk_env_full_adder_zip E2 g cin lsp = (E2', g2', cs2, cout2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ cout1 = cout2 /\ lrs1 = lrs2.
Proof.
  elim: lsp E1 E2 g cin E1' E2' g1' g2' cs1 cs2 cout1 cout2 lrs1 lrs2
  => [| [l1 l2] lsp IH] //= E1 E2 g cin E1' E2' g1' g2' cs1 cs2 cout1 cout2 lrs1 lrs2 Heq.
  - case=> ? ? ? ? ?; case=> ? ? ? ? ?; subst. done.
  - set E1'' :=
      (env_upd
         (env_upd E1 g
                  (xorb (xorb (interp_lit E1 l1) (interp_lit E1 l2)) (interp_lit E1 cin)))
         (g + 1)%positive
         (interp_lit E1 l1 && interp_lit E1 l2
          || xorb (interp_lit E1 l1) (interp_lit E1 l2) && interp_lit E1 cin)).
    set E2'' :=
      (env_upd
         (env_upd E2 g
                  (xorb (xorb (interp_lit E2 l1) (interp_lit E2 l2)) (interp_lit E2 cin)))
         (g + 1)%positive
         (interp_lit E2 l1 && interp_lit E2 l2
          || xorb (interp_lit E2 l1) (interp_lit E2 l2) && interp_lit E2 cin)).
    dcase (mk_env_full_adder_zip E1'' (g + 1 + 1)%positive (Pos (g + 1)%positive) lsp) =>
    [[[[[E_tl1 g_tl1] cs_tl1] lcout_tl1] lrs_tl1] Htl1].
    dcase (mk_env_full_adder_zip E2'' (g + 1 + 1)%positive (Pos (g + 1)%positive) lsp) =>
    [[[[[E_tl2 g_tl2] cs_tl2] lcout_tl2] lrs_tl2] Htl2].
    have Heq': env_equal E1'' E2''.
    { rewrite /E1'' /E2''. rewrite (env_equal_interp_lit l1 Heq) (env_equal_interp_lit l2 Heq)
                                   (env_equal_interp_lit cin Heq).
      apply: env_equal_upd. apply: env_equal_upd. assumption. }
    move: (IH _ _ _ _ _ _ _ _ _ _ _ _ _ _ Heq' Htl1 Htl2) => [H1 [H2 [H3 [H4 H5]]]]; subst.
    case=> ? ? ? ? ?; case=> ? ? ? ? ?; subst.
    repeat split. assumption.
Qed.

Lemma mk_env_full_adder_env_equal E1 E2 g cin ls1 ls2 E1' E2' g1' g2' cs1 cs2 cout1 cout2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_full_adder E1 g cin ls1 ls2 = (E1', g1', cs1, cout1, lrs1) ->
  mk_env_full_adder E2 g cin ls1 ls2 = (E2', g2', cs2, cout2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ cout1 = cout2 /\ lrs1 = lrs2.
Proof. exact: mk_env_full_adder_zip_env_equal. Qed.

Lemma mk_env_add_env_equal E1 E2 g ls1 ls2 E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_add E1 g ls1 ls2 = (E1', g1', cs1, lrs1) ->
  mk_env_add E2 g ls1 ls2 = (E2', g2', cs2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof.
  rewrite /mk_env_add => Heq.
  dcase (mk_env_full_adder E1 g lit_ff ls1 ls2) => [[[[[H1 H2] H3] H4] H5] H6].
  dcase (mk_env_full_adder E2 g lit_ff ls1 ls2) => [[[[[H7 H8] H9] H10] H11] H12].
  case=> ? ? ? ?; case=> ? ? ? ?; subst.
  move: (mk_env_full_adder_env_equal Heq H6 H12) => [? [? [? [? ?]]]]. done.
Qed.


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir
     Aaron Bohannon
     Arthur Charg\'eraud
     Stephanie Weirich *)

(** remove printing ~ *)

Require Import Coq.FSets.FSets.
Require Import Coq.Lists.List.
Require Import Coq.Logic.Decidable.

Require Import CoqFSetDecide.
Require Import CoqListFacts.
Require Import LibTactics.

Require Import MetatheoryAtom.
Import AtomSetImpl.
Require Import LibTactics.

(* *********************************************************************** *)
(** * Implementation *)

  (* ********************************************************************* *)
  (** ** Basic definitions *)

  (** This section defines the following basic operations and
      predicates on association lists.

        - [one]: Constructs an association list consisting of exactly
          one binding.
        - [map]: Maps a function over the values in an association list.
        - [dom]: Computes the domain of an association list, i.e., the
          set consisting of its keys.
        - [disjoint]: Binary predicate that holds when the domains of
          two association lists are disjoint.
        - [binds]: Ternary predicate that holds when a key-value pair
          appears somewhere in an association list.
        - [uniq]: Unary predicate that holds when an association list
          binds any given key at most once.  Note that [uniq_push] is
          defined in terms of [one], due to our normal form for
          association lists.

      Implicit arguments are declared by default for these
      definitions.  We define some local notations to make the
      definition of [uniq] easier to read and to be consistent with
      the notations used in the rest of this library. *)

  Section Definitions.
    Set Implicit Arguments.
    Variables A B C : Set.

    Definition one (C : Set) (item : C) : list C := cons item nil.

    Inductive asn (A:Set) (B:Set) : Set :=
      | VarAsn : atom -> A -> asn A B
      | AltAsn : B         -> asn A B
    .

    Definition map (f1 : A -> A) (f2: B -> B) (E : list (asn A B)) : list (asn A B) :=
      List.map (fun x => match x with
                         | VarAsn x a => VarAsn B x (f1 a)
                         | AltAsn b   => AltAsn A (f2 b)
                         end) E.

    Fixpoint dom (A: Set) (B: Set) (E : list (asn A B)) {struct E} : atoms :=
      match E with
        | nil => empty
        | (VarAsn x _) :: E' => add x (dom E')
        | _ :: E' => dom E'
      end.

    Definition disjoint (E : list (asn A B)) (F : list (asn A B)) : Prop :=
      Subset (inter (dom E) (dom F)) empty.

    Definition binds (x : atom) (a : A) (E : list (asn A B)) : Prop :=
      List.In (VarAsn  B x a) E.

    Definition bindsAlt (b : B) (E : list (asn A B)) : Prop :=
      List.In (AltAsn A b) E.

    Notation Local "x ~~ a" := (one (VarAsn B x a)) (at level 68).
    Notation Local "x `notin` E" := (~ In x E) (at level 70).

    Inductive uniq : list (asn A B) -> Prop :=
      | uniq_nil :
          uniq nil
      | uniq_push : forall x a E,
          uniq E ->
          x `notin` dom E ->
          uniq ((x ~~ a) ++ E)
      | uniq_alt : forall b E,
          uniq E ->
          uniq (one (AltAsn A b) ++ E).

    Fixpoint erase (E : list (asn A B)) : list B :=
      match E with
      | nil => nil
      | (AltAsn b) :: E => b :: erase E
      | (VarAsn x a) :: E => erase E
      end.

    Unset Implicit Arguments.
  End Definitions.

  (* ********************************************************************* *)
  (** ** Local notations *)

  (** We make a local notation for [one], and for operations and
      predicate on finite sets, in order to make the statements of the
      lemmas below more readable.  The notations are local so that
      users of this functor may choose their own notations. *)

  Notation Local "[ i ]" := (one i).
(*  Notation Local "x ~~ T" := (one (VarAsn B x T)) (at level 68). *)

  Notation Local "E `union` F" :=
    (union E F)
    (at level 65, right associativity).
  Notation Local "x `in` E" :=
    (In x E)
    (at level 70).
  Notation Local "x `notin` E" :=
    (~ In x E)
    (at level 70).
  Notation Local "E [=] F" :=
    (Equal E F)
    (at level 70, no associativity).
  Notation Local "E [<=] F" :=
    (Subset E F)
    (at level 70, no associativity).

  (* ********************************************************************* *)
  (** ** List properties *)

  (** The following block of properties is used mainly for rewriting
      association lists into the normal form described above.  See the
      [simpl_alist] and [rewrite_alist] tactics below. *)

  Section ListProperties.
    Variables X : Set.
    Variables x y : X.
    Variables l l1 l2 l3 : list X.

    Lemma cons_app_one :
      cons x l = [ x ] ++ l.
    Proof. clear. reflexivity. Qed.

    Lemma cons_app_assoc :
      (cons x l1) ++ l2 = cons x (l1 ++ l2).
    Proof. clear. reflexivity. Qed.

    Lemma app_assoc :
      (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
    Proof. clear. apply app_ass. Qed.

    Lemma app_nil_1 :
      nil ++ l = l.
    Proof. clear. reflexivity. Qed.

    Lemma app_nil_2 :
      l ++ nil = l.
    Proof. clear. auto with datatypes. Qed.

    Lemma in_one :
      List.In x [ y ] <-> x = y.
    Proof. clear. simpl. intuition congruence. Qed.

    Lemma in_app :
      List.In x (l1 ++ l2) <-> List.In x l1 \/ List.In x l2.
    Proof. clear. split; auto using in_or_app, in_app_or. Qed.

  End ListProperties.

  Hint Rewrite cons_app_one cons_app_assoc app_assoc : rewr_list.
  Hint Rewrite app_nil_1 app_nil_2 : rewr_list.
  Hint Rewrite in_one in_app : rewr_list_in.

  (** The following block of properties is an assortment of
      structural properties about lists. *)

  Section AssortedListProperties.
    Variables X : Set.
    Variables x y : X.
    Variables l l1 l2 l3 : list X.

    Lemma one_eq_app :
      [ x ] ++ l1 = l2 ++ l3 ->
      (exists qs, l2 = x :: qs /\ l1 = qs ++ l3) \/
      (l2 = nil /\ l3 = x :: l1).
    Proof. simpl. auto using CoqListFacts.cons_eq_app. Qed.

    Lemma app_eq_one :
      l2 ++ l3 = [ x ] ++ l1 ->
      (exists qs, l2 = x :: qs /\ l1 = qs ++ l3) \/
      (l2 = nil /\ l3 = x :: l1).
    Proof. simpl. auto using CoqListFacts.app_eq_cons. Qed.

    Lemma nil_neq_one_mid :
      nil <> l1 ++ [ x ] ++ l2.
    Proof. simpl. apply List.app_cons_not_nil. Qed.

    Lemma one_mid_neq_nil :
      l1 ++ [ x ] ++ l2 <> nil.
    Proof.
      intros H; symmetry in H; revert H.
      simpl. apply List.app_cons_not_nil.
    Qed.

  End AssortedListProperties.

  (* ********************************************************************* *)
  (** ** Properties of [map] and [dom] *)

  (** The following lemmas are used mainly to simplify applications of
      [map] and [dom] to association lists.  See also the [simpl_alist]
      and [rewrite_alist] tactics below. *)

  Section Properties.
    Variables A B : Set.
    Variables f1 : A -> A.
    Variables f2 : B -> B.
    Variables x : atom.
    Variables b : A.
    Variables a : B.
    Variables E F G : list (asn A B).

    Lemma map_nil :
      map f1 f2 nil = nil.
    Proof. clear. reflexivity. Qed.

    Lemma map_consVar :
      map f1 f2 ((VarAsn B x b) :: E) = (VarAsn B x (f1 b)) :: map f1 f2 E.
    Proof. clear. reflexivity. Qed.

    Lemma map_consAlt :
      map f1 f2 ((AltAsn A a) :: E) = (AltAsn A (f2 a)) :: map f1 f2 E.
    Proof. clear. reflexivity. Qed.

    Lemma map_oneVar :
      map f1 f2 (one (VarAsn B x b)) = one (VarAsn B x (f1 b)).
    Proof. clear. reflexivity. Qed.

    Lemma map_oneAlt :
      map f1 f2 (one (AltAsn A a)) = one (AltAsn A (f2 a)).
    Proof. clear. reflexivity. Qed.

    Lemma map_app :
      map f1 f2 (E ++ F) = map f1 f2 E ++ map f1 f2 F.
    Proof. clear. unfold map. rewrite -> List.map_app. reflexivity. Qed.

    Lemma dom_nil :
      (@dom A B nil) = empty.
    Proof. clear. reflexivity. Qed.

    Lemma dom_consVar :
      dom (VarAsn B x b :: E) [=] singleton x `union` dom E.
    Proof. clear. simpl. fsetdec. Qed.

    Lemma dom_consAlt :
      dom (AltAsn A a :: E) [=] dom E.
    Proof. clear. simpl. fsetdec. Qed.

    Lemma dom_one :
      dom (one (VarAsn B x b)) [=] singleton x.
    Proof. clear. simpl. fsetdec. Qed.

    Lemma dom_app :
      dom (E ++ F) [=] dom E `union` dom F.
    Proof. clear. induction E as [ | a ]; simpl; try (destruct a); fsetdec. Qed.

    Lemma dom_map :
      dom (map f1 f2 E) [=] dom E.
    Proof. clear. induction E as [ | a ]; simpl; try (destruct a); fsetdec. Qed.

  End Properties.

  Hint Rewrite map_nil map_consVar map_consAlt map_oneVar map_oneAlt map_app : rewr_map.
  Hint Rewrite dom_nil dom_consVar dom_consAlt dom_one dom_app dom_map : rewr_dom.

  (* ********************************************************************* *)
  (** ** The [simpl_alist] tactic *)

  (** The [simpl_alist] tactic rewrites association lists so that they
      are in the normal form described above.  Similar to the [simpl]
      tactic, we define "[in *]" and "[in H]" variants of the tactic. *)

  Ltac simpl_asnlist :=
    autorewrite with rewr_list rewr_list_in rewr_map rewr_dom.
  Tactic Notation "simpl_asnlist" "in" hyp(H) :=
    autorewrite with rewr_list rewr_list_in rewr_map rewr_dom in H.
  Tactic Notation "simpl_asnlist" "in" "*" :=
    autorewrite with rewr_list rewr_list_in rewr_map rewr_dom in *.

  (* ********************************************************************* *)
  (** ** The [rewrite_alist] tactic *)

  (** The tactic [(rewrite_alist E)] replaces an association list in
      the conclusion of the goal with [E].  Suitability for
      replacement is determined by whether [simpl_alist] can put [E]
      and the chosen environment in the same normal form, up to
      convertibility's in Coq.  We also define an "[in H]" variant
      that performs the replacement in a hypothesis [H].  *)

  Tactic Notation "rewrite_asnlist" constr(E) :=
    match goal with
      | |- context[?x] =>
        change x with E
      | |- context[?x] =>
        replace x with E;
          [ | try reflexivity; simpl_asnlist; reflexivity ]
    end.

  Tactic Notation "rewrite_asnlist" constr(E) "in" hyp(H) :=
    match type of H with
      | context[?x] =>
        change x with E in H
      | context[?x] =>
        replace x with E in H;
          [ | try reflexivity; simpl_asnlist; reflexivity ]
    end.

  (* ********************************************************************* *)
  (** ** Basic facts about [disjoint] *)

  Section BasicDisjointFacts.
    Implicit Types A B C D : Set.

    Lemma disjoint_sym_1 :
      forall A B (E : list (asn A B)) (F : list (asn A B)),
      disjoint E F ->
      disjoint F E.
    Proof. unfold disjoint. fsetdec. Qed.

    Lemma disjoint_sym :
      forall A B (E : list (asn A B)) (F : list (asn A B)),
      disjoint E F <-> disjoint F E.
    Proof. intuition auto using disjoint_sym_1. Qed.

    Lemma disjoint_one_1 :
      forall A B (x : atom) (a : A) (F : list (asn A B)),
      disjoint (one (VarAsn B x a)) F ->
      x `notin` dom F.
    Proof. unfold disjoint. intros. simpl_asnlist in *. fsetdec. Qed.

    Lemma disjoint_one_2 :
      forall A B (x : atom) (a : A) (F : list (asn A B)),
      x `notin` dom F ->
      disjoint (one (VarAsn B x a)) F.
    Proof. unfold disjoint. intros. simpl_asnlist in *. fsetdec. Qed.

    Lemma disjoint_one_l :
      forall A B (x : atom) (a : A) (E : list (asn A B)),
      disjoint (one (VarAsn B x a)) E <-> x `notin` dom E.
    Proof. intros. unfold disjoint; simpl_asnlist; split; fsetdec. Qed.

    Lemma disjoint_one_r :
      forall A B (x : atom) (a : A) (E : list (asn A B)),
      disjoint E (one (VarAsn B x a)) <-> x `notin` dom E.
    Proof. intros. rewrite -> disjoint_sym. apply disjoint_one_l. Qed.

    Lemma disjoint_app_1 :
      forall A B (E F : list (asn A B)) (G : list (asn A B)),
      disjoint (E ++ F) G ->
      disjoint E G.
    Proof. intros. unfold disjoint in *. simpl_asnlist in *. fsetdec. Qed.

    Lemma disjoint_app_2 :
      forall A B (E F : list (asn A B)) (G : list (asn A B)),
      disjoint (E ++ F) G ->
      disjoint F G.
    Proof. intros. unfold disjoint in *. simpl_asnlist in *. fsetdec. Qed.

    Lemma disjoint_app_3 :
      forall A B (E F : list (asn A B)) (G : list (asn A B)),
      disjoint E G ->
      disjoint F G ->
      disjoint (E ++ F) G.
    Proof. intros. unfold disjoint in *. simpl_asnlist in *. fsetdec. Qed.

    Lemma disjoint_app_l :
      forall A B (E F : list (asn A B)) (G : list (asn A B)),
      disjoint (E ++ F) G <-> disjoint E G /\ disjoint F G.
    Proof.
      intros; intuition eauto using
        disjoint_app_1, disjoint_app_2, disjoint_app_3.
    Qed.

    Lemma disjoint_app_r :
      forall A B (E F : list (asn A B)) (G : list (asn A B)),
      disjoint G (E ++ F) <-> disjoint E G /\ disjoint F G.
    Proof. intros. rewrite -> disjoint_sym. apply disjoint_app_l. Qed.

    Lemma disjoint_map_1 :
      forall A B C (E : list (asn A B)) (F : list (asn A B)) (f1 : A -> A) (f2 : B -> B),
      disjoint (map f1 f2 E) F ->
      disjoint E F.
    Proof. unfold disjoint. intros. simpl_asnlist in *. trivial. Qed.

    Lemma disjoint_map_2 :
      forall A B C (E : list (asn A B)) (F : list (asn A B)) (f1 : A -> A)(f2: B -> B),
      disjoint E F ->
      disjoint (map f1 f2 E) F.
    Proof. unfold disjoint. intros. simpl_asnlist in *. trivial. Qed.

    Lemma disjoint_map_l :
      forall A B C (E : list (asn A B)) (F : list (asn A B)) (f1 : A -> A) (f2: B -> B),
      disjoint (map f1 f2 E) F <-> disjoint E F.
    Proof. intros; intuition eauto using disjoint_map_1, disjoint_map_2. Qed.

    Lemma disjoint_map_r :
      forall A B C (E : list (asn A B)) (F : list (asn A B)) (f1 : A -> A) (f2: B -> B),
      disjoint F (map f1 f2 E) <-> disjoint E F.
    Proof. intros. rewrite -> disjoint_sym. apply disjoint_map_l. auto. Qed.

  End BasicDisjointFacts.

  Hint Rewrite
    disjoint_one_l disjoint_one_r
    disjoint_app_l disjoint_app_r
    disjoint_map_l disjoint_map_r
  : rewr_uniq.

  (* ********************************************************************* *)
  (** ** Basic facts about [uniq] *)

  (** The following lemmas are facts about [uniq] with respect to the
      basic functions ([one], [app], and [map]) that can be used to
      build association lists. *)

  Section UniqProperties.
    Variables A B : Set.
    Variables f1 : A -> A.
    Variables f2 : B -> B.
    Variables x : atom.
    Variables b : A.
    Variables E F G : list (asn A B).

    Lemma uniq_one_1 :
      uniq (one (VarAsn B x b)).
    Proof.
      clear. rewrite_asnlist ((one (VarAsn B x b)) ++ nil).
      apply uniq_push; [ apply uniq_nil | fsetdec ].
    Qed.

    Lemma uniq_app_1 :
      uniq (E ++ F) -> uniq E.
    Proof.
      clear. intros H; induction E as [ | a E']; simpl_asnlist in *.
        apply uniq_nil.
        destruct a.
        apply uniq_push; inversion H; subst.
          auto.
          simpl_asnlist in *. fsetdec.
        apply uniq_alt; inversion H; subst.
          auto.
    Qed.

    Lemma uniq_app_2 :
      uniq (E ++ F) -> uniq F.
    Proof.
      clear. intros H; induction E as [ | a E'].
        apply H.
        inversion H; subst. auto.
        inversion H; subst. auto.
    Qed.

    Lemma uniq_app_3 :
      uniq (E ++ F) -> disjoint E F.
    Proof.
      clear. intros H. red. induction E as [ | a E'].
        fsetdec.
        inversion H; subst. simpl_asnlist in *. lapply IHE'.
          fsetdec.
          assumption.
        inversion H; subst. simpl_asnlist in *. lapply IHE'.
          fsetdec.
          assumption.
    Qed.

    Lemma uniq_app_4 :
      uniq E ->
      uniq F ->
      disjoint E F ->
      uniq (E ++ F).
    Proof.
      clear. intros HE HF Hd.
      induction E as [ | a E']; simpl_asnlist in *.
        assumption.
        rewrite -> disjoint_app_l in Hd.
          inversion HE; subst. apply uniq_push.
            intuition.
            rewrite disjoint_one_l in Hd. simpl_asnlist. fsetdec.
        apply uniq_alt.
          inversion HE; subst.
            intuition.
    Qed.

    Lemma uniq_app :
      uniq (E ++ F) <-> uniq E /\ uniq F /\ disjoint E F.
    Proof.
      clear; intuition eauto using
        uniq_app_1, uniq_app_2, uniq_app_3, uniq_app_4.
    Qed.

    Lemma uniq_map_1 :
      uniq (map f1 f2 E) ->
      uniq E.
    Proof.
      clear. intros H. induction E as [ | a E']; simpl_asnlist in *.
        apply uniq_nil.
        destruct a.
        inversion H; subst. apply uniq_push; simpl_asnlist in *; auto.
        inversion H; subst. apply uniq_alt; simpl_asnlist in *; auto.
    Qed.

    Lemma uniq_map_2 :
      uniq E ->
      uniq (map f1 f2 E).
    Proof.
      clear. intros J. induction E as [ | a E']; simpl_asnlist in *.
      apply uniq_nil.
      inversion J; subst. simpl_asnlist. apply uniq_push.
        auto.
        rewrite dom_map. trivial.
      inversion J; subst. simpl_asnlist. apply uniq_alt. auto.
    Qed.

    Lemma uniq_map :
      uniq (map f1 f2 E) <-> uniq E.
    Proof.
      clear. intuition eauto using uniq_map_1, uniq_map_2.
    Qed.

  End UniqProperties.

  Hint Rewrite uniq_app uniq_map : rewr_uniq.

  (* ********************************************************************* *)
  (** ** The [solve_uniq] tactic *)

  (** This tactic attempts to solve goals about [uniq].  Given its
      definition, it's likely to work only when the hypotheses in the
      goal already contain all the relevant [uniq] propositions.
      Thus, the tactic may not be generally useful.  It is useful,
      however, for proving facts about [uniq] such as the ones below.

      Implementation note: The second [simpl_asnlist] in the definition
      is because of [disjoint_one_{l,r}].  The "[|| fail]" at the end
      is so that in the case of failure, the error message reported to
      the user is not the one from [fsetdec]. *)

  Ltac solve_uniq :=
    try trivial;
    simpl_asnlist in *;
    autorewrite with rewr_uniq in *;
    simpl_asnlist in *;
    intuition (
      auto using uniq_nil, uniq_one_1 ||
      (rewrite -> disjoint_sym; auto) ||
      (unfold disjoint in *; fsetdec))
    || fail.

  (* ********************************************************************* *)
  (** ** Facts about [uniq] *)

  Section UniqDerived.
    Variables A B : Set.
    Variables x y : atom.
    Variables a b : A.
    Variables E F G : list (asn A B).

    Lemma uniq_cons_3 :
      uniq E ->
      x `notin` dom E ->
      uniq ((VarAsn B x a) :: E).
    Proof. clear. solve_uniq. Qed.

    Lemma uniq_insert_mid :
      uniq (G ++ E) ->
      x `notin` dom (G ++ E) ->
      uniq (G ++ (one (VarAsn B x a)) ++ E).
    Proof. clear. solve_uniq. Qed.

    Lemma uniq_remove_mid :
      uniq (E ++ F ++ G) ->
      uniq (E ++ G).
    Proof. clear. solve_uniq. Qed.

    Lemma uniq_map_app_l : forall (f1 : A -> A)(f2: B -> B),
      uniq (F ++ E) ->
      uniq (map f1 f2 F ++ E).
    Proof. clear. intros. solve_uniq. Qed.

    Lemma fresh_mid_tail :
      uniq (F ++ (one (VarAsn B x a)) ++ E) ->
      x `notin` dom E.
    Proof. clear. solve_uniq. Qed.

    Lemma fresh_mid_head :
      uniq (F ++ (one (VarAsn B x a)) ++ E) ->
      x `notin` dom F.
    Proof. clear. solve_uniq. Qed.

  End UniqDerived.

  (* ********************************************************************* *)
  (** ** Basic facts about [binds] *)

  (** The following lemmas are facts about [binds] with respect to the
      basic functions ([one] and [app]) that can be used to build
      association lists.

      Note: [map] is treated further below. *)

  Section BindsProperties.
    Variables A B : Set.
    Variables x y : atom.
    Variables a b : A.
    Variables E F G : list (asn A B).

    Lemma binds_nil :
      binds x a (@nil (asn A B)) <-> False.
    Proof. clear. split. inversion 1. intuition. Qed.

    Lemma binds_one_3 :
      x = y ->
      a = b ->
      binds x a (one (VarAsn B y b)).
    Proof. clear. intros. red. simpl. left. congruence. Qed.

    Lemma binds_one_1 :
      binds x a (one (VarAsn B y b)) ->
      x = y.
    Proof. clear. intros H1. inversion H1; intuition congruence. Qed.

    Lemma binds_one_2 :
      binds x a (one (VarAsn B y b)) ->
      a = b.
    Proof. clear. intros H1. inversion H1; intuition congruence. Qed.

    Lemma binds_one_iff :
      binds x a (one (VarAsn B y b)) <-> x = y /\ a = b.
    Proof.
      clear. split.
        intros H1. intuition eauto using binds_one_1, binds_one_2.
        intros H1. intuition auto using binds_one_3.
    Qed.

  Lemma binds_cons_1 :
    binds x a ((VarAsn B y b) :: E) ->
    (x = y /\ a = b) \/ binds x a E.
  Proof. clear. inversion 1 as [J | J]; try injection J; auto. Qed.

  Lemma binds_cons_2 :
    x = y ->
    a = b ->
    binds x a ((VarAsn B y b) :: E).
  Proof. clear. unfold binds. simpl. left. f_equal; auto. Qed.

  Lemma binds_cons_3 :
    binds x a E ->
    binds x a ((VarAsn B y b) :: E).
  Proof. clear. unfold binds. simpl. right. trivial. Qed.

  Lemma binds_cons_iff :
    binds x a ((VarAsn B y b) :: E) <-> (x = y /\ a = b) \/ binds x a E.
  Proof.
    clear. intuition auto using binds_cons_1, binds_cons_2, binds_cons_3.
  Qed.

    Lemma binds_app_1 :
      binds x a E ->
      binds x a (E ++ F).
    Proof. clear. intros H. red in H |- *. rewrite -> in_app. auto. Qed.

    Lemma binds_app_2 :
      binds x a F ->
      binds x a (E ++ F).
    Proof. clear. intros H. red in H |- *. rewrite -> in_app. auto. Qed.

    Lemma binds_app_3 :
      binds x a (E ++ F) ->
      binds x a E \/ binds x a F.
    Proof.
      clear. induction E as [ | a1 E' ].
        auto.
        unfold binds. simpl. intros [H | H].
          inversion H; subst. auto.
          unfold binds in *. apply IHE' in H. intuition.
    Qed.

    Lemma binds_app :
      binds x a (E ++ F) <-> binds x a E \/ binds x a F.
    Proof.
      clear. intuition auto using binds_app_1, binds_app_2, binds_app_3.
    Qed.

  End BindsProperties.

  Hint Rewrite binds_nil binds_one_3 binds_app : rewr_binds.
  Hint Rewrite binds_nil binds_one_3 : rewr_binds_uniq.

  (* ********************************************************************* *)
  (** ** Additional lemmas and tactics for working with [binds] *)

  Section MoreBindsProperties.
    Variables A B : Set.
    Variables x y : atom.
    Variables a b : A.
    Variables E F G : list (asn A B).

    Lemma binds_dom_contradiction: forall (E : list (asn A B)),
      binds x a E ->
      x `notin` dom E ->
      False.
    Proof.
      clear. induction E as [ | a1 E' ]; simpl.
        intros H. inversion H.
        unfold binds in *. simpl. intros [H | H] J.
          inversion H; subst. fsetdec.
          apply IHE' in H. trivial. destruct a1. fsetdec. auto.
    Qed.

    Lemma binds_app_uniq :
      uniq (E ++ F) ->
      (binds x a (E ++ F) <->
        (binds x a E /\ x `notin` dom F) \/
        (binds x a F /\ x `notin` dom E)).
    Proof with intuition (fsetdec || eauto using binds_dom_contradiction).
      clear. intros H1.
      autorewrite with rewr_uniq in H1. unfold disjoint in H1.
      assert (H : x `notin` dom F \/ x `notin` dom E) by fsetdec.
      rewrite binds_app...
    Qed.

  End MoreBindsProperties.

  Hint Rewrite binds_app_uniq using solve_uniq : rewr_binds_uniq.

  (** The [apply_binds_dom_contradiction] tactic solves a goal by
      applying the [binds_dom_contradiction] lemma.  The tactic
      succeeds only if the the hypotheses of the lemma are immediately
      satisfied. *)

  Ltac apply_binds_dom_contradiction :=
    match goal with
      | H : binds ?x ?a ?E, J : ?x `notin` (dom ?E) |- _ =>
        assert False by apply (@binds_dom_contradiction _ _ _ _ H J);
        intuition
      | H : binds ?x ?a ?E, J : ?x `in` (dom ?E) -> False |- _ =>
        assert False by apply (@binds_dom_contradiction _ _ _ _ H J);
        intuition
    end.

  (** The [solve_binds] tactic attempts to solve goals about [binds].
      Given its definition, it's likely to work only when the
      hypotheses in the goal already contain all the relevant [binds]
      propositions.  Thus, the tactic may not be generally useful.  It
      is useful, however, for proving facts about [binds] such as the
      ones below. *)

  Ltac solve_binds :=
    simpl_asnlist in *;
    autorewrite with rewr_binds in *;
    intuition (auto || fsetdec || apply_binds_dom_contradiction)
    || fail.

  (** The tactics [analyze_binds] and [analyze_binds_uniq] tactics
      take as an argument a hypotheses about [binds] and perform a
      case analysis based on the structure of the association list.
      In the case of [analyze_binds_uniq], the analysis is performed
      assuming that the association list is [uniq].  The lemmas
      [binds_app] and [binds_app_uniq] are examples of such case
      analysis.

      Implementation notes:

        - The initial calls to [simpl_asnlist] put the relevant
          association lists into normal form.
        - In the case of [binds_app_uniq], we assert that the
          association list is [uniq].  This enables the [autorewrite]
          step to succeed.
        - Rather than work on [H] itself, we copy it and work on the
          copy.  Thus, in instances where the analysis leaves unsolved
          subgoals, it is still possible to see the original
          hypothesis.
        - The rest of the tactic breaks apart the copy of H and tries
          several simple means for solving the resulting subgoals. *)

  Ltac analyze_binds H :=
    simpl_asnlist;
    simpl_asnlist in H;
    match type of H with
      | binds ?x ?a ?E =>
        let J := fresh in
        pose proof H as J;
        autorewrite with rewr_binds in J;
        simpl_asnlist in J;
        try (progress decompose [and or] J; clear J);
        try solve [trivial | discriminate | intuition | fsetdec]
    end.

  Ltac analyze_binds_uniq H :=
    simpl_asnlist;
    simpl_asnlist in H;
    match type of H with
      | binds ?x ?a ?E =>
        match goal with
          | H : uniq ?E |- _ => idtac
          | _ => assert (uniq E); [ try solve_uniq | ]
        end;
        let J := fresh in
        pose proof H as J;
        autorewrite with rewr_binds_uniq in J;
        simpl_asnlist in J;
        try (progress decompose [and or] J; clear J);
        try solve [trivial | discriminate | intuition | fsetdec]
    end.

  (* ********************************************************************* *)
  (** ** Facts about [binds] *)

  Section BindsDerived.
    Variables A B : Set.
    Variables f1 : A -> A.
    Variables f2 : B -> B.
    Variables x y : atom.
    Variables a b : A.
    Variables E F G : list (asn A B).

    Lemma binds_map_2 :
      binds x a E ->
      binds x (f1 a) (map f1 f2 E).
    Proof.
      clear. induction E; simpl_asnlist.
        inversion 1.
        unfold binds in *. simpl. intros [? | ?].
          destruct a0.
             inversion H; subst.
             left. congruence.
             inversion H.
          destruct a0.
            right. auto.
            right. auto.
    Qed.

    Lemma binds_weaken :
      binds x a (E ++ G) ->
      binds x a (E ++ F ++ G).
    Proof. clear. intros. solve_binds. Qed.

    Lemma binds_In : forall x a (E : list (asn A B)),
      binds x a E ->
      x `in` dom E.
    Proof.
      clear. induction E as [ | y ? F ]; intros J; simpl_asnlist.
      analyze_binds J.
      analyze_binds J; subst; auto with set.
        inversion H0;subst. simpl. fsetdec.
          inversion H.
    Qed.

    Lemma fresh_app_l :
      uniq (F ++ E) ->
      binds x a E ->
      x `notin` dom F.
    Proof.
      clear. intros.
      assert (x `in` dom E) by eauto using binds_In.
      solve_uniq.
    Qed.

    Lemma fresh_app_r :
      uniq (F ++ E) ->
      binds x a F ->
      x `notin` dom E.
    Proof.
      clear. intros.
      assert (x `in` dom F) by eauto using binds_In.
      solve_uniq.
    Qed.

  End BindsDerived.


(* Cyclone Semantics using TLC/LN in Coq Version 4 *)
(* "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".   Daniel Grossman, August 2003 *)
(* This is all of the LN infrastructure packed in a module for types. *)
(* Brian Milnes 2016 *)

Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax.
Require Export Cyclone_LN_Types.
Require Export Cyclone_LN_Terms.
(* Substituting a type into a term for a type variable. *)

Module TTM. (* T = Types TM = Terms *)

Function subst_v (tau : Tau) (alpha : var) (v : V) {struct v} : V :=
  match v with
    | fevar i => fevar i
    | bevar i => bevar i
  end.

Hint Resolve subst_v.

Fixpoint subst_e (tau : Tau) (alpha : var) (e : E) {struct e} : E :=
 match e with
   | v_e v         => v_e (subst_v tau alpha v)
   | i_e i         => i_e i
   | p_e x p       => p_e x p
   | f_e f         =>        (f_e (subst_f  tau alpha f))
   | amp e'        => amp    (subst_e     tau alpha e')
   | star e'       => star   (subst_e     tau alpha e')
   | cpair e1 e2   => cpair  (subst_e     tau alpha e1) (subst_e tau alpha e2)
   | dot e' i      => dot    (subst_e     tau alpha e') i
   | assign e1 e2  => assign (subst_e     tau alpha e1) (subst_e tau alpha e2)
   | appl  e1 e2   => appl   (subst_e     tau alpha e1) (subst_e tau alpha e2)
   | call s        => call   (subst_st    tau alpha s)
   | inst e' t     => inst   (subst_e     tau alpha e') (T.subst tau alpha t)
   | pack t e' t'  => pack   (T.subst tau alpha t) (subst_e tau alpha e')
                             (T.subst tau alpha t')
 end
with subst_st (tau : Tau) (alpha : var) (s: St) {struct s} : St :=
  match s with
    | e_s e         => e_s      (subst_e tau alpha e)
    | retn e        => retn     (subst_e tau alpha e)
    | seq s1 s2     => seq      (subst_st tau alpha s1) (subst_st tau alpha s2)
    | if_s e s1 s2  => if_s     (subst_e tau alpha e)
                                (subst_st tau alpha s1) (subst_st tau alpha s2)
    | while e s     => while    (subst_e tau alpha e)   (subst_st tau alpha s)
    | letx e s      => letx     (subst_e tau alpha e)   (subst_st tau alpha s)
    | openx     e s  => openx     (subst_e tau alpha e)   (subst_st tau alpha s)
    | openstar e s  => openstar (subst_e tau alpha e)   (subst_st tau alpha s)
end
with subst_f (tau : Tau) (alpha : var) (f : F) {struct f} : F  :=
 match f with
   | (dfun tau1 tau2 s) =>
     (dfun (T.subst tau alpha tau1) (T.subst tau alpha tau2) (subst_st tau alpha s))
   | ufun k f => (ufun k (subst_f tau alpha f))
end.

Hint Resolve subst_e.
Hint Resolve subst_st.
Hint Resolve subst_f.

Notation "[ t 'TTM_v>'  alpha ] tm" := (subst_v  t alpha tm) (at level 68) : cyclone_scope.
Notation "[ t 'TTM_e>'  alpha ] tm" := (subst_e  t alpha tm) (at level 68) : cyclone_scope.
Notation "[ t 'TTM_st>' alpha ] tm" := (subst_st t alpha tm) (at level 68) : cyclone_scope.
Notation "[ t 'TTM_f>'  alpha ] tm" := (subst_f  t alpha tm) (at level 68) : cyclone_scope.

Function subst (tau : Tau) (alpha : var) (t: Term) {struct t} : Term :=
  match t with
    | term_st s => term_st (subst_st tau alpha s)
    | term_e  e => term_e  (subst_e tau alpha e)
    | term_f  f => term_f  (subst_f tau alpha f)
  end.

Hint Resolve subst.

Notation "[ t 'TTM>' alpha ] tm" := (subst t alpha tm) (at level 68) : cyclone_scope.

(* Open a type binder in a term. *)

Definition open_rec_v (k : nat) (t : Tau) (v : V)  : V :=
  match v with
    | fevar i => fevar i
    | bevar i => bevar i
  end.

Fixpoint open_rec_st  (k : nat) (t : Tau) (s : St)  {struct s}  : St :=
 match s with
    | e_s  e        => e_s      (open_rec_e  k t e)
    | retn e        => retn     (open_rec_e  k t e)
    | seq s0 s1     => seq      (open_rec_st k t s0) (open_rec_st k t s1)
    | if_s e s1 s2  => if_s     (open_rec_e  k t e)
                                (open_rec_st k t s1) (open_rec_st k t s2)
    | while e s     => while    (open_rec_e  k t e)  (open_rec_st k t s)
    | letx e s      => letx     (open_rec_e  k t e)  (open_rec_st k t s)
    | openx e s      => openx     (open_rec_e  k t e)  (open_rec_st k t s)
    | openstar e s  => openstar (open_rec_e  k t e)  (open_rec_st k t s)
  end
with open_rec_e   (k : nat) (t : Tau) (e : E) {struct e}  : E :=
  match e with
    | v_e v         => v_e (open_rec_v k t v)
    | i_e i         => i_e i
    | p_e x p       => p_e x p
    | f_e f         => f_e    (open_rec_f  k t f)
    | amp e         => amp    (open_rec_e  k t e)
    | star e        => star   (open_rec_e  k t e)
    | cpair e1 e2   => cpair  (open_rec_e  k t e1) (open_rec_e k t e2)
    | dot  e ipe    => dot    (open_rec_e  k t e) ipe
    | assign e1 e2  => assign (open_rec_e  k t e1) (open_rec_e k t e2)
    | appl e1 e2    => appl   (open_rec_e  k t e1) (open_rec_e k t e2)
    | call s        => call   (open_rec_st k t s)
    | inst e t'      => inst   (open_rec_e  k t e) (T.open_rec k t t')
    | pack t0 e t1  => pack   (T.open_rec k t t0) (open_rec_e k t e) (T.open_rec k t t1)
end
with open_rec_f   (k : nat) (t : Tau) (f : F) {struct f} : F :=
  match f with
    | dfun tau1 tau2 s => dfun (T.open_rec k t tau1) (T.open_rec k t tau2)
                               (open_rec_st k t s)
    | ufun k' f        => ufun k' (open_rec_f k t f)
  end.

Function open_rec  (k : nat) (t : Tau) (T : Term) : Term :=
  match T with
    | term_st s    => term_st (open_rec_st k t s)
    | term_e  e    => term_e  (open_rec_e  k t e)
    | term_f  f    => term_f  (open_rec_f  k t f)
  end.

Definition open t T := open_rec 0 t T.

Notation "{ k TTM_v> u } t"  := (open_rec_v k u t) (at level 67) : cyclone_scope.
Notation "{ k TTM_e> u } t"  := (open_rec_e k u t) (at level 67) : cyclone_scope.
Notation "{ k TTM_st> u } t" := (open_rec_st k u t) (at level 67) : cyclone_scope.
Notation "{ k TTM_f> u } t"  := (open_rec_f k u t) (at level 67) : cyclone_scope.
Notation "{ k TTM> u }   t"  := (open_rec k u t) (at level 67) : cyclone_scope.

Notation "t 'TTM^^' u"    := (open u t)       (at level 67) : cyclone_scope.
Notation "t 'TTM^' alpha" := (open alpha t)   (at level 67) : cyclone_scope.

(* Closing a type variable in a term. *)

Function close_rec_v (k : nat) (v : var) (v' : V) {struct v}  : V := v'.

Fixpoint close_rec_st  (k : nat) (v : var) (s : St)  {struct s}  : St :=
 match s with
    | e_s  e        => e_s      (close_rec_e  k v e)
    | retn e        => retn     (close_rec_e  k v e)
    | seq s0 s1     => seq      (close_rec_st k v s0) (close_rec_st k v s1)
    | if_s e s1 s2  => if_s     (close_rec_e  k v e)
                                (close_rec_st k v s1) (close_rec_st k v s2)
    | while e s     => while    (close_rec_e  k v e)  (close_rec_st k v s)
    | letx e s      => letx     (close_rec_e  k v e)  (close_rec_st k v s)
    | openx e s     => openx    (close_rec_e  k v e)  (close_rec_st k v s)
    | openstar e s  => openstar (close_rec_e  k v e)  (close_rec_st k v s)
  end
with close_rec_e   (k : nat) (v : var) (e : E) {struct e}  : E :=
  match e with
    | v_e v'        => v_e (close_rec_v k v v')
    | i_e i         => i_e i
    | p_e x p       => p_e (close_rec_v k v x) p
    | f_e f         => f_e    (close_rec_f  k v f)
    | amp e         => amp    (close_rec_e  k v e)
    | star e        => star   (close_rec_e  k v e)
    | cpair e1 e2   => cpair  (close_rec_e  k v e1) (close_rec_e k v e2)
    | dot  e ipe    => dot    (close_rec_e  k v e) ipe
    | assign e1 e2  => assign (close_rec_e  k v e1) (close_rec_e k v e2)
    | appl e1 e2    => appl   (close_rec_e  k v e1) (close_rec_e k v e2)
    | call s        => call   (close_rec_st k v s)
    | inst e t      => inst   (close_rec_e  k v e) (T.close_rec k v t)
    | pack t0 e t1  => pack   (T.close_rec     k v t0)
                              (close_rec_e  k v e) (T.close_rec k v t1)
end
with close_rec_f   (k : nat) (v : var) (f : F) {struct f} : F :=
  match f with
    | dfun tau1 tau2 s => dfun (T.close_rec k v tau1) (T.close_rec k v tau2)
                               (close_rec_st k v s)
    | ufun k' f        => ufun k' (close_rec_f k v f)
  end.

Notation "{ k <TTM_e alpha } t" := (close_rec_e k alpha t) (at level 67) : cyclone_scope.
Notation "{ k <TTM_st alpha } t" := (close_rec_st k alpha t) (at level 67) : cyclone_scope.
Notation "{ k <TTM_f alpha } t" := (close_rec_f k alpha t) (at level 67) : cyclone_scope.

Function close_rec  (k : nat) (v : var) (t : Term) : Term :=
  match t with
    | term_st s    => term_st (close_rec_st k v s)
    | term_e  e    => term_e  (close_rec_e  k v e)
    | term_f  f    => term_f  (close_rec_f  k v f)
  end.

Definition close v t := close_rec 0 v t.

Notation "{ k <TTM alpha } t" := (T.close_rec k alpha t) (at level 67) : cyclone_scope.

(* Free type variables of a term. *)

Function fv_v (v : V) : vars :=
  match v with
    | (bevar i) => \{}
    | (fevar x) => \{}
  end.

Hint Extern 1 (_ \notin fv_v _) => simpl; notin_solve.

Fixpoint fv_st (t : St) {struct t} : vars :=
  match t with
    | e_s  e       => fv_e e
    | retn e       => fv_e e
    | seq s0 s1    => (fv_st s0) \u (fv_st s1)
    | if_s e s0 s1 => (fv_e e) \u (fv_st s0) \u (fv_st s1)
    | while e s0   => (fv_e e) \u (fv_st s0)
    | letx e s     => (fv_e e) \u (fv_st s)
    | openx e s     => (fv_e e) \u (fv_st s)
    | openstar e s => (fv_e e) \u (fv_st s)
  end
with  fv_e (e : E) {struct e} : vars :=
  match e with
    | v_e v         => fv_v v
    | i_e  i        => \{}
    | p_e x _       => \{}
    | f_e f         => fv_f f
    | amp e         => fv_e e
    | star e        => fv_e e
    | cpair e0 e1   => (fv_e e0) \u (fv_e e1)
    | dot e _       => fv_e e
    | assign e1 e2  => (fv_e e1) \u (fv_e e2)
    | appl e1 e2    => (fv_e e1) \u (fv_e e2)
    | call s        => fv_st s
    | inst e t      => (fv_e e) \u (T.fv t)
    | pack t0 e t1  => (T.fv t0) \u (fv_e e) \u (T.fv t1)
  end
with  fv_f (f : F) {struct f} : vars :=
  match f with
  | dfun t1 t2 s    => (T.fv t1) \u (T.fv t2) \u (fv_st s)
  | ufun k f        => fv_f f
end.

Hint Extern 1 (_ \notin fv_st _) => simpl; notin_solve.
Hint Extern 1 (_ \notin fv_e _) => simpl; notin_solve.
Hint Extern 1 (_ \notin fv_f _) => simpl; notin_solve.

Function fv (t : Term) {struct t} : vars :=
  match t with
    | term_st s    => fv_st s
    | term_e  e    => fv_e e
    | term_f  f    => fv_f f
 end.

Hint Extern 1 (_ \notin fv _) => simpl; notin_solve.

Definition closed x := fv x = \{}.

(* Is a term locally closed on type variables. *)

Inductive lc_st : St -> Prop :=
 | lc_st_e_s  : forall e, lc_e  e -> lc_st (e_s e)
 | lc_retn    : forall e, lc_e  e -> lc_st (retn e)
 | lc_seq     : forall s0 s1, lc_st s0 -> lc_st s1 -> lc_st (seq s0 s1)
 | lc_if      : forall e s0 s1, lc_e  e -> lc_st s0 -> lc_st s1 ->
                                    lc_st (if_s e s0 s1)
 | lc_while   : forall e s, lc_e  e -> lc_st s -> lc_st (while e s)
 | lc_st_letx : forall e s,
                       lc_e  e -> lc_st s ->
                       lc_st (letx e s)
 | lc_open   : forall e s,
                     lc_e  e -> lc_st s -> lc_st (openx e s)
 | lc_openstar  : forall e s,
                        lc_e  e -> lc_st s -> lc_st (openstar e s)
with      lc_e : E -> Prop :=
 | lc_fevar : forall x, lc_e  (v_e (fevar x))
 | lc_i_e     : forall i, lc_e  (i_e i)
 | lc_p_e     : forall x p, lc_e  (v_e (fevar x)) -> lc_e  (p_e (fevar x) p)
 | lc_f_e     : forall f, lc_f f -> lc_e  (f_e f)
 | lc_amp     : forall e, lc_e  e -> lc_e  (amp e)
 | lc_star    : forall e, lc_e  e -> lc_e  (star e)
 | lc_cpair   : forall e0 e1, lc_e  e0 -> lc_e  e1 -> lc_e  (cpair e0 e1)
 | lc_dot     : forall e ipe, lc_e  e -> lc_e  (dot e ipe)
 | lc_assign  : forall e1 e2, lc_e  e1 -> lc_e  e2 -> lc_e  (appl e1 e2)
 | lc_appl    : forall e1 e2, lc_e  e1 -> lc_e  e2 -> lc_e  (appl e1 e2)
 | lc_call    : forall s, lc_st s -> lc_e  (call s)
 | lc_inst    : forall e t, lc_e  e -> T.lc t -> lc_e  (inst e t)
 | lc_pack    : forall t0 e t1, T.lc t0 -> lc_e  e -> T.lc t1 ->
                                lc_e  (pack t0 e t1)
with      lc_f : F -> Prop :=
 | lc_dfun : forall t1 t2 s, T.lc t1 -> T.lc t2 -> lc_st s ->
                                     lc_f (dfun t1 t2 s)
 | lc_ufun : forall k f, lc_f f -> lc_f (ufun k f).

Inductive lc : Term -> Prop :=
  | lc_as_st : forall s, lc_st s -> lc (term_st s)
  | lc_as_e  : forall e, lc_e  e -> lc (term_e  e)
  | lc_as_f  : forall f, lc_f  f -> lc (term_f  f).

Hint Constructors lc_st.
Hint Constructors lc_e.
Hint Constructors lc_f.
Hint Constructors lc.

Definition body t :=
  exists L, forall alpha, alpha \notin L -> lc (open (ftvar alpha) t).

(* BUG what's right here ? *)

Ltac gather_vars :=
  let A' := gather_vars_with (fun x : vars => x) in
  let B' := gather_vars_with (fun x : var  => \{x}) in
  let C' := gather_vars_with (fun x : Tau => T.fv x) in
  let D' := gather_vars_with (fun x : V => fv_v x) in
  let E' := gather_vars_with (fun x : St => fv_st x) in
  let F' := gather_vars_with (fun x : E => fv_e x) in
  let G' := gather_vars_with (fun x : F => fv_f x) in
  let H' := gather_vars_with (fun x : Term => fv x) in
  let I' := gather_vars_with (fun x : St => TM.fv_st x) in
  let J' := gather_vars_with (fun x : E => TM.fv_e x) in
  let K' := gather_vars_with (fun x : F => TM.fv_f x) in
  let L' := gather_vars_with (fun x : Term => fv x) in
  constr:(A' \u (B' \u (C' \u D' \u E' \u F' \u G' \u H' \u I' \u J'
            \u K' \u L'))).

Ltac pick_fresh X :=
  let L := gather_vars in (pick_fresh_gen L X).

Tactic Notation "pick_fresh" ident(x) :=
  let L := gather_vars in pick_fresh_gen (L) x.

Tactic Notation "pick_fresh" ident(x) "from" constr(E) :=
  let L := gather_vars in pick_fresh_gen (L \u E) x.

Tactic Notation "apply_fresh" constr(T) :=
  apply_fresh_base T gather_vars ltac_no_arg.

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; auto_star.

(* From the JAR paper but does not parse.
Tactic Notation "apply_fresh" "*" constr(T) :=
  apply_fresh T; auto_star.
*)

Tactic Notation "exists_fresh" :=
  let y := fresh "y" in let Fry := fresh "Fr" y in
  exists_fresh_gen gather_vars y Fry.

End TTM.


(* Mohamed Sami Cherif and Paolo Torrini,
   Universite' Lille-1 - CRIStAL-CNRS
*)
(* example of concrete module *)

Require Import EnvLibA.
Require Import PRelLibA.
Require Import IdModTypeA.

Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Export Coq.Arith.PeanoNat.
Require Import Coq.Arith.EqNat.

Module ModLEnv <: IdModType.

  Definition Id := string.

  Definition IdEqDec := string_dec.

  Instance IdEq2 : DEq Id :=
  {
  dEq := IdEqDec
  }.

  Definition IdEq := IdEq2.

  Definition W := list (Id * nat).

  Definition Loc_PI := valTyp_irrelevance.

  Definition BInit := @nil (Id * nat).

  Instance WP2 : PState W :=
  {
  loc_pi := Loc_PI;

  b_init := BInit
  }.

  Definition WP := WP2.

End ModLEnv.