(* Ugly tacty to resolve sign condition for R *)
Require Import RAux.
Require Export RGroundTac.
Require Import List.
Require Import Replace2.

(* Theorems to simplify the goal 0 ? x * y and x * y ? 0 where ? is < > <= >= *)

Definition Rsign_type := fun (x y : list R) => Prop.

Definition Rsign_cons : forall x y, (Rsign_type x y) := fun x y => True.

Ltac Rsign_push term1 term2 := generalize (Rsign_cons term1 term2); intro.

Ltac Rsign_le term :=
  match term with
  | (?X1 * ?X2)%R =>
    Rsign_le X1;
    match goal with
    | H1: (Rsign_type ?s1 ?s2) |- _ =>
      Rsign_le X2;
      match goal with
      | H2: (Rsign_type ?s3 ?s4) |- _ =>
        clear H1 H2;
        let s5 := (eval unfold List.app in (s1++s3)) in
        let s6 := (eval unfold List.app in (s2++s4)) in
        Rsign_push s5 s6
      end
    end
  | _ =>
    let H1 := fresh "H" in
    ((assert (H1: (0 <= term)%R); [auto with real; fail | idtac])
     || (assert (H1: (term <= 0)%R); [auto with real; fail | idtac]); clear H1;
     Rsign_push (term::nil) (@nil R)) || Rsign_push (@nil R) (term::nil)
  end.

Ltac Rsign_lt term :=
  match term with
  | (?X1 * ?X2)%R =>
    Rsign_lt X1;
    match goal with
    | H1: (Rsign_type ?s1 ?s2) |- _ =>
      Rsign_lt X2;
      match goal with
      | H2: (Rsign_type ?s3 ?s4) |- _ =>
        clear H1 H2;
        let s5 := (eval unfold List.app in (s1++s3)) in
        let s6 := (eval unfold List.app in (s2++s4)) in
        Rsign_push s5 s6
      end
    end
  | _ =>
    let H1 := fresh "H" in
    ((assert (H1: (0 < term)%R); [auto with real; fail | idtac])
     || (assert (H1: (term < 0)%R); [auto with real; fail | idtac]); clear H1;
     Rsign_push (term::nil) (@nil R)) || Rsign_push (@nil R) (term::nil)
  end.

Ltac Rsign_top0 :=
  match goal with
  | |- (0 <= ?X1)%R => Rsign_le X1
  | |- (?X1 <= 0)%R => Rsign_le X1
  | |- (0 < ?X1)%R => Rsign_lt X1
  | |- (?X1 < 0)%R => Rsign_le X1
  | |- (0 >= ?X1)%R => Rsign_le X1
  | |- (?X1 >= 0)%R => Rsign_le X1
  | |- (0 > ?X1)%R => Rsign_lt X1
  | |- (?X1 > 0)%R => Rsign_le X1
  end.

Ltac Rsign_top :=
  match goal with
  | |- (?X1 * _ <= ?X1 * _)%R => Rsign_le X1
  | |- (?X1 * _ < ?X1 * _)%R => Rsign_le X1
  | |- (?X1 * _ >= ?X1 * _)%R => Rsign_le X1
  | |- (?X1 * _ > ?X1 * _)%R => Rsign_le X1
  end.

Ltac Rhyp_sign_top0 H:=
  match type of H with
  | (0 <= ?X1)%R => Rsign_lt X1
  | (?X1 <= 0)%R => Rsign_lt X1
  | (0 < ?X1)%R => Rsign_lt X1
  | (?X1 < 0)%R => Rsign_lt X1
  | (0 >= ?X1)%R => Rsign_lt X1
  | (?X1 >= 0)%R => Rsign_lt X1
  | (0 > ?X1)%R => Rsign_lt X1
  | (?X1 > 0)%R => Rsign_lt X1
  end.

Ltac Rhyp_sign_top H :=
  match type of H with
  | (?X1 * _ <= ?X1 * _)%R => Rsign_lt X1
  | (?X1 * _ < ?X1 * _)%R => Rsign_lt X1
  | (?X1 * _ >= ?X1 * _)%R => Rsign_lt X1
  | (?X1 * _ > ?X1 * _)%R => Rsign_lt X1
  | ?X1 => generalize H
  end.

Ltac Rsign_get_term g :=
  match g with
  | (0 <= ?X1)%R => X1
  | (?X1 <= 0)%R => X1
  | (?X1 * _ <= ?X1 * _)%R => X1
  | (0 < ?X1)%R => X1
  | (?X1 < 0)%R => X1
  | (?X1 * _ < ?X1 * _)%R => X1
  | (0 >= ?X1)%R => X1
  | (?X1 >= 0)%R => X1
  | (?X1 * _ >= ?X1 * _)%R => X1
  | (?X1 * _ >= _)%R => X1
  | (0 > ?X1)%R => X1
  | (?X1 > 0)%R => X1
  | (?X1 * _ > ?X1 * _)%R => X1
  end.

Ltac Rsign_get_left g :=
  match g with
  | (_ * ?X1 <= _)%R => X1
  | (_ * ?X1 < _)%R => X1
  | (_ * ?X1 >= _)%R => X1
  | (_ * ?X1 > _)%R => X1
  end.

Ltac Rsign_get_right g :=
  match g with
  | (_ <= _ * ?X1)%R => X1
  | (_ < _ * ?X1)%R => X1
  | (_ >= _ * ?X1)%R => X1
  | (_ > _ * ?X1)%R => X1
  end.

Fixpoint mkRprodt (l: list R)(t:R) {struct l}: R :=
  match l with nil => t | e::l1 => (e * mkRprodt l1 t)%R end.

Fixpoint mkRprod (l: list R) : R :=
  match l with nil => 1%R | e::nil => e | e::l1 => (e * mkRprod l1)%R end.

(* Tactic for 0 ? x * y where ? is < > <= >= *)

Ltac rsign_tac_aux0 :=
  match goal with
  | |- (0 <= ?X1 * ?X2)%R =>
    let H1 := fresh "H" in
    (assert (H1: (0 <= X1)%R); auto with real; apply Rle_sign_pos_pos)
    || (assert (H1: (X1 <= 0)%R); auto with real; apply Rle_sign_neg_neg);
    try rsign_tac_aux0; clear H1
  | |- (?X1 * ?X2 <= 0)%R =>
    let H1 := fresh "H" in
    (assert (H1: (0 <= X1)%R); auto with real; apply Rle_sign_pos_neg)
    || (assert (H1: (X1 <= 0)%R); auto with real; apply Rle_sign_neg_pos);
    try rsign_tac_aux0; clear H1
  | |- (0 < ?X1 * ?X2)%R =>
    let H1 := fresh "H" in
    (assert (H1: (0 < X1)%R); auto with real; apply Rlt_sign_pos_pos)
    || (assert (H1: (X1 < 0)%R); auto with real; apply Rlt_sign_neg_neg);
    try rsign_tac_aux0; clear H1
  | |- (?X1 * ?X2 < 0)%R =>
    let H1 := fresh "H" in
    (assert (H1: (0 < X1)%R); auto with real; apply Rlt_sign_pos_neg)
    || (assert (H1: (X1 < 0)%R); auto with real; apply Rlt_sign_neg_pos);
    try rsign_tac_aux0; clear H1
  | |- (?X1 * ?X2 >= 0)%R =>
    let H1 := fresh "H" in
    (assert (H1: (0 >= X1)%R); auto with real; apply Rge_sign_neg_neg)
    || (assert (H1: (X1 >= 0)%R); auto with real; apply Rge_sign_pos_pos);
    try rsign_tac_aux0; clear H1
  | |- (0 >= ?X1 * ?X2)%R =>
    let H1 := fresh "H" in
    (assert (H1: (X1 >= 0)%R); auto with real; apply Rge_sign_pos_neg)
    || (assert (H1: (0 >= X1)%R); auto with real; apply Rge_sign_neg_pos);
    try rsign_tac_aux0; clear H1
  | |- (0 > ?X1 * ?X2)%R =>
    let H1 := fresh "H" in
    (assert (H1: (0 > X1)%R); auto with real; apply Rgt_sign_neg_pos)
    || (assert (H1: (X1 > 0)%R); auto with real; apply Rgt_sign_pos_neg);
    try rsign_tac_aux0; clear H1
  | |- (?X1 * ?X2 > 0)%R =>
    let H1 := fresh "H" in
    (assert (H1: (0 > X1)%R); auto with real; apply Rgt_sign_neg_neg)
    || (assert (H1: (X1 > 0)%R); auto with real; apply Rgt_sign_pos_pos);
    try rsign_tac_aux0; clear H1
  | _ => auto with real; fail 1 "rsign_tac_aux"
  end.

Ltac rsign_tac0 :=
  Rsign_top0;
  match goal with
  | H1: (Rsign_type ?s1 ?s2) |- ?g =>
    clear H1;
    let s := (eval unfold mkRprod, mkRprodt in (mkRprodt s1 (mkRprod s2))) in
    let t := Rsign_get_term g in
    replace t with s; [try rsign_tac_aux0 | try ring]; auto with real
  end.

(* tatic for hyp 0 ? x * y where ? is < > <= >= *)

Ltac hyp_rsign_tac_aux0 H :=
  match type of H with
  | (0 <= ?X1 * ?X2)%R =>
    let H1 := fresh "H" in
    ((assert (H1: (0 < X1)%R); auto with real; generalize (Rle_sign_pos_pos_rev _ _ H1 H))
     || (assert (H1: (X1 < 0)%R); auto with real; generalize (Rle_sign_neg_neg_rev _ _ H1 H));
     clear H; intros H; try hyp_rsign_tac_aux0 H; clear H1)
  | (?X1 * ?X2 <= 0)%R =>
    let H1 := fresh "H" in
    ((assert (H1: (0 < X1)%R); auto with real; generalize (Rle_sign_pos_neg_rev _ _ H1 H))
     || (assert (H1: (X1 <= 0)%R); auto with real; generalize (Rle_sign_neg_pos_rev _ _ H1 H));
     clear H; intros H; try hyp_rsign_tac_aux0 H; clear H1)
  | (0 < ?X1 * ?X2)%R =>
    let H1 := fresh "H" in
    ((assert (H1: (0 < X1)%R); auto with real; generalize (Rlt_sign_pos_pos_rev _ _ H1 H))
     || (assert (H1: (X1 < 0)%R); auto with real; generalize (Rlt_sign_neg_neg_rev _ _ H1 H));
     clear H; intros H; try hyp_rsign_tac_aux0 H; clear H1)
  | (?X1 * ?X2 < 0)%R =>
    let H1 := fresh "H" in
    ((assert (H1: (0 < X1)%R); auto with real; generalize (Rlt_sign_pos_neg_rev _ _ H1 H))
     || (assert (H1: (X1 < 0)%R); auto with real; generalize (Rlt_sign_neg_pos_rev _ _ H1 H));
     clear H; intros H; try hyp_rsign_tac_aux0 H; clear H1)
  | (?X1 * ?X2 >= 0)%R =>
    let H1 := fresh "H" in
    ((assert (H1: (0 >X1)%R); auto with real; generalize (Rge_sign_neg_neg_rev _ _ H1 H))
     || (assert (H1: (X1 > 0)%R); auto with real; generalize (Rge_sign_pos_pos _ _ H1 H));
     clear H; intros H; try hyp_rsign_tac_aux0 H; clear H1)
  | (0 >= ?X1 * ?X2)%R =>
    let H1 := fresh "H" in
    ((assert (H1: (X1 > 0)%R); auto with real; generalize (Rge_sign_pos_neg _ _ H1 H))
     || (assert (H1: (0 > X1)%R); auto with real; generalize (Rge_sign_neg_pos _ _ H1 H));
     clear H; intros H; try hyp_rsign_tac_aux0 H; clear H1)
  | (0 > ?X1 * ?X2)%R =>
    let H1 := fresh "H" in
    ((assert (H1: (0 > X1)%R); auto with real; generalize (Rgt_sign_neg_pos _ _ H1 H))
     || (assert (H1: (X1 > 0)%R); auto with real; generalize (Rgt_sign_pos_neg _ _ H1 H));
     clear H; intros H; try hyp_rsign_tac_aux0 H; clear H1)
  | (?X1 * ?X2 > 0)%R =>
    let H1 := fresh "H" in
    ((assert (H1: (0 > X1)%R); auto with real; generalize (Rgt_sign_neg_neg _ _ H1 H))
     || (assert (H1: (X1 > 0)%R); auto with real; generalize (Rgt_sign_pos_pos _ _ H1 H));
     clear H; intros H; try hyp_rsign_tac_aux0 H; clear H1)
  | _ => auto with real; fail 1 "hyp_rsign_tac_aux0"
  end.

Ltac hyp_rsign_tac0 H :=
  Rhyp_sign_top0 H;
  match goal with
  | H1: (Rsign_type ?s1 ?s2) |- ?g =>
    clear H1;
    let s := (eval unfold mkRprod, mkRprodt in (mkRprodt s1 (mkRprod s2))) in
    let t := Rsign_get_term g in
    replace t with s in H; [try hyp_rsign_tac_aux0 H | try ring];
    auto with real
  end.

(* Tactic for goal x1 * x2 ? x1 * x3 where ? is < > <= >= *)

Ltac rsign_tac_aux :=
  match goal with
  | |- (?X1 * ?X2 <= ?X1 * ?X3)%R =>
    let H1 := fresh "H" in
    (assert (H1: (0 <= X1)%R); auto with real; apply Rmult_le_compat_l)
    || (assert (H1: (X1 <= 0)%R); auto with real; apply Rmult_le_neg_compat_l);
    try rsign_tac_aux; clear H1
  | |- (?X1 * ?X2 < ?X1 * ?X3)%R =>
    let H1 := fresh "H" in
    (assert (H1: (0 <= X1)%R); auto with real; apply Rmult_lt_compat_l)
    || (assert (H1: (X1 <= 0)%R); auto with real; apply Rmult_lt_neg_compat_l);
    try rsign_tac_aux; clear H1
  | |- (?X1 * ?X2 >= ?X1 * ?X3)%R =>
    let H1 := fresh "H" in
    (assert (H1: (X1 >= 0)%R); auto with real; apply Rmult_ge_compat_l)
    || (assert (H1: (0 >= X1)%R); auto with real; apply Rmult_ge_neg_compat_l);
    try rsign_tac_aux; clear H1
  | |- (?X1 * ?X2 > ?X1 * ?X3)%R =>
    let H1 := fresh "H" in
    (assert (H1: (0 <= X1)%R); auto with real; apply Rmult_lt_compat_l)
    || (assert (H1: (X1 <= 0)%R); auto with real; apply Rmult_lt_neg_compat_l);
    try rsign_tac_aux; clear H1
  | _ => auto with real; fail 1 "Rsign_tac_aux"
  end.

Ltac rsign_tac :=
  rsign_tac0
  || (Rsign_top;
     match goal with
     | H1: (Rsign_type ?s1 ?s2) |- ?g =>
       clear H1;
       let s := (eval unfold mkRprod, mkRprodt in
                    (mkRprodt s1 (mkRprod s2)))
       in
       let t := Rsign_get_term g in
       let l := Rsign_get_left g in
       let r := Rsign_get_right g in
       let sl := (eval unfold mkRprod, mkRprodt in
                     (mkRprodt s1 (Rmult (mkRprod s2) l)))
       in
       let sr := (eval unfold mkRprod, mkRprodt in
                     (mkRprodt s1 (Rmult (mkRprod s2) r)))
       in
       replace2_tac (Rmult t l) (Rmult t r) sl sr; [rsign_tac_aux | ring | ring]
     end).

(* Tactic for hyp x1 * x2 ? x1 * x3 where ? is < > <= >= *)

Ltac hyp_rsign_tac_aux H :=
  match type of H with
  | (?X1 * ?X2 <= ?X1 * ?X3)%R =>
    let H1 := fresh "H" in
    (assert (H1: (0 < X1)%R); auto with real; generalize (Rmult_le_compat_l_rev _ _ _ H1 H))
    || (assert (H1: (X1 < 0)%R); auto with real; generalize (Rmult_le_neg_compat_l_rev _ _ _ H1 H));
    clear H; intros H; try hyp_rsign_tac_aux H; clear H1
  | (?X1 * ?X2 < ?X1 * ?X3)%R =>
    let H1 := fresh "H" in
    (assert (H1: (0 < X1)%R); auto with real; generalize (Rmult_lt_compat_l_rev _ _ _ H1 H))
    || (assert (H1: (X1 < 0)%R); auto with real; generalize (Rmult_lt_neg_compat_l_rev _ _ _ H1 H));
    clear H; intros H; try hyp_rsign_tac_aux H; clear H1
  | (?X1 * ?X2 >= ?X1 * ?X3)%R =>
    let H1 := fresh "H" in
    (assert (H1: (X1 > 0)%R); auto with real; generalize (Rmult_ge_compat_l_rev _ _ _ H1 H))
    || (assert (H1: (0 > X1)%R); auto with real; generalize (Rmult_ge_neg_compat_l_rev _ _ _ H1 H));
    clear H; intros H; try hyp_rsign_tac_aux H; clear H1
  | (?X1 * ?X2 > ?X1 * ?X3)%R =>
    let H1 := fresh "H" in
    (assert (H1: (0 < X1)%R); auto with real; generalize (Rmult_gt_compat_l_rev _ _ _ H1 H))
    || (assert (H1: (X1 < 0)%R); auto with real; generalize (Rmult_gt_neg_compat_l_rev _ _ _ H1 H));
    clear H; intros H; try hyp_rsign_tac_aux H; clear H1
  | _ => auto with real; fail 0 "Rhyp_sign_tac_aux"
  end.

Ltac hyp_rsign_tac H :=
  hyp_rsign_tac0 H
  || (Rhyp_sign_top H;
     match goal with
     | H1: (Rsign_type ?s1 ?s2) |- _ =>
       clear H1;
       let s := (eval unfold mkRprod, mkRprodt in
                    (mkRprodt s1 (mkRprod s2)))
       in
       let g := type of H in
       let t := Rsign_get_term g in
       let l := Rsign_get_left g in
       let r := Rsign_get_right g in
       let sl := (eval unfold mkRprod, mkRprodt in
                     (mkRprodt s1 (Rmult (mkRprod s2) l)))
       in
       let sr := (eval unfold mkRprod, mkRprodt in
                     (mkRprodt s1 (Rmult (mkRprod s2) r)))
       in
       generalize H; replace2_tac (Rmult t l) (Rmult t r) sl sr;
       [clear H; intros H; try hyp_rsign_tac_aux H | ring | ring]
     end).

Section Test.

Let test1 : forall a b c, (0 < a -> a * b < a * c -> b < c)%R.
Proof.
intros a b c H1 H2.
hyp_rsign_tac H2.
Qed.

Let test2 : forall a b c, (a < 0 -> a * b < a * c -> c < b)%R.
Proof.
intros a b c H1 H2.
hyp_rsign_tac H2.
Qed.

Let test3 : forall a b c, (0 < a -> a * b <= a * c -> b <= c)%R.
intros a b c H1 H2.
hyp_rsign_tac H2.
Qed.

Let test4 : forall a b c, (0 > a -> (a * b) >= (a * c) -> c >= b)%R.
intros a b c H1 H2.
hyp_rsign_tac H2.
Qed.

End Test.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 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.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli & Mark Bickford

*)

Require Export rules_product.
Require Export rules_typehood.

(** printing |- $\vdash$ *)
(** printing ->  $\rightarrow$ *)

(* begin hide *)

(* end hide *)

(* [23] ============ PAIR FORMATION (ALT) ============ *)

(**

<<
   H |- x:A * B ext <a,b>

     By pairFormation_alt s z ()

     H |- a in A
     H |- B[x\a] ext b
     H, z : A |- istype(B[x\z])
>>

 *)

Definition rule_pair_formation_alt {p}
           (A B a b : NTerm)
           (x z  : NVar)
           (H    : @barehypotheses p) :=
  mk_rule
    (mk_baresequent H (mk_concl (mk_product A x B) (mk_pair a b)))
    [ mk_baresequent H (mk_conclax (mk_member a A)),
      mk_baresequent H (mk_concl (subst B x a) b),
      mk_baresequent (snoc H (mk_hyp z A))
                     (mk_conclax (mk_istype (subst B x (mk_var z)))) ]
    [sarg_var z, sarg_term a].

Lemma rule_pair_formation_alt_true {p} :
  forall lib (A B a b : NTerm)
         (x z : NVar)
         (H   : @barehypotheses p),
    rule_true lib (rule_pair_formation_alt A B a b x z H).
Proof.
  intros.
  unfold rule_pair_formation_alt, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.

  unfold args_constraints in cargs; allsimpl.
  pose proof (cargs (sarg_var z)) as arg1; autodimp arg1 hyp.
  pose proof (cargs (sarg_term a)) as arg2; autodimp arg2 hyp.
  clear cargs.
  allunfold @arg_constraints; GC.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  rename Hyp2 into hyp3.
  destseq; allsimpl; proof_irr; GC.

  assert (closed_extract H (mk_concl (mk_product A x B) (mk_pair a b))) as cp.
  { clear hyp1 hyp2 hyp3.
    unfold closed_extract; simpl.
    allunfold @covered; allsimpl.
    autorewrite with slow core in *.
    allrw subvars_app_l; repnd; dands; auto. }

  exists cp; GC.

  (* We prove some simple facts on our sequents *)
  assert ((z <> x -> !LIn z (free_vars B))
          # !LIn z (free_vars A)
          # !LIn z (vars_hyps H)) as vhyps.

  { clear hyp1 hyp2 hyp3.
    dwfseq.
    autorewrite with slow core in *.
    sp;
      try (complete (assert (LIn z (remove_nvars [x] (free_vars B)))
                      as j by (rw in_remove_nvars; rw in_single_iff; sp);
                     discover; tcsp)). }

  destruct vhyps as [ nzB vhyps ].
  destruct vhyps as [ nzA nzH ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  lsubst_tac.

  assert (forall s3,
            similarity lib s1 s3 H
            -> {ca3 : cover_vars A s3
                & {cb3 : cover_vars_upto B (csub_filter s3 [x]) [x]
                & tequality
                    lib
                    (mkc_product (lsubstc A w1 s1 c1) x
                                 (lsubstc_vars B w2 (csub_filter s1 [x]) [x] c2))
                    (mkc_product (lsubstc A w1 s3 ca3) x
                                 (lsubstc_vars B w2 (csub_filter s3 [x]) [x] cb3)) }}) as teq.

  { introv sim'.
    dup sim' as ca3.
    eapply similarity_cover_vars in ca3;[|exact c1].
    dup sim' as cb3.
    eapply similarity_cover_vars_upto in cb3;[|exact c2].

    exists ca3 cb3.

    apply tequality_product; dands.

    + vr_seq_true in hyp1.
      pose proof (hyp1 s1 s3 eqh sim') as h; clear hyp1; exrepnd.
      lsubst_tac; proof_irr.
      clear h1.
      apply tequality_mkc_member in h0; repnd; auto.

    + intros a1 a2 ea.
      repeat (substc_lsubstc_vars3;[]).

      vr_seq_true in hyp3.
      pose proof (hyp3 (snoc s1 (z,a1)) (snoc s3 (z,a2))) as h; clear hyp3.
      repeat (autodimp h hyp).

      * apply hyps_functionality_snoc2; simpl; auto;[].
        introv equ sim''.

        vr_seq_true in hyp1.
        pose proof (hyp1 s1 s' eqh sim'') as h; clear hyp1; exrepnd.
        lsubst_tac; proof_irr.
        clear h1.
        apply tequality_mkc_member in h0; repnd; auto.

      * sim_snoc; dands; auto.

      * exrepnd.
        lsubst_tac; proof_irr.
        rw @tequality_mkc_istype in h0.
        rw @equality_axiom_in_mkc_istype in h1.

        assert (cover_vars (mk_var z) (snoc s1 (z, a1))) as cov1.
        { apply cover_vars_var; rw @dom_csub_snoc; simpl; rw in_snoc; tcsp. }
        assert (cover_vars (mk_var z) (snoc s3 (z, a2))) as cov2.
        { apply cover_vars_var; rw @dom_csub_snoc; simpl; rw in_snoc; tcsp. }

        repeat lsubstc_subst_aeq.
        repeat (substc_lsubstc_vars3;[]).
        lsubst_tac.
        repeat (lsubstc_snoc2;[]).
        proof_irr; auto. }

  dands.

  { apply teq in sim; clear teq; exrepnd; proof_irr; auto. }

  apply equality_in_product; dands.

  { apply teq in sim; clear teq; exrepnd; proof_irr; auto.
    apply tequality_product in sim1; repnd.
    apply tequality_refl in sim0; auto. }

  { intros a1 a2 ea.
    repeat (substc_lsubstc_vars3;[]).
    apply similarity_refl in sim.
    apply teq in sim; clear teq; exrepnd; proof_irr.
    apply tequality_product in sim1; repnd; proof_irr.
    apply sim1 in ea; clear sim1.
    repeat (substc_lsubstc_vars3;[]).
    proof_irr; auto. }

  eexists; eexists; eexists; eexists; dands; spcast;
  try (complete (apply computes_to_valc_refl; eauto 3 with slow));[|].

  - vr_seq_true in hyp1.
    pose proof (hyp1 s1 s2 eqh sim) as h; clear hyp1; exrepnd.
    lsubst_tac; proof_irr.
    apply tequality_mkc_member in h0; repnd.
    apply member_if_inhabited in h1.
    eapply equality_trans. exact h1. apply h0.
    apply equality_sym in h1. apply equality_refl in h1. auto.

  - repeat (substc_lsubstc_vars3;[]).
    vr_seq_true in hyp2.
    pose proof (hyp2 s1 s2 eqh sim) as h; clear hyp2; exrepnd.

    repeat lsubstc_subst_aeq.
    repeat (substc_lsubstc_vars3;[]).
    proof_irr; auto.
Qed.

(* begin hide *)

Lemma rule_pair_formation_alt_true_ex {p} :
  forall lib  z A B a b x H,
    @rule_true_if p lib (rule_pair_formation_alt A B a b x z H).
Proof.
  intros.
  generalize (rule_pair_formation_alt_true lib A B a b x z  H); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* ============ PAIR EQUALITY (ALT) ============ *)

(**

<<

   H |- <a1,b1> = <a2,b2> in x:A*B

     By pairEquality_alt z ()

     H |- a1 = a2 in A
     H |- b1 = b2 in B[x\a1]
     H, z : A |- istype(B[x\z])
>>
 *)

Definition rule_pair_equality_alt {o}
           (A B a1 a2 b1 b2 : NTerm)
           (x z : NVar)
           (H : @barehypotheses o) :=
  mk_rule
    (mk_baresequent
       H
       (mk_conclax (mk_equality
                      (mk_pair a1 b1)
                      (mk_pair a2 b2)
                      (mk_product A x B))))
    [ mk_baresequent H (mk_conclax (mk_equality a1 a2 A)),
      mk_baresequent H (mk_conclax (mk_equality b1 b2 (subst B x a1))),
      mk_baresequent
        (snoc H (mk_hyp z A))
        (mk_conclax (mk_istype
                       (subst B x (mk_var z))
                     )) ]
    [sarg_var z].

Lemma rule_pair_equality_alt_true {o} :
  forall lib (A B a1 a2 b1 b2 : NTerm)
         (x z : NVar)
         (H   : @barehypotheses o),
    rule_true lib (rule_pair_equality_alt A B a1 a2 b1 b2 x z H).
Proof.
  intros.
  unfold rule_pair_equality_alt, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  rename Hyp2 into hyp3.
  destseq; allsimpl; proof_irr; GC.

  exists (@covered_axiom o (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  assert ((z <> x -> !LIn z (free_vars B))
          # !LIn z (free_vars A)
          # !LIn z (vars_hyps H)) as vhyps.

  { clear hyp1 hyp2 hyp3.
    dwfseq.
    autorewrite with slow core in *.
    sp;
      try (complete (assert (LIn z (remove_nvars [x] (free_vars B)))
                      as j by (rw in_remove_nvars; rw in_single_iff; sp);
                     discover; tcsp)). }

  destruct vhyps as [ nzB vhyps ].
  destruct vhyps as [ nzA nzH ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  lsubst_tac.
  rw <- @member_equality_iff.

  assert (forall s1 s2,
            hyps_functionality lib s1 H ->
            similarity lib s1 s2 H
            -> {ca1 : cover_vars A s1
                & {cb1 : cover_vars_upto B (csub_filter s1 [x]) [x]
                & {ca2 : cover_vars A s2
                & {cb2 : cover_vars_upto B (csub_filter s2 [x]) [x]
                & tequality
                    lib
                    (mkc_product (lsubstc A w0 s1 ca1) x
                                 (lsubstc_vars B w3 (csub_filter s1 [x]) [x] cb1))
                    (mkc_product (lsubstc A w0 s2 ca2) x
                                 (lsubstc_vars B w3 (csub_filter s2 [x]) [x] cb2)) }}}}) as teq.

  { introv eqh' sim'.
    dup sim' as ca.
    eapply similarity_cover_vars2 in ca;[|exact sim|exact c4]; repnd; GC;[].
    dup sim' as cb.
    eapply similarity_cover_vars_upto2 in cb;[|exact sim|exact c5]; repnd; GC;[].

    exists ca1 cb1 ca cb.

    apply tequality_product; dands.

    + vr_seq_true in hyp1.
      pose proof (hyp1 s0 s3 eqh' sim') as h; clear hyp1; exrepnd.
      lsubst_tac; proof_irr.
      clear h1.
      apply tequality_mkc_equality in h0; repnd; auto.

    + intros a a' ea.
      repeat (substc_lsubstc_vars3;[]).

      vr_seq_true in hyp3.
      pose proof (hyp3 (snoc s0 (z,a)) (snoc s3 (z,a'))) as h; clear hyp3.
      repeat (autodimp h hyp).

      * apply hyps_functionality_snoc2; simpl; auto;[].
        introv equ sim''.

        vr_seq_true in hyp1.
        pose proof (hyp1 s0 s' eqh' sim'') as h; clear hyp1; exrepnd.
        lsubst_tac; proof_irr.
        clear h1.
        apply tequality_mkc_equality in h0; repnd; auto.

      * sim_snoc; dands; auto.

      * exrepnd.
        lsubst_tac; proof_irr.
        rw @tequality_mkc_istype in h0.
        assert (cover_vars (mk_var z) (snoc s0 (z, a))) as cov1.
        { apply cover_vars_var; rw @dom_csub_snoc; simpl; rw in_snoc; tcsp. }
        assert (cover_vars (mk_var z) (snoc s3 (z, a'))) as cov2.
        { apply cover_vars_var; rw @dom_csub_snoc; simpl; rw in_snoc; tcsp. }

        repeat lsubstc_subst_aeq.
        repeat (substc_lsubstc_vars3;[]).
        lsubst_tac.
        repeat (lsubstc_snoc2;[]).
        proof_irr; auto. }

  pose proof (teq_and_eq_if_equality
                lib (mk_product A x B) (mk_pair a1 b1) (mk_pair a2 b2)
                s1 s2 H wT w1 w2 c1 c0 c2 c3 cT cT0
                eqh sim) as eqp.
  repeat (autodimp eqp hyp); auto;
  [| |lsubst_tac; clear_irr; auto];[|].

  { lsubst_tac; clear_irr.
    apply teq in sim; clear teq; exrepnd; proof_irr; auto. }

  clear dependent s1.
  clear dependent s2.
  introv hf sim.
  lsubst_tac.
  apply equality_in_product; dands.

  { apply teq in sim; clear teq; exrepnd; proof_irr; auto.
    apply tequality_product in sim1; repnd.
    apply tequality_refl in sim0; auto. }

  { intros a a' ea.
    repeat (substc_lsubstc_vars3;[]).
    apply similarity_refl in sim.
    apply teq in sim; auto; clear teq; exrepnd; proof_irr.
    apply tequality_product in sim1; repnd; proof_irr.
    apply sim1 in ea; clear sim1.
    repeat (substc_lsubstc_vars3;[]).
    proof_irr; auto. }

  eexists; eexists; eexists; eexists; dands; spcast;
  try (complete (apply computes_to_valc_refl; eauto 3 with slow));[|].

  - vr_seq_true in hyp1.
    pose proof (hyp1 s1 s2 hf sim) as h; clear hyp1; exrepnd.
    lsubst_tac; proof_irr.
    apply tequality_mkc_equality in h0; repnd.
    rw <- @member_equality_iff in h1.
    eapply equality_trans. exact h1. apply h0.
    apply equality_sym in h1. apply equality_refl in h1. auto.

  - repeat (substc_lsubstc_vars3;[]).
    vr_seq_true in hyp2.
    pose proof (hyp2 s1 s2 hf sim) as h; clear hyp2; exrepnd.
    lsubst_tac; proof_irr.
    apply tequality_mkc_equality in h0; repnd.
    rw <- @member_equality_iff in h1.
    allrw @fold_equorsq.
    clear h2.

    assert (cover_vars a1 s2) as cov.
    { eapply similarity_cover_vars in sim; eauto. }

    assert (equality lib (lsubstc b1 w5 s1 c3) (lsubstc b2 w7 s2 c5) (lsubstc (subst B x a1) wT0 s1 cT)).
    { eapply equality_trans. exact h1. apply h0.
     apply equality_sym in h1; apply equality_refl in h1. auto.
    }

    repeat lsubstc_subst_aeq.
    repeat (substc_lsubstc_vars3;[]).
    proof_irr; auto.

Qed.


(*From Coq Require Import Strings.String.
From Coq Require Import Strings.Ascii.
From Coq Require Import Init.Datatypes.*)
Require Import Omega.
Require Import Coq.Lists.ListSet.
Require Import Coq.Init.Nat.
Require Import Coq.Arith.EqNat.
Require Import Arith.
Require Import Coq.Program.Wf.
Open Scope list.

Definition atom:= nat.
Definition atoms := set atom.
Definition empty : atoms := empty_set atom.
Definition singleton (x : atom) := x :: nil.

Definition union := set_union Nat.eq_dec.
Definition remove := set_remove Nat.eq_dec.
Definition add := set_add Nat.eq_dec.
Definition mem := set_mem Nat.eq_dec.

Definition fresh (ns: atoms): atom :=
(set_fold_left max ns 0) + 1
.

Definition X: atom := (fresh nil).
Definition Y: atom := (fresh (X :: nil)).
Definition Z: atom := (fresh (X :: Y :: nil)).

(* Module ECC. *)

(* -=ECC Definition=- *)

Inductive ECCuni: Type :=
  | uProp
  | uType (i: nat)
.

Inductive ECCexp: Type :=
  | eId (x: atom)
  | eUni (U: ECCuni)
  | ePi (x: atom) (A B: ECCexp)
  | eAbs (x: atom) (A e: ECCexp)
  | eApp  (e1 e2: ECCexp)
  | eLet (x: atom) (e1 e2: ECCexp)
  | eSig (x: atom) (A B: ECCexp)
  | ePair (e1 e2 A: ECCexp)
  | eFst (e: ECCexp)
  | eSnd (e: ECCexp)
  | eIf (e e1 e2: ECCexp)
  | eTru
  | eFls
  | eBool
.

Inductive ECCenv: Type :=
  | gEmpty
  | gAssum (g: ECCenv) (x: atom) (A: ECCexp)
  | gDef (g: ECCenv) (x: atom) (e: ECCexp)
.

Fixpoint ECCsize (e: ECCexp) : nat :=
  match e with
  | eId _ => 1
  | eUni _ => 1
  | ePi _ A B => 1 + (ECCsize A) + (ECCsize B)
  | eAbs _ A e => 1 + (ECCsize A) + (ECCsize e)
  | eApp e1 e2 => 1 + (ECCsize e1) + (ECCsize e2)
  | eLet _ e1 e2 => 1 + (ECCsize e1) + (ECCsize e2)
  | eSig _ A B => 1 + (ECCsize A) + (ECCsize B)
  | ePair e1 e2 A => 1 + (ECCsize e1) + (ECCsize e2) + (ECCsize A)
  | eFst e => 1 + (ECCsize e)
  | eSnd e => 1 + (ECCsize e)
  | eIf e e1 e2 => 1 + (ECCsize e) + (ECCsize e1) + (ECCsize e2)
  | eTru => 1
  | eFls => 1
  | eBool => 1
end.

Hint Constructors ECCuni.
Hint Constructors ECCexp.
Hint Constructors ECCenv.

Lemma ECCsize_non_zero : forall e, 0 < ECCsize e.
Proof.
  induction e; simpl; omega.
Qed.

(* -=ECC Evaluation=- *)

(* -Lookup- *)

Inductive ECC_LookupTypeR : ECCenv -> atom -> ECCexp -> Prop:=
  | LT_gFirst (g': ECCenv) (x: atom) (A: ECCexp):
    ECC_LookupTypeR (gAssum g' x A) x A
  | LT_AssumRest (g: ECCenv) (x x': atom) (A a': ECCexp):
    ECC_LookupTypeR g x A ->
    (x <> x') ->
    (ECC_LookupTypeR (gAssum g x' a') x A)
  | LT_DefRest (g: ECCenv) (x x': atom) (A a': ECCexp):
    ECC_LookupTypeR g x A ->
(*     (x <> x') -> *)
    (ECC_LookupTypeR (gDef g x' a') x A)
.

Inductive ECC_LookupDefR : ECCenv -> atom -> ECCexp -> Prop:=
  | LD_gFirst (g': ECCenv) (x: atom) (e A: ECCexp):
    ECC_LookupDefR (gAssum (gDef g' x e) x A) x e
  | LD_AssumRest (g: ECCenv) (x x': atom) (e a': ECCexp):
    ECC_LookupDefR g x e ->
    (x <> x') ->
    (ECC_LookupDefR (gAssum g x' a') x e)
  | LD_DefRest (g: ECCenv) (x x': atom) (e e': ECCexp):
    ECC_LookupDefR g x e ->
    (x <> x') ->
    (ECC_LookupDefR (gDef g x' e') x e)
.
(* Q: what if looking up a type and get a value first, or vice versa? *)

Hint Constructors ECC_LookupTypeR.

Example ECC_LookupFirstExample:
ECC_LookupTypeR (gAssum gEmpty X eTru) X eTru.
Proof.
  auto.
Qed.

Example ECC_LookupRestExample:
X <> Y -> ECC_LookupTypeR (gAssum (gAssum gEmpty X eTru) Y eFls) X eTru.
Proof.
  auto.  (* WOW!*)
Qed.

Fixpoint ECC_LookupType (g: ECCenv) (x: atom): option ECCexp :=
match g with
  | gEmpty => None
  | gAssum g' x' A => if (x' =? x) then Some A else (ECC_LookupType g' x)
  | gDef g' x' e => (ECC_LookupType g' x)
end.

Fixpoint ECC_LookupDef (g: ECCenv) (x: atom): option ECCexp :=
match g with
  | gEmpty => None
  | gAssum g' x' A => if (x' =? x) then match g' with
      | gEmpty => None
      | gAssum g'' x'' A => None
      | gDef g' x'' e => if (x'' =? x) then Some e else None
      end
      else (ECC_LookupDef g' x)
  | gDef g' x' e => if (x' =? x) then None else (ECC_LookupDef g' x)
end.

Lemma ECC_EmptyImpliesNothing : forall (x: atom) (A: ECCexp), ECC_LookupTypeR gEmpty x A -> False.
Proof.
intros. inversion H.
Qed.

Lemma ECC_LookupTypeReflects (g: ECCenv) (x: atom) (A: ECCexp) : ECC_LookupTypeR g x A <-> (ECC_LookupType g x) = Some A.
Proof.
intros. split.
 - intros. induction H.
  + cbn. rewrite <- beq_nat_refl. reflexivity.
  + cbn. cut (x' =? x = false).
    * intros. rewrite H1. apply IHECC_LookupTypeR.
    * apply Nat.eqb_neq. auto.
  + cbn. apply IHECC_LookupTypeR.
 - intros. induction g.
  + discriminate.
  + inversion H. destruct (x0 =? x) eqn:eq.
    * inversion H1. apply Nat.eqb_eq in eq. rewrite eq. apply LT_gFirst.
    * apply LT_AssumRest.
      -- apply IHg. apply H1.
      -- apply Nat.eqb_neq in eq. auto.
  + apply LT_DefRest.
    * apply IHg. apply H.
Qed.

Lemma ECC_LookupDefReflects (g: ECCenv) (x: atom) (A: ECCexp) : ECC_LookupDefR g x A <-> (ECC_LookupDef g x) = Some A.
Proof.
intros. split.
 - intros. induction H.
  + cbn. rewrite <- beq_nat_refl. reflexivity.
  + cbn. cut (x' =? x = false).
    * intros. rewrite H1. apply IHECC_LookupDefR.
    * apply Nat.eqb_neq. auto.
  + cbn. cut (x' =? x = false).
    * intros. rewrite H1. apply IHECC_LookupDefR.
    * apply Nat.eqb_neq. auto.
 - intros. induction g.
  + discriminate.
  + inversion H. destruct (x0 =? x) eqn:eq.
    *  destruct g eqn:eq2.
      -- discriminate.
      -- discriminate.
      -- apply Nat.eqb_eq in eq. rewrite eq. destruct (x1 =? x) eqn:eq3.
        ++ inversion H1. apply Nat.eqb_eq in eq3. rewrite eq3. apply LD_gFirst.
        ++ discriminate.
   * apply LD_AssumRest.
     -- apply IHg. apply H1.
     -- apply Nat.eqb_neq in eq. auto.
  + inversion H. destruct (x0 =? x) eqn:eq.
    * discriminate.
    * apply LD_DefRest.
      -- apply IHg. apply H1.
      -- apply Nat.eqb_neq in eq. auto.
Qed.

(* Substitution *)

Fixpoint FV (e: ECCexp) : atoms :=
match e with
  | eId x => singleton x
  | eUni U => empty
  | ePi x A B =>  union (FV A) (remove x (FV B))
  | eAbs x A e => union (FV A) (remove  x (FV e))
  | eApp  e1 e2 => (union (FV e1) (FV e2))
  | eLet x e1 e2 => (union (FV e1) (FV e2))
  | eSig x A B => (union (FV A) (remove  x (FV B)))
  | ePair e1 e2 A => (union (union  (FV e1) (FV e2)) (FV A))
  | eFst e => (FV e)
  | eSnd e => (FV e)
  | eIf e e1 e2 => (union (union  (FV e) (FV e1)) (FV e2))
  | eTru => empty
  | eFls => empty
  | eBool => empty
end.

(*Let's get nominal!*)

Definition swap_var (x:atom) (y:atom) (z:atom) :=
  if (z =? x) then y else if (z =? y) then x else z.

Fixpoint swap (x:atom) (y:atom) (t:ECCexp) : ECCexp :=
  match t with
  | eId z     => eId (swap_var x y z)
  | eAbs z A t1  => eAbs (swap_var x y z) (swap x y A) (swap x y t1)
  | eApp t1 t2 => eApp (swap x y t1) (swap x y t2)
  | ePi x' A B => ePi (swap_var x y x') (swap x y A) (swap x y B)
  | eLet x' e1 e2 => eLet (swap_var x y x') (swap x y e1) (swap x y e2)
  | eSig x' A B => eSig (swap_var x y x') (swap x y A) (swap x y B)
  | ePair e1 e2 A => ePair (swap x y e1) (swap x y e2) (swap x y A)
  | eFst e => (eFst (swap x y e))
  | eSnd e => (eSnd (swap x y e))
  | eIf e e1 e2 => (eIf (swap x y e) (swap x y e1) (swap x y e2))
  | _ => t
  end.

Lemma swap_size_eq : forall x y t,
    ECCsize (swap x y t) = ECCsize t.
Proof.
  induction t; simpl; auto.
Qed.

(* If there are free variables in the substitute,
   and if the term being substituted in binds one of them,
   then we need to perform an alpha conversion of the term being substituted in
   that avoids capturing any free variables in the substitute or in the body
   of the term being substituted in. *)

Program Fixpoint substWork (x: atom) (arg body: ECCexp) (FVInArg: atoms) {measure (ECCsize body)}:=
match body with
  | eId x' => if (x =? x') then arg else body
  | eAbs x' A e =>
      if (x =? x')
        then (eAbs x' (substWork x arg A FVInArg) e)
        else let xnew := fresh (union FVInArg (FV e)) in
                    (eAbs xnew (substWork x arg A FVInArg) (substWork x arg (swap x' xnew e) FVInArg))
  | ePi x' A B =>
      if (x =? x')
        then (ePi x' (substWork x arg A FVInArg) B)
        else let xnew := fresh (union FVInArg (FV B)) in
                (ePi xnew (substWork x arg A FVInArg) (substWork x arg (swap x' xnew B) FVInArg))
  | eLet x' A B =>
      if (x =? x')
        then (eLet x' (substWork x arg A FVInArg) B)
        else let xnew := fresh (union FVInArg (FV B)) in
                (eLet xnew (substWork x arg A FVInArg) (substWork x arg (swap x' xnew B) FVInArg))
  | eSig x' A B =>
      if (x =? x')
        then (eSig x' (substWork x arg A FVInArg) B)
        else let xnew := fresh (union FVInArg (FV B)) in
                (eSig xnew (substWork x arg A FVInArg) (substWork x arg (swap x' xnew B) FVInArg))
  | eApp e1 e2 => (eApp (substWork x arg e1 FVInArg) (substWork x arg e2 FVInArg))
  | eUni U => body
  | ePair e1 e2 A => (ePair (substWork x arg e1 FVInArg) (substWork x arg e2 FVInArg) (substWork x arg A FVInArg))
  | eFst e => (eFst (substWork x arg e FVInArg))
  | eSnd e => (eSnd (substWork x arg e FVInArg))
  | eIf e e1 e2 => (eIf (substWork x arg e FVInArg) (substWork x arg e1 FVInArg) (substWork x arg e2 FVInArg))
  | eTru => eTru
  | eFls => eFls
  | eBool => eBool
end.
Obligations.
Solve Obligations with (Tactics.program_simpl; cbn; omega).
Solve Obligations with (Tactics.program_simpl; cbn; rewrite -> swap_size_eq; omega).

Definition subst (x: atom) (arg body: ECCexp):= substWork x arg body (FV arg).

Inductive ECC_Aeq : ECCexp -> ECCexp -> Prop :=
  | aeq_id (e: ECCexp):
    ECC_Aeq e e
  | aeq_var (x: atom):
     ECC_Aeq (eId x) (eId x)
  | aeq_abs_same (x: atom) (t1 t2 b1 b2: ECCexp):
     ECC_Aeq t1 t2 ->
     ECC_Aeq b1 b2 ->
     ECC_Aeq (eAbs x t1 b1) (eAbs x t2 b2)
  | aeq_abs_diff (x y: atom) (t1 t2 b1 b2: ECCexp):
     x <> y ->
     (mem x (FV b2)) = false ->
     ECC_Aeq b1 (swap y x b2) ->
     ECC_Aeq t1 t2 ->
     ECC_Aeq (eAbs x t1 b1) (eAbs y t2 b2)
  | aeq_pi_same (x: atom) (t1 t2 b1 b2: ECCexp):
     ECC_Aeq t1 t2 ->
     ECC_Aeq b1 b2 ->
     ECC_Aeq (ePi x t1 b1) (ePi x t2 b2)
  | aeq_pi_diff (x y: atom) (t1 t2 b1 b2: ECCexp):
     x <> y ->
     (mem x (FV b2)) = false ->
     ECC_Aeq b1 (swap y x b2) ->
     ECC_Aeq t1 t2 ->
     ECC_Aeq (ePi x t1 b1) (ePi y t2 b2)
  | aeq_let_same (x: atom) (t1 t2 b1 b2: ECCexp):
     ECC_Aeq t1 t2 ->
     ECC_Aeq b1 b2 ->
     ECC_Aeq (eLet x t1 b1) (eLet x t2 b2)
  | aeq_let_diff (x y: atom) (t1 t2 b1 b2: ECCexp):
     x <> y ->
     (mem x (FV b2)) = false ->
     ECC_Aeq b1 (swap y x b2) ->
     ECC_Aeq t1 t2 ->
     ECC_Aeq (eLet x t1 b1) (eLet y t2 b2)
  | aeq_sig_same (x: atom) (t1 t2 b1 b2: ECCexp):
     ECC_Aeq t1 t2 ->
     ECC_Aeq b1 b2 ->
     ECC_Aeq (eSig x t1 b1) (eSig x t2 b2)
  | aeq_sig_diff (x y: atom) (t1 t2 b1 b2: ECCexp):
     x <> y ->
     (mem x (FV b2)) = false ->
     ECC_Aeq b1 (swap y x b2) ->
     ECC_Aeq t1 t2 ->
     ECC_Aeq (eSig x t1 b1) (eSig y t2 b2)
  | aeq_app (t1 t2 t1' t2': ECCexp):
     ECC_Aeq t1 t1' -> ECC_Aeq t2 t2' ->
     ECC_Aeq (eApp t1 t2) (eApp t1' t2')
  | aeq_pair (t1 t2 t1' t2' A A': ECCexp):
     ECC_Aeq t1 t1' -> ECC_Aeq t2 t2' ->
     ECC_Aeq A A' ->
     ECC_Aeq (ePair t1 t2 A) (ePair t1' t2' A')
  | aeq_eFst (e e': ECCexp):
     ECC_Aeq e e' ->
     ECC_Aeq (eFst e) (eFst e')
  | aeq_eSnd (e e': ECCexp):
     ECC_Aeq e e' ->
     ECC_Aeq (eSnd e) (eSnd e')
  | aeq_if (e1 e2 e3 e1' e2' e3': ECCexp):
     ECC_Aeq e1 e1' ->
     ECC_Aeq e2 e2' ->
     ECC_Aeq e3 e3' ->
     ECC_Aeq (eIf e1 e2 e3) (eIf e1' e2' e3').

Hint Constructors ECC_Aeq.

Timeout 30 Compute substWork X (eTru) (eId X) (FV eTru).
Compute substWork X (eTru) (eAbs Y (eBool) (eId X)) (FV eTru).
Compute substWork X (eTru) (eAbs X (eId X) (eId X)) (FV eTru).
Eval vm_compute in substWork X (eTru) (eAbs X (eId X) (eId X)) (FV eTru).

(* -Step- *)
Inductive ECC_RedR : ECCenv -> ECCexp -> ECCexp -> Prop :=
  | R_ID (g: ECCenv) (x: atom) (e': ECCexp) :
    ECC_LookupDefR g x e' -> ECC_RedR g (eId x) e'
  | R_App (g: ECCenv) (x: atom) (A body arg: ECCexp) :
    ECC_RedR g (eApp (eAbs x A body) arg) (subst x arg body) (*do anything with env here?*)
  | R_Fst (g: ECCenv) (e1 e2 A: ECCexp) :
    ECC_RedR g (eFst (ePair e1 e2 A)) e1
  | R_Snd (g: ECCenv) (e1 e2 A: ECCexp) :
    ECC_RedR g (eSnd (ePair e1 e2 A)) e2
  | R_Let (g: ECCenv) (x: atom) (e1 e2: ECCexp) :
    ECC_RedR g (eLet x e1 e2) (subst x e1 e2)  (*or here?*)
  | R_IfTru (g: ECCenv) (e1 e2: ECCexp) :
    ECC_RedR g (eIf eTru e1 e2) e1
  | R_IfFls (g: ECCenv) (e1 e2: ECCexp) :
    ECC_RedR g (eIf eFls e1 e2) e2
.

Hint Constructors ECC_RedR.

(* Reflective Transitive Closure of step*)
Inductive ECC_RedClosR : ECCenv -> ECCexp -> ECCexp -> Prop :=
  (*| R_RedR (g g': ECCenv) (e e': ECCexp): (* maybe don't need this one? it follows from refl + trans*)
      ECC_RedR g e e' ->
      ECC_RedClosR g e e'*)
  | R_Refl (g: ECCenv) (e: ECCexp):
      ECC_RedClosR g e e
  | R_Trans (g: ECCenv) (e e' e'': ECCexp) :
      ECC_RedR g e e' ->
      ECC_RedClosR g e' e'' ->
      ECC_RedClosR g e e''
  | R_CongLet (g: ECCenv) (e e1 e2: ECCexp) (x: atom) :
      ECC_RedClosR (gDef g x e) e1 e2 ->
      ECC_RedClosR g (eLet x e e1) (eLet x e e2)
  | R_CongLam1 (g: ECCenv) (A A' e e': ECCexp) (x: atom) :
      ECC_RedClosR g A A' ->
      ECC_RedClosR (gAssum g x A) e e' ->
      ECC_RedClosR g (eAbs x A e) (eAbs x A' e')
  | R_CongPi (g: ECCenv) (A A' B B': ECCexp) (x: atom) :
      ECC_RedClosR g A A' ->
      ECC_RedClosR (gAssum g x A) B B' ->
      ECC_RedClosR g (ePi x A B) (ePi x A' B')
  | R_CongSig (g: ECCenv) (A A' B B': ECCexp) (x: atom) :
      ECC_RedClosR g A A' ->
      ECC_RedClosR (gAssum g x A) B B' ->
      ECC_RedClosR g (eSig x A B) (eSig x A' B')
  | R_CongPair (g: ECCenv) (e1 e1' e2 e2' A A': ECCexp) :
      ECC_RedClosR g e1 e1' ->
      ECC_RedClosR g e2 e2' ->
      ECC_RedClosR g A A'   ->
      ECC_RedClosR g (ePair e1 e2 A) (ePair e1' e2' A')
  | R_CongApp (g: ECCenv) (e1 e1' e2 e2': ECCexp) :
      ECC_RedClosR g e1 e1' ->
      ECC_RedClosR g e2 e2' ->
      ECC_RedClosR g (eApp e1 e2) (eApp e1' e2')
  | R_CongFst (g: ECCenv) (V V': ECCexp) :
      ECC_RedClosR g V V' ->
      ECC_RedClosR g (eFst V) (eFst V')
  | R_CongSnd (g: ECCenv) (V V': ECCexp) :
      ECC_RedClosR g V V' ->
      ECC_RedClosR g (eSnd V) (eSnd V')
  | R_CongIf (g: ECCenv) (e e' e1 e1' e2 e2': ECCexp) :
      ECC_RedClosR g e e' ->
      ECC_RedClosR g e1 e1' ->
      ECC_RedClosR g e2 e2' ->
      ECC_RedClosR g (eIf e e1 e2) (eIf e' e1' e2')
.

Hint Constructors ECC_RedClosR.

Inductive ECC_Equiv: ECCenv -> ECCexp -> ECCexp -> Prop :=
  | E_Equiv (g: ECCenv) (e e1 e2: ECCexp) :
      ECC_RedClosR g e1 e ->
      ECC_RedClosR g e2 e ->
      ECC_Equiv g e1 e2
  | E_EquivIta1 (g: ECCenv) (e1 A e e2 e2': ECCexp) (x: atom) :
      ECC_RedClosR g e1 (eAbs x A e) ->
      ECC_RedClosR g e2 e2' ->
      ECC_Equiv (gAssum g x A) e (eApp e2' (eId x)) ->
      ECC_Equiv g e1 e2
  | E_EquivIta2 (g: ECCenv) (e e1 e1' e2 A : ECCexp) (x: atom) :
      ECC_RedClosR g e1 e1' ->
      ECC_RedClosR g e2 (eAbs x A e) ->
      ECC_Equiv (gAssum g x A) (eApp e1' (eId x)) e ->
      ECC_Equiv g e1 e2
  | E_EquivAlpha (g: ECCenv) (e1 e2: ECCexp):
      ECC_Aeq e1 e2 ->
      ECC_Equiv g e1 e2
.

Hint Constructors ECC_Equiv.

(* Typing *)

Inductive ECC_sub_type: ECCenv -> ECCexp -> ECCexp -> Prop :=
| ST_Cong (g: ECCenv) (A B: ECCexp) :
  ECC_Equiv g A B ->
  ECC_sub_type g A B
| ST_Cum (g: ECCenv) (i: nat) :
  ECC_sub_type g (eUni (uType i)) (eUni (uType (S i)))
| ST_Pi (g: ECCenv) (A1 A2 B1 B2: ECCexp) (x1 x2: atom) :
  (ECC_Equiv g A1 A2) ->
  (ECC_sub_type (gAssum g x1 A2) B1 (subst x2 (eId x1) B2)) -> (* eId x1 ?*)
  (ECC_sub_type g (ePi x1 A1 B1) (ePi x2 A2 B2))
.

Hint Constructors ECC_sub_type.

Inductive ECC_has_type: ECCenv -> ECCexp -> ECCexp -> Prop :=
| T_Ax_Prop (g: ECCenv) :
  (ECC_has_type g (eUni uProp) (eUni (uType 0)))
| T_Ax_Type (g: ECCenv) (i: nat) :
  (ECC_has_type g (eUni (uType i)) (eUni (uType (S i))))
| T_Var (g: ECCenv) (x: atom) (A: ECCexp) :
  (ECC_LookupTypeR g x A) -> (* this needs adjustment *)
  (ECC_has_type g (eId x) A)
| T_Let (g: ECCenv) (e e' A B: ECCexp) (x: atom):
  (ECC_has_type g e A) ->
  (ECC_has_type (gDef (gAssum g x A) x e) e' B) ->
  (ECC_has_type g (eLet x e e') (subst x e B))
| T_Prod_Prop (g: ECCenv) (x: atom) (A B: ECCexp) (i: nat):
  (ECC_has_type g A (eUni (uType i))) ->
  (ECC_has_type (gAssum g x A) B (eUni (uProp))) ->
  (ECC_has_type g (ePi x A B) (eUni (uProp)))
| T_Prod_Type (g: ECCenv) (x: atom) (A B: ECCexp) (i: nat):
  (ECC_has_type g A (eUni (uType i))) ->
  (ECC_has_type (gAssum g x A) B (eUni (uType i))) ->
  (ECC_has_type g (ePi x A B) (eUni (uType i)))
| T_Lam (g: ECCenv) (x: atom) (A e B: ECCexp) :
  (ECC_has_type (gAssum g x A) e B) ->
  (ECC_has_type g (eAbs x A e) (ePi x A B))
| T_App (g: ECCenv) (x: atom) (e e' A' B: ECCexp) :
  (ECC_has_type g e (ePi x A' B)) ->
  (ECC_has_type g e' A') ->
  (ECC_has_type g (eApp e e') (subst x e B))
| T_Sig (g: ECCenv) (x: atom) (A B: ECCexp) (i: nat) :
  (ECC_has_type g A (eUni (uType i))) ->
  (ECC_has_type (gAssum g x A) B (eUni (uType i))) -> (* should these be the same i*)
  (ECC_has_type g (eSig x A B) (eUni (uType i)))
| T_Pair (g: ECCenv) (e1 e2 A B: ECCexp) (x: atom) :
  (ECC_has_type g e1 A) ->
  (ECC_has_type g e2 (subst x e1 B)) ->
  (ECC_has_type g (ePair e1 e2 (eSig x A B)) (eSig x A B))
| T_Fst (g: ECCenv) (e A B: ECCexp) (x: atom) :
  (ECC_has_type g e (eSig x A B)) ->
  (ECC_has_type g (eFst e) A)
| T_Snd (g: ECCenv) (e A B: ECCexp) (x: atom) :
  (ECC_has_type g e (eSig x A B)) ->
  (ECC_has_type g (eSnd e) (subst x (eFst e) B))
| T_Bool (g: ECCenv):
  (ECC_has_type g (eBool) (eUni (uType 0)))
| T_True (g: ECCenv):
  (ECC_has_type g (eTru) (eBool))
| T_False (g: ECCenv):
  (ECC_has_type g (eFls) (eBool))
| T_If (g: ECCenv) (B U e e1 e2: ECCexp) (x: atom):
  (ECC_has_type (gAssum g x (eBool)) B U) ->
  (ECC_has_type g e (eBool)) ->
  (ECC_has_type g e1 (subst x (eTru) B)) ->
  (ECC_has_type g e2 (subst x (eFls) B)) ->
  (ECC_has_type g (eIf e e1 e2) (subst x e B))
| T_Conv (g: ECCenv) (e A B U: ECCexp) :
  (ECC_has_type g e A) ->
  (ECC_has_type g B U) ->
  (ECC_sub_type g A B) ->
  (ECC_has_type g e B)
.

Hint Constructors ECC_has_type.

Goal ECC_has_type gEmpty (eUni uProp) (eUni (uType 0)).
Proof.
intuition.
Qed.

(* ECC Notation *)

Bind Scope ECC_scope with ECCexp.
Bind Scope ECC_scope with ECCuni.
Bind Scope ECC_scope with ECCenv.
Delimit Scope ECC_scope with ECC.
Coercion eId: atom >-> ECCexp.

Notation "'type' x" := (eUni (uType x)) (at level 50):  ECC_scope.
Notation "'prop'" := (eUni uProp) (at level 50):  ECC_scope.
Definition example_Type := (type 3)%ECC: ECCexp.
Definition example_Prop := (prop)%ECC: ECCexp.

Notation "{ e1 e2 }" := (eApp e1 e2) (at level 50,e1 at level 9):  ECC_scope.
Definition example_App := { X Y }%ECC: ECCexp.

Notation "'LET' x ':=' A 'in' B" := (eLet x A B) (at level 50, format "'[v' 'LET'  x  ':='  A '/' 'in' '['  B ']' ']'") : ECC_scope.
Definition example_Let := (LET X := Y in Z)%ECC : ECCexp.
Print example_Let.
Definition F:= fresh (X::Y::Z::nil).
Definition example_Let2 := (LET X := (type 3) in LET F := (LET X := (type 2) in X) in ({X F}))%ECC.
Print example_Let2.

Notation "'Pi' x : A '->' B" := (ePi x A B) (at level 50, x at level 9, A at level 9) : ECC_scope.
Definition example_Pi := (Pi X : F -> Y)%ECC : ECCexp.
Notation "'\'  x : A  '->'  B" := (eAbs x A B) (at level 50, x at level 9, A at level 9) : ECC_scope.
Definition example_Abs := (\ X: Y -> Z)%ECC : ECCexp.
Notation "'Sig' x : A '..' B" := (eSig x A B) (at level 50, x at level 1, A at level 1): ECC_scope.
Definition example_Sig := (Sig X : Y .. Z)%ECC : ECCexp.
Notation "< e1 , e2 > 'as' A" := (ePair e1 e2 A) (at level 50, e1 at level 5, e2 at level 5, A at level 5): ECC_scope.
Definition example_Pair := (< X, Y > as (Sig X : Y .. Z))%ECC : ECCexp.
Notation "'fst' e" := (eFst e) (at level 50, e at level 5): ECC_scope.
Notation "'snd' e" := (eSnd e) (at level 50, e at level 5): ECC_scope.

Definition example_ycombinator := (\F:(type 3) -> ({(\X:(type 2) -> ({F {X X}})) (\X:(type 2) -> ({F {X X}}))}))%ECC.
Print example_ycombinator.

Compute subst X Y (LET Y := type 1 in X).

Goal ECC_RedClosR gEmpty (LET X := Y in LET Y := type 1 in X) Y.
Proof.
cut (ECC_RedR gEmpty (LET X := Y in LET Y := type 1 in X)%ECC (subst X (eId Y) (LET Y := type 1 in X))%ECC).
- cut (ECC_RedR gEmpty (subst X (eId Y) (LET Y := type 1 in X))%ECC Y).
  + eauto.
  + cbv. apply R_Let.
- cbv. apply R_Let.
Qed.

Goal ECC_has_type gEmpty (fst (<eTru , eFls> as (Sig X : eBool .. eBool))) eBool.
eauto.
Qed.

Goal ECC_has_type gEmpty (fst (<eTru , eFls> as
                            (Sig X : eBool .. (eIf X eBool (Pi Y : eBool -> eBool))))) eBool.
Proof.
eapply T_Fst. eapply T_Pair.
  - apply T_True.
  - cbv. apply T_Conv with (A := eBool) (U := (type 0)%ECC).
    + apply T_False.
    + eapply T_Conv.
      * apply T_If with (U:=(type 1)%ECC).
        -- auto.
        -- auto.
        -- auto.
        -- cbn. eapply T_Prod_Type.
          ++ auto.
          ++ auto.
      * auto.
      * cbn. apply ST_Cong. apply E_EquivAlpha. apply aeq_id.
    + apply ST_Cong. apply E_Equiv with (e:= eBool).
      * auto.
      * eauto.
Unshelve. exact 1.
Qed.

(* End ECC.*)

(* (* Module ECCA. *)
 *)
(* -=ECCA Definition=- *)

(* Restricted ECCA, used in computing *)

Inductive ECCAval: Type :=
  | avId (x: atom)
  | avUni (U: ECCuni)
  | avPi (x: atom) (A B: ECCAconf)
  | avAbs (x: atom) (A B: ECCAconf)
  | avSig (x: atom) (A B: ECCAconf)
  | avPair (v1 v2: ECCAval) (A: ECCAconf)
  | avTru
  | avFls
  | avBool
with
ECCAconf: Type :=
  | acfComp (e: ECCAcomp)
  | acfLet (x: atom) (A: ECCAcomp) (B: ECCAconf)
  | acfIf (v: ECCAval) (m1 m2: ECCAconf)
with
ECCAcomp: Type :=
  | acpApp (v1 v2: ECCAval)
  | acpVal (v: ECCAval)
  | acpFst (v: ECCAval)
  | acpSnd (v: ECCAval)
  | acpSubst (x arg body: ECCAval)
.

Inductive ECCAcont: Type :=
  | actHole
  | actLetHole (x: atom) (B: ECCAconf)
.

Inductive ECCAenv: Type :=
  | agEmpty
  | agAssum (g: ECCAenv) (x: atom) (A: ECCAconf)
  | agDef (g: ECCAenv) (x: atom) (v: ECCAcomp)
  | agEq (g: ECCAenv) (v1 v2: ECCAval)
.
Inductive ECCAexp: Type :=
  | eavId (x: atom)
  | eavUni (U: ECCuni)
  | eavPi (x: atom) (A B: ECCAexp)
  | eavAbs (x: atom) (A B: ECCAexp)
  | eavSig (x: atom) (A B: ECCAexp)
  | eavPair (v1 v2: ECCAexp) (A: ECCAexp)
  | eavTru
  | eavFls
  | eavBool
  | eacfComp (e: ECCAexp)
  | eacfLet (x: atom) (A: ECCAexp) (B: ECCAexp)
  | eacfIf (v: ECCAexp) (m1 m2: ECCAexp)
  | eacpApp (v1 v2: ECCAexp)
  | eacpVal (v: ECCAexp)
  | eacpFst (v: ECCAexp)
  | eacpSnd (v: ECCAexp)
  | eacpSubst (x arg body: ECCAexp)
.

Fixpoint flattenECCAval (e: ECCAval): ECCAexp :=
match e with
  | avId x => eavId x
  | avUni U => eavUni U
  | avPi x A B => eavPi x (flattenECCAconf A) (flattenECCAconf B)
  | avAbs x A B => eavAbs x (flattenECCAconf A) (flattenECCAconf B)
  | avSig x A B => eavSig x (flattenECCAconf A) (flattenECCAconf B)
  | avPair v1 v2 A => eavPair (flattenECCAval v1) (flattenECCAval v2) (flattenECCAconf A)
  | avTru => eavTru
  | avFls => eavFls
  | avBool => eavBool
end
with flattenECCAcomp (e: ECCAcomp): ECCAexp :=
match e with
  | acpApp v1 v2 => eacpApp (flattenECCAval v1) (flattenECCAval v2)
  | acpVal v => eacpVal (flattenECCAval v)
  | acpFst v => eacpFst (flattenECCAval v)
  | acpSnd v => eacpSnd (flattenECCAval v)
  | acpSubst x arg body => eacpSubst (flattenECCAval x) (flattenECCAval arg) (flattenECCAval body)
end
with flattenECCAconf (e: ECCAconf): ECCAexp :=
match e with
  | acfComp e => eacfComp (flattenECCAcomp e)
  | acfLet x A B => eacfLet x (flattenECCAcomp A) (flattenECCAconf B)
  | acfIf v m1 m2 => eacfIf (flattenECCAval v) (flattenECCAconf m1) (flattenECCAconf m2)
end.

Coercion acpVal: ECCAval >-> ECCAcomp.
Coercion acfComp: ECCAcomp >-> ECCAconf.

Inductive ECCA_LookupTypeR : ECCAenv -> atom -> ECCAconf -> Prop:=
  | aLT_gFirst (g': ECCAenv) (x: atom) (A: ECCAval):
      ECCA_LookupTypeR (agAssum g' x A) x A
  | aLT_AssumRest (g: ECCAenv) (x x': atom) (A a': ECCAval):
      ECCA_LookupTypeR g x A ->
      (x <> x') ->
      (ECCA_LookupTypeR (agAssum g x' a') x A)
  | aLT_DefRest (g: ECCAenv) (x x': atom) (A a': ECCAval):
      ECCA_LookupTypeR g x A ->
  (*     (x <> x') -> *)
      (ECCA_LookupTypeR (agDef g x' a') x A)
  | aLT_EqRest (g: ECCAenv) (x: atom) (v A v': ECCAval):
      ECCA_LookupTypeR g x A ->
      ECCA_LookupTypeR (agEq g v v') x A
.

Inductive ECCA_LookupDefR : ECCAenv -> atom -> ECCAcomp -> Prop:=
  | aLD_gFirst (g': ECCAenv) (x: atom) (e: ECCAcomp) (A: ECCAconf):
      ECCA_LookupDefR (agAssum (agDef g' x e) x A) x e
  | aLD_AssumRest (g: ECCAenv) (x x': atom) (e: ECCAcomp) (a': ECCAconf):
      ECCA_LookupDefR g x e ->
      (x <> x') ->
      (ECCA_LookupDefR (agAssum g x' a') x e)
  | aLD_DefRest (g: ECCAenv) (x x': atom) (e e': ECCAcomp):
      ECCA_LookupDefR g x e ->
      (x <> x') ->
      (ECCA_LookupDefR (agDef g x' e') x e)
  | aLD_EqRest (g: ECCAenv) (x: atom) (v v': ECCAval) (e: ECCAcomp):
      ECCA_LookupDefR g x e ->
      ECCA_LookupDefR (agEq g v v') x e
.

(*should change val to conf *)
Inductive ECCA_LookupEqR : ECCAenv -> ECCAval -> ECCAval -> Prop:=
  | aLE_gFirst (g': ECCAenv) (v v': ECCAval):
    ECCA_LookupEqR (agEq g' v v') v v'
  | aLE_AssumRest (g: ECCAenv) (x : atom) (v v' a: ECCAval):
      ECCA_LookupEqR g v v' ->
      (ECCA_LookupEqR (agAssum g x a) v v')
  | aLE_DefRest (g: ECCAenv) (x: atom) (v v' e: ECCAval):
      ECCA_LookupEqR g v v' ->
      (ECCA_LookupEqR (agDef g x e) v v')
  | aLE_EqRest (g: ECCAenv) (x: atom) (v1 v2 v1' v2': ECCAval):
      ECCA_LookupEqR g v1 v2 ->
      (v1 <> v1') ->
      ECCA_LookupEqR (agEq g v1' v2') v1 v2
.

Definition aSubst (x: atom) (arg body: ECCAconf): ECCAconf. Proof. Admitted.
Definition ECCA_RedClosR: ECCAenv -> ECCAconf -> ECCAconf -> Prop. Proof. Admitted.
Definition ECCA_Aeq: ECCAconf -> ECCAconf -> Prop. Proof. Admitted.

Definition conf_to_val (e: ECCAconf): option ECCAval :=
match e with
  | acfComp c => match c with
      | acpVal v => Some v
      | _ => None
      end
  | _ => None
  end.

Compute (conf_to_val avTru).
Compute (conf_to_val (acfLet X avTru avTru)).
Compute (conf_to_val (acpVal avTru)).
Compute (conf_to_val (acfComp avTru)).

(* Lemma conf_is_val_dec: forall e: ECCAconf,
(exists v, (conf_to_val e) = Some v) + (conf_to_val e = None). Proof.
intros. destruct e; auto.
  - destruct e; auto.
    +  *)

Inductive ECCA_Equiv: ECCAenv -> ECCAconf -> ECCAconf -> Prop :=
  | aE_Equiv (g: ECCAenv) (e e1 e2: ECCAconf) :
      ECCA_RedClosR g e1 e ->
      ECCA_RedClosR g e2 e ->
      ECCA_Equiv g e1 e2
   | aE_EquivIta1 (g: ECCAenv) (e1 A e e2 e2': ECCAconf) (v2': ECCAval) (x: atom) :
      ECCA_RedClosR g e1 (avAbs x A e) ->
      ECCA_RedClosR g e2 e2' ->
      conf_to_val e2' = Some v2' ->
      ECCA_Equiv (agAssum g x A) e (acpApp v2' (avId x)) ->
      ECCA_Equiv g e1 e2
   | aE_EquivIta2 (g: ECCAenv) (e e1 e1' e2 A : ECCAconf) (v1': ECCAval) (x: atom) :
      ECCA_RedClosR g e1 e1' ->
      ECCA_RedClosR g e2 (avAbs x A e) ->
      conf_to_val e1' = Some v1' ->
      ECCA_Equiv (agAssum g x A) (acpApp v1' (avId x)) e ->
      ECCA_Equiv g e1 e2
  | aE_EquivAlpha (g: ECCAenv) (e1 e2: ECCAconf):
      ECCA_Aeq e1 e2 ->
      ECCA_Equiv g e1 e2
  | aE_Subst1 (g: ECCAenv) (e1 e2 v: ECCAval) (e e': ECCAconf):
      conf_to_val e = Some v ->
      ECCA_Equiv g e e' ->
      ECCA_Equiv g (acpSubst e1 e2 v) e'
  | aE_Subst2 (g: ECCAenv) (e1 e2 v: ECCAval) (e e': ECCAconf):
      conf_to_val e = Some v ->
      ECCA_Equiv g e e' ->
      ECCA_Equiv g e' (acpSubst e1 e2 v)
.

Inductive ECCA_sub_type: ECCAenv -> ECCAconf -> ECCAconf -> Prop :=
| aST_Cong (g: ECCAenv) (A B: ECCAconf) :
  ECCA_Equiv g A B ->
  ECCA_sub_type g A B
| aST_Cum (g: ECCAenv) (i: nat) :
  ECCA_sub_type g (avUni (uType i)) (avUni (uType (S i)))
| aST_Pi (g: ECCAenv) (A1 A2 B1 B2: ECCAconf) (x1 x2: atom) :
  (ECCA_Equiv g A1 A2) ->
  (ECCA_sub_type (agAssum g x1 A2) B1 (aSubst x2 (avId x1) B2)) -> (* eId x1 ?*)
  (ECCA_sub_type g (avPi x1 A1 B1) (avPi x2 A2 B2))
.

Inductive ECCA_val_has_type: ECCAenv -> ECCAval -> ECCAconf -> Prop :=
| aT_Ax_Prop (g: ECCAenv) :
  (ECCA_val_has_type g (avUni uProp) (avUni (uType 0)))
| aT_Ax_Type (g: ECCAenv) (i: nat) :
  (ECCA_val_has_type g (avUni (uType i)) (avUni (uType (S i))))
| aT_Var (g: ECCAenv) (x: atom) (A: ECCAval) :
  (ECCA_LookupTypeR g x A) -> (* this needs adjustment *)
  (ECCA_val_has_type g (avId x) A)
| aT_Bool (g: ECCAenv):
  (ECCA_val_has_type g (avBool) (avUni (uType 0)))
| aT_True (g: ECCAenv):
  (ECCA_val_has_type g (avTru) (avBool))
| aT_False (g: ECCAenv):
  (ECCA_val_has_type g (avFls) (avBool))
| aT_Sig (g: ECCAenv) (x: atom) (A B: ECCAconf) (i: nat) :
  (ECCA_conf_has_type g A (avUni (uType i))) ->
  (ECCA_conf_has_type (agAssum g x A) B (avUni (uType i))) ->
  (ECCA_val_has_type g (avSig x A B) (avUni (uType i)))
| aT_Pair (g: ECCAenv) (v1 v2: ECCAval) (A B: ECCAconf) (x: atom) :
  (ECCA_val_has_type g v1 A) ->
  (ECCA_val_has_type g v2 (aSubst x v1 B)) ->
  (ECCA_val_has_type g (avPair v1 v2 (avSig x A B)) (avSig x A B))
| aT_Prod_Prop (g: ECCAenv) (x: atom) (A B: ECCAconf) (i: nat):
  (ECCA_conf_has_type g A (avUni (uType i))) ->
  (ECCA_conf_has_type (agAssum g x A) B (avUni (uProp))) ->
  (ECCA_val_has_type g (avPi x A B) (avUni (uProp)))
| aT_Prod_Type (g: ECCAenv) (x: atom) (A B: ECCAconf) (i: nat):
  (ECCA_conf_has_type g A (avUni (uType i))) ->
  (ECCA_conf_has_type (agAssum g x A) B (avUni (uType i))) ->
  (ECCA_val_has_type g (avPi x A B) (avUni (uType i)))
| aT_Lam (g: ECCAenv) (x: atom) (A e B: ECCAconf) :
  (ECCA_conf_has_type (agAssum g x A) e B) ->
  (ECCA_val_has_type g (avAbs x A e) (avPi x A B))
| aT_ValIsConf (g: ECCAenv) (v: ECCAval) (e: ECCAconf):
  ECCA_conf_has_type g v e ->
  ECCA_val_has_type g v e
with
ECCA_conf_has_type: ECCAenv -> ECCAconf -> ECCAconf -> Prop :=
| aT_Let (g: ECCAenv) (n: ECCAcomp) (m A B: ECCAconf) (x: atom):
  (ECCA_comp_has_type g n A) ->
(*should this be (def(assum(g))) or (assum(def(g)))*)
  (ECCA_conf_has_type (agDef (agAssum g x A) x n) m B) ->
  (ECCA_conf_has_type g (acfLet x n m) (aSubst x n B))
| aT_If (g: ECCAenv) (B U e1 e2: ECCAconf) (e: ECCAval) (x: atom):
  ECCA_conf_has_type (agAssum g x avBool) B U ->
  ECCA_val_has_type g e avBool ->
  ECCA_conf_has_type (agEq g e avTru) e1 (aSubst x avTru B) ->
  ECCA_conf_has_type (agEq g e avFls) e2 (aSubst x avFls B) ->
  ECCA_conf_has_type g (acfIf e e1 e2) (aSubst x e B)
| aT_Comp (g: ECCAenv) (e: ECCAcomp) (A: ECCAconf):
  ECCA_comp_has_type g e A ->
  ECCA_conf_has_type g (acfComp e) A
| aT_Conv (g: ECCAenv) (e A B U: ECCAconf) :
  (ECCA_conf_has_type g e A) ->
  (ECCA_conf_has_type g B U) ->
  (ECCA_sub_type g A B) ->
  (ECCA_conf_has_type g e B)
with
ECCA_comp_has_type: ECCAenv -> ECCAcomp -> ECCAconf -> Prop :=
| aT_App (g: ECCAenv) (x: atom) (e e': ECCAval) (A' B: ECCAconf) :
  (ECCA_val_has_type g e (avPi x A' B)) ->
  (ECCA_val_has_type g e' A') ->
  (ECCA_comp_has_type g (acpApp e e') (aSubst x e B))
| aT_Fst (g: ECCAenv) (e: ECCAval) (A B: ECCAconf) (x: atom) :
  (ECCA_val_has_type g e (avSig x A B)) ->
  (ECCA_comp_has_type g (acpFst e) A)
| aT_Snd (g: ECCAenv) (e: ECCAval) (A B: ECCAconf) (x: atom) :
  (ECCA_val_has_type g e (avSig x A B)) ->
  (ECCA_comp_has_type g (acpSnd e) (aSubst x (acpFst e) B))
| aT_Subst (x: atom) (g: ECCAenv) (A B U: ECCAconf) (e e1 e2: ECCAval):
  (ECCA_conf_has_type (agAssum g x A) B U) ->
  ECCA_val_has_type g e1 A ->
  ECCA_val_has_type g e2 A ->
  ECCA_val_has_type g e (aSubst x e1 B) ->
  ECCA_LookupEqR g e1 e2 ->
  ECCA_comp_has_type g (acpSubst e1 e2 e) (aSubst x e2 B)
| aT_Val (g: ECCAenv) (v: ECCAval) (A: ECCAconf):
  ECCA_val_has_type g v A ->
  ECCA_comp_has_type g (acpVal v) A
| aT_CompIsConf (g: ECCAenv) (c: ECCAcomp) (e: ECCAconf):
  ECCA_conf_has_type g c e ->
  ECCA_comp_has_type g c e
.

(* -=ECCA Notation=- *)

Bind Scope ECCA_scope with ECCAval.
Bind Scope ECCA_scope with ECCAconf.
Bind Scope ECCA_scope with ECCAcomp.
Bind Scope ECCA_scope with ECCAcont.
Delimit Scope ECCA_scope with ECCA.
Coercion avId: atom >-> ECCAval.
Definition natToAtom (i: nat) : atom := i.
Coercion natToAtom: nat >-> atom.

Notation "'type' x" := (avUni (uType x)) (at level 50):  ECCA_scope.
Notation "'prop'" := (avUni uProp) (at level 50):  ECCA_scope.
Definition example_aType := (type 3)%ECCA: ECCAval.
Definition example_aProp := (prop)%ECCA: ECCAval.

Notation "{ e1 e2 }" := (acpApp e1 e2) (at level 50,e1 at level 9):  ECCA_scope.
Definition example_aApp := { X Y }%ECCA: ECCAcomp.

Notation "'LET' x ':=' A 'in' B" := (acfLet x A B) (at level 50, format "'[v' 'LET'  x  ':='  A '/' 'in' '['  B ']' ']'") : ECCA_scope.
Definition example_aLet := (LET X := Y in Z)%ECCA : ECCAconf.
Print example_aLet.
Definition example_aLet2 := (LET X := (type 3) in LET F := (LET X := (type 2) in X) in ({X F}))%ECC.
Print example_aLet2.

Notation "'P' x : A '->' B" := (avPi x A B) (at level 50, x at level 9, A at level 9) : ECCA_scope.
Definition example_aPi := (P X : Y -> Z)%ECCA : ECCAval.
Notation "'\' x : A '->' B" := (avAbs x A B) (at level 50, x at level 9, A at level 9) : ECCA_scope.
Definition example_aAbs := (\ X : Y -> Z)%ECCA : ECCAval.

Notation "'[]'" := (actHole) (at level 50) : ECCA_scope.
Definition aHole := []%ECCA.
Notation "'LET' x ':=' '[]' 'in' B" := (actLetHole x B) (at level 50) : ECCA_scope.
Definition example_aLetHole := (LET X := [] in X)%ECCA.
Print example_aLetHole.

Goal ECCA_comp_has_type agEmpty (acpFst (avPair avTru avFls
    (avSig X avBool
          (acfIf X avBool (avPi Y avBool avBool))))) avBool.
Proof.
eapply aT_Fst. eapply aT_Pair.
  - apply aT_True.
  - cbv. apply aT_ValIsConf. apply aT_Conv with (A := avBool) (U := (type 0)%ECCA).
    + apply aT_Comp. apply aT_Val. apply aT_False.
    + eapply T_Conv.
      * apply T_If with (U:=(type 1)%ECC).
        -- auto.
        -- auto.
        -- auto.
        -- cbn. eapply T_Prod_Type.
          ++ auto.
          ++ auto.
      * auto.
      * cbn. apply ST_Cong. apply E_EquivAlpha. apply aeq_id.
    + apply ST_Cong. apply E_Equiv with (e:= eBool).
      * auto.
      * eauto.
Unshelve. exact 1.
Qed.

(* End ECCA. *)
(*
Inductive ECCA_Aeq : ECCexp -> ECCexp -> Prop :=
  | aeq_id (e: ECCexp):
    ECC_Aeq e e
  | aeq_var (x: atom):
     ECC_Aeq (eId x) (eId x)
  | aeq_abs_same (x: atom) (t1 t2 b1 b2: ECCexp):
     ECC_Aeq t1 t2 ->
     ECC_Aeq b1 b2 ->
     ECC_Aeq (eAbs x t1 b1) (eAbs x t2 b2)
  | aeq_abs_diff (x y: atom) (t1 t2 b1 b2: ECCexp):
     x <> y ->
     (mem x (FV b2)) = false ->
     ECC_Aeq b1 (swap y x b2) ->
     ECC_Aeq t1 t2 ->
     ECC_Aeq (eAbs x t1 b1) (eAbs y t2 b2)
  | aeq_pi_same (x: atom) (t1 t2 b1 b2: ECCexp):
     ECC_Aeq t1 t2 ->
     ECC_Aeq b1 b2 ->
     ECC_Aeq (ePi x t1 b1) (ePi x t2 b2)
  | aeq_pi_diff (x y: atom) (t1 t2 b1 b2: ECCexp):
     x <> y ->
     (mem x (FV b2)) = false ->
     ECC_Aeq b1 (swap y x b2) ->
     ECC_Aeq t1 t2 ->
     ECC_Aeq (ePi x t1 b1) (ePi y t2 b2)
  | aeq_let_same (x: atom) (t1 t2 b1 b2: ECCexp):
     ECC_Aeq t1 t2 ->
     ECC_Aeq b1 b2 ->
     ECC_Aeq (eLet x t1 b1) (eLet x t2 b2)
  | aeq_let_diff (x y: atom) (t1 t2 b1 b2: ECCexp):
     x <> y ->
     (mem x (FV b2)) = false ->
     ECC_Aeq b1 (swap y x b2) ->
     ECC_Aeq t1 t2 ->
     ECC_Aeq (eLet x t1 b1) (eLet y t2 b2)
  | aeq_sig_same (x: atom) (t1 t2 b1 b2: ECCexp):
     ECC_Aeq t1 t2 ->
     ECC_Aeq b1 b2 ->
     ECC_Aeq (eSig x t1 b1) (eSig x t2 b2)
  | aeq_sig_diff (x y: atom) (t1 t2 b1 b2: ECCexp):
     x <> y ->
     (mem x (FV b2)) = false ->
     ECC_Aeq b1 (swap y x b2) ->
     ECC_Aeq t1 t2 ->
     ECC_Aeq (eSig x t1 b1) (eSig y t2 b2)
  | aeq_app (t1 t2 t1' t2': ECCexp):
     ECC_Aeq t1 t1' -> ECC_Aeq t2 t2' ->
     ECC_Aeq (eApp t1 t2) (eApp t1' t2')
  | aeq_pair (t1 t2 t1' t2' A A': ECCexp):
     ECC_Aeq t1 t1' -> ECC_Aeq t2 t2' ->
     ECC_Aeq A A' ->
     ECC_Aeq (ePair t1 t2 A) (ePair t1' t2' A')
  | aeq_eFst (e e': ECCexp):
     ECC_Aeq e e' ->
     ECC_Aeq (eFst e) (eFst e')
  | aeq_eSnd (e e': ECCexp):
     ECC_Aeq e e' ->
     ECC_Aeq (eSnd e) (eSnd e')
  | aeq_if (e1 e2 e3 e1' e2' e3': ECCexp):
     ECC_Aeq e1 e1' ->
     ECC_Aeq e2 e2' ->
     ECC_Aeq e3 e3' ->
     ECC_Aeq (eIf e1 e2 e3) (eIf e1' e2' e3').

 *)
(* ===ECC to ECCA translation== *)

Fixpoint fill_hole (e: ECCAcomp) (K: ECCAcont): ECCAconf :=
  match K with
    | actHole => acfComp e
    | actLetHole x B => acfLet x e B
end.

(* Plan: starter function starts namestate at max of atoms in the ECCexp, so all new atoms are higher than old atoms. *)

(* {ns : NameState} *)

Fixpoint trans  (ns: atom) (e: ECCexp) (K: ECCAcont) : ECCAconf :=
  let X := (S ns) in
  let Y := (S (S ns)) in
  let Z := (S (S (S ns))) in
  match e with
    | eId x => (fill_hole (acpVal (avId x)) K)
    | ePi x A B => (fill_hole (acpVal (avPi (x) (trans ns A actHole) (trans ns B actHole))) K)
    | eAbs x A e => (fill_hole (acpVal (avAbs x (trans ns A actHole) (trans ns e actHole))) K)
    | eApp e1 e2 =>
        (trans X e1 (actLetHole X
            (trans Y e2 (actLetHole Y
                (fill_hole (acpApp (avId X) (avId Y)) K)))))
    | eLet x e1 e2 => (trans ns e1 (actLetHole x
                          (trans (ns) e2 K)))
    | eSig x A B => (fill_hole (acpVal (avSig x (trans ns A actHole) (trans ns B actHole))) K)
    | ePair e1 e2 A => (trans X e1 (actLetHole X
            (trans Y e2 (actLetHole Y
               (trans Z A (actLetHole Z
                (fill_hole (avPair (avId X) (avId Y) (avId Z)) K)))))))
    | eFst e => (trans X e (actLetHole X
                   (fill_hole (acpFst (avId X)) K)))
    | eSnd e => (trans X e (actLetHole X
                   (fill_hole (acpSnd X) K)))
    | eTru => (fill_hole (acpVal avTru) K)
    | eFls => (fill_hole (acpVal avFls) K)
    | eBool=> (fill_hole (acpVal avBool) K)
    | eUni u => (fill_hole (acpVal (avUni u)) K)
    | eIf e e1 e2 => (trans X e (actLetHole X
                        (acfIf (avId X)
                            (trans Y e1 (actLetHole Y (fill_hole (acpSubst X avTru (avId Y)) K)))
                            (trans Y e1 (actLetHole Y (fill_hole (acpSubst X avFls (avId Y)) K))))))
end.

Definition transStarter (e: ECCexp):=
  trans (fresh (FV e)) e actHole
.

Compute transStarter (LET X := Y in LET Y := type 1 in X)%ECC.
Compute transStarter (fst (<eTru , eFls> as
                            (Sig X : eBool .. (eIf X eBool (Pi Y : eBool -> eBool))))).


(**
   Monad rewriter example
   Builds on ext-lib monads.
 *)

(*Require Import McExamples.PolyRewrite.Monads.MSimpleMonads.
Require Import McExamples.PolyRewrite.Monads.MSimpleMonadsReify.*)
Require Import McExamples.PolyRewrite.Monads.Monad.
Require Import ExtLib.Structures.Monad.
Require Import ExtLib.Tactics.

Module TheMonad (M : Monad) (F : Frob M).
  Import M.
  Import F.

  (* Set-up for Ltac-based rewriter *)

  Definition lem1 := @monad_left_id.
  (* M M_mon M_monOk. *)
  Definition lem2 := @monad_right_id.
  Definition lem3 := @monad_assoc.

  Create HintDb monads.

  Hint Rewrite lem1 lem2 lem3 : monads.

  Definition ex1 := @bind M M_mon _ _ (ret 5) (fun x => ret (x + 1))%nat.
  (* tests *)
  Goal exists x, ex1 = x.
  Proof.
    unfold ex1.
    Time rewrite_strat (bottomup (hints monads; eval cbv beta)).
    eexists; reflexivity.
  Qed.

  (* TODO: Applicative and stuff *)
  Fixpoint makeLeftIdTest (n : nat) : M nat :=
    match n with
    | O => ret 1
    | S n' => bind (makeLeftIdTest n') (fun x => ret (x + 1))
    end.

  Goal (exists x, makeLeftIdTest 80 = x).
    cbv beta zeta iota delta -[bind ret].
    (*    Time autorewrite with monads. *)
    Time  rewrite_strat (bottomup (hints monads; eval cbv beta)).
    eexists; reflexivity.
  Qed.

  Fixpoint makeRightIdTest (n : nat) : M nat :=
    match n with
    | O => ret 1
    | S n' => bind (makeRightIdTest n') ret
    end.

  Goal (exists x, makeRightIdTest 80 = x).
    compute.
    Time autorewrite with monads. (* 1.454s for n = 80 *)
    eexists; reflexivity.
  Qed.

  Fixpoint makeAssocTest (n : nat) : M nat :=
    match n with
    | 0 => frob 1
    | S n' => bind (makeAssocTest n') (fun x => ret (x + 1))
    end.

  Require Import Coq.Classes.Morphisms.
  Require Import Coq.Logic.FunctionalExtensionality.

  (* Needed to setoid_rewrite monadic expressions *)
  Instance bind_proper :
    forall T U,
      Proper (@eq (M T) ==> pointwise_relation T (@eq (M U)) ==> @eq (M U)) bind.
  intros. red. red. intros; subst.
  red. intros.
  unfold pointwise_relation in H.
  apply functional_extensionality in H.
  subst.
  reflexivity.
  Qed.

  (* change to repeat first *)
  (* rtac - reify lemmas, write automation
             will need a simple-ish monad language with bind and ret
             use funext for now
   *)
  Goal (exists x, makeAssocTest 10 = x).
  Proof.
    simpl.
    Time (rewrite_strat (bottomup (hints monads; eval cbv beta))).
    eexists; reflexivity.
  Qed.

  (*   n = depth of overall tree
         k = depth of associations at each node *)
  Fixpoint makeLeftIdAssocTest (n : nat) (k : nat) : M nat :=
    match n with
    | 0 => frob 1
    | S n' => @bind M _ _ nat (makeLeftIdAssocTest n' k) (fun _ => makeAssocTest k)
    end.

  (* 2 2 is another common test *)
  Goal (exists x, makeLeftIdAssocTest 2 2 = x).
    simpl.
    Time rewrite_strat (bottomup (hints monads; eval cbv beta)).
    eexists; reflexivity.
  Qed.

  Goal (exists x, makeLeftIdAssocTest 8 5 = x).
    simpl.
    (* i don't understand why we must have this outer repeat... *)
    Time (rewrite_strat ((bottomup (hints monads; eval cbv beta)))).
    eexists; reflexivity.
  Qed.

  (* n = depth *)
  Fixpoint makeRightIdAssocTest (n : nat) : M nat :=
    match n with
    | 0 => @bind M _ _ nat (frob 1) ret
    | S n' => bind (makeRightIdAssocTest n') (fun k => frob (k + 1))
    end.

  Goal (exists x, makeRightIdAssocTest 2 = x).
  Proof.
    simpl.
    Time rewrite_strat (bottomup (hints monads; eval cbv beta)).
    eexists; reflexivity.
  Qed.

  Module Demo.
    Definition goal := fun n => (exists x, makeRightIdAssocTest n = x).
    Ltac prep := unfold goal; simpl.
    Ltac run := rewrite_strat (bottomup (hints monads; eval cbv beta)).
    Ltac cleanup := eexists; reflexivity.
  End Demo.

End TheMonad.


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

(** * DecimalFacts : some facts about Decimal numbers *)

Require Import Decimal NumeralNotation.

Lemma uint_dec (d d' : uint) : { d = d' } + { d <> d' }.
Proof.
 decide equality.
Defined.

Lemma rev_revapp d d' :
 rev (revapp d d') = revapp d' d.
Proof.
 revert d'. induction d; simpl; intros; now rewrite ?IHd.
Qed.

Lemma rev_rev d : rev (rev d) = d.
Proof.
 apply rev_revapp.
Qed.

(** Normalization on little-endian numbers *)

Fixpoint nztail d :=
 match d with
 | Nil => Nil
 | D0 d => match nztail d with Nil => Nil | d' => D0 d' end
 | D1 d => D1 (nztail d)
 | D2 d => D2 (nztail d)
 | D3 d => D3 (nztail d)
 | D4 d => D4 (nztail d)
 | D5 d => D5 (nztail d)
 | D6 d => D6 (nztail d)
 | D7 d => D7 (nztail d)
 | D8 d => D8 (nztail d)
 | D9 d => D9 (nztail d)
 end.

Definition lnorm d :=
 match nztail d with
 | Nil => zero
 | d => d
 end.

Lemma nzhead_revapp_0 d d' : nztail d = Nil ->
 nzhead (revapp d d') = nzhead d'.
Proof.
 revert d'. induction d; intros d' [=]; simpl; trivial.
 destruct (nztail d); now rewrite IHd.
Qed.

Lemma nzhead_revapp d d' : nztail d <> Nil ->
 nzhead (revapp d d') = revapp (nztail d) d'.
Proof.
 revert d'.
 induction d; intros d' H; simpl in *;
 try destruct (nztail d) eqn:E;
  (now rewrite ?nzhead_revapp_0) || (now rewrite IHd).
Qed.

Lemma nzhead_rev d : nztail d <> Nil ->
 nzhead (rev d) = rev (nztail d).
Proof.
 apply nzhead_revapp.
Qed.

Lemma rev_nztail_rev d :
  rev (nztail (rev d)) = nzhead d.
Proof.
 destruct (uint_dec (nztail (rev d)) Nil) as [H|H].
 - rewrite H. unfold rev; simpl.
   rewrite <- (rev_rev d). symmetry.
   now apply nzhead_revapp_0.
 - now rewrite <- nzhead_rev, rev_rev.
Qed.

Lemma revapp_nil_inv d d' : revapp d d' = Nil -> d = Nil /\ d' = Nil.
Proof.
 revert d'.
 induction d; simpl; intros d' H; auto; now apply IHd in H.
Qed.

Lemma rev_nil_inv d : rev d = Nil -> d = Nil.
Proof.
 apply revapp_nil_inv.
Qed.

Lemma rev_lnorm_rev d :
  rev (lnorm (rev d)) = unorm d.
Proof.
 unfold unorm, lnorm.
 rewrite <- rev_nztail_rev.
 destruct nztail; simpl; trivial;
  destruct rev eqn:E; trivial; now apply rev_nil_inv in E.
Qed.

Lemma nzhead_nonzero d d' : nzhead d <> D0 d'.
Proof.
 induction d; easy.
Qed.

Lemma unorm_0 d : unorm d = 0%uint <-> nzhead d = Nil.
Proof.
 unfold unorm. split.
 - generalize (nzhead_nonzero d).
   destruct nzhead; intros H [=]; trivial. now destruct (H u).
 - now intros ->.
Qed.

Lemma unorm_nonnil d : unorm d <> Nil.
Proof.
 unfold unorm. now destruct nzhead.
Qed.

Lemma nzhead_invol d : nzhead (nzhead d) = nzhead d.
Proof.
 now induction d.
Qed.

Lemma unorm_invol d : unorm (unorm d) = unorm d.
Proof.
 unfold unorm.
 destruct (nzhead d) eqn:E; trivial.
 destruct (nzhead_nonzero _ _ E).
Qed.

Lemma norm_invol d : norm (norm d) = norm d.
Proof.
 unfold norm.
 destruct d.
 - f_equal. apply unorm_invol.
 - destruct (nzhead d) eqn:E; auto.
   destruct (nzhead_nonzero _ _ E).
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* by Evelyne Contejean *)

(**  *Dickson Lemma: the multiset extension of a well-founded ordering is well-founded.
 *)

Set Implicit Arguments.

Require Import Relations.
Require Import List.
Require Import Setoid.
Require Import closure.
Require Import more_list.
Require Import Multiset.
Require Import list_permut.

Module Make (DS1 : decidable_set.S).

Module DS := DS1.
Module LP := list_permut.Make (DS1).
Import LP.

(** ** Definition of the multiset extension of a relation. *)
Inductive multiset_extension_step (R : relation elt) : list elt -> list elt -> Prop :=
  | rmv_case :
     forall l1 l2 l la a, (forall b, In b la -> R b a) ->
      list_permut l1 (la ++ l) -> list_permut l2 (a :: l) ->
      multiset_extension_step R l1 l2.

(** If n << {a} U m, then
      either, there exists n' such that n = {a} U n' and n' << m,
      or, there exists k, such that n = k U m, and k << {a}. *)
Lemma two_cases :
 forall R a m n,
 multiset_extension_step R n (a :: m) ->
 (exists n', list_permut n (a :: n') /\
             multiset_extension_step R n' m) \/
 (exists k, (forall b, In b k -> R b a) /\
            list_permut n (k ++ m)).
Proof.
intros R a m n M; inversion_clear M as [x1 x2 l la a0 H H0 H1];
elim (eq_elt_dec a a0); intro a_eq_a0; subst.

assert (H2 : list_permut m l).
apply remove_context_list_permut_cons with a0; trivial.
right; exists la; split; trivial; setoid_rewrite H0; setoid_rewrite H2; auto.

left; elim (In_dec eq_elt_dec a0 m); intro In_a0.
generalize (split_list_app_cons eq_elt_dec _ _ In_a0); clear In_a0;
destruct (split_list eq_elt_dec m a0); intro; subst.
assert (H2 : list_permut (a :: l0 ++ l1) l).
apply remove_context_list_permut_cons with a0;
setoid_rewrite <- H1; pattern a at 1; do 2 rewrite app_comm_cons;
apply list_permut_add_cons_inside; auto.
exists (la ++ l0 ++ l1); split.
setoid_rewrite H0; setoid_rewrite <- H2; apply list_permut_sym;
apply list_permut_add_cons_inside; auto.
apply (rmv_case (l1:=la ++ l0 ++ l1) (l2:= l0 ++ a0 :: l1) (l:= l0 ++ l1) R la H); auto;
apply list_permut_sym; apply list_permut_add_cons_inside; auto.

absurd (In a0 (a :: m)).
intro H2; elim H2; clear H2; intro H2; subst;
[ absurd (a0 = a0) | absurd (In a0 m) ]; trivial.
setoid_rewrite H1; left; trivial.
Qed.

(** [multiset_extension_step] is compatible with permutation. *)
Lemma list_permut_multiset_extension_step_1 :
  forall R l1 l2 l, list_permut l1 l2 ->
  multiset_extension_step R l1 l -> multiset_extension_step R l2 l.
Proof.
intros R l1 l2 l P M1; inversion M1; subst.
apply (rmv_case (l1:=l2) (l2:=l) (l:=l4) R la H); trivial;
setoid_rewrite <- P; trivial.
Qed.

Lemma list_permut_multiset_extension_step_2 :
  forall R l1 l2 l, list_permut l1 l2 ->
  multiset_extension_step R l l1 -> multiset_extension_step R l l2.
Proof.
intros R l1 l2 l P M1; inversion M1; subst.
apply (rmv_case (l1:=l) (l2:=l2) (l:=l4) R la H); trivial;
setoid_rewrite <- P; trivial.
Qed.

Lemma context_multiset_extension_step_app1 :
  forall R l1 l2 l, multiset_extension_step R l1 l2 ->
                         multiset_extension_step R (l ++ l1) (l ++ l2).
Proof.
intros R l1 l2 l H; destruct H as [l1 l2 l12 la a H P1 P2].
apply (@rmv_case R (l++l1) (l++l2) (l++l12) la a); trivial.
apply list_permut_trans with (l ++ la ++ l12).
apply context_list_permut_app1; trivial.
do 2 rewrite <- app_ass; apply context_list_permut_app2; trivial.
apply list_permut_app_app.
apply list_permut_trans with (l ++ a :: l12).
apply context_list_permut_app1; trivial.
apply list_permut_sym; apply list_permut_add_cons_inside;
apply list_permut_refl.
Qed.

Lemma context_trans_clos_multiset_extension_step_app1 :
  forall R l1 l2 l, trans_clos (multiset_extension_step R) l1 l2 ->
                         trans_clos (multiset_extension_step R) (l ++ l1) (l ++ l2).
Proof.
intros R l1 l2 l H; induction H.
apply t_step; apply context_multiset_extension_step_app1; trivial.
apply t_trans with (l ++ y); trivial.
apply context_multiset_extension_step_app1; trivial.
Qed.

Lemma context_multiset_extension_step_app2 :
  forall R l1 l2 l, multiset_extension_step R l1 l2 ->
                         multiset_extension_step R (l1 ++ l) (l2 ++ l).
Proof.
intros R l1 l2 l H; destruct H as [l1 l2 l12 la a H P1 P2].
apply (@rmv_case R (l1++l) (l2++l) (l12++l) la a); trivial.
rewrite <- app_ass; apply context_list_permut_app2; trivial.
rewrite app_comm_cons; apply context_list_permut_app2; trivial.
Qed.

Add Parametric Morphism R : (@multiset_extension_step R) with signature (list_permut ==> list_permut ==> iff) as mult_morph.
Proof.
intros l1 l2 P12 l3 l4 P34; split; [intro R13 | intro R24].
apply list_permut_multiset_extension_step_2 with l3; trivial.
apply list_permut_multiset_extension_step_1 with l1; trivial.
apply list_permut_multiset_extension_step_2 with l4; auto;
apply list_permut_multiset_extension_step_1 with l2; auto.
Qed.

(** *** Accessibility lemmata. *)
Lemma list_permut_acc :
  forall R l1 l2, list_permut l2 l1 ->
  Acc (multiset_extension_step R) l1 -> Acc (multiset_extension_step R) l2.
Proof.
intros R l1 l2 Meq A1; apply Acc_intro; intros l M2;
inversion A1; apply H; subst;
setoid_rewrite <- Meq; trivial.
Qed.

Add Parametric Morphism R : (Acc (multiset_extension_step R)) with signature (list_permut ==> iff) as acc_morph.
Proof.
intros l1 l2 P; split; [intro A1 | intro A2].
apply list_permut_acc with l1; trivial; setoid_rewrite <- P; auto.
apply list_permut_acc with l2; trivial.
Qed.

Lemma dickson_aux1 :
forall (R : relation elt) a,
 (forall b, R b a ->
  forall m, Acc (multiset_extension_step R) m ->
            Acc (multiset_extension_step R) (b :: m)) ->
 forall m, Acc (multiset_extension_step R) m ->
 (forall m', (multiset_extension_step R) m' m ->
             Acc (multiset_extension_step R) (a :: m')) ->
 Acc (multiset_extension_step R) (a :: m).
Proof.
intros R a IH2_a m Acc_m IHa_M; apply Acc_intro;
intros n H; elim (two_cases H); clear H.
intros [n' [P M]]; refine (list_permut_acc P _); apply IHa_M; trivial.
intros [k [M P]]; refine (list_permut_acc P _); clear P; induction k; trivial; simpl;
apply IH2_a.
apply M; left; trivial.
apply IHk; intros; apply M; right; trivial.
Qed.

Lemma dickson_aux2 :
forall R m,
  Acc (multiset_extension_step R) m ->
  forall a, (forall b, R b a ->
             forall m, Acc (multiset_extension_step R) m ->
                       Acc (multiset_extension_step R) (b :: m)) ->
   Acc (multiset_extension_step R) (a :: m).
Proof.
intros R m Acc_m a IH2_a;
apply (Acc_iter  (R:= multiset_extension_step R)
(fun m => Acc (multiset_extension_step R) m ->
Acc (multiset_extension_step R) (a :: m))); trivial;
clear m Acc_m;
intros m H Acc_m; apply dickson_aux1; trivial;
intros; apply H; trivial;
apply Acc_inv with m; trivial.
Qed.

Lemma dickson_aux3 :
forall R a, Acc R a -> forall m, Acc (multiset_extension_step R) m ->
Acc (multiset_extension_step R) (a :: m).
Proof.
intros R a Acc_a;
apply (Acc_iter  (R:= R)
(fun a => Acc R a -> forall m, Acc (multiset_extension_step R) m ->
Acc (multiset_extension_step R) (a :: m))); trivial;
clear a Acc_a;
intros a H Acc_a m Acc_m; apply dickson_aux2; trivial;
intros; apply H; trivial;
apply Acc_inv with a; trivial.
Qed.

(** Main lemma. *)
Lemma dickson :
  forall R, well_founded R -> well_founded (multiset_extension_step R).
Proof.
intros R Wf_R; unfold well_founded in *;
intros m; induction m as [ | a m].
apply Acc_intro; intros m H; inversion_clear H;
absurd (a :: l = nil);
[ discriminate | apply list_permut_nil; setoid_rewrite H2; auto].
apply dickson_aux3; trivial.
Qed.

Lemma multiset_closure :
  forall R p q, transitive _ R ->
  closure.trans_clos (multiset_extension_step R) p q ->
	exists p', exists q', exists pq,
   	list_permut p (p' ++ pq) /\
   	list_permut q (q' ++ pq) /\
   	q' <> nil /\
   	(forall a, In a p' -> exists b, In b q' /\ R a b).
Proof.
intros R p q trans_R p_lt_q; induction p_lt_q as [p q p_lt_q | p q r p_lt_q q_lt_r].
destruct p_lt_q as [p q pq la a H Pp Pq].
exists la; exists (a :: nil); exists pq; simpl; split; trivial.
split; trivial.
split; trivial.
discriminate.
intros b b_in_la; exists a; split; [left; trivial | apply H; trivial].
destruct p_lt_q as [p q pq la a la_lt_a Pp Pq].
generalize IHq_lt_r; clear IHq_lt_r.
intros [q' [r' [qr [Pq' [Pr [r'_diff_nil q'_lt_r']]]]]].
assert (a_in_q'_qr : In a (q' ++ qr)).
apply in_permut_in with q; trivial.
apply in_permut_in with (a :: pq); [left | apply list_permut_sym]; trivial.
destruct (in_app_or _ _ _ a_in_q'_qr) as [a_in_q' | a_in_qr]; clear a_in_q'_qr.
generalize (split_list_app_cons eq_elt_dec _ _ a_in_q');
destruct (split_list eq_elt_dec q' a) as [q1' q2']; intro; subst.
exists (la ++ q1' ++ q2'); exists r'; exists qr; split.
refine (list_permut_trans Pp _).
do 2 rewrite app_ass; apply context_list_permut_app1.
apply list_permut_remove_hd with a.
refine (list_permut_trans (list_permut_sym Pq) _).
rewrite app_comm_cons; rewrite <- app_ass; trivial.
split; trivial.
split; trivial.
intros b b_in_la_q1'_q2';
destruct (in_app_or _ _ _ b_in_la_q1'_q2') as [b_in_la | b_in_q1'_q2'];
clear b_in_la_q1'_q2'; [idtac |
destruct (in_app_or _ _ _ b_in_q1'_q2') as [b_in_q1' | b_in_q2']; clear b_in_q1'_q2'].
destruct (q'_lt_r' a a_in_q') as [c [c_in_r' a_lt_c]]; exists c; split; trivial.
apply trans_R with a; trivial; apply la_lt_a; trivial.
apply q'_lt_r'; apply in_or_app; left; trivial.
apply q'_lt_r'; apply in_or_app; right; right; trivial.

generalize (split_list_app_cons eq_elt_dec _ _ a_in_qr);
destruct (split_list eq_elt_dec qr a) as [qr1 qr2]; intro; subst.
exists (la ++ q'); exists (a :: r'); exists (qr1 ++ qr2); split.
refine (list_permut_trans Pp _).
rewrite app_ass; apply context_list_permut_app1.
rewrite <- app_ass; apply list_permut_remove_hd with a.
refine (list_permut_trans (list_permut_sym Pq) _).
rewrite app_ass; trivial.
split.
refine (list_permut_trans Pr _); rewrite <- app_ass;
apply list_permut_sym; simpl; apply list_permut_add_cons_inside;
rewrite ass_app; apply list_permut_refl.
split.
discriminate.
intros b b_in_la_q';
destruct (in_app_or _ _ _ b_in_la_q') as [b_in_la | b_in_q']; clear b_in_la_q'.
exists a; split; [left | apply la_lt_a]; trivial.
destruct (q'_lt_r' _ b_in_q') as [c [c_in_r' b_lt_c]].
exists c; split; trivial; right; trivial.
Qed.

(*
Lemma trans_multiset_extension_step :
  forall R, antisymmetric elt R -> transitive elt R ->
  transitive (list elt) (multiset_extension_step R).
Proof.
intros R antisym trans.
intros l1 l2 l3 R12 R23.
destruct R12 as [ l1 l2 l12 la1 a2 H1 P1 P2].
destruct R23 as [ l2 l3 l23 la2 a3 H2 P2' P3].
generalize (ac_syntactic l12 (a2 :: nil) l23 la2 (list_permut_trans (list_permut_sym P2) P2')).
intros [u1 [u2 [u3 [u4 [Q1 [Q2 [Q3 Q4]]]]]]].
destruct u3 as [ | b3 u3]; destruct u4 as [ | b4 u4].
assert (H := list_permut_length Q2); discriminate.
destruct u4 as [ | c4 u4].
simpl in Q2; rewrite <- app_nil_end in Q3.
assert (a2_eq_b4 := list_permut_length_1 Q2); subst b4; clear Q2.
apply (@rmv_case R l1 l3 u1 (app la1 u2) a3).
intros b H; destruct (in_app_or _ _ _ H) as [b_in_la1 | b_in_u2]; clear H.
(*** ici ****)
     forall l1 l2 l la a, (forall b, In b la -> R b a) ->
      list_permut l1 (la ++ l) -> list_permut l2 (a :: l) ->
      multiset_extension_step R l1 l2.

assert (H := list_permut_length Q2).
 discriminate.
*)
End Make.


Module CoColor.
	CoInductive color  :=
		  Color (red : nat) (green : nat) (blue : nat).

	Definition isColor  (__input : color) : Prop :=
		match __input with
			  Color _ _ _ => True
		end.

	Definition getColorRed  (__input : color) : isColor __input -> nat :=
		match __input with
			  Color red _ _ => fun __precondition => red
		end.

	Definition getColorGreen  (__input : color) : isColor __input -> nat :=
		match __input with
			  Color _ green _ => fun __precondition => green
		end.

	Definition getColorBlue  (__input : color) : isColor __input -> nat :=
		match __input with
			  Color _ _ blue => fun __precondition => blue
		end.
End CoColor.

Module Color.
	Parameter Label : Type.

	CoInductive color  :=
		  Color (red : nat) (green : nat) (blue : nat)
		| Labeled (__tag : Label) (__data : color)
		| Reference (__tag : Label).

	Definition isColor  (__input : color) : Prop :=
		match __input with
			  Color _ _ _ => True
			| _ => False
		end.

	Definition isLabeled  (__input : color) : Prop :=
		match __input with
			  Labeled _ _ => True
			| _ => False
		end.

	Definition isReference  (__input : color) : Prop :=
		match __input with
			  Reference _ => True
			| _ => False
		end.

	Definition getColorRed  (__input : color) : isColor __input -> nat :=
		match __input with
			  Color red _ _ => fun __precondition => red
			| _ => fun __precondition => match __precondition with end
		end.

	Definition getColorGreen  (__input : color) : isColor __input -> nat :=
		match __input with
			  Color _ green _ => fun __precondition => green
			| _ => fun __precondition => match __precondition with end
		end.

	Definition getColorBlue  (__input : color) : isColor __input -> nat :=
		match __input with
			  Color _ _ blue => fun __precondition => blue
			| _ => fun __precondition => match __precondition with end
		end.

	Definition getLabeled__tag  (__input : color) : isLabeled __input -> Label :=
		match __input with
			  Labeled __tag _ => fun __precondition => __tag
			| _ => fun __precondition => match __precondition with end
		end.

	Definition getLabeled__data  (__input : color) : isLabeled __input -> color :=
		match __input with
			  Labeled _ __data => fun __precondition => __data
			| _ => fun __precondition => match __precondition with end
		end.

	Definition getReference__tag  (__input : color) : isReference __input -> Label :=
		match __input with
			  Reference __tag => fun __precondition => __tag
			| _ => fun __precondition => match __precondition with end
		end.

	Inductive subterm  (__root : color) : color -> Type :=
		  SubRoot : subterm __root __root
		| SubLabeled : forall __tag __data, subterm __root (Labeled  __tag __data) -> subterm __root __data.
End Color.


(*******************************************************************)
(*  This is part of RelationAlgebra, it is distributed under the   *)
(*    terms of the GNU Lesser General Public License version 3     *)
(*              (see file LICENSE for more details)                *)
(*                                                                 *)
(*  Copyright 2012: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(*******************************************************************)

(** * kat_reification: various definitions to ease the KAT reification process *)

(** We reify KAT terms as [syntax.expr] trees over an alphabet
   including [lsyntax.expr] for Boolean tests. This allows us to reuse
   the tools developped for ra_{normalise,reflexivity}, and this gives
   us more flexibility

   Here define the conversion function from this syntax to [gregex],
   as well as dependently typed positive maps to ease the definition
   of the environment for predicate variables *)

Require Import lsyntax ordinal lset.
Require Export positives kat gregex syntax.

Section s.
Notation Idx := positive.       (* type indices *)
Notation Sigma := positive.     (* Kleene variable indices *)
Notation Pred := positive.      (* predicate variables indices *)

Context {X: kat.ops}.

(** * Dependently types positive maps *)

(** we use dependently typed binary trees:
   [v f'] is used to repredent dependent functions of
   type [forall n, Pred -> tst (f' n)] *)
Inductive v: (Idx -> ob X) -> Type :=
| v_L: forall f', v f'
| v_N: forall f',
  v (fun n => f' (xO n)) ->
  (Pred -> tst (f' xH)) ->
  v (fun n => f' (xI n)) -> v f'.

(** [v_get] transforms such a tree into the corresponding function,
   using [lattice.top] to fill the gaps *)
Fixpoint v_get f' (t: v f') n p: tst (f' n) :=
  match t with
    | v_L _ => lattice.top
    | v_N _ l m r =>
      match n with
        | xO n => v_get _ l n p
        | xI n => v_get _ r n p
        | xH => m p
      end
  end.

(** [v_add f' t n x] adds the binding [(n,x)] to [t] *)
Fixpoint v_add f' (t: v f') n: (Pred -> tst (f' n)) -> v f' :=
  match t with
    | v_L f' =>
        match n with
        | xH => fun x => v_N _ (v_L _) x (v_L _)
        | xO n => fun x => v_N _
          (v_add (fun n => f' (xO n)) (v_L _) n x) (fun _ => lattice.top) (v_L _)
        | xI n => fun x => v_N _
          (v_L _) (fun _ => lattice.top) (v_add (fun n => f' (xI n)) (v_L _) n x)
        end
    | v_N f' l y r =>
        match n with
        | xH => fun x => v_N _ l x r
        | xO n => fun x => v_N _ (v_add (fun n => f' (xO n)) l n x) y r
        | xI n => fun x => v_N _ l y (v_add (fun n => f' (xI n)) r n x)
        end
    end.

(** * Syntax of KAT reification *)

(** we use packages for Kleene variables, as for [ra_refication]  *)
Context {f': Idx -> ob X} {fs: Sigma -> Pack X f'}.

(** reified KAT expressions are just generic expressions
   ([syntax.expr]) over the following alphabet, which includes
   [lsyntax.expr] for Boolean expressions. The index type of the
   Boolean expressions is declared only once, at the [e_var] nodes
   switching from [syntax.expr] to [lsyntax.expr] *)
Definition var := (Sigma + Idx * lsyntax.expr Pred)%type.

(** typing functions for this alphabet: use the packages for Kleene
   variables, and the declared type for Boolean expressions *)
Definition s' (a: var) := match a with inl a => src_ fs a | inr (n,_) => n end.
Definition t' (a: var) := match a with inl a => tgt_ fs a | inr (n,_) => n end.

(** final type of reified KAT expressions *)
Definition kat_expr := expr s' t'.

(** additional constructors:
   - [e_inj n p] injects a Boolean expression [p], at type [n]
   - [e_var i] produces a Kleene variable
   - [p_var a] produces a predicat variable
   *)
Definition e_inj n p: kat_expr n n := e_var (inr (n,p)).
Definition e_var i: kat_expr (src_ fs i) (tgt_ fs i) := e_var (inl i).
Definition p_var := @lsyntax.e_var Pred.

Section e.

(** * Interpretation of KAT reified expressions *)

(** we use the interpretations functions [syntax.expr] and
   [lsyntax.expr], with the appropriate substitutions *)

Variable fp: forall n, Pred -> tst (f' n).

Definition eval: forall n m, kat_expr n m -> X (f' n) (f' m) :=
  syntax.eval (fun a =>
    match a return X (f' (s' a)) (f' (t' a)) with
      | inl a => val (fs a)
      | inr (n,p) => inj (lsyntax.eval (fp n) p)
    end).

End e.

(** * Predicate variables of a KAT expression *)
Fixpoint vars {n m} (e: kat_expr n m): list Pred :=
  match e with
    | e_zer _ _
    | e_top _ _
    | e_one _ => []
    | e_pls x y
    | e_cap x y
    | e_ldv x y
    | e_rdv x y
    | e_dot x y => union (vars x) (vars y)
    | e_neg x
    | e_itr x
    | e_str x
    | e_cnv x => vars x
    | syntax.e_var (inr (_,x)) => lsyntax.vars x
    | syntax.e_var _ => []
  end.

(** index of an element in a list, as an ordinal.
   Together with the list of all predicate variables indices appearing in a
   reified term, this function will allow us to convert positive
   indices to ordinal ones, as required byb [gregex]. *)
Fixpoint idx (x: Pred) (l: list Pred): option (ord (length l)) :=
  match l with
    | [] => None
    | y::q =>
      if eqb_pos x y then Some ord0 else
      match idx x q with Some i => Some (ordS i) | None => None end
  end.

(** * From reified KAT expressions to [gregex] *)

(** we interpret the expression in the [gregex] model,
   mapping all Boolean expressions with positives variables
   to their counterpart with ordinal variables *)
Definition to_gregex (l: list positive):
  forall n m, kat_expr n m -> gregex (length l) (src_ fs) (tgt_ fs) n m :=
    syntax.eval (fun a =>
      match a return gregex _ (src_ fs) (tgt_ fs) (s' a) (t' a) with
        | inl a => g_var a
        | inr (n,p) => g_prd _ _
          (* here we just map all predicate variable indices
             into their ordinal counterpart *)
          (lsyntax.eval (fun x =>
            match idx x l with
              | Some i => lsyntax.e_var i
              | None => lsyntax.e_top: lsyntax.expr_ BL
            end) p)
      end).

(** correctness of the [idx] function *)
Lemma in_idx x l: In x l -> exists j, idx x l = Some j /\ nth j l xH = x.
Proof.
  induction l. intros []. intro Hl. simpl idx. case eqb_spec.
  intros <-. exists ord0. now split.
  destruct Hl as [<-|Hl]. congruence.
  intros _. apply IHl in Hl as [j [-> Hj]]. exists (ordS j). split. reflexivity.
  destruct j. assumption.
Qed.

(** factorisation of the interpretation function, through [gregex]

   since the type of expressions is slightly to big (it contains
   residuals and converse, for instance), we have to check that the
   expression does not use such constructions, whence the first
   hypothesis. *)
Lemma to_gregex_eval {L: laws X} v n m e fp: e_level e << BKA -> vars e <== v ->
  eval fp n m e ==
  gregex.eval f' (fun n i => fp n (nth i v xH)) (fun i => val (fs i)) (to_gregex v n m e).
Proof.
  induction e; simpl e_level; simpl (vars _); intros Hl Hv;
    try discriminate_levels; simpl; rewrite ?union_app in Hv.
   reflexivity.
   symmetry. apply kat.inj_top.
   apply cup_weq.
    apply IHe1. solve_lower'. rewrite <- Hv. lattice.
    apply IHe2. solve_lower'. rewrite <- Hv. lattice.
   apply dot_weq.
    apply IHe1. solve_lower'. rewrite <- Hv. lattice.
    apply IHe2. solve_lower'. rewrite <- Hv. lattice.
   apply itr_weq, IHe. solve_lower'. assumption.
   rewrite kat.inj_top, <-str_itr. apply str_weq, IHe. solve_lower'. assumption.
   destruct a as [a|[n p]]. reflexivity.
   simpl. apply kat.inj_weq. clear Hl.
   induction p; simpl; simpl (lsyntax.vars _) in Hv; rewrite ?union_app in Hv.
    reflexivity.
    reflexivity.
    apply cup_weq.
     apply IHp1. rewrite <-Hv. lattice.
     apply IHp2. rewrite <-Hv. lattice.
    apply cap_weq.
     apply IHp1. rewrite <-Hv. lattice.
     apply IHp2. rewrite <-Hv. lattice.
    apply neg_weq, IHp. assumption.
    simpl. destruct (in_idx a v) as [j [-> Hj]]. apply Hv; now left.
    simpl. now rewrite Hj.
Qed.

(** as a corollary, we get the reification lemma
   (The hypothesis that expressions do not use forbidden symbols will be easily
   checked by reflection, dynamically.) *)

Corollary to_gregex_weq {L: laws X} n m e f fp:
  e_level e + e_level f << BKA ->
  (let v := vars (e_pls e f) in to_gregex v n m e == to_gregex v n m f) ->
  eval fp n m e == eval fp n m f.
Proof.
  intros Hl H. rewrite 2(to_gregex_eval (vars (e_pls e f)))
    by (solve_lower' || simpl (vars _); rewrite union_app; lattice).
   apply H, L.
Qed.

End s.

Arguments e_inj _ _ _ _%positive _%last.
Arguments e_var _ _ _ _%positive.
Arguments p_var _%positive.

(** Load ML reification modules *)

Declare ML Module "ra_common".
Declare ML Module "kat_reification".


Definition range(M: map K V): set V :=
  snd (domain_and_range M).


Definition empty_set: set E := nil.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
From Coq Require Import Strings.Ascii.
From Coq Require Import Arith.Arith.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.EqNat.
From Coq Require Import Lists.List.
Import ListNotations.
From LF Require Import Maps Imp.

Definition isWhite (c : ascii) : bool :=
  let n := nat_of_ascii c in
  orb (orb (n =? 32) (* space *)
           (n =? 9)) (* tab *)
      (orb (n =? 10) (* linefeed *)
           (n =? 13)). (* Carriage return. *)
Notation "x '<=?' y" := (x <=? y)
  (at level 70, no associativity) : nat_scope.
Definition isLowerAlpha (c : ascii) : bool :=
  let n := nat_of_ascii c in
    andb (97 <=? n) (n <=? 122).
Definition isAlpha (c : ascii) : bool :=
  let n := nat_of_ascii c in
    orb (andb (65 <=? n) (n <=? 90))
        (andb (97 <=? n) (n <=? 122)).

Definition isDigit (c : ascii) : bool :=
  let n := nat_of_ascii c in
    andb (48 <=? n) (n <=? 57).
Inductive chartype := white | alpha | digit | other.

Definition classifyChar (c : ascii) : chartype :=
  if isWhite c then
    white
  else if isAlpha c then
    alpha
  else if isDigit c then
    digit
  else
    other.
Fixpoint list_of_string (s : string) : list ascii :=
    match s with
    | EmptyString => []
    | String c s => c :: (list_of_string s)
    end.
Fixpoint string_of_list (xs : list ascii) : string :=
    fold_right String EmptyString xs.
Definition token := string.
Fixpoint tokenize_helper (cls : chartype) (acc xs : list ascii)
                         : list (list ascii) :=
 let tk := match acc with [] => [] | _::_ => [rev acc] end in
 match xs with
    | [] => tk
    | (x::xs') =>
      match cls, classifyChar x, x with
      | _, _, "(" =>
        tk ++ ["("]::(tokenize_helper other [] xs')
      | _, _, ")" =>
        tk ++ [")"]::(tokenize_helper other [] xs')
      | _, white, _ =>
        tk ++ (tokenize_helper white [] xs')
      | alpha,alpha,x =>
        tokenize_helper alpha (x::acc) xs'
      | digit,digit,x =>
        tokenize_helper digit (x::acc) xs'
      | other,other,x =>
        tokenize_helper other (x::acc) xs'
      | _,tp,x =>
        tk ++ (tokenize_helper tp [x] xs')
      end
    end %char.

Definition tokenize (s : string) : list string :=
    map string_of_list (tokenize_helper white [] (list_of_string s)).