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

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

(* ===== bit_blast_sle ===== *)

Definition bit_blast_sle g ls1 ls2: generator * cnf * literal :=
  let '(g_eq, cs_eq, r_eq) := bit_blast_eq g ls1 ls2 in
  let '(g_slt, cs_slt, r_slt) := bit_blast_slt g_eq ls1 ls2 in
  let '(g_disj, cs_disj, r_disj) := bit_blast_disj g_slt r_eq r_slt in
  (g_disj, catrev cs_eq (catrev cs_slt cs_disj), r_disj).

Lemma bit_blast_sle_correct g bs1 bs2 E ls1 ls2 g' cs lr:
  bit_blast_sle g ls1 ls2 = (g', cs, lr) ->
  size ls1 = size ls2 ->
  enc_bits E ls1 bs1 -> enc_bits E ls2 bs2 ->
  interp_cnf E (add_prelude cs) ->
  enc_bit E lr (sleB bs1 bs2).
Proof.
  rewrite /bit_blast_sle.
  case Hbb_eq : (bit_blast_eq g ls1 ls2) => [[g_eq cs_eq] r_eq].
  case Hbb_slt : (bit_blast_slt g_eq ls1 ls2) => [[g_slt cs_slt] r_slt].
  case Hbb_disj : (bit_blast_disj g_slt r_eq r_slt) => [[g_disj cs_disj] r_disj].
  case=> _ <- <- Hsz Henc1 Henc2.
  rewrite !add_prelude_catrev => /andP [Hics_eq /andP [Hics_slt Hics_disj]].
  rewrite /sleB.
  move: (bit_blast_eq_correct Hbb_eq Hsz Henc1 Henc2 Hics_eq) => HeEr_eq.
  move: (bit_blast_slt_correct Hbb_slt Henc1 Henc2 Hics_slt) => HeEr_slt.
  exact: (bit_blast_disj_correct Hbb_disj HeEr_eq HeEr_slt Hics_disj).
Qed.

Definition mk_env_sle E g ls1 ls2: env * generator * cnf * literal :=
  let '(E_eq, g_eq, cs_eq, r_eq) := mk_env_eq E g ls1 ls2 in
  let '(E_slt, g_slt, cs_slt, r_slt) := mk_env_slt E_eq g_eq ls1 ls2 in
  let '(E_disj, g_disj, cs_disj, r_disj) := mk_env_disj E_slt g_slt r_eq r_slt in
  (E_disj, g_disj, catrev cs_eq (catrev cs_slt cs_disj), r_disj).

Lemma mk_env_sle_is_bit_blast_sle E g ls1 ls2 E' g' cs lr:
    mk_env_sle E g ls1 ls2 = (E', g', cs, lr) ->
    bit_blast_sle g ls1 ls2 = (g', cs, lr).
Proof.
  rewrite /mk_env_sle /bit_blast_sle.
  case Hmkeq : (mk_env_eq E g ls1 ls2) => [[[E_eq g_eq] cs_eq] r_eq].
  case Hmkslt : (mk_env_slt E_eq g_eq ls1 ls2) => [[[E_slt g_slt] cs_slt] r_slt].
  case Hmkdisj : (mk_env_disj E_slt g_slt r_eq r_slt) => [[[E_disj g_disj] cs_disj] r_disj].
  rewrite (mk_env_eq_is_bit_blast_eq Hmkeq) {Hmkeq}.
  rewrite (mk_env_slt_is_bit_blast_slt Hmkslt) {Hmkslt}.
  rewrite (mk_env_disj_is_bit_blast_disj Hmkdisj) {Hmkdisj}.
  by case=> _ <- <- <-.
Qed.

Lemma mk_env_sle_newer_gen E g ls1 ls2 E' g' cs lr:
    mk_env_sle E g ls1 ls2 = (E', g', cs, lr) ->
    (g <=? g')%positive.
Proof.
  rewrite /mk_env_sle.
  case Hmkeq : (mk_env_eq E g ls1 ls2) => [[[E_eq g_eq] cs_eq] r_eq].
  case Hmkslt : (mk_env_slt E_eq g_eq ls1 ls2) => [[[E_slt g_slt] cs_slt] r_slt].
  case Hmkdisj : (mk_env_disj E_slt g_slt r_eq r_slt) => [[[E_disj g_disj] cs_disj] r_disj].
  case=> _ <- _ _.
  move: (mk_env_eq_newer_gen Hmkeq) => {Hmkeq} Hgge.
  move: (mk_env_slt_newer_gen Hmkslt) => {Hmkslt} Hgegs.
  move: (mk_env_disj_newer_gen Hmkdisj) => {Hmkdisj} Hgsgd.
  move : (pos_leb_trans Hgge Hgegs) => Hggs {Hgge Hgegs}.
  exact: (pos_leb_trans Hggs Hgsgd).
Qed.

Lemma mk_env_sle_newer_res E g ls1 ls2 E' g' cs lr:
    mk_env_sle E g ls1 ls2 = (E', g', cs, lr) ->
    newer_than_lit g' lr.
Proof.
  rewrite /mk_env_sle.
  case Hmkeq : (mk_env_eq E g ls1 ls2) => [[[E_eq g_eq] cs_eq] r_eq].
  case Hmkslt : (mk_env_slt E_eq g_eq ls1 ls2) => [[[E_slt g_slt] cs_slt] r_slt].
  case Hmkdisj : (mk_env_disj E_slt g_slt r_eq r_slt) => [[[E_disj g_disj] cs_disj] r_disj].
  case=> _ <- _ <-.
  exact: (mk_env_disj_newer_res Hmkdisj).
Qed.

Lemma mk_env_sle_newer_cnf E g ls1 ls2 E' g' cs lr:
    mk_env_sle E g ls1 ls2 = (E', g', cs, lr) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g ls1 -> newer_than_lits g ls2 ->
    newer_than_cnf g' cs.
Proof.
  rewrite /mk_env_sle.
  case Hmkeq : (mk_env_eq E g ls1 ls2) => [[[E_eq g_eq] cs_eq] r_eq].
  case Hmkslt : (mk_env_slt E_eq g_eq ls1 ls2) => [[[E_slt g_slt] cs_slt] r_slt].
  case Hmkdisj : (mk_env_disj E_slt g_slt r_eq r_slt) => [[[E_disj g_disj] cs_disj] r_disj].
  case=> _ <- <- _ Hgt Hgl1 Hgl2. rewrite /= !newer_than_cnf_catrev.
  (* newer_than_cnf g_disj cs_eq *)
  move : (mk_env_eq_newer_cnf Hmkeq Hgt Hgl1 Hgl2) => Hgece.
  move : (mk_env_slt_newer_gen Hmkslt) => Hgegs.
  move : (mk_env_disj_newer_gen Hmkdisj) => Hgsgd.
  move : (pos_leb_trans Hgegs Hgsgd) => Hgegd.
  rewrite (newer_than_cnf_le_newer Hgece Hgegd) /=.
  (* newer_than_cnf g_disj cs_slt *)
  move : (mk_env_eq_newer_gen Hmkeq) => Hgge.
  move : (newer_than_lit_le_newer Hgt Hgge) => Hget.
  move : (newer_than_lits_le_newer Hgl1 Hgge) => Hgel1.
  move : (newer_than_lits_le_newer Hgl2 Hgge) => Hgel2.
  move : (mk_env_slt_newer_cnf Hmkslt Hget Hgel1 Hgel2) => Hgscs.
  rewrite (newer_than_cnf_le_newer Hgscs Hgsgd) /=.
  (* newer_than_cnf g_disj cs_disj *)
  move : (mk_env_eq_newer_res Hmkeq) => Hgere.
  move : (mk_env_slt_newer_res Hmkslt) => Hgsrs.
  move : (newer_than_lit_le_newer Hgere Hgegs) => Hgsre.
  exact: (mk_env_disj_newer_cnf Hmkdisj Hgsre Hgsrs).
Qed.

Lemma mk_env_sle_preserve E g ls1 ls2 E' g' cs lr:
    mk_env_sle E g ls1 ls2 = (E', g', cs, lr) ->
    env_preserve E E' g.
Proof.
  rewrite /mk_env_sle.
  case Hmkeq : (mk_env_eq E g ls1 ls2) => [[[E_eq g_eq] cs_eq] r_eq].
  case Hmkslt : (mk_env_slt E_eq g_eq ls1 ls2) => [[[E_slt g_slt] cs_slt] r_slt].
  case Hmkdisj : (mk_env_disj E_slt g_slt r_eq r_slt) => [[[E_disj g_disj] cs_disj] r_disj].
  case=> <- _ _ _.
  move : (mk_env_eq_preserve Hmkeq) => HpEEeg.
  move : (mk_env_slt_preserve Hmkslt) => HpEeEsge.
  move : (mk_env_disj_preserve Hmkdisj) => HpEsEdgs.
  move : (mk_env_eq_newer_gen Hmkeq) => {Hmkeq} Hgge.
  move : (mk_env_slt_newer_gen Hmkslt) => {Hmkslt} Hgegs.
  move : (env_preserve_le HpEeEsge Hgge) => HpEeEsg.
  move : (pos_leb_trans Hgge Hgegs) => Hggs.
  move : (env_preserve_le HpEsEdgs Hggs) => HpEsEdg.
  move: (env_preserve_trans HpEEeg HpEeEsg) => HpEEsg.
  exact: (env_preserve_trans HpEEsg HpEsEdg).
Qed.

Lemma mk_env_sle_sat E g ls1 ls2 E' g' cs lr:
    mk_env_sle E g ls1 ls2 = (E', g', cs, lr) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g ls1 -> newer_than_lits g ls2 ->
    interp_cnf E' cs.
Proof.
  rewrite /mk_env_sle.
  case Hmkeq : (mk_env_eq E g ls1 ls2) => [[[E_eq g_eq] cs_eq] r_eq].
  case Hmkslt : (mk_env_slt E_eq g_eq ls1 ls2) => [[[E_slt g_slt] cs_slt] r_slt].
  case Hmkdisj : (mk_env_disj E_slt g_slt r_eq r_slt) => [[[E_disj g_disj] cs_disj] r_disj].
  case=> <- _ <- _ Hgt Hgl1 Hgl2.
  rewrite !interp_cnf_catrev.
  (* interp_cnf E_disj cs_eq *)
  move : (mk_env_eq_sat Hmkeq Hgt Hgl1 Hgl2) => HiEece.
  move : (mk_env_slt_preserve Hmkslt) => HpEeEsge.
  move : (mk_env_disj_preserve Hmkdisj) => HpEsEdgs.
  move : (mk_env_slt_newer_gen Hmkslt) => Hgegs.
  move : (env_preserve_le HpEsEdgs Hgegs) => HpEsEdge.
  move : (env_preserve_trans HpEeEsge HpEsEdge) => HpEeEdge.
  move : (mk_env_eq_newer_cnf Hmkeq Hgt Hgl1 Hgl2) => Hgece.
  rewrite (env_preserve_cnf HpEeEdge Hgece).
  rewrite HiEece /=.
  (* interp_cnf E_disj cs_slt *)
  move : (mk_env_eq_newer_gen Hmkeq) => Hgge.
  move : (newer_than_lit_le_newer Hgt Hgge) => Hget.
  move : (newer_than_lits_le_newer Hgl1 Hgge) => Hgel1.
  move : (newer_than_lits_le_newer Hgl2 Hgge) => Hgel2.
  move : (mk_env_slt_sat Hmkslt Hget Hgel1 Hgel2) => HiEscs.
  move : (mk_env_slt_newer_cnf Hmkslt Hget Hgel1 Hgel2) => Hgscs.
  rewrite (env_preserve_cnf HpEsEdgs Hgscs).
  rewrite HiEscs /=.
  (* interp_cnf E_disj cs_disj *)
  move : (mk_env_eq_newer_res Hmkeq) => Hgere.
  move : (newer_than_lit_le_newer Hgere Hgegs) => Hgsre.
  move : (mk_env_slt_newer_res Hmkslt) => Hgsrs.
  exact : (mk_env_disj_sat Hmkdisj Hgsre Hgsrs).
Qed.

(*
Lemma toZK n : cancel (@toZ n) (@fromZ n.+1).
Proof.
  induction n.
  - case/tupleP => b x.
    case b.
    + by rewrite tuple0 /toZ !tupleE/= /joinlsb/=.
    + rewrite tuple0 /toZ !tupleE/=. by apply val_inj.
  - case/tupleP => b x.
    move : (IHn x) => Hx.
    case b;
      rewrite /toZ/= beheadCons theadCons/=;
      case Hsplitx : (splitmsb x) => [c bs].
      case Hc: c; rewrite Hc in Hsplitx.
      * rewrite /joinlsb/= toNegZCons.
        rewrite -Hx /toZ/= Hsplitx/=.
        rewrite Z.double_spec toNegZ_toNat.
        assert (0<=(Z.of_nat (2 ^ n - 1 - toNat bs)))%Z as Hge0 by omega.
        case Hofnat: (Z.of_nat (2 ^ n - 1 - toNat bs))=>[|p|p].
        by apply val_inj.
        Local Opaque fromNegZ.
        rewrite /fromZ 2!Z.opp_involutive -!Zpred_succ/=.
        by apply val_inj.
        rewrite Hofnat in Hge0.
        move: (Pos2Z.neg_is_neg p)=> Hneg ; omega.
      * rewrite /joinlsb/= toPosZCons.
        rewrite -Hx /toZ/= Hsplitx/=.
        rewrite toPosZ_toNat.
        assert (0<=(Z.of_nat (toNat bs)))%Z as Hge0 by omega.
        case Hofnat: (Z.of_nat (toNat bs)) => [|p|p].
        rewrite /=fromPosZ_fromNat/= /joinlsb/=.
        rewrite fromNat0. by apply val_inj.
        omega.
        Local Opaque fromPosZ.
        rewrite /fromZ/=. by apply val_inj.
        rewrite Hofnat in Hge0.
        move: (Pos2Z.neg_is_neg p)=> Hneg ; omega.
    + case Hc: c; rewrite Hc in Hsplitx.
      * rewrite /joinlsb/=toNegZCons.
        rewrite -Hx/toZ/=Hsplitx/=.
        rewrite Z.double_spec toNegZ_toNat.
        assert (0<=Z.of_nat (2 ^ n - 1 - toNat bs))%Z as Hge0 by omega.
        case Hofnat: (Z.of_nat (2 ^ n - 1 - toNat bs))=>[|p|p].
        by apply val_inj.
        rewrite /fromZ 2!Z.opp_involutive -!Zpred_succ/=.
        by apply val_inj.
        rewrite Hofnat in Hge0.
        move: (Pos2Z.neg_is_neg p)=> Hneg ; omega.
      * rewrite /joinlsb/= toPosZCons.
        rewrite -Hx /toZ/= Hsplitx/=.
        rewrite toPosZ_toNat.
        assert (0<=(Z.of_nat (toNat bs)))%Z as Hge0 by omega.
        case Hofnat: (Z.of_nat (toNat bs)) => [|p|p].
        by apply val_inj.
        rewrite /fromZ/=. by apply val_inj.
        rewrite Hofnat in Hge0.
        move: (Pos2Z.neg_is_neg p)=> Hneg ; omega.
Qed.

Definition toZ_inj n := can_inj (@toZK n).

Lemma toZ_eq n : forall (x y : BITS n.+1), (x == y) = (toZ x == toZ y).
Proof.
  induction n.
  - case/tupleP => [x1 bs1]; case/tupleP => [x2 bs2].
    rewrite !tupleE.
    case E: (toZ (cons_tuple x1 bs1) == toZ (cons_tuple x2 bs2)).
    rewrite (toZ_inj (eqP E)). by rewrite eq_refl.
    apply (contraFF (b:=false)) => // => H.
    rewrite (eqP H) (eq_refl) in E. done.
  - case/tupleP => [x1 bs1]; case/tupleP => [x2 bs2].
    case E: (toZ [tuple of x1 :: bs1] == toZ [tuple of x2 :: bs2]).
    rewrite (toZ_inj (eqP E)). by rewrite eq_refl.
    apply (contraFF (b:=false)) => // => H.
    rewrite (eqP H) (eq_refl) in E. done.
Qed.

Corollary toZ_neq n (x y : BITS n.+1): (x != y) = (toZ x != toZ y).
Proof. by rewrite toZ_eq. Qed.
*)

Lemma mk_env_sle_env_equal E1 E2 g ls1 ls2 E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_sle E1 g ls1 ls2 = (E1', g1', cs1, lrs1) ->
  mk_env_sle E2 g ls1 ls2 = (E2', g2', cs2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof.
  rewrite /mk_env_sle => Heq.
  dcase (mk_env_eq E1 g ls1 ls2) => [[[[E_eq1 g_eq1] cs_eq1] lrs_eq1] Heq1].
  dcase (mk_env_eq E2 g ls1 ls2) => [[[[E_eq2 g_eq2] cs_eq2] lrs_eq2] Heq2].
  move: (mk_env_eq_env_equal Heq Heq1 Heq2) => {Heq Heq1 Heq2} [Heq [? [? ?]]]; subst.
  dcase (mk_env_slt E_eq1 g_eq2 ls1 ls2) => [[[[E_lt1 g_lt1] cs_lt1] lrs_lt1] Hlt1].
  dcase (mk_env_slt E_eq2 g_eq2 ls1 ls2) => [[[[E_lt2 g_lt2] cs_lt2] lrs_lt2] Hlt2].
  move: (mk_env_slt_env_equal Heq Hlt1 Hlt2) => {Heq Hlt1 Hlt2} [Heq [? [? ?]]]; subst.
  dcase (mk_env_disj E_lt1 g_lt2 lrs_eq2 lrs_lt2)
  => [[[[E_disj1 g_disj1] cs_disj1] lrs_disj1] Hdisj1].
  dcase (mk_env_disj E_lt2 g_lt2 lrs_eq2 lrs_lt2)
  => [[[[E_disj2 g_disj2] cs_disj2] lrs_disj2] Hdisj2].
  move: (mk_env_disj_env_equal Heq Hdisj1 Hdisj2) => {Heq Hdisj1 Hdisj2} [Heq [? [? ?]]]; subst.
  case=> ? ? ? ?; case=> ? ? ? ?; subst. repeat split. assumption.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* $Id: LegacyRing.v 14641 2011-11-06 11:59:10Z herbelin $ *)

Require Export Bool.
Require Export LegacyRing_theory.
Require Export Quote.
Require Export Ring_normalize.
Require Export Ring_abstract.
Declare ML Module "ring_plugin".

(* As an example, we provide an instantation for bool. *)
(* Other instatiations are given in ArithRing and ZArithRing in the
   same directory *)

Definition BoolTheory :
  Ring_Theory xorb andb true false (fun b:bool => b) eqb.
split; simpl in |- *.
destruct n; destruct m; reflexivity.
destruct n; destruct m; destruct p; reflexivity.
destruct n; destruct m; reflexivity.
destruct n; destruct m; destruct p; reflexivity.
destruct n; reflexivity.
destruct n; reflexivity.
destruct n; reflexivity.
destruct n; destruct m; destruct p; reflexivity.
destruct x; destruct y; reflexivity || simpl in |- *; tauto.
Defined.

Add Legacy Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory
 [ true false ].


Require Import VST.floyd.proofauto.
Require Import VST.progs.even.
Instance CompSpecs : compspecs.
Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope assert.

Definition odd_spec :=
 DECLARE _odd
  WITH z : Z, b: unit
  PRE [ _n OF tuint]
    PROP(0 <= z <= Int.max_signed) LOCAL(temp _n (Vint (Int.repr z))) SEP()
  POST [ tint ]
    PROP() LOCAL(temp ret_temp (Vint (if Z.odd z then Int.one else Int.zero))) SEP().

Definition even_spec :=
 DECLARE _even
  WITH z : Z
  PRE [ _n OF tuint]
    PROP(0 <= z <= Int.max_signed) LOCAL(temp _n (Vint (Int.repr z))) SEP()
  POST [ tint ]
    PROP() LOCAL(temp ret_temp (Vint (if Z.even z then Int.one else Int.zero))) SEP().

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog nil gv
  POST [ tint ]
    PROP() LOCAL(temp ret_temp (Vint (if Z.even 42 then Int.one else Int.zero))) SEP().


(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp.analysis Require Import boolp reals distr.
(* ------- *) Require Import inhabited notations.

Require Import Eqdep_dec.

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

Import GRing.Theory Num.Theory.

Local Open Scope ring_scope.

Delimit Scope syn_scope with S.
Delimit Scope xsyn_scope with X.
Delimit Scope vsyn_scope with V.
Delimit Scope mem_scope with M.

(* -------------------------------------------------------------------- *)
Parameter R : realType.

Canonical real_ihbType := Eval hnf in IhbType R 0.

Notation Distr T := {distr T / R}.

(* -------------------------------------------------------------------- *)
Section MemType.
Variable (mident : eqType).

Record memType_ : Type := mkMem {
  mheap    :> choiceType;
  mget_    :  mheap -> forall (T : ihbType), mident -> T;
  mset_    :  mheap -> forall (T : ihbType), mident -> T -> mheap;
  mget_eq_  : forall T m x v, @mget_ (@mset_ m T x v) T x = v;
  mget_neq_ : forall T U m x y v, (T <> U \/ x != y) ->
                @mget_ (@mset_ m T x v) U y = @mget_ m U y;
}.

Section GetSet.
Variable (M : memType_) (T : ihbType).

Definition mget (m : M) (x : mident) :=
  nosimpl (@mget_ M m T x).

Definition mset (m : M) (x : mident) (v : T) :=
  nosimpl (@mset_ M m T x v).

End GetSet.

Variable (M : memType_) (T U : ihbType).

Lemma mget_eq (m : M) (x : mident) (v : T) : mget T (mset m x v) x = v.
Proof. by unlock mget mset; apply/mget_eq_. Qed.

Lemma mget_neq (m : M) (x y : mident) (v : T) : (T <> U \/ x != y) ->
  mget U (mset m x v) y = mget U m y.
Proof. by unlock mget mset; apply/mget_neq_. Qed.

Definition memType_of of phant mident := memType_.
End MemType.

Notation memType T := (memType_of (Phant T)).

(* -------------------------------------------------------------------- *)
(* Expressions and probabilistic expressions *)

Section Vars.
Context {ident : eqType}.

Inductive vars_r (T : ihbType) :=
| Var of ident.

Definition vars_of of phant ident := vars_r.
End Vars.

Notation vars_ ident := (vars_of (Phant ident)).

(* -------------------------------------------------------------------- *)
Section Syntax.
Context {ident : eqType} {mem : memType ident}.

Local Notation vars := (vars_ ident).

Definition vname {T} (v : vars T) :=
  let: Var name := v in name.

Definition vtype {T} (v : vars T) := T.

Inductive expr_ : Type -> Type :=
| var_  {T}   of vars T : expr_ T
| cst_  {T}   of T : expr_ T
| prp_        of pred mem : expr_ bool
| app_  {T U} of expr_ (T -> U) & expr_ T : expr_ U.

Notation bexpr   := (expr_ bool).
Notation dexpr T := (expr_ (Distr T)).

(* -------------------------------------------------------------------- *)
Bind Scope syn_scope with expr_.

(* -------------------------------------------------------------------- *)
Section VarsEqType.
Variables (T : ihbType) (I : eqType).

Definition vars_eq (x y : vars_ I T) :=
  let: Var x := x in let: Var y := y in x == y.

Lemma vars_eqP (x y : vars_ I T) : reflect (x = y) (vars_eq x y).
Proof.
by case: x y => [x] [y]; apply: (iffP idP) => /= [/eqP->|[->]].
Qed.

Definition vars_eqMixin := EqMixin vars_eqP.
Canonical vars_eqType := EqType (vars_ I T) vars_eqMixin.
End VarsEqType.

Canonical tvars_eqType (I : eqType) := Eval hnf in @tag_eqType
  (EqType ihbType (comparableClass (fun x y => pselect (x = y))))
  (vars_eqType^~ I).

(* -------------------------------------------------------------------- *)
Lemma eq_vars {t u : ihbType} (x : vars t) (y : vars u) :
      (Tagged vars y = Tagged vars x)
  <-> (vtype x = vtype y /\ vname x == vname y).
Proof. split.
+ case: x y => [x] [y]; rewrite /vtype /= => /(@eqP (tvars_eqType ident)).
  rewrite -tag_eqE /tag_eq /= => /andP[/eqP] /= ->.
  by rewrite tagged_asE => /eqP[->]; rewrite eqxx.
+ by case: x y => [x] [y]; rewrite /vtype /= => -[-> /eqP->].
Qed.

(* -------------------------------------------------------------------- *)
(* Commands *)

Inductive cmd_ : Type :=
| abort
| skip
| assign {t} of vars t & expr_ t
| random {t} of vars t & dexpr t
| cond       of bexpr & cmd_ & cmd_
| while      of bexpr & cmd_
| seqc       of cmd_ & cmd_.

Bind Scope syn_scope with cmd_.
End Syntax.

(* -------------------------------------------------------------------- *)
Notation "'If' e 'then' c1 'else' c2"
  := (cond e%X c1%S c2%S) : syn_scope.

Notation "'IfT' e 'then' c1"
  := (cond e%X c1%S skip) : syn_scope.

Notation "'While' e 'Do' c"
  := (while e%X c%S) : syn_scope.

Notation "x <<- e"
  := (assign x%V e%X) : syn_scope.

Notation "x <$- d"
  := (random x%V d%X) : syn_scope.

Notation "c1 ;; c2"
  := (seqc c1%S c2%S) : syn_scope.

Local Open Scope syn_scope.

(* -------------------------------------------------------------------- *)
Arguments expr_ : clear implicits.
Arguments cmd_  : clear implicits.

(* -------------------------------------------------------------------- *)
Parameter ident : countType.

Notation sident := (Countable.sort ident).

(* -------------------------------------------------------------------- *)
Section CoreMem.

Inductive coremem :=
  CoreMem (m : forall {T : ihbType}, ident -> T).

Definition coremem_get := (fun m => let: CoreMem m := m in m).

Coercion coremem_get : coremem >-> Funclass.

Definition coremem_set := nosimpl (fun (m : coremem) {T : ihbType} x v =>
  CoreMem (fun U y =>
    if pselect (T = U) is left eq then
      if x == y then ecast _ _ eq v else m U y
    else coremem_get m U y)).

Lemma get_set_eq {T : ihbType} (m : coremem) (x : ident) (v : T) :
  (coremem_set m x v) T x = v.
Proof.
rewrite /coremem_get /=; case: (pselect _) => // eq; rewrite eqxx.
suff ->: eq = erefl T by done.
by apply/UIP_dec=> {x} x y; apply/pselect.
Qed.

Lemma get_set_nex {T U : ihbType} (m : coremem) (x y : ident) (v : T) :
  x != y -> (coremem_set m x v) U y = m U y.
Proof.
move=> ne_xy; rewrite /coremem_set /coremem_get /=.
by case: pselect => //; rewrite (negbTE ne_xy).
Qed.

Lemma get_set_net {T U : ihbType} (m : coremem) (x y: ident) (v : T) :
  T <> U -> (coremem_set m x v) U y = m U y.
Proof. by rewrite /coremem_set /coremem_get; case: pselect. Qed.

Lemma get_set_ne {T U : ihbType} (m : coremem) (x y : ident) (v : T) :
  (T <> U \/ x !=y) -> (coremem_set m x v) U y = m U y.
Proof. by move=> [/get_set_net |/get_set_nex] ->. Qed.

Lemma coremem_comparable : comparable coremem.
Proof. by move=> m1 m2; apply/pselect. Qed.

Definition coremem_eqMixin := comparableClass coremem_comparable.
Canonical  coremem_eqType  := Eval hnf in EqType coremem coremem_eqMixin.

Axiom coremem_choice : choiceMixin coremem.
Canonical coremem_choiceType := Eval hnf in ChoiceType coremem coremem_choice.

End CoreMem.

Arguments coremem : clear implicits.

(* -------------------------------------------------------------------- *)
Definition cmem : memType ident := locked {|
  mheap     := [choiceType of coremem];
  mget_     := coremem_get;
  mset_     := coremem_set;
  mget_eq_  := @get_set_eq;
  mget_neq_ := @get_set_ne;
|}.

Notation dmem := (Distr cmem).

(* -------------------------------------------------------------------- *)
Inductive side : predArgType := SLeft | SRight.

Coercion bool_of_side (s : side) :=
  match s with SLeft => false | SRight => true end.

Definition side_of_bool (b : bool) :=
  if b then SRight else SLeft.

Lemma side_of_boolK : cancel bool_of_side side_of_bool.
Proof. by case. Qed.

Definition side_eqMixin := CanEqMixin side_of_boolK.
Canonical  side_eqType := Eval hnf in EqType side side_eqMixin.
Definition side_choiceMixin := CanChoiceMixin side_of_boolK.
Canonical  side_choiceType := Eval hnf in ChoiceType side side_choiceMixin.
Definition side_countMixin := CanCountMixin side_of_boolK.
Canonical  side_countType := Eval hnf in CountType side side_countMixin.
Definition side_finMixin := CanFinMixin side_of_boolK.
Canonical  side_finType := Eval hnf in FinType side side_finMixin.

Notation "''1'" := SLeft.
Notation "''2'" := SRight.

Definition mselect {T : Type} (s : side) (m : T * T) :=
  match s with
  | '1 => m.1
  | '2 => m.2
  end.

Notation "m # s" := (mselect s m) (at level 2, format "m # s") : mem_scope.

(* -------------------------------------------------------------------- *)
Lemma side2 {A : Type} s (x : A * A) : ((fst, snd)#s x = x#s)%M.
Proof. by case: s. Qed.

Lemma side_app {A B : Type} (f : A -> B) s (x y : A) :
  (f (x, y)#s = (f x, f y)#s)%M.
Proof. by case: s. Qed.

(* -------------------------------------------------------------------- *)
Notation rident := (sident * side)%type.

Definition coremem2 := (mheap cmem * mheap cmem)%type.

Definition coremem2_get (m : coremem2) T xs :=
  mget T (m#(xs.2))%M xs.1.

Definition coremem2_set (m : coremem2) (T : ihbType) xs (v : T) :=
  match xs.2 return coremem2 with
  | '1 => (mset m.1 xs.1 v, m.2)
  | '2 => (m.1, mset m.2 xs.1 v)
  end.

Coercion coremem2_get : coremem2 >-> Funclass.

Set Printing Coercions.

Lemma get_set2_eq {T} m x v : (@coremem2_set m T x v) T x = v.
Proof. by case: m x => m1 m2 [x []] /=; apply mget_eq. Qed.

Lemma get_set2_ne {T U} m x y v :
  (T <> U \/ x != y) -> (@coremem2_set m T x v) U y = m U y.
Proof.
case: m x y => m1 m2 [x []] [y []] //= h; apply mget_neq => /=;
  by (elim: h => h; [left | right; apply: contra h => /eqP->]).
Qed.

Canonical coremem2_choiceType := Eval hnf in [choiceType of coremem2].

(* -------------------------------------------------------------------- *)
Definition rmem : memType rident := nosimpl {|
  mheap     := [choiceType of coremem2];
  mget_     := coremem2_get;
  mset_     := coremem2_set;
  mget_eq_  := @get_set2_eq;
  mget_neq_ := @get_set2_ne;
|}.

(* -------------------------------------------------------------------- *)
Notation vars    := (vars_ sident).
Notation expr    := (expr_ _ cmem).
Notation cmd     := (cmd_  _ cmem).
Notation bexpr   := (expr bool).
Notation dexpr T := (expr (Distr T)).
Notation prp     := (@prp_ _ cmem).

(* -------------------------------------------------------------------- *)
Notation app2_ f x1 x2 := (app_ (app_ f x1) x2).

Notation "c %:S"    := (@cst_ _ _ _ c) (at level 2, format "c %:S").
Notation "e1 == e2" := (app2_ (cst_ eq_op) e1 e2) : xsyn_scope.
Notation "e1 <= e2" := (app2_ (cst_ <=%R ) e1 e2) : xsyn_scope.
Notation "e1 < e2"  := (app2_ (cst_ <%R  ) e1 e2) : xsyn_scope.
Notation "e1 || e2" := (app2_ (cst_ orb  ) e1 e2) : xsyn_scope.
Notation "e1 && e2" := (app2_ (cst_ andb ) e1 e2) : xsyn_scope.
Notation "~~ e"     := (app_ (cst_ negb) e)       : xsyn_scope.
Notation "e1 + e2"  := (app2_ (cst_ +%R) e1 e2)   : xsyn_scope.
Notation "e1 * e2"  := (app2_ (cst_ *%R) e1 e2)   : xsyn_scope.
Notation "e1 :: e2" := (app2_ (cst_ cons) e1 e2)  : xsyn_scope.
Notation "` x"      := (@var_ _ _ _ x%V)          : xsyn_scope.

Notation "e1 == e2 :> T" := (app2_ (cst_ eq_op) (e1 : T) (e2 : T))
 (only parsing) : xsyn_scope.

Notation "e1 <= e2 :> T" := (app2_ (cst_ <=%R ) (e1 : T) (e2 : T))
 (only parsing) : xsyn_scope.

Notation "e1 < e2 :> T"  := (app2_ (cst_ <%R  ) (e1 : T) (e2 : T))
 (only parsing) : xsyn_scope.

(* -------------------------------------------------------------------- *)
Section SynInject.
Context {I1 I2 : eqType} {mem1 : memType I1} {mem2:memType I2}
        (h : I1 -> I2) (mh : mem2 -> mem1).

Local Notation vars1 := (vars_ I1).
Local Notation vars2 := (vars_ I2).
Local Notation expr1 := (@expr_ I1 mem1).
Local Notation expr2 := (@expr_ I2 mem2).
Local Notation cmd1  := (cmd_  I1 mem1).
Local Notation cmd2  := (cmd_  I2 mem2).

Definition ivar {T : ihbType} (x : vars1 T) : vars2 T :=
  let: Var x := x in Var T (h x).

Definition iprop (p : pred mem1) : pred mem2 :=
  fun m => p (mh m).

Fixpoint iexpr {T : Type} (e : expr1 T) : expr2 T :=
  match e with
  | var_ _   x     => var_ (ivar x)
  | cst_ _   c     => cst_ c
  | prp_     p     => prp_ (iprop p)
  | app_ _ _ e1 e2 => app_ (iexpr e1) (iexpr e2)
  end.

Fixpoint icmd (c : cmd1) : cmd2 :=
  match c with
  | abort => abort
  | skip  => skip

  | x <<- e =>
      ivar x <<- iexpr e

  | x <$- e =>
      ivar x <$- iexpr e

  | If e then c1 else c2 =>
      If iexpr e then icmd c1 else icmd c2

  | While e Do c =>
      While iexpr e Do icmd c

  | seqc c1 c2 =>
      seqc (icmd c1) (icmd c2)
  end.
End SynInject.

(* -------------------------------------------------------------------- *)
Notation rvars := (vars_ rident).
Notation rexpr := (expr_ _ rmem).
Notation rcmd  := (cmd_  _ rmem).

Implicit Types (s : side).

Notation   irvar  s := (@ivar  _ _ (fun x => (x, s))) (only parsing).
Definition irexpr s := (@iexpr _ _ cmem rmem (fun x : ident => (x, s)) (fun m=> (m#s)%M)).
Definition ircmd  s := (@icmd  _ _ cmem rmem (fun x : ident => (x, s)) (fun m=> (m#s)%M)).

Reserved Notation "x # s" (at level 2, format "x # s").

Notation "x # s" := (ivar (pair^~ s) x) : vsyn_scope.
Notation "e # s" := (irexpr s e) : xsyn_scope.
Notation "c # s" := (ircmd s c) : syn_scope.
Notation rmem1 m := (m.1 : mem).
Notation rmem2 m := (m.2 : mem).
Notation rprp    := (@prp_ _ rmem).

(* -------------------------------------------------------------------- *)
Notation assn  := (pred cmem).
Notation dassn := (pred dmem).
Notation rassn := (pred rmem).


Set Implicit Arguments.
Require Import TLC.LibTactics.
(* Load the CFML library, with time credits. *)
Require Import CFML.CFLibCredits.
Require Pervasives_ml.
Require Array_ml.
Require Import Pervasives_proof.
Require Import ArrayCredits_proof.
(* Load the big-O library. *)
Require Import Dominated.
Require Import UltimatelyGreater.
Require Import Monotonic.
Require Import LibZExtra.
(* Load the custom CFML tactics with support for big-Os *)
Require Import CFMLBigO.
(* Load the CF definitions. *)
Require Import Dependent_nested_ml.

Ltac auto_tilde ::= try solve [ auto with maths | false; math ].

Lemma f_spec :
  specZ [cost \in_O (fun n => n^2)]
    (forall n,
       0 <= n -> (* FIXME (need more xfor lemmas) *)
       app f [n]
       PRE (\$ cost n)
       POST (fun (_:unit) => \[])).
Proof.
  xspecO_refine straight_line. intros n N. xcf. xpay.
  weaken. xfor_inv (fun (_:int) => \[]). math.
  { intros i Hi. xpay.
    weaken. xfor_inv (fun (_:int) => \[]). math.
    intros j Hj. xpay. xret. hsimpl. hsimpl. hsimpl.
    { simpl. rewrite Z.add_0_r. reflexivity. } }
  hsimpl. hsimpl.
  { simpl.
    assert (L: forall f g a b, f = g -> cumul a b f = cumul a b g) by admit. (* FIXME *)
    erewrite L; swap 1 2. extens. intro i.
    reflexivity. reflexivity. }

  cleanup_cost.
  admit. (* TODO *)

  dominated.
  rewrite dominated_big_sum_bound.
  { eapply dominated_eq_r; swap 1 2.
    { intros a. rewrite (Z.pow_2_r a). reflexivity. }
    dominated. eapply dominated_eq_l; swap 1 2.
    intro.
    hide_evars_then ltac:(fun _ => rewrite cumulP; rewrite big_const_Z; ring_simplify).
    reflexivity. reflexivity. }
  ultimately_greater. apply~ filter_universe_alt.
  apply filter_universe_alt. monotonic. admit.
Qed.


Require Import GMu.Definitions.
Require Import GMu.Infrastructure.
Require Import GMu.Equations.
Require Import TLC.LibTactics.
Require Import TLC.LibEnv.
Require Import TLC.LibLN.

  (* Ht : {Σ, empty}⊢ trm_constructor Tparams Name e1 ∈ T1 ** T2 *)
Lemma CanonicalConstructorType : forall Σ Δ E Tparams Name Ctor e1 T,
    {Σ, Δ, E} ⊢(Treg) trm_constructor Tparams (Name, Ctor) e1 ∈ T ->
    exists Typs, T = typ_gadt Typs Name.
Proof.
  introv Htyp.
  inversions Htyp.
  rewrite rewrite_open_tt_many_gadt.
  eexists.
  f_equal.
Qed.

Lemma CanonicalConstructorTypeGen : forall Σ Δ E Tparams Ctor e1 T,
    {Σ, Δ, E} ⊢(Treg) trm_constructor Tparams Ctor e1 ∈ T ->
    exists Typs Name, T = typ_gadt Typs Name.
Proof.
  intros.
  destruct Ctor.
  apply CanonicalConstructorType in H; auto.
  destruct H as [Typs Heq].
  eexists. eexists. eauto.
Qed.

Local Hint Resolve CanonicalConstructorTypeGen.

Ltac contradictory_constructor_type :=
  lazymatch goal with
  | H: {?S, ?D, ?E} ⊢(?TT) trm_constructor ?Ts ?C ?e ∈ ?T |- _ =>
    apply CanonicalConstructorTypeGen in H;
    let Hcontradict := fresh "contradict" in
    destruct H as [? [? Hcontradict]];
    inversion Hcontradict
  end.

Lemma CanonicalFormTuple : forall Σ Δ e T1 T2,
    value e ->
    {Σ, Δ, empty} ⊢(Treg) e ∈ T1 ** T2 ->
    exists v1 v2, e = trm_tuple v1 v2.
Proof.
  introv Hv Ht.
  inversion Hv; inversion Ht; subst; eauto; try congruence.
  inversions H6.
  - false* binds_empty_inv.
  - contradictory_constructor_type.
Qed.

Lemma CanonicalFormAbs : forall Σ Δ e T1 T2,
    value e ->
    {Σ, Δ, empty} ⊢(Treg) e ∈ T1 ==> T2 ->
    exists v1, e = trm_abs T1 v1.
Proof.
  introv Hv Ht.
  inversion Hv; inversion Ht; subst; eauto; try congruence.
  - false* binds_empty_inv.
  - contradictory_constructor_type.
Qed.

Lemma CanonicalFormTAbs : forall Σ Δ e T,
    value e ->
    {Σ, Δ, empty} ⊢(Treg) e ∈ typ_all T ->
    exists v1, e = trm_tabs v1.
Proof.
  introv Hv Ht.
  inversion Hv; inversion Ht; subst; eauto; try congruence.
  - false* binds_empty_inv.
  - contradictory_constructor_type.
Qed.

Lemma CanonicalFormUnit : forall Σ Δ e,
    value e ->
    {Σ, Δ, empty} ⊢(Treg) e ∈ typ_unit ->
    e = trm_unit.
Proof.
  introv Hv Ht.
  inversion Hv; inversion Ht; subst; eauto; try congruence.
  - false* binds_empty_inv.
  - contradictory_constructor_type.
Qed.

Lemma CanonicalFormGadt : forall Σ Δ e Ts N,
    value e ->
    {Σ, Δ, empty} ⊢(Treg) e ∈ typ_gadt Ts N ->
    exists Ts' C v, e = trm_constructor Ts' (N, C) v.
Proof.
  introv Hv Ht.
  inversion Hv; inversion Ht; subst; eauto; try congruence.
  - false* binds_empty_inv.
  - rewrite rewrite_open_tt_many_gadt in H8.
    inversions H8.
    inversions H13.
    repeat eexists.
Qed.


(** Concurrent bag specification from the HOCAP paper.
    "Modular Reasoning about Separation of Concurrent Data Structures"
    <http://www.kasv.dk/articles/hocap-ext.pdf>

Deriving the sequential specification from the abstract one
*)
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.proofmode Require Import proofmode.
From iris.heap_lang Require Import proofmode notation.
From iris_examples.hocap Require Import abstract_bag.
From iris.prelude Require Import options.

Section proof.
  Context `{heapGS Σ}.
  Variable b : bag Σ.
  Variable N : namespace.

  (** An exclusive specification keeps track of the exact contents of the bag *)
  Definition bagE (γ : name Σ b) (x : val) (X : gmultiset val) : iProp Σ :=
    (is_bag b N γ x ∗ bag_contents b γ X)%I.

  Lemma newBag_spec :
    {{{ True }}}
      newBag b #()
    {{{ x, RET x; ∃ γ, bagE γ x ∅ }}}.
  Proof.
    iIntros (Φ) "_ HΦ". iApply newBag_spec; eauto.
    iNext. iIntros (x γ) "[#Hbag Hb]". iApply "HΦ".
    iExists γ; by iFrame.
  Qed.

  Lemma pushBag_spec γ x X v :
    {{{ bagE γ x X }}}
       pushBag b x (of_val v)
    {{{ RET #(); bagE γ x ({[+ v +]} ⊎ X) }}}.
  Proof.
    iIntros (Φ) "Hbag HΦ".
    iApply (pushBag_spec b N (bagE γ x X)%I (bagE γ x ({[+ v +]} ⊎ X))%I γ with "[] [Hbag]"); eauto.
    { iModIntro. iIntros (Y) "[Hb1 Hb2]".
      iDestruct "Hb2" as "[#Hbag Hb2]".
      iDestruct (bag_contents_agree with "Hb1 Hb2") as %<-.
      iMod (bag_contents_update b ({[+ v +]} ⊎ Y) with "[$Hb1 $Hb2]") as "[Hb1 Hb2]".
      by iFrame. }
    { iDestruct "Hbag" as "[#Hbag Hb]". iFrame "Hbag". eauto. }
  Qed.

  Lemma popBag_spec γ x X :
    {{{ bagE γ x X }}}
       popBag b x
    {{{ v, RET v; (⌜X = ∅⌝ ∧ ⌜v = NONEV⌝ ∧ bagE γ x ∅)
                 ∨ (∃ Y y, ⌜X = {[+ y +]} ⊎ Y⌝ ∧ ⌜v = SOMEV y⌝ ∧ bagE γ x Y)}}}.
  Proof.
    iIntros (Φ) "Hbag HΦ".
    iApply (popBag_spec b N (bagE γ x X)%I (fun v => (⌜X = ∅⌝ ∧ ⌜v = NONEV⌝ ∧ bagE γ x ∅)
                 ∨ (∃ Y y, ⌜X = {[+ y +]} ⊎ Y⌝ ∧ ⌜v = SOMEV y⌝ ∧ bagE γ x Y))%I γ with "[] [] [Hbag]"); eauto.
    { iModIntro. iIntros (Y y) "[Hb1 Hb2]".
      iDestruct "Hb2" as "[#Hbag Hb2]".
      iDestruct (bag_contents_agree with "Hb1 Hb2") as %<-.
      iMod (bag_contents_update b Y with "[$Hb1 $Hb2]") as "[Hb1 Hb2]".
      iFrame. iRight. iModIntro. iExists _,_; repeat iSplit; eauto. }
    { iModIntro. iIntros "[Hb1 Hb2]".
      iDestruct "Hb2" as "[#Hbag Hb2]".
      iDestruct (bag_contents_agree with "Hb1 Hb2") as %<-.
      iModIntro. iFrame. iLeft. repeat iSplit; eauto. }
    { iDestruct "Hbag" as "[#Hbag Hb]". iFrame "Hbag". eauto. }
  Qed.
End proof.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import Coq.ZArith.ZArith.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.Reachable.ParenBalanced.Core.
Require Import Fiat.Parsers.Refinement.BinOpBrackets.ParenBalanced.
Require Import Fiat.Common.

Set Implicit Arguments.

Section helpers.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}.
  Context {pdata : paren_balanced_hiding_dataT Char}.

  Local Ltac induction_str_len str :=
    let len := fresh "len" in
    set (len := length str);
      generalize (eq_refl : length str = len);
      clearbody len; revert str;
      induction len; intros str ?.

  Local Ltac t :=
    repeat match goal with
             | [ |- ?x = ?x ] => reflexivity
             | [ H : is_true false |- _ ] => solve [ inversion H ]
             | [ H : false = true |- _ ] => solve [ inversion H ]
             | _ => progress rewrite ?take_length, ?drop_length
             | [ H : _ |- _ ] => progress rewrite ?take_length, ?drop_length, ?drop_take, ?drop_0, ?NPeano.Nat.sub_0_r, ?NPeano.Nat.sub_1_r in H
             | [ H : ?x = 0, H' : context[?x] |- _ ] => rewrite H in H'
             | [ H : length ?str = 0, H' : is_true (take _ (drop _ ?str) ~= [ _ ])%string_like |- _ ]
               => apply length_singleton in H'
             | [ H : get 0 _ = None |- _ ] => apply no_first_char_empty in H
             | _ => progress simpl in *
             | _ => progress subst
             | _ => setoid_rewrite Bool.andb_true_iff
             | [ H : (_ && _ = true)%bool |- _ ] => apply Bool.andb_true_iff in H
             | _ => progress specialize_by omega
             | _ => progress specialize_by assumption
             | _ => progress split_and
             | [ |- context[if ?e then _ else _] ] => destruct e eqn:?
             | [ H : context[if ?e then _ else _] |- _ ] => destruct e eqn:?
             | _ => solve [ eauto with nocore ]
             | [ H : context[drop _ (drop _ _)] |- _ ] => setoid_rewrite drop_drop in H
             | [ |- context[match get 0 (take _ _) with _ => _ end] ] => rewrite !get_take_lt by omega
             | [ H : context[(_ + 1)%nat] |- _ ] => setoid_rewrite NPeano.Nat.add_1_r in H
             | [ |- context[get 0 ?str] ] => erewrite (proj1 (get_0 str _)) by eassumption
             | [ |- context[get 0 (take 0 ?str)] ] => rewrite (has_first_char_nonempty (take 0 str))
                                                     by (rewrite take_length; reflexivity)
             | [ H : context[Compare_dec.zerop ?x] |- _ ] => destruct (Compare_dec.zerop x)
             | _ => progress intros
             | _ => omega
             | [ H : context[match get 0 ?str with _ => _ end] |- _ ] => destruct (get 0 str) eqn:?
             | _ => progress unfold is_true in *
           end.

  Lemma paren_balanced_hiding'_prefix (str : String) (n n' level : nat)
        (H_hiding : paren_balanced_hiding' (take n str) level)
        (H_hiding_prefix : paren_balanced' (take n' str) level)
        {ch}
        (Hlt : n' < n)
        (H_ch : (take 1 (drop n' str) ~= [ ch ])%string_like)
        (H_bin_op : is_bin_op ch)
  : False.
  Proof.
    generalize dependent level.
    generalize dependent n'.
    generalize dependent n.
    induction_str_len str.
    { t. }
    { specialize (IHlen (drop 1 str)).
      specialize_by (rewrite drop_length; omega).
      intros ?????.
      rewrite paren_balanced_hiding'_recr, paren_balanced'_recr.
      unfold paren_balanced_hiding'_step, paren_balanced'_step.
      destruct n' as [|n'].
      { t. }
      { specialize (IHlen (pred n) n').
        t. } }
  Qed.
End helpers.


(* * FOL Reductions *)

From Undecidability.DiophantineConstraints Require Import H10C.
From Undecidability.DiophantineConstraints.Util Require Import H10UPC_facts.
From Undecidability.FOL Require Import Syntax.Facts Deduction.FragmentNDFacts Semantics.Tarski.FragmentSoundness Semantics.Tarski.FragmentFacts Syntax.BinSig Semantics.Kripke.FragmentCore  Semantics.Kripke.FragmentSoundness Semantics.Kripke.FragmentToTarski.
From Undecidability.FOL.Reductions Require Import H10UPC_to_FOL_minimal H10UPC_to_FOL_constructions.
From Undecidability.Shared Require Import Dec.
From Undecidability.Shared.Libs.PSL Require Import Numbers.
From Undecidability.Synthetic Require Import Definitions.
From Coq Require Import Arith Lia List.

(* ** Validity *)

(*
Idea: The relation (###) has the following properties:#
#
#
#n ~ p: n is left component of p#
#
#
#p ~ n: p is right component of p#
#
#
#p ~ p: the special relationship of H10UPC#
#
#
#n ~ m: n = m. Special case n=0, m=1: #
#
          The instance h10 of H10UPC is a yes-instance. #
#
          This is to facilitate Friedman translation#
#
*)

Set Default Goal Selector "!".

Notation Pr t t' := (@atom _ sig_binary _ _ tt (Vector.cons _ t _ (Vector.cons _ t' _ (Vector.nil _)))).

(* The validity reduction.
    We assume a generic falsity flag and a list h10 for which we build a formula.
 *)
Section validity.

  Context {ff : falsity_flag}.
  Context {h10 : list h10upc}.
  (* All are placed in a context where $0 is the 0 constant and $1, $2 are arbitrary but fixed *)
  (* We do a Friedman translation, where this represents falsity *)
  Definition wFalse t:= Pr $t $(S t).
  (* We use a stronger version of falsity, which is <-> False in our standart model, to ease writing eliminators *)
  Definition sFalse := ∀ ∀ Pr $0 $1.
  (* Friedman not *)
  Definition Not k t := k → wFalse t.
  (* $k is a number *)
  Definition N k := Pr $k $k.
  (* $k is a pair *)
  Definition P' k (_:nat):= (N k) → sFalse.
  (* If $k is a pair ($l,$r), where $l, $r are numbers, then c. *)
  Definition P k l r t c := P' k t → N l → N r → Pr $l $k → Pr $k $r → c.
  (* if the pairs $pl = ($a,$b), $pr = ($c,$d) are in relation, then t *)
  Definition rel pl pr a b c d tt t := P pl a b tt (P pr c d tt (Pr $pl $pr → t)).
  (* There exist (Friedman translated) pairs relating ($a,$b) to ($c,$d) *)
  Definition erel a b c d t := Not (∀ ∀ P 0 (2+a) (2+b) (2+t)
                                        (P 1 (2+c) (2+d) (2+t)
                                         (Pr $0 $1 → wFalse (2+t)))) t.
  (* Axiom 1 - zero is a number *)
  Definition F_zero := N 0.
  (* Axiom 2 - we can build (left) successors: for each pair (a,0) we have a pair (S a, 0) *)
  Definition F_succ_left := ∀ N 0 → Not (∀ ∀ ∀ P 2 3 4 5
                                                 (P 0 1 4 5
                                                  (Pr $2 $0 → wFalse 5))) 2.
  (* Axiom 3 - we can build right successors: (x,y)#(a,b) -> (x,S y)#(S a,S (b+y)) *)
  Definition F_succ_right := ∀ ∀ ∀ ∀ ∀ ∀ ∀ ∀         (*8 pairs *)
                             ∀ ∀ ∀ ∀ ∀ ∀ ∀           (* 0 x 1 y 2 a 3 b 4 c 5 y' 6 a' 15 zero-const*)
                             rel 7 8 0 1 2 3 16      (* (x,y) # (a,b) *)
                            (rel 9 10 3 1 4 3 16     (* (b,y) # (c,b) *)
                            (rel 11 12 1 15 5 15 16  (* (y,0) # (y',0) *)
                            (rel 13 14 2 15 6 15 16  (* (a,0) # (a'0) *)
                            (erel 0 5 6 4 16))))     (* (x,y') # (a',c) *).
  (* Generate n all quantifiers around i *)
  Fixpoint emplace_forall (n:nat) (i:form) :=
          match n with 0 => i
        | S n => ∀ (emplace_forall n i) end.
  (* Translate our formula, one relation at a time *)
  Definition translate_single (h:h10upc) nv :=
          match h with ((a,b),(c,d)) =>
            erel a b c d nv end.
  (* Translate an entire instance of H10UPC, assuming a proper context *)
  Fixpoint translate_rec (t:form) (nv:nat) (l:list h10upc) :=
          match l with nil => t
                     | l::lr => translate_single l nv → translate_rec t nv lr end.
  (* Actually translate the instance of H10UPC, by creating a proper context *)
  Definition translate_constraints (x:list h10upc) :=
    let nv := S (highest_var_list x)
    in (emplace_forall nv (translate_rec (Pr $(S nv) $(2+nv)) (S nv) x)) → Pr $1 $2.

  (* The actual reduction instance. If h10 is a yes-instance of H10UPC, this formula is valid and vice-versa
      The 3 variables are the zero constant and two arbitrary values which define the atomic predicate for
      Friedman translation. *)
  Definition F := ∀ ∀ ∀ F_zero → F_succ_left → F_succ_right → translate_constraints h10.

  Section Transport.
    (* The solution to cs *)
    Context (φ: nat -> nat).
    (* Proof that it actually is a solution *)
    Context (Hφ : forall c, In c h10 -> h10upc_sem φ c).
    Class model := {
      D : Type;
      I : interp D;
      rho : env D;
      zero : D; cr1 : D; cr2 : D;
      vF_zero : (zero .: cr2 .: cr1 .: rho) ⊨ F_zero;
      vF_succ_left : (zero .: cr2 .: cr1 .: rho) ⊨ F_succ_left;
      vF_succ_right : (zero .: cr2 .: cr1 .: rho) ⊨ F_succ_right;
    }.
    Context (valid_in : model).
    Instance II : interp D. exact I. Defined.
    Notation i_Pr i i' :=
      (@i_atom _ _ _ I tt (Vector.cons _ i _ (Vector.cons _ i' _ (Vector.nil _)))).

    Definition isNum (d:D) := i_Pr d d.
    Definition D_wFalse := i_Pr cr2 cr1.
    Definition D_Not k := k -> D_wFalse.
    Definition isPair' d := (isNum d) -> forall a b, i_Pr b a.
    Definition isPair (p l r:D) := isNum l /\ isNum r /\ isPair' p /\ i_Pr l p /\ i_Pr p r.

    Definition repr_nums f n := f 0 = zero /\ forall m:nat, m < n ->
              (exists (pl pr:D), isNum (f (S m)) /\ isPair pl (f m) zero /\ isPair pr (f (S m)) zero /\ i_Pr pl pr).

    Definition constr_nums (n:nat) : D_Not (forall f:nat -> D, repr_nums f n -> D_wFalse).
    Proof.
    induction n as [|n IH]; intros H.
    - apply (H (fun _ => zero)). split. 1: easy. intros m HH. exfalso. lia.
    - apply IH. intros f [IH0 IHfs].
      apply (@vF_succ_left valid_in (f n)); fold sat.
      + change (isNum (f n)). destruct n as [|n].
        * rewrite IH0. apply vF_zero.
        * destruct (IHfs n) as [pl [pr [HH _]]]. 1:lia. easy.
      + cbn. intros pl sn pr Ppl Nfn Nz Pfnl Plz Ppr Nsn Nz' Psnr Prz Pplpr.
        pose (fun m => if m =? S n then sn else f m) as f'.
        apply (H f'). split.
        * easy.
        * intros m Hm. destruct (Nat.eq_dec n m) as [Heq|Hneq].
          -- exists pl, pr. rewrite <- Heq.
             assert (f' (S n) = sn) as ->. 1: unfold f'; assert (S n =? S n = true) as ->.
             1:apply Nat.eqb_eq; lia. 1:easy.
             assert (f' n = f n) as  ->. 1:unfold f'; assert (n =? S n = false) as ->.
             1:apply Nat.eqb_neq; lia. 1:easy.
             now repeat split.
          -- destruct (IHfs m) as [pl' [pr' Hplplr']]. 1:lia.
             exists pl', pr'.
             assert (f' (S m) = f (S m)) as ->. 1: unfold f'; assert (S m =? S n = false) as ->.
             1:apply Nat.eqb_neq; lia. 1:easy.
             assert (f' m = f m) as  ->. 1:unfold f'; assert (m =? S n = false) as ->.
             1:apply Nat.eqb_neq; lia. 1:easy.
             easy.
    Qed.

    Lemma repr_num_isNum (f:nat -> D) (n:nat) (m:nat) : repr_nums f n -> m <= n -> isNum (f m).
    Proof.
    intros [Hzero Hrepr] Hnm.
    destruct m as [|m].
    - rewrite Hzero. apply vF_zero.
    - destruct (Hrepr m Hnm) as [pl [pr [H _]]]. apply H.
    Qed.

    Lemma constr_rel (a b c d : nat) (f:nat -> D) (n:nat) :
        repr_nums f n
     -> b <= n -> a <= n -> c <= n -> d <= n
     -> h10upc_sem_direct ((a,b),(c,d))
     -> D_Not (forall pl pr, isPair pl (f a) (f b)
                         -> isPair pr (f c) (f d)
                         -> i_Pr pl pr -> D_wFalse).
    Proof.
    intros Hreprnums Hbn.
    pose proof Hreprnums as Hrepr_nums.
    destruct Hreprnums as [Zrepr Hrepr].
    induction b as [|b IH] in a,c,d|-*; intros Han Hcn Hdn Habcd.
    - cbn in Habcd. assert (c = S a /\ d = 0) as [Hc Hd]. 1:lia.
      rewrite Hc, Hd, !Zrepr in *.
      destruct (Hrepr a) as [pl [pr [Ha [Hpl Hpr]]]]. 1:lia.
      intros Hcr. now apply (Hcr pl pr).
    - destruct (@h10upc_inv a b c d Habcd) as [c' [d' [Habcd' [Hc' Hd']]]].
      rewrite <- Hc', <- Hd' in *.
      assert (h10upc_sem_direct ((d',b),(d'+b+1,d'))) as Hdb.
      + split. 1: now lia. apply Habcd'.
      + intros Hcr.
        apply (IH a c' d'). 1-3: lia. 1: easy.
        intros pab pc'd' Hpab Hpc'd' Hpabc'd'.
        apply (IH d' (d'+b+1) d'). 1-3: lia. 1: easy.
        intros pd'b pd'bd' Hpd'b Hpd'bd' Hpd'bd'bd'.
        destruct (Hrepr b) as [pb [pb' [Nsb [Hpb [Hpb' Hpbpb']]]]]. 1:lia.
        destruct (Hrepr c') as [pc [pc' [Nsc [Hpc [Hpc' Hpcpc']]]]]. 1:lia.
        pose proof (@vF_succ_right valid_in pc' pc pb' pb pd'bd' pd'b pc'd' pab
                    (f (S c')) (f (S b)) (f(d' + b + 1)) (f d') (f c') (f b) (f a)) as sr.
        apply sr; cbn; fold isNum.
        1-5: now destruct Hpab as [H'l [H'r [H'p [H'pl H'pr]]]].
        1-5: now destruct Hpc'd' as [H'l [H'r [H'p [H'pl H'pr]]]].
        1: easy.
        1-5: now destruct Hpd'b as [H'l [H'r [H'p [H'pl H'pr]]]].
        1-5: now destruct Hpd'bd' as [H'l [H'r [H'p [H'pl H'pr]]]].
        1: easy.
        1-5: now destruct Hpb as [H'l [H'r [H'p [H'pl H'pr]]]].
        1-5: now destruct Hpb' as [H'l [H'r [H'p [H'pl H'pr]]]].
        1: easy.
        1-5: now destruct Hpc as [H'l [H'r [H'p [H'pl H'pr]]]].
        1-5: now destruct Hpc' as [H'l [H'r [H'p [H'pl H'pr]]]].
        1: easy.
        intros pScsum paSb HpaSb H'a H'Sb HlpaSb HrpaSb HpScsum H'Sc H'dsum HlpScsum HrpScsum Hprel.
        apply (Hcr paSb pScsum). all: now repeat split.
    Qed.

    Lemma prove_emplace_forall (n:nat) (i:form) (r:env D) :
    r ⊨ emplace_forall n i
    -> forall f, (fun v => if v <? n then f v else r (v-n)) ⊨ i.
    Proof.
    induction n as [|n IH] in r|-*.
    - cbn. intros H f. apply (sat_ext I (rho := r) (xi:=fun v => r(v-0)) i).
      + intros x. now rewrite Nat.sub_0_r.
      + easy.
    - intros H f. cbn. cbn in H. specialize (H (f n)). specialize (IH (f n .: r) H f).
      eapply (sat_ext I (xi := (fun v : nat => if v <? n then f v else (f n .: r) (v - n))) i).
      + intros x. destruct (Nat.eq_dec x n) as [Hxn|Hnxn].
        * destruct (Nat.leb_le x n) as [_ Hr]. specialize (Hr ltac:(lia)). rewrite Hr.
          destruct (Nat.ltb_ge x n) as [_ Hr2]. specialize (Hr2 ltac:(lia)). rewrite Hr2.
          assert (x-n=0) as Hxn0. 1:lia. rewrite Hxn0. cbn. now f_equal.
        * destruct (x <? n) as [|] eqn:Hxn.
          -- apply (Nat.ltb_lt) in Hxn. assert (x <=? n = true) as Hxn2. 1: apply Nat.leb_le; lia.
             rewrite Hxn2. easy.
          -- apply (Nat.ltb_ge) in Hxn. assert (x <=? n = Datatypes.false) as Hxn2. 1: apply Nat.leb_gt; lia.
             rewrite Hxn2. assert (x-n = S(x-S n))  as Hxn3. 1:lia. rewrite Hxn3. cbn. easy.
      + easy.
    Qed.

    Lemma prove_constraints : (zero .: cr2 .: cr1 .: rho) ⊨ translate_constraints h10.
    Proof using φ Hφ.
    pose (S (highest_var_list h10)) as h10vars.
    unfold translate_constraints. fold h10vars.
    pose (highest_num φ h10vars) as h10max.
    pose (@constr_nums h10max) as Hcons.
    intros HH. cbn.
    pose proof (prove_emplace_forall HH) as H. clear HH.
    apply Hcons. intros f Hrepr. specialize (H (fun t => f (φ t))).
    pose ((fun v : nat => if v <? h10vars then (fun t : nat => f (φ t)) v else (zero .: cr2 .: cr1 .: rho) (v - h10vars))) as newenv.
    assert (newenv (S h10vars) = cr2) as Hne1.
    1: {unfold newenv. assert (S h10vars <? h10vars = false) as ->. 1: apply Nat.leb_gt; now lia.
        assert (S h10vars - h10vars = 1) as ->. 1:now lia. easy. }
    assert (newenv (S (S h10vars)) = cr1) as Hne2.
    1: {unfold newenv. assert (S (S h10vars) <? h10vars = false) as ->. 1: apply Nat.leb_gt;lia.
        assert (S (S h10vars) - h10vars = 2) as ->. 1:now lia. easy. }
    fold newenv in H.
    assert (forall c:h10upc, In c h10 -> newenv ⊨ translate_single c (S h10vars)) as Hmain.
    - intros [[a b][c d]] Hin.
      pose (@highest_var_list_descr h10 ((a,b),(c,d)) Hin) as Habcdmax.
      cbn in Habcdmax. intros HH.
      cbn. rewrite Hne1, Hne2.
      apply (@constr_rel (φ a) (φ b) (φ c) (φ d) f h10max). 1:easy.
      1-4: eapply highest_num_descr; lia.
      1: apply (@Hφ ((a,b),(c,d)) Hin).
      intros pab pcd [Ha [Hb [Hab [Haab Hbab]]]] [Hc [Hd [Hcd [Hccd Hdcd]]]] Hpp.
      assert (forall k:nat, k < h10vars -> newenv k = f (φ k)) as Hvars.
      1:{ unfold newenv, h10vars. intros k Hk. destruct (Nat.ltb_lt k h10vars) as [_ Hr].
          fold h10vars. now rewrite Hr. }
      cbn in HH. rewrite Hne1, Hne2, (Hvars a), (Hvars b), (Hvars c), (Hvars d) in HH.
      2-5: unfold h10vars;lia.
      now apply (@HH pcd pab).
    - induction h10 as [|hx hr IH] in H,Hmain|-*.
      + cbn in H. rewrite Hne1,Hne2 in H. apply H.
      + apply IH.
        * cbn in H. apply H. apply Hmain. now left.
        * intros c Hhr. apply Hmain. now right.
    Qed.
  End Transport.

  Lemma transport_direct : H10UPC_SAT h10 -> valid F.
  Proof.
    intros [φ Hφ].
    intros D I rho.
    intros cr1 cr2 zero.
    intros H_zero H_succ_left H_succ_right.
    eapply (@prove_constraints φ Hφ (Build_model H_zero H_succ_left H_succ_right)).
  Qed.
End validity.

Theorem directValidReduction : reduces (H10UPC_SAT) (@valid sig_empty sig_binary falsity_off).
Proof.
exists (fun l => @F falsity_off l). split.
* apply transport_direct.
* apply inverseTransport.
Qed.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  Ifnot, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export csubst2.
Require Export continuity_defs.
Require Export list.  (* Why?? *)

Lemma alpha_eq_bterm_refl {o} :
  forall (b : @BTerm o),
    alpha_eq_bterm b b.
Proof.
  destruct b as [l t].
  apply alpha_eq_bterm_congr; eauto 3 with slow.
Qed.
Hint Resolve alpha_eq_bterm_refl : slow.

Lemma alphaeqbt_vs_nil_refl {o} :
  forall (b : @BTerm o),
    alphaeqbt_vs [] b b.
Proof.
  introv.
  apply alphaeqbt_eq; eauto 3 with slow.
Qed.
Hint Resolve alphaeqbt_vs_nil_refl : slow.

Ltac gen_newvar :=
  match goal with
    | [ |- context[newvarlst ?l] ] => remember (newvarlst l)
    | [ |- context[newvar ?x] ] => remember (newvar x)
  end.

Lemma oneswapvar_eq1 :
  forall a b, oneswapvar a b a = b.
Proof.
  introv.
  unfold oneswapvar; boolvar; sp.
Qed.

Lemma oneswapvar_neq :
  forall a b v, v <> a -> v <> b -> oneswapvar a b v = v.
Proof.
  introv ni1 ni2.
  unfold oneswapvar; boolvar; sp.
Qed.

Lemma newvar_prop2 {p} :
  forall v (t : @NTerm p), LIn v (free_vars t) -> newvar t <> v.
Proof.
  introv i e; subst.
  apply newvar_prop in i; sp.
Qed.
Hint Resolve newvar_prop2 : slow.

Definition agree_upto_b_type {o} vi (b f g : @NTerm o) : NTerm :=
  mk_isect
    (mk_set
       mk_int
       vi
       (mk_member (absolute_value (mk_var vi)) (mk_natk_aux vi b)))
    vi
    (mk_equality
       (mk_apply f (mk_var vi))
       (mk_apply g (mk_var vi))
       mk_int).

Definition continuous_type_aux_aux {o} vb vg vi vf (F f : @NTerm o) :=
  mk_product
    mk_tnat
    vb
    (mk_isect
       int2int
       vg
       (mk_isect
          (agree_upto_b_type
             vi
             (mk_var vb)
             f
             (mk_var vg))
          vf
          (mk_equality
             (mk_apply F f)
             (mk_apply F (mk_var vg))
             mk_int))).

Lemma alphaeq_continuous_type_aux_aux {o} :
  forall vb1 vb2 vg1 vg2 vi1 vi2 vf1 vf2 (F f : @NTerm o),
    closed F
    -> closed f

    -> vi1 <> vb1
    -> vi1 <> vg1
    -> vg1 <> vb1
    -> vf1 <> vg1

    -> vi2 <> vb2
    -> vi2 <> vg2
    -> vg2 <> vb2
    -> vf2 <> vg2

    -> alphaeq
         (continuous_type_aux_aux vb1 vg1 vi1 vf1 F f)
         (continuous_type_aux_aux vb2 vg2 vi2 vf2 F f).
Proof.
  introv clF clf;
  introv ni1 ni2 ni3 ni4 ni5 ni6 ni7 ni8.
  constructor; simpl; auto.
  introv j.
  destruct n;[|destruct n]; try (complete cpx); unfold selectbt; simpl.
  { apply alphaeqbt_eq; auto. }
  pose proof (ex_fresh_var ([vb1,vb2,vg1,vg2,vi1,vi2,vf1,vf2,
                             @newvar o mk_int,
                             @newvar o (mk_less_than (mk_var vi1) (mk_var vb1)),
                             @newvar o (mk_less_than (mk_var vi2) (mk_var vb2))]
                              ++ allvars f
                              ++ allvars F)) as fv; exrepnd.
  allsimpl; allrw not_over_or; repnd; GC.
  apply (aeqbt _ [v]); try (complete (simpl; auto)).
  { apply disjoint_singleton_l; intro k; allsimpl; repndors; subst; tcsp.
    allrw app_nil_r; allrw in_app_iff; allsimpl; repndors; subst; tcsp.
    { allrw in_app_iff; allsimpl; repndors; tcsp. }
    { allrw in_app_iff; allsimpl; repndors; tcsp.
      allrw in_app_iff; allsimpl; repndors; tcsp. }
  }

  simpl.
  allrw oneswapvar_eq1.
  allrw (oneswapvar_neq vb1 v vi1); auto;[].
  allrw (oneswapvar_neq vb1 v vg1); auto;[].
  allrw (oneswapvar_neq vb2 v vi2); auto;[].
  allrw (oneswapvar_neq vb2 v vg2); auto;[].
  repeat (rw (oneswapvar_neq vb1 v (newvar (mk_less_than (mk_var vi1) (@mk_var o vb1))));
          auto; try (apply newvar_prop2; simpl; tcsp);[]);[].
  repeat (rw (oneswapvar_neq vb2 v (newvar (mk_less_than (mk_var vi2) (@mk_var o vb2))));
          auto; try (apply newvar_prop2; simpl; tcsp);[]);[].

  constructor; simpl; tcsp; fold_terms.
  introv i.
  destruct n;[|destruct n]; try (complete cpx); unfold selectbt; simpl;
  eauto 3 with slow;[|].

  { apply alphaeqbt_eq.
    apply alphaeqbt_nilv2.
    apply alphaeq_eq.
    constructor; simpl; auto.
    introv k.
    destruct n;[|destruct n]; cpx; unfold selectbt; simpl.
    { apply alphaeqbt_eq; auto. }
    pose proof (ex_fresh_var ([oneswapvar vb1 v (newvar (@mk_int o)),
                               oneswapvar vb2 v (newvar (@mk_int o))])) as fv; exrepnd.
    apply (aeqbt _ [v0]); simpl; auto.
    { apply disjoint_singleton_l; intro k; allsimpl.
      allrw not_over_or; repndors; tcsp. }
    { apply alphaeq_refl. }
  }

  { pose proof (ex_fresh_var ([v, vg1, vi1, vg2, vi2, vb1, vf1, vb2, vf2,
                               oneswapvar vb1 v vf1,
                               oneswapvar vb2 v vf2,
                               oneswapvar vb1 v nvarx,
                               oneswapvar vb2 v nvarx,
                               newvar (mk_less_than (mk_var vi1) (@mk_var o vb1)),
                               newvar (mk_less_than (mk_var vi2) (@mk_var o vb2))
                              ]
                                ++ allvars (cswap [(vb1, v)] f)
                                ++ allvars (cswap [(vb1, v)] F)
                                ++ allvars (cswap [(vb2, v)] f)
                                ++ allvars (cswap [(vb2, v)] F)
                                ++ allvars f
                                ++ allvars F
                             )
               ) as fv; exrepnd.
    allsimpl; allrw not_over_or; repnd; GC.
    apply (aeqbt _ [v0]); allsimpl; tcsp.

    { apply disjoint_singleton_l; intro k; allsimpl; repndors; tcsp.
      allrw app_nil_r; allrw in_app_iff; allsimpl; allrw not_over_or;
      allrw in_app_iff; allsimpl; repndors; tcsp.
      allrw in_app_iff; allsimpl; repndors; tcsp. }

    allrw oneswapvar_eq1.
    allrw (oneswapvar_neq vg1 v0 vi1); auto;[].
    allrw (oneswapvar_neq vg1 v0 v); auto;[].
    allrw (oneswapvar_neq vg1 v0 vf1); auto;[].
    allrw (oneswapvar_neq vg2 v0 vi2); auto;[].
    allrw (oneswapvar_neq vg2 v0 v); auto;[].
    allrw (oneswapvar_neq vg2 v0 vf2); auto;[].

    constructor; allsimpl; tcsp.
    introv i.
    destruct n;[|destruct n]; try (complete cpx); unfold selectbt; simpl;
    fold_terms;[|].

    { apply alphaeqbt_eq.
      apply alphaeqbt_nilv2.
      apply alphaeq_eq.
      constructor; simpl; auto.
      introv k.
      destruct n;[|destruct n]; cpx; unfold selectbt; simpl;[|].

      { apply alphaeqbt_eq.
        apply alphaeqbt_nilv2.
        apply alphaeq_eq.
        constructor; simpl; auto.
        introv k.
        destruct n;[|destruct n]; cpx; unfold selectbt; simpl.
        { apply alphaeqbt_eq; auto. }

        pose proof (ex_fresh_var ([vi1, vi2, v,
                                   oneswapvar vg1 v0 (oneswapvar vb1 v nvarx),
                                   oneswapvar vg1 v0 (newvar (mk_less_than (mk_var vi1) (@mk_var o vb1))),
                                   oneswapvar vg2 v0 (oneswapvar vb2 v nvarx),
                                   oneswapvar vg2 v0 (newvar (mk_less_than (mk_var vi2) (@mk_var o vb2)))
                                  ]
                                 )
                   ) as fv; exrepnd.
        allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.
        apply (aeqbt _ [v1]); simpl; auto.
        { apply disjoint_singleton_l; intro k; allsimpl; repndors; tcsp. }

        allrw oneswapvar_eq1.
        allrw (oneswapvar_neq vi1 v1 v); auto;[].
        allrw (oneswapvar_neq vi2 v1 v); auto;[].

        rw (oneswapvar_neq vi1 v1
                           (oneswapvar vg1 v0
                                       (newvar (mk_less_than (mk_var vi1) (@mk_var o vb1)))));
          tcsp;
          [|complete (unfold oneswapvar; boolvar; tcsp; apply newvar_prop2; simpl; sp)].

        rw (oneswapvar_neq vi2 v1
                           (oneswapvar vg2 v0
                                       (newvar (mk_less_than (mk_var vi2) (@mk_var o vb2)))));
          tcsp;
          [|complete (unfold oneswapvar; boolvar; tcsp; apply newvar_prop2; simpl; sp)].

        fold_terms.
        constructor; simpl; auto.
        introv k.
        destruct n;[|destruct n;[|destruct n] ]; cpx; unfold selectbt; simpl;
        eauto 3 with slow;[].

        (*
        { apply alphaeqbt_eq.
          apply alphaeqbt_nilv2.
          apply alphaeq_eq.
          constructor; simpl; auto.
          introv p.
          destruct n;[|destruct n;[|destruct n;[|destruct n] ] ]; cpx; unfold selectbt; simpl;
          eauto 3 with slow;[].

          { apply alphaeqbt_eq.
            apply alphaeqbt_nilv2.
            apply alpha_eq_refl.
            apply alphaeq_eq.
            allrw oneswapvar_eq1; tcsp. }

          { apply alphaeqbt_eq; auto. }

          { apply alphaeqbt_eq.
            apply alphaeqbt_nilv2.
            apply alphaeq_eq.
            constructor; simpl; auto.
            introv p.
            destruct n; cpx; unfold selectbt; simpl; tcsp.
            apply alphaeqbt_eq.
            apply alphaeqbt_nilv2.
            apply alphaeq_eq.
            allrw oneswapvar_eq1; tcsp. }

          { apply alphaeqbt_eq.
            apply alphaeqbt_nilv2.
            apply alphaeq_eq.
            allrw oneswapvar_eq1; tcsp. }
        }

        { apply alphaeqbt_eq.
          apply alphaeqbt_nilv2.
          apply alphaeq_eq.
          constructor; simpl; auto.
          introv p.
          destruct n;[|destruct n;[|destruct n;[|destruct n] ] ]; cpx; unfold selectbt; simpl.

          { apply alphaeqbt_eq.
            apply alphaeqbt_nilv2.
            apply alphaeq_eq.
            allrw oneswapvar_eq1; tcsp. }

          { apply alphaeqbt_eq; auto. }

          { apply alphaeqbt_eq.
            apply alphaeqbt_nilv2.
            apply alphaeq_eq.
            constructor; simpl; auto.
            introv p.
            destruct n; cpx; unfold selectbt; simpl; tcsp.
            apply alphaeqbt_eq.
            apply alphaeqbt_nilv2.
            apply alphaeq_eq.
            allrw oneswapvar_eq1; tcsp. }

          { apply alphaeqbt_eq.
            apply alphaeqbt_nilv2.
            apply alphaeq_eq.
            allrw oneswapvar_eq1; tcsp. }
        }
*)

        { apply alphaeqbt_eq.
          apply alphaeqbt_nilv2.
          apply alphaeq_eq.
          constructor; simpl; auto.
          fold_terms.
          introv p.
          destruct n;[|destruct n]; cpx; unfold selectbt; simpl; tcsp; eauto 3 with slow;[].

          (*
          { apply alphaeqbt_eq; auto. }
*)

          { pose proof (ex_fresh_var ([ v1, v,
                                        oneswapvar vi1 v1 (oneswapvar vg1 v0 (oneswapvar vb1 v nvarx)),
                                        oneswapvar vg1 v0 (newvar (mk_less_than (mk_var vi1) (@mk_var o vb1))),
                                        oneswapvar vi2 v1 (oneswapvar vg2 v0 (oneswapvar vb2 v nvarx)),
                                        oneswapvar vg2 v0 (newvar (mk_less_than (mk_var vi2) (@mk_var o vb2)))
                                      ]
                                     )
                       ) as fv; exrepnd.
            allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.
            apply (aeqbt _ [v2]); simpl; auto.
            { apply disjoint_singleton_l; intro k; allsimpl; repndors; tcsp. }

            fold_terms;[].
            constructor; simpl; auto.

            allrw oneswapvar_eq1.
            allrw (oneswapvar_neq v1 v2 v); auto;[].

            introv p.
            destruct n;[|destruct n]; cpx; unfold selectbt; simpl; tcsp; eauto 3 with slow;[|].

            { apply alphaeqbt_eq.
              apply alphaeqbt_nilv2.
              apply alphaeq_eq.
              constructor; simpl; auto.
              introv q.
              destruct n;[|destruct n]; cpx; unfold selectbt; simpl; tcsp.

              { apply alphaeqbt_eq.
                apply alphaeqbt_nilv2.
                apply alphaeq_eq.
                constructor; simpl; auto.
                introv r.
                destruct n;[|destruct n;[|destruct n;[|destruct n] ] ]; cpx; unfold selectbt; simpl; tcsp;
                eauto 3 with slow;[].

                (*
                { apply alphaeqbt_eq.
                  apply alphaeqbt_nilv2.
                  apply alphaeq_eq.
                  allrw oneswapvar_eq1; tcsp. }

                { apply alphaeqbt_eq; auto. }

                { apply alphaeqbt_eq; auto. }
*)

                { apply alphaeqbt_eq.
                  apply alphaeqbt_nilv2.
                  apply alphaeq_eq.
                  constructor; simpl; auto.
                  introv r.
                  destruct n;[|destruct n]; cpx; unfold selectbt; simpl; tcsp;
                  eauto 3 with slow;[].

                  (*
                  { apply alphaeqbt_eq; auto. }
*)

                  { apply alphaeqbt_eq.
                    apply alphaeqbt_nilv2.
                    apply alphaeq_eq.
                    constructor; simpl; auto.
                    introv r.
                    destruct n; cpx; unfold selectbt; simpl; tcsp.

                    { apply alphaeqbt_eq.
                      apply alphaeqbt_nilv2.
                      apply alphaeq_eq.
                      constructor; simpl; auto.
                      introv s.
                      destruct n; cpx; unfold selectbt; simpl; tcsp.

                      { pose proof (ex_fresh_var ([ oneswapvar v1 v2 (oneswapvar vi1 v1 (oneswapvar vg1 v0 (oneswapvar vb1 v nvarx))),
                                                    oneswapvar v1 v2 (oneswapvar vi2 v1 (oneswapvar vg2 v0 (oneswapvar vb2 v nvarx)))
                                                  ]
                                                 )
                                   ) as fv; exrepnd.
                        allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.
                        apply (aeqbt _ [v3]); simpl; auto.
                        { apply disjoint_singleton_l; intro k; allsimpl; repndors; tcsp. }
                        fold_terms;[].

                        allrw oneswapvar_eq1; tcsp.
                      }
                    }
                  }
                }
              }

              { pose proof (ex_fresh_var ([ oneswapvar v1 v2 (oneswapvar vi1 v1 (oneswapvar vg1 v0 (oneswapvar vb1 v (newvar (@mk_void o))))),
                                            oneswapvar v1 v2 (oneswapvar vi2 v1 (oneswapvar vg2 v0 (oneswapvar vb2 v (newvar (@mk_void o)))))
                                          ]
                                         )
                           ) as fv; exrepnd.
                allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.
                apply (aeqbt _ [v3]); simpl; auto.
                { apply disjoint_singleton_l; intro k; allsimpl; repndors; tcsp. }
                fold_terms;[].

                constructor; simpl; auto.
                introv r.
                destruct n;[|destruct n]; cpx; unfold selectbt; simpl; tcsp;
                eauto 3 with slow;[].

                (*
                { apply alphaeqbt_eq; auto. }
*)

                { apply alphaeqbt_eq.
                  apply alphaeqbt_nilv2.
                  apply alphaeq_eq.
                  constructor; simpl; auto.
                  introv r.
                  destruct n; cpx; unfold selectbt; simpl; tcsp;[].

                  apply alphaeqbt_eq.
                  apply alphaeqbt_nilv2.
                  apply alphaeq_eq.
                  constructor; simpl; auto.
                  introv q.
                  destruct n; cpx; unfold selectbt; simpl; tcsp;[].

                  pose proof (ex_fresh_var ([ oneswapvar
                                                (oneswapvar v1 v2 (oneswapvar vi1 v1 (oneswapvar vg1 v0 (oneswapvar vb1 v (newvar (@mk_void o)))))) v3
                                                (oneswapvar v1 v2 (oneswapvar vi1 v1 (oneswapvar vg1 v0 (oneswapvar vb1 v nvarx)))),
                                              oneswapvar
                                                (oneswapvar v1 v2 (oneswapvar vi2 v1 (oneswapvar vg2 v0 (oneswapvar vb2 v (newvar (@mk_void o)))))) v3
                                                (oneswapvar v1 v2 (oneswapvar vi2 v1 (oneswapvar vg2 v0 (oneswapvar vb2 v nvarx))))
                                            ]
                                           )
                             ) as fv; exrepnd.
                  allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.
                  apply (aeqbt _ [v4]); simpl; auto.
                  { apply disjoint_singleton_l; intro k; allsimpl; repndors; tcsp. }
                  fold_terms;[].
                  allrw oneswapvar_eq1; tcsp.
                }
              }
            }

            { pose proof (ex_fresh_var ([ v, v2,
                                          oneswapvar v1 v2 (oneswapvar vg1 v0 (newvar (mk_less_than (mk_var vi1) (@mk_var o vb1)))),
                                          oneswapvar v1 v2 (oneswapvar vg2 v0 (newvar (mk_less_than (mk_var vi2) (@mk_var o vb2)))),
                                          oneswapvar v1 v2 (oneswapvar vi1 v1 (oneswapvar vg1 v0 (oneswapvar vb1 v nvarx))),
                                          oneswapvar v1 v2 (oneswapvar vi2 v1 (oneswapvar vg2 v0 (oneswapvar vb2 v nvarx)))
                                        ]
                                       )
                         ) as fv; exrepnd.
              allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.
              apply (aeqbt _ [v3]); simpl; auto.
              { apply disjoint_singleton_l; intro k; allsimpl; repndors; tcsp. }
              fold_terms;[].

              rw (oneswapvar_neq v1 v2
                                 (oneswapvar vg1 v0
                                             (newvar (mk_less_than (mk_var vi1) (@mk_var o vb1)))));
                tcsp;[].

              rw (oneswapvar_neq v1 v2
                                 (oneswapvar vg2 v0
                                             (newvar (mk_less_than (mk_var vi2) (@mk_var o vb2)))));
                tcsp;[].

              constructor; simpl; auto.
              introv r.
              destruct n;[|destruct n;[|destruct n;[|destruct n] ] ]; cpx; unfold selectbt; simpl; tcsp;
              eauto 3 with slow;[| |].

              { apply alphaeqbt_eq.
                apply alphaeqbt_nilv2.
                apply alphaeq_eq.
                allrw oneswapvar_eq1; tcsp.

                rw (oneswapvar_neq
                      (oneswapvar vg1 v0
                                  (newvar (mk_less_than (mk_var vi1) (@mk_var o vb1))))
                      v3 v2);
                    tcsp;[].

                rw (oneswapvar_neq
                      (oneswapvar vg2 v0
                                  (newvar (mk_less_than (mk_var vi2) (@mk_var o vb2))))
                      v3 v2);
                    tcsp; eauto 3 with slow.
              }

              { apply alphaeqbt_eq.
                apply alphaeqbt_nilv2.
                apply alphaeq_eq.
                unfold oneswapvar; boolvar; eauto 3 with slow; sp.
              }

              (*
              { apply alphaeqbt_eq; auto. }
*)

              { apply alphaeqbt_eq.
                apply alphaeqbt_nilv2.
                apply alphaeq_eq.
                constructor; simpl; auto.
                introv r.
                destruct n;[|destruct n]; cpx; unfold selectbt; simpl; tcsp;
                eauto 3 with slow;[].

                (*
                { apply alphaeqbt_eq; auto. }
*)

                { apply alphaeqbt_eq.
                  apply alphaeqbt_nilv2.
                  apply alphaeq_eq.
                  constructor; simpl; auto.
                  introv r.
                  destruct n; cpx; unfold selectbt; simpl; tcsp.

                  apply alphaeqbt_eq.
                  apply alphaeqbt_nilv2.
                  apply alphaeq_eq.
                  constructor; simpl; auto.
                  introv q.
                  destruct n; cpx; unfold selectbt; simpl; tcsp.

                  pose proof (ex_fresh_var ([ oneswapvar
                                                (oneswapvar vg1 v0 (newvar (mk_less_than (mk_var vi1) (@mk_var o vb1)))) v3
                                                (oneswapvar v1 v2 (oneswapvar vi1 v1 (oneswapvar vg1 v0 (oneswapvar vb1 v nvarx)))),
                                              oneswapvar
                                                (oneswapvar vg2 v0 (newvar (mk_less_than (mk_var vi2) (@mk_var o vb2)))) v3
                                                (oneswapvar v1 v2 (oneswapvar vi2 v1 (oneswapvar vg2 v0 (oneswapvar vb2 v nvarx))))
                                            ]
                                           )
                             ) as fv; exrepnd.
                  allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.
                  apply (aeqbt _ [v4]); simpl; auto.
                  { apply disjoint_singleton_l; intro k; allsimpl; repndors; tcsp. }
                  fold_terms;[].
                  allrw oneswapvar_eq1; tcsp.
                }
              }
            }
          }
        }
      }

      { pose proof (ex_fresh_var ([ vi1, vi2, v0, vg1, vb1, v, vg2, vb2
                                  ]
                                    ++ allvars (cswap [(vg1, v0)] (cswap [(vb1, v)] f))
                                    ++ allvars (cswap [(vg2, v0)] (cswap [(vb2, v)] f))
                                    ++ allvars f
                                 )
                   ) as fv; exrepnd.
        allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.
        apply (aeqbt _ [v1]); simpl; auto.
        { apply disjoint_singleton_l; intro k; allsimpl;
          allrw in_app_iff; allsimpl;
          repndors; tcsp. }
        fold_terms;[].
        allrw oneswapvar_eq1; tcsp.
        constructor; simpl; auto.

        introv k.
        destruct n;[|destruct n;[|destruct n ] ]; cpx; unfold selectbt; simpl; tcsp;
        eauto 3 with slow;[|].

        { apply alphaeqbt_eq.
          apply alphaeqbt_nilv2.
          apply alphaeq_eq.

          constructor; simpl; auto.
          introv p.
          destruct n;[|destruct n ]; cpx; unfold selectbt; simpl; tcsp;
          eauto 3 with slow;[].

          { apply alphaeqbt_eq.
            apply alphaeqbt_nilv2.
            apply alphaeq_eq.
            allrw @cswap_cswap; allsimpl.
            apply (alphaeq_trans _ f).
            { apply alphaeq_cswap_cl2; simpl; repeat (rw disjoint_cons_l);
              simpl; allrw not_over_or; dands; try (rw clf); tcsp.
              repeat (rw no_repeats_cons); dands; simpl; tcsp. }
            { apply alphaeq_sym.
              apply alphaeq_cswap_cl2; simpl; repeat (rw disjoint_cons_l);
              simpl; allrw not_over_or; dands; try (rw clf); tcsp.
              repeat (rw no_repeats_cons); dands; simpl; tcsp. }
          }

          (*
          { apply alphaeqbt_eq; apply alphaeqbt_nilv2; auto. }
*)
        }

        { rw (oneswapvar_neq vi1 v1 v0); auto.
          rw (oneswapvar_neq vi2 v1 v0); auto.
          apply alphaeqbt_eq; apply alphaeqbt_nilv2; auto. }

        (*
        { apply alphaeqbt_eq; apply alphaeqbt_nilv2; auto. }
*)
      }
    }

    { rw (oneswapvar_neq vg1 v0 (oneswapvar vb1 v vf1));
      auto; [|unfold oneswapvar; boolvar; complete sp].

      rw (oneswapvar_neq vg2 v0 (oneswapvar vb2 v vf2));
      auto; [|unfold oneswapvar; boolvar; complete sp].

      pose proof (ex_fresh_var ([ v0, vg1, vb1, vg2, vb2,
                                  oneswapvar vb1 v vf1,
                                  oneswapvar vb2 v vf2
                                ]
                                  ++ allvars (cswap [(vg1, v0)] (cswap [(vb1, v)] F))
                                  ++ allvars (cswap [(vg1, v0)] (cswap [(vb1, v)] f))
                                  ++ allvars (cswap [(vg2, v0)] (cswap [(vb2, v)] F))
                                  ++ allvars (cswap [(vg2, v0)] (cswap [(vb2, v)] f))
                                  ++ allvars F
                               )
                 ) as fv; exrepnd.
      allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.
      apply (aeqbt _ [v1]); simpl; auto.
      { apply disjoint_singleton_l; intro k; allsimpl;
        allrw in_app_iff; allsimpl; repndors; tcsp. }
      fold_terms;[].
      allrw oneswapvar_eq1; tcsp.
      constructor; simpl; auto.

      introv p.
      destruct n;[|destruct n;[|destruct n] ]; cpx; unfold selectbt; simpl; tcsp;
      eauto 3 with slow;[|].

      { apply alphaeqbt_eq.
        apply alphaeqbt_nilv2.
        apply alphaeq_eq.

        constructor; simpl; auto.

        introv q.
        destruct n;[|destruct n ]; cpx; unfold selectbt; simpl; tcsp;
        eauto 3 with slow;[|].

        { apply alphaeqbt_eq.
          apply alphaeqbt_nilv2.
          apply alphaeq_eq.

          apply (alphaeq_trans _ F).

          { pose proof (alphaeq_cswap_cl2 F [(vb1,v)]) as h1.
            repeat (autodimp h1 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp;[].

            pose proof (alphaeq_cswap_cl2 (cswap [(vb1,v)] F) [(vg1,v0)]) as h2.
            repeat (autodimp h2 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp.
            { apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1; rw clF; simpl; tcsp. }

            pose proof (alphaeq_cswap_cl2 (cswap [(vg1,v0)] (cswap [(vb1,v)] F)) [(oneswapvar vb1 v vf1, v1)]) as h3.
            repeat (autodimp h3 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp.
            { apply alphaeq_eq in h2; apply alphaeq_preserves_free_vars in h2; rw h2.
              apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1.
              rw clF; simpl; tcsp. }
            eauto with slow. }

          { pose proof (alphaeq_cswap_cl2 F [(vb2,v)]) as h1.
            repeat (autodimp h1 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp;[].

            pose proof (alphaeq_cswap_cl2 (cswap [(vb2,v)] F) [(vg2,v0)]) as h2.
            repeat (autodimp h2 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp.
            { apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1; rw clF; simpl; tcsp. }

            pose proof (alphaeq_cswap_cl2 (cswap [(vg2,v0)] (cswap [(vb2,v)] F)) [(oneswapvar vb2 v vf2, v1)]) as h3.
            repeat (autodimp h3 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp.
            { apply alphaeq_eq in h2; apply alphaeq_preserves_free_vars in h2; rw h2.
              apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1.
              rw clF; simpl; tcsp. }
            eauto with slow. }
        }

        { apply alphaeqbt_eq.
          apply alphaeqbt_nilv2.
          apply alphaeq_eq.

          apply (alphaeq_trans _ f).

          { pose proof (alphaeq_cswap_cl2 f [(vb1,v)]) as h1.
            repeat (autodimp h1 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clf); tcsp;[].

            pose proof (alphaeq_cswap_cl2 (cswap [(vb1,v)] f) [(vg1,v0)]) as h2.
            repeat (autodimp h2 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clf); tcsp.
            { apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1; rw clf; simpl; tcsp. }

            pose proof (alphaeq_cswap_cl2 (cswap [(vg1,v0)] (cswap [(vb1,v)] f)) [(oneswapvar vb1 v vf1, v1)]) as h3.
            repeat (autodimp h3 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clf); tcsp.
            { apply alphaeq_eq in h2; apply alphaeq_preserves_free_vars in h2; rw h2.
              apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1.
              rw clf; simpl; tcsp. }
            eauto with slow. }

          { pose proof (alphaeq_cswap_cl2 f [(vb2,v)]) as h1.
            repeat (autodimp h1 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clf); tcsp;[].

            pose proof (alphaeq_cswap_cl2 (cswap [(vb2,v)] f) [(vg2,v0)]) as h2.
            repeat (autodimp h2 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clf); tcsp.
            { apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1; rw clf; simpl; tcsp. }

            pose proof (alphaeq_cswap_cl2 (cswap [(vg2,v0)] (cswap [(vb2,v)] f)) [(oneswapvar vb2 v vf2, v1)]) as h3.
            repeat (autodimp h3 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clf); tcsp.
            { apply alphaeq_eq in h2; apply alphaeq_preserves_free_vars in h2; rw h2.
              apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1.
              rw clf; simpl; tcsp. }
            eauto with slow. }
        }
      }

      { apply alphaeqbt_eq.
        apply alphaeqbt_nilv2.
        apply alphaeq_eq.

        constructor; simpl; auto.
        introv q.
        destruct n;[|destruct n ]; cpx; unfold selectbt; simpl; tcsp;
        eauto 3 with slow;[|].

        { apply alphaeqbt_eq.
          apply alphaeqbt_nilv2.
          apply alphaeq_eq.

          apply (alphaeq_trans _ F).

          { pose proof (alphaeq_cswap_cl2 F [(vb1,v)]) as h1.
            repeat (autodimp h1 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp;[].

            pose proof (alphaeq_cswap_cl2 (cswap [(vb1,v)] F) [(vg1,v0)]) as h2.
            repeat (autodimp h2 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp.
            { apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1; rw clF; simpl; tcsp. }

            pose proof (alphaeq_cswap_cl2 (cswap [(vg1,v0)] (cswap [(vb1,v)] F)) [(oneswapvar vb1 v vf1, v1)]) as h3.
            repeat (autodimp h3 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp.
            { apply alphaeq_eq in h2; apply alphaeq_preserves_free_vars in h2; rw h2.
              apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1.
              rw clF; simpl; tcsp. }
            eauto with slow. }

          { pose proof (alphaeq_cswap_cl2 F [(vb2,v)]) as h1.
            repeat (autodimp h1 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp;[].

            pose proof (alphaeq_cswap_cl2 (cswap [(vb2,v)] F) [(vg2,v0)]) as h2.
            repeat (autodimp h2 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp.
            { apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1; rw clF; simpl; tcsp. }

            pose proof (alphaeq_cswap_cl2 (cswap [(vg2,v0)] (cswap [(vb2,v)] F)) [(oneswapvar vb2 v vf2, v1)]) as h3.
            repeat (autodimp h3 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp.
            { apply alphaeq_eq in h2; apply alphaeq_preserves_free_vars in h2; rw h2.
              apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1.
              rw clF; simpl; tcsp. }
            eauto with slow. }
        }

        { apply alphaeqbt_eq.
          apply alphaeqbt_nilv2.
          apply alphaeq_eq.

          unfold oneswapvar; boolvar; tcsp; eauto 3 with slow.
        }
      }

      (*
      { apply alphaeqbt_eq; auto. }
*)
    }
  }
Qed.


From Undecidability.L Require Import L Tactics.Computable Tactics.ComputableTactics Tactics.Extract.
From MetaCoq Require Import Template.All TemplateMonad.Core Template.Ast.
Require Import String List.
Export String.StringSyntax.

Import MonadNotation.
Local Open Scope string_scope.

(* *** Generation of encoding functions *)

Fixpoint mkLApp (s : term) (L : list term) :=
  match L with
  | [] => s
  | t :: L => mkLApp (tApp (tConstruct (mkInd term_kn 0) 1 []) [s; t]) L
  end.

Definition encode_arguments (B : term) (a i : nat) A_j :=
      A <- tmUnquoteTyped Type A_j ;;
      name <- (tmEval cbv (name_of A_j ++ "_term") >>=  Core.tmFreshName)  ;;
      E <- tmTryInfer name None (encodable A);;
      t <- ret (@enc A E);;
      l <- tmQuote t;;
      ret (tApp l [tRel (a - i - 1) ]).

Definition mkMatch (t1 t2 d : Ast.term) (cases : nat -> list term -> Core.TemplateMonad term) :=
  hs_num <- tmGetOption (split_head_symbol t1) "no head symbol found";;
  let '(ind, Params) := hs_num in
  let params := List.length Params in
  L <- list_constructors ind >>= tmEval hnf ;;
    body <- monad_map_i (fun i '(n, s, args) =>
                          l <- tmArgsOfConstructor ind i ;;
                          l' <- monad_map_i (insert_params FUEL Params) (skipn params l) ;;
                          t <- cases i l' ;; ret (args, t)) L ;;
  ret (tCase (ind, params) (tLambda nAnon t1 t2) d
             body).

Definition L_facts_mp := MPfile ["L_facts"; "Util"; "L"; "Undecidability"].

Definition tmMatchCorrect (A : Type) : Core.TemplateMonad Prop :=
  t <- (tmEval hnf A >>= tmQuote) ;;
  hs_num <- tmGetOption (split_head_symbol t) "no inductive";;
  let '(ind, Params) := hs_num in
  num <- tmNumConstructors (inductive_mind ind) ;;
  x <- Core.tmFreshName "x" ;;
  mtch <- mkMatch t (* argument type *) tTerm (* return type *) (tRel (2 * num))
           (fun i (* ctr index *) ctr_types (* ctr type *) =>
              args <- tmEval cbv (|ctr_types|);;
              C <- monad_map_i (encode_arguments t args) ctr_types ;;
              ret (stack (map (tLambda (nAnon)) ctr_types)
                               (((fun s => mkAppList s C) (tRel (args + 2 * (num - i) - 1)))))
           ) ;;
   E' <- Core.tmInferInstance None (encodable A);;
   E <- tmGetMyOption E' "failed" ;;
   t' <- ret (@enc A E);;
   l <- tmQuote t';;
   encn <- ret (tApp l [tRel (2*num) ]) ;;
   lhs <- ret (mkLApp encn ((fix f n := match n with 0 => [] | S n => tRel (2 * n + 1) :: f n end ) num)) ;;
   ter <- ret (tProd nAnon t (it (fun s : term => tProd nAnon tTerm (tProd nAnon (tApp (tConst (L_facts_mp, "proc") []) [tRel 0]) s)) num ((tApp (tConst (L_facts_mp, "redLe") []) [mkNat num; lhs; mtch]))));;
   ter <- tmEval cbv ter ;;
   tmUnquoteTyped Prop ter.

Definition matchlem n A := (Core.tmBind (tmMatchCorrect A) (fun m => tmLemma n m ;; ret tt)).

Definition tmGenEncode (n : ident) (A : Type) : TemplateMonad (encodable A) :=
  e <- tmEncode A;;
  modpath <- tmCurrentModPath tt ;;
  p <- Core.tmLemma (n ++ "_proc") (forall x : A, proc (e x)) ;;
  n3 <- tmEval cbv ("encodable_" ++ n) ;;
  d <- tmInstanceRed n3 None (mk_encodable p);;
  m <- tmMatchCorrect A;;
  n4 <- tmEval cbv (n ++ "_correct") ;;
  Core.tmBind (tmMatchCorrect A) (fun m' => tmLemma n4 m';;ret d).

Arguments tmGenEncode _%string _%type.

Definition tmGenEncodeInj (n : ident) (A : Type) : TemplateMonad unit :=
  d <- tmGenEncode n A;;
  n2 <- tmEval cbv ((n ++ "_inj"));;
  i <- Core.tmLemma n2  (@encInj A d);;
  n3 <- tmEval cbv ("encInj_" ++ n) ;;
  d <- tmInstanceRed n3 None i;;
  ret tt.

Arguments tmGenEncodeInj _%string _%type.

(*
Definition tmGenEncode' (n : ident) (A : Type) :=
  e <- tmEncode n A;;
  modpath <- tmCurrentModPath tt ;;
  e <- tmUnquoteTyped (encodable A) (tConst (modpath, n) []);;
  p <- Core.tmLemma (n ++ "_proc") (forall x : A, proc (@enc_f A e x)) ;;
  n2 <- tmEval cbv ((n ++ "_inj"));;
  i <- Core.tmLemma n2  (injective (@enc_f _ e)) ;;
  n3 <- tmEval cbv ("encodable_" ++ n) ;;
  d <- tmInstanceRed n3 None  (@mk_registered A e p i);;
  m <- tmMatchCorrect A ;; ret tt. *)

(* TODO : use other methode instead, e.g. with typeclasses, as default obligation tactic is very fragile *)
Global Obligation Tactic := match goal with
                           | [ |- forall x : ?X, proc ?f ] => try register_proc
                           | [ |- encInj _ ] => unfold encInj;register_inj
                           | [ |- injective ?f ] => register_inj
                           | [ |- context [_ >(<= _) _] ] => extract match
                           end || Tactics.program_simpl.