(********************************************************)
(*    OrderedList.v                                     *)
(*     Ordered List                                     *)
(*                               thery@sophia.inria.fr  *)
(*                                      (2006)          *)
(********************************************************)
Require Import List.
Require Import Permutation.
Require Import UList.

Section ordered.

(* The type of the elements in the list *)
Variable A: Set.

(* Comparison values *)
Inductive cmp : Set := lt | eq | gt.

(* Opposite *)
Definition opp v := match v with lt => gt | eq => eq | gt => lt end.

(* Weight function *)
Variable weight : A -> A -> cmp.

(* Transitivity *)
Hypothesis weight_trans :
  forall a b c, weight a b = weight b c -> weight a c = weight a b.

(* Anti symmetry *)
Hypothesis weight_anti_sym :
  forall a b, weight b a = opp (weight a b).

(* Reflexivity *)
Theorem weight_refl a : weight a a = eq.
Proof.
generalize (weight_anti_sym a a);
  case (weight a a); auto; intros; discriminate.
Qed.

(* Compatibility left *)
Hypothesis weight_compat_l :
  forall a b c, weight a b = eq -> weight a c = weight b c.

(* Compatibility right *)
Theorem weight_compat_r a b c : weight a b = eq -> weight c a = weight c b.
Proof.
intro H; repeat rewrite (fun x => weight_anti_sym x c).
rewrite weight_compat_l with (b := b); auto.
Qed.

(* No collision *)
Hypothesis weight_exact : forall a b, weight a b = eq -> a = b.

Theorem weight_equiv a b : weight a b = eq <-> a = b.
Proof.
split; intros H; subst; auto.
apply weight_refl.
Qed.

Definition A_dec (a b : A) : {a = b} + {a <> b}.
Proof.
generalize (weight_equiv a b);
 case (weight a b); intros (H1, H2); auto.
  right; intros H; generalize (H2 H); intros; discriminate.
right; intros H; generalize (H2 H); intros; discriminate.
Defined.

(* Ordered list *)
Inductive olist: list A -> Prop :=
   olist_nil: olist nil
|  olist_one: forall a, olist (a :: nil)
| olist_cons: forall a b l,
      weight a b = lt -> olist (b::l) -> olist (a::b::l).

(* Removing the first element of an ordered list, the list
   remains ordered
 *)
Theorem olist_inv a l : olist (a :: l) -> olist l.
Proof.
case l; simpl; auto.
intros H; apply olist_nil.
intros a1 l1 H; inversion H; auto.
Qed.

(* Removing the second element of an ordered list, the list
   remains ordered
 *)
Theorem olist_skip  a b l : olist (a :: b :: l) -> olist (a :: l).
Proof.
revert a b; elim l; simpl; auto.
  intros; apply olist_one.
intros a1 l1 Rec a2 b1 H.
assert (Eq1: weight a2 b1 = lt).
  inversion H; auto.
assert (Eq2: weight b1 a1 = lt).
  inversion_clear H as [| H0 H1|]; auto.
  inversion_clear H1 ; auto.
apply olist_cons; auto.
  rewrite weight_trans with (b := b1); auto.
  apply trans_equal with (1 := Eq1); auto.
inversion_clear H; auto.
inversion_clear H1; auto.
Qed.

(* All the elements in an ordered list are smaller thant the head *)
Theorem olist_weight a b l :
  olist (a :: l) -> In b l -> weight a b = lt.
Proof.
intro H; generalize a b H; elim l; clear a b l H.
  intros a b _ H1; case H1.
simpl; intros a1 l Rec a b H [H1 | H1]; subst; auto.
  inversion H; auto.
assert (Eq1: weight a a1 = lt).
  inversion H; auto.
rewrite weight_trans with (b := a1); auto.
rewrite Eq1; apply sym_equal; apply Rec; auto.
inversion_clear H; auto.
Qed.

(* An ordered list is unique *)
Theorem olist_ulist l : olist l -> ulist l.
Proof.
elim l; simpl; auto.
intros a l1; case l1; auto.
intros b l2 Rec H; inversion_clear H as [| H0 H1 |].
apply ulist_cons; auto.
simpl; intros [H2 | H2]; subst; auto.
  rewrite weight_refl in H0; discriminate.
generalize (weight_anti_sym a b); rewrite H0.
rewrite olist_weight with (l := l2); auto.
intros; discriminate.
Qed.

(* Check if a literal is in a clause *)
Fixpoint is_in (a: A) (l: list A) {struct l}: bool :=
  match l with
    nil => false
  | b :: l1 =>
     match weight a b with
       eq => true
     | lt => false
     | gt => is_in a l1
     end
  end.

Theorem is_in_correct a l : olist l -> if is_in a l then In a l else ~ In a l.
Proof.
elim l; simpl; auto.
intros b l1 Rec H.
assert (F0: olist l1); try (apply olist_inv with (1 := H)).
case_eq (weight a b); intros H1; auto.
- intros [H3 | H3]; subst; auto.
    rewrite weight_refl in H1; discriminate.
  generalize (weight_anti_sym b a); rewrite H1.
  rewrite olist_weight with (l := l1); simpl; intros; auto;
  discriminate.
- rewrite weight_exact with (1 := H1); auto.
- generalize (Rec F0); case (is_in a l1); auto.
  intros H3 [H4 | H4]; subst; auto.
  rewrite weight_refl in H1; discriminate.
Qed.

(* Insert an element in an ordered list with duplication *)
Fixpoint insert (a: A) (l: list A) {struct l}: list A :=
  match l with
    nil => a :: nil
  | b :: l1 =>
      match weight a b with
        lt => a :: l
      | eq => l
      | gt => b :: insert a l1
      end
  end.

(* The inserted element is in the result *)
Theorem insert_in a l : In a (insert a l).
Proof.
elim l; simpl; auto.
intros b l1 H; case_eq (weight a b); auto with datatypes.
intros H1; rewrite weight_exact with (1 := H1);
  auto with datatypes.
Qed.

(* The initial list is in the result *)
Theorem insert_incl a l : incl l (insert a l).
Proof.
elim l; simpl; auto with datatypes.
intros b l1 H; case_eq (weight a b); auto with datatypes.
Qed.

(* The result contains only the initial list or the inserted element *)
Theorem insert_inv a b l : In a (insert b l) -> a = b \/ In a l.
Proof.
elim l; simpl; auto with datatypes.
  intuition.
intros c l1 H; case_eq (weight b c); simpl; auto with datatypes.
  intuition.
intuition.
Qed.

(* If the initial list is ordered so is the result *)
Theorem insert_olist a l : olist l -> olist (insert a l).
Proof.
elim l; simpl; auto.
  intros; apply olist_one; auto.
intros b l1 Rec H; case_eq (weight a b); intros H1; auto.
  apply olist_cons; auto.
assert (Eq1: olist l1); try apply olist_inv with (1 := H).
generalize (Rec Eq1).
assert (Eq2: forall c, In c (insert a l1) -> weight b c = lt).
  intros c H2.
  case insert_inv with (1 := H2); auto.
    intros; subst; rewrite weight_anti_sym; rewrite H1; auto.
  intros H3; apply olist_weight with (1 := H); auto.
generalize Eq2; case (insert a l1); auto.
  intros; apply olist_one.
intros c l2 H2 H3; apply olist_cons; auto with datatypes.
Qed.

(* Insert an element in an ordered list l if needed (a does not
   occur in l) and then call the continuation f with the tail of l
 *)
Fixpoint insert_cont (f: list A -> list A) (a: A) (l: list A) {struct l}:
      list A :=
  match l with
    nil => a :: f nil
  | b :: l1 =>
      match weight a b with
        lt => a :: f l
      | eq => a :: f l1
      | gt => b :: insert_cont f a l1
      end
  end.

(* Merge two ordered lists *)
Fixpoint merge (l1 l2: list A) {struct l1}: list A :=
  match l1 with
    nil => l2
  | a :: l3 => insert_cont (merge l3) a l2
  end.

Theorem merge_incl_l l1 l2 : incl l1 (merge l1 l2).
Proof.
revert l2; elim l1; simpl; auto with datatypes; clear l1.
  intros l2 a H; case H.
intros a l1 Rec l2 b; simpl; intros [H | H]; subst; auto.
  elim l2; simpl; auto; clear l2.
  intros c l2 Rec1; case_eq (weight b c); intros H; auto with datatypes.
elim l2; simpl; auto; clear l2.
  right; apply (Rec nil b); auto.
intros c l2 Rec1; case_eq (weight a c); intros H1; auto with datatypes.
  simpl; right; apply (Rec (c :: l2) b); auto.
simpl; right; apply (Rec l2 b); auto.
Qed.

Theorem merge_incl_r l1 l2 : incl l2 (merge l1 l2).
Proof.
revert l2; elim l1; simpl; auto with datatypes.
intros a l3 Rec l2; elim l2; simpl; auto with datatypes; clear l2.
intros b l2 Rec1; case_eq (weight a b); intros H; auto with datatypes.
intro c; simpl; intros [H1 | H1]; subst.
  left; apply weight_exact; auto.
right; apply (Rec l2 c); auto.
Qed.

Theorem merge_inv a l1 l2 : In a (merge l1 l2) -> In a l1 \/ In a l2.
Proof.
revert l2; elim l1; simpl; auto; clear l1.
intros b l1 Rec l2; elim l2; simpl; auto; clear l2.
  intros [H | H]; auto.
  case (Rec nil); auto.
intros c l2 Rec1; case (weight b c); simpl; intros [H | H]; subst; auto.
- case (Rec (c :: l2)); auto.
- case (Rec l2); auto.
- case Rec1; auto.
Qed.

(* Old trick to prove that ordering is preserved we first need
   to prove something stronger
 *)
Theorem merge_olist_strong a l1 l2 :
  olist (a :: l1) -> olist (a :: l2)  -> olist (a :: merge l1 l2).
revert a l2; elim l1; simpl; auto; clear l1.
intros b l1 Rec a l2 H.
assert (V1: weight a b = lt); try apply olist_weight with (1 := H); auto with datatypes.
assert (V2: olist (b :: l1)); try apply olist_inv with (1 := H).
generalize a V1; elim l2; simpl; clear a l2 H V1; auto.
  intros a V1 _; apply olist_cons; auto.
  apply Rec; auto.
  apply olist_one; auto.
intros c l2 Rec1 a V1 H1; case_eq (weight b c); intros H2.
- apply olist_cons; auto.
  apply Rec; auto with datatypes.
  apply olist_cons; auto.
  apply olist_inv with (1 := H1); auto.
- apply olist_cons; auto.
  apply Rec; auto with datatypes.
  rewrite weight_exact with (1 := H2); auto.
  apply olist_inv with (1 := H1); auto.
- apply olist_cons; auto.
  apply olist_weight with (1 := H1); auto with datatypes.
  apply Rec1; auto.
    rewrite weight_anti_sym; rewrite H2; auto.
  apply olist_inv with (1 := H1); auto.
Qed.

(* merge keeps ordering *)
Theorem merge_olist l1 l2 :
  olist l1 -> olist l2  -> olist (merge l1 l2).
Proof.
case l1; clear l1; simpl; auto.
intros a l1; case l2; simpl; auto; clear l2.
  intros; apply merge_olist_strong; auto.
  apply olist_one; auto.
intros b l2 H H1.
case_eq (weight a b); intros H2; auto.
- apply merge_olist_strong; auto.
  apply olist_cons; auto.
- apply merge_olist_strong; auto.
  rewrite weight_exact with (1 := H2); auto.
- generalize b H H1 H2; elim l2; simpl; auto; clear l2 b H H1 H2.
  intros b H H1 H2; apply olist_cons; auto.
  rewrite weight_anti_sym; rewrite H2; auto.
  apply merge_olist_strong; auto.
  apply olist_one; auto.
  intros b l2 Rec c H H1 H2.
  case_eq (weight a b); intros H3; auto.
  * apply olist_cons; auto.
      rewrite weight_anti_sym; rewrite H2; auto.
    apply merge_olist_strong; auto.
    apply olist_cons; auto.
    apply olist_inv with (1 := H1); auto.
  * apply olist_cons; auto.
      rewrite weight_anti_sym; rewrite H2; auto.
    apply merge_olist_strong; auto.
    rewrite weight_exact with (1 := H3); auto.
    apply olist_inv with (1 := H1); auto.
  * apply olist_cons; auto.
    apply olist_weight with (1 := H1); auto with datatypes.
    apply Rec; auto.
    apply olist_inv with (1 := H1); auto.
Qed.

(* Insert an element in an ordered list *)
Fixpoint  ocons (a: A) (l: list A) {struct l}: list A :=
  match l with
    nil => a :: nil
  | b :: l1 =>
      match weight a b with
        lt => a :: l
      | eq => a :: l
      | gt => b :: ocons a l1
      end
  end.

(* ocons always increments the length *)
Theorem ocons_length a l : length (ocons a l) = S (length l).
Proof.
elim l; simpl; auto.
intros b l1 H; case (weight a b); simpl; auto.
Qed.

(* The inserted element is in the result *)
Theorem ocons_in a l : In a (ocons a l).
Proof.
elim l; simpl; auto.
intros b l1 H; case_eq (weight a b); auto with datatypes.
Qed.

(* The initial list is in the result *)
Theorem ocons_incl a l : incl l (ocons a l).
Proof.
elim l; simpl; auto with datatypes.
intros b l1 H; case_eq (weight a b); auto with datatypes.
Qed.

(* The result contains only the initial list or the inserted element *)
Theorem ocons_inv a b l : In a (ocons b l) -> a = b \/ In a l.
Proof.
elim l; simpl; auto with datatypes.
  intuition.
intros c l1 H; case_eq (weight b c); simpl; intuition.
Qed.

(* Add an element in an ordered list l with possible duplication
   and then call the continuation f with the tail of l
 *)
Fixpoint add_cont (f: list A -> list A) (a: A) (l: list A) {struct l}:
      list A :=
  match l with
    nil => a :: f nil
  | b :: l1 =>
      match weight a b with
        lt => a :: f l
      | eq => a :: f l
      | gt => b :: add_cont f a l1
      end
  end.

(* Add two ordered lists with possible duplication *)
Fixpoint add (l1 l2: list A) {struct l1}: list A :=
  match l1 with
    nil => l2
  | a :: l3 => add_cont (add l3) a l2
  end.

Theorem add_length l1 l2 : length (add l1 l2) = length l1 + length l2.
Proof.
revert l2; elim l1; simpl; auto; clear l1.
intros a l1 Rec l2; elim l2; simpl; auto; clear l2.
  rewrite Rec; auto.
intros b l2 Rec1; case (weight a b); simpl; auto.
- rewrite Rec; simpl; repeat rewrite <- plus_n_Sm; auto with arith.
- rewrite Rec; simpl; repeat rewrite <- plus_n_Sm; auto with arith.
- rewrite Rec1; simpl; repeat rewrite <- plus_n_Sm; auto with arith.
Qed.

Theorem add_incl_l l1 l2 : incl l1 (add l1 l2).
Proof.
revert l2; elim l1; simpl; auto with datatypes; clear l1.
  intros l1 a H; case H.
intros a l1 Rec l2 b; simpl; intros [H | H]; subst; auto.
  elim l2; simpl; auto; clear l2.
  intros c l2 Rec1; case_eq (weight b c); intros H; auto with datatypes.
elim l2; simpl; auto; clear l2.
  right; apply (Rec nil b); auto.
intros c l2 Rec1; case_eq (weight a c); intros H1; auto with datatypes.
  simpl; right; apply (Rec (c :: l2) b); auto.
simpl; right; apply (Rec (c :: l2) b); auto.
Qed.

Theorem add_incl_r l1 l2 : incl l2 (add l1 l2).
Proof.
revert l2; elim l1; simpl; auto with datatypes.
intros a l3 Rec l2; elim l2; simpl; auto with datatypes; clear l2.
intros b l2 Rec1; case_eq (weight a b); intros H; auto with datatypes.
Qed.

Theorem add_inv a l1 l2 : In a (add l1 l2) -> In a l1 \/ In a l2.
Proof.
revert l2; elim l1; simpl; auto; clear l1.
intros b l1 Rec l2; elim l2; simpl; auto; clear l2.
  intros [H | H]; auto.
  case (Rec nil); auto.
intros c l2 Rec1; case (weight b c); simpl; intros [H | H]; subst; auto.
- case (Rec (c :: l2)); auto.
- case (Rec (c :: l2)); auto.
- case Rec1; auto.
Qed.

(* Remove an element from the list l if needed and then call
   the continuation f on the tail of l
 *)
Fixpoint rm_cont (f: list A -> list A) (a: A) (l: list A) {struct l}:
          list A :=
  match l with
    nil => nil
  | b :: l1 =>
     match weight a b with
       eq => f l1
     | lt => f l
     | gt => b :: rm_cont f a l1
     end
  end.

(* Remove all the element of the list l1 from the list l2 *)
Fixpoint rm (l1 l2: list A) {struct l1}: list A :=
  match l1 with
    nil => l2
  | a :: l3 =>
      rm_cont (rm l3) a l2
  end.

Theorem rm_incl l1 l2 : incl (rm l1 l2) l2.
Proof.
revert l2; elim l1; simpl; auto with datatypes; clear l1.
intros a l1 Rec l2; elim l2; simpl; auto with datatypes; clear l2.
intros b l2 H; case_eq (weight a b); auto with datatypes.
Qed.

Theorem rm_not_in (a: A) l1 l2 : olist l1 -> olist l2 ->
  In a l1 -> ~ In a (rm l1 l2).
Proof.
revert l2; generalize a; elim l1; simpl; auto; clear a l1.
intros b l1 Rec a l2 H1 H2.
assert (O1: olist l1); try apply olist_inv with (1 := H1).
intros [H | H]; subst; auto.
  generalize H2; elim l2; simpl; auto with datatypes; clear l2 H2.
  intros b l2 Rec1 H2.
  assert (O2: olist l2); try apply olist_inv with (1 := H2).
  case_eq (weight a b); auto with datatypes; intros H3.
  - intros H4; absurd (In a (b :: l2)); auto.
      simpl; intros [H5 | H5]; subst.
        rewrite weight_refl in H3; discriminate.
      rewrite weight_anti_sym in H3; rewrite (olist_weight b a l2) in H3;
      try discriminate; auto.
    apply (rm_incl l1 (b :: l2) a); auto.
  - assert (a = b); subst.
      apply weight_exact with (1 := H3).
    intros H4; absurd (In b l2); auto.
      assert (H5: ulist (b :: l2)); try apply olist_ulist; auto.
      inversion H5; auto.
    apply (rm_incl l1 l2 b); auto.
  - simpl; intros [H4 | H4]; subst.
      rewrite weight_refl in H3; discriminate.
    case Rec1; auto.
  - generalize H2; elim l2; simpl; auto with datatypes; clear l2 H2.
    intros c l2 Rec1 H2.
    assert (O2: olist l2); try apply olist_inv with (1 := H2).
    case_eq (weight b c); auto with datatypes; intros H3.
    simpl; intros [H4 | H4]; subst.
      rewrite (olist_weight b a l1) in H3; auto; discriminate.
    case Rec1; auto.
Qed.

Theorem rm_in (a: A) l1 l2 : olist l1 -> olist l2 ->
  ~ In a l1 -> In a l2 -> In a (rm l1 l2).
Proof.
revert l2; generalize a; elim l1; simpl; auto; clear a l1.
intros b l1 Rec a l2 H1 H2 H3 H4.
generalize H2 H4; elim l2; simpl; auto; clear l2 H2 H4.
assert (O1: olist l1); try apply olist_inv with (1 := H1).
  intros c l3 Rec1 H4 [H5 | H5]; subst.
  case_eq (weight b a); auto with datatypes; intros H5.
  case H3; rewrite weight_exact with (1 := H5); auto.
assert (O2: olist l3); try apply olist_inv with (1 := H4).
case_eq (weight b c); auto with datatypes; intros H6.
Qed.

Theorem rm_olist_strong a l1 l2 :
  olist (a :: l2) -> olist (a :: rm l1 l2).
Proof.
revert a l2; elim l1; simpl; auto; clear l1.
intros a l1 Rec c l2; generalize c; elim l2; simpl; auto; clear c l2.
intros b l2 Rec1 c H.
case_eq (weight a b); intros H1; auto.
  apply Rec; auto.
  apply olist_skip with (1 := H); auto.
apply olist_cons; auto.
  apply olist_weight with (1 := H); auto with datatypes.
apply Rec1; auto.
apply olist_inv with (1 := H); auto.
Qed.

Theorem rm_olist l1 l2 : olist l2 -> olist (rm l1 l2).
Proof.
revert l2; elim l1; simpl; auto; clear l1.
intros a l1 Rec l2; case l2; simpl; auto; clear l2.
intros b l2 H; case_eq (weight a b); intros H1; auto.
  apply Rec; auto.
  apply olist_inv with (1 := H); auto.
generalize b H H1; elim l2; simpl; auto; clear b l2 H H1.
intros b l2 Rec1 c H H1.
case_eq (weight a b); intros H2; auto.
- apply rm_olist_strong; auto.
- apply rm_olist_strong; auto.
  apply olist_skip with (1 := H); auto.
- apply olist_cons; auto.
  apply olist_weight with (1 := H); auto with datatypes.
  apply Rec1; auto.
  apply olist_inv with (1 := H); auto.
Qed.

(** Lifting the order to a lexico on list *)

(* Lexico on list  *)
Fixpoint lexico (l1 l2: list A) {struct l1}: cmp :=
  match l1 with
    nil => match l2 with nil => eq | _ => lt end
  | a:: l3 =>
     match l2 with
       nil => gt
     | b :: l4 =>
        match weight a b with
          eq => lexico l3 l4
        | X => X
        end
     end
   end.

Theorem lexico_trans a b c :
  lexico a b = lexico b c -> lexico a c = lexico a b.
Proof.
revert b c; elim a; simpl; auto; clear a.
  intros b; case b; auto; clear b.
  intros x b c; case c; clear c; simpl; auto.
  intros; discriminate.
intros x a Rec; intros b c; case c; case b; clear b c; simpl;
 try (intros; discriminate; fail); auto.
intros y b z c.
case_eq (weight x y); auto; intros H1.
- case_eq (weight y z); auto; intros H2.
  * rewrite (weight_trans x y z); rewrite H1; auto.
  * rewrite <- (weight_compat_r y z x); auto.
    rewrite H1; auto.
  * intros; discriminate.
- rewrite (weight_compat_l x y z); auto.
  case_eq (weight y z); auto; intros H2.
- case_eq (weight y z); auto; intros H2.
  * intros; discriminate.
  * rewrite <- (weight_compat_r y z x); auto.
    rewrite H1; auto.
  * rewrite (weight_trans x y z); auto.
      rewrite H1; auto.
    rewrite H1; auto.
Qed.

Theorem lexico_anti_sym a b : lexico b a = opp (lexico a b).
Proof.
revert b; elim a; clear a; simpl; auto.
  intros b; case b; clear b; simpl; auto.
intros x a Rec b; case b; clear b; simpl; auto.
intros y b; rewrite (weight_anti_sym x y).
case (weight x y); simpl; auto.
Qed.

(* No collision *)
Theorem lexico_exact a b : lexico a b = eq -> a = b.
Proof.
revert b; elim a; simpl; auto; clear a.
  intros b; case b; auto.
  intros; discriminate.
intros x a Rec b; case b; auto; clear b.
  intros; discriminate.
intros y b.
generalize (weight_exact x y).
case (weight x y); auto.
- intros; discriminate.
- intros; eq_tac; auto.
- intros; discriminate.
Qed.

End ordered.

(* Computable equality test *)
Definition eq_nat: forall x y : nat, {x = y} + {x <> y}.
Proof.
fix eq_nat 2; intros x y; case x; case y.
- left; auto.
- intros y1; right; intros; discriminate.
- intros x1; right; intros; discriminate.
- intros y1 x1; case (eq_nat x1 y1); intros H.
  left; auto.
  right; contradict H; injection H; auto.
Defined.

(* Comparison for integers *)
Fixpoint test (n m: nat) {struct n}: cmp :=
  match n with
       O => match m with O => eq | _ => lt end
  | S n1 => match m with O => gt | S m1 => test n1 m1 end
  end.

Theorem test_trans n1 n2 n3 :
  test n1 n2 = test n2 n3 -> test n1 n3 = test n1 n2.
Proof.
revert n2 n3; elim n1; simpl; auto; clear n1.
  intros n2; elim n2; simpl; auto; clear n2.
  intros n2 Rec n3; elim n3; simpl; auto; clear n3.
  intros; discriminate.
intros n1 Rec n2; elim n2; clear n2; simpl; auto.
  intros n3; elim n3; simpl; auto; clear n3.
  intros; discriminate.
intros n2 Rec1 n3; elim n3; simpl; auto; clear n3.
Qed.

Theorem test_anti_sym n1 n2 : test n1 n2 = opp (test n2 n1).
Proof.
revert n2; elim n1; simpl; auto; clear n1.
  intros n2; elim n2; simpl; auto; clear n2.
intros n1 Rec n2; elim n2; simpl; auto; clear n2.
Qed.

Theorem test_exact n1 n2 : test n1 n2 = eq -> n1 = n2.
Proof.
revert n2; elim n1; simpl; auto; clear n1.
  intros n2; elim n2; simpl; auto; clear n2.
  intros; discriminate.
intros n1 Rec n2; elim n2; simpl; auto; clear n2.
intros; discriminate.
Qed.

Theorem test_compat_l a b c : test a b = eq -> test a c = test b c.
Proof.
revert b c; elim a; simpl; auto; clear a.
  intros b; case b; try (intros; discriminate; fail).
  intros c; case c; auto.
intros a Rec b; case b; clear b.
  intros; discriminate.
intros b c Hb; case c; simpl; auto.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_collinear2.
Require Export GeoCoq.Elements.OriginalProofs.lemma_collinear1.

Section Euclid.

Context `{Ax1:euclidean_neutral}.

Lemma lemma_collinearorder :
   forall A B C,
   Col A B C ->
   Col B A C /\ Col B C A /\ Col C A B /\ Col A C B /\ Col C B A.
Proof.
intros.
assert (Col B C A) by (conclude lemma_collinear2).
assert (Col C A B) by (conclude lemma_collinear2).
assert (Col B A C) by (conclude lemma_collinear1).
assert (Col A C B) by (conclude lemma_collinear2).
assert (Col C B A) by (conclude lemma_collinear2).
close.
Qed.

End Euclid.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (x : natural) (lf1 : natural) (y : natural)
  : natural := mult x (plus Zero y).


Require Import Reals.
Local Open Scope R_scope.
From ValidSDP Require Import validsdp.

Let p (x0 x1 x2 : R) :=
  -x0 + 2/1 * x1 - x2 - 417817267/500000000 * x1 * (1 + x1).

Let b1 (x0 x1 x2 : R) :=
  (x0 + 5/1) * (5/1 - x0).

Let b2 (x0 x1 x2 : R) :=
  (x1 + 5/1) * (5/1 - x1).

Let b3 (x0 x1 x2 : R) :=
  (x2 + 5/1) * (5/1 - x2).

Let lb := -36713/1000.

Let ub := 10439/1000.

Theorem p_ge_lb (x0 x1 x2 : R) :
  b1 x0 x1 x2 >= 0 ->
  b2 x0 x1 x2 >= 0 ->
  b3 x0 x1 x2 >= 0 ->
  lb <= p x0 x1 x2.
Proof.
unfold b1, b2, b3, p, lb.
validsdp.
Qed.

Theorem p_le_ub (x0 x1 x2 : R) :
  b1 x0 x1 x2 >= 0 ->
  b2 x0 x1 x2 >= 0 ->
  b3 x0 x1 x2 >= 0 ->
  p x0 x1 x2 <= ub.
Proof.
unfold b1, b2, b3, p, ub.
validsdp.
Qed.


(*

   Benedikt Ahrens and Régis Spadotti

   Terminal semantics for codata types in intensional Martin-Löf type theory

   http://arxiv.org/abs/1401.1053

*)

(*

  Content of this file:

  definition of the functor [EQ] from sets to setoids, proof that it is strong monoidal

*)

Require Import Category.Types.
Require Import Category.Setoids.
Require Import Theory.Category.
Require Import Theory.Functor.
Require Import Theory.Product.
Require Import Theory.Isomorphism.
Require Import Theory.ProductPreservingFunctor.

(*------------------------------------------------------------------------------
  -- ＦＵＮＣＴＯＲ  ＥＱ
  ----------------------------------------------------------------------------*)
(** * Functor 𝑬𝑸 : 𝑻𝒚𝒑𝒆 → 𝑺𝒆𝒕𝒐𝒊𝒅 **)

(** ** Definition **)

Program Definition F : 𝑻𝒚𝒑𝒆 → 𝑺𝒆𝒕𝒐𝒊𝒅 := λ T ∙ Setoids.make  ⦃ Carrier  ≔ T
                                                            ; Equiv    ≔ eq ⦄.

Program Definition map {A B} : [ A ⇒ B ⟶ F A ⇒ F B ] :=
  λ f ↦ Setoids.Morphism.make f.
(** f-cong **)
Next Obligation.
  intros f g eq_fg x y eq_xy; simpl.
  now rewrite eq_xy.
Qed.

Lemma id A : id[ F A ] ≈ map id[ A ].
Proof.
  intros x y eq_xy; now rewrite eq_xy.
Qed.

Lemma map_compose A B C (f : A ⇒ B) (g : B ⇒ C) : map (g ∘ f) ≈ (map g) ∘ (map f).
Proof.
  intros x y eq_xy. now rewrite eq_xy.
Qed.

Definition 𝑬𝑸 : Functor 𝑻𝒚𝒑𝒆 𝑺𝒆𝒕𝒐𝒊𝒅 := mkFunctor id map_compose.

(*------------------------------------------------------------------------------
  -- ＥＱ  ＩＳ  ＰＲＥＳＥＶＥＳ  ＰＲＯＤＵＣＴ
  ----------------------------------------------------------------------------*)
(** ** 𝑬𝑸 is strong monoidal **)

Program Instance 𝑬𝑸_PF : ProductPreservingFunctor 𝑬𝑸 :=
  ProductPreservingFunctor.make ⦃ φ ≔ λ A B ∙ Setoids.Morphism.make (λ x ∙ x) ⦄.
(** φ-cong **)
Next Obligation.
  now f_equal.
Qed.
(** φ-inverse **)
Next Obligation.
  constructor.
  - (* iso_left *)
    intros f g eq_fg. exact eq_fg.
  - (* iso_right *)
    intros f g eq_fg. simpl in *. destruct f. auto.
Qed.

(*------------------------------------------------------------------------------
  -- ＦＵＮＣＴＯＲ  ＥＱ-×
  ----------------------------------------------------------------------------*)
(** * Functor 𝑬𝑸-× : 𝑻𝒚𝒑𝒆 × 𝑻𝒚𝒑𝒆 → 𝑺𝒆𝒕𝒐𝒊𝒅 **)

(** ** Definition **)

Program Definition 𝑬𝑸_prod : Functor (𝑻𝒚𝒑𝒆 𝘅 𝑻𝒚𝒑𝒆) 𝑺𝒆𝒕𝒐𝒊𝒅 :=
  Functor.make ⦃ F   ≔ λ A ∙ Setoids.make ⦃ Carrier ≔ fst A ⟨×⟩ snd A
                                          ; Equiv ≔ eq ⦄
               ; map ≔ λ A B ∙ λ f ↦ Setoids.Morphism.make (λ x ∙ (fst f (fst x) , snd f (snd x))) ⦄.
(** equivalence **)
Next Obligation.
  eauto with typeclass_instances.
Qed.
(** map-proper **)
Next Obligation.
  intros [? ?] [? ?] [? ?] [? ?] [? ?] eq. injection eq; intros.
  simpl in *; f_equal; congruence.
Qed.

Notation "𝑬𝑸-𝘅" := 𝑬𝑸_prod.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (x : natural) (lf1 : natural) (y : natural)
  : natural := mult x (plus y Zero).


(** * RIS.language : Languages. *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import tools algebra.

Section lang.
  Context {A : Set}.
  (** * Definitions *)
  (** A language is a set of words, i.e. a predicate over lists. *)
  Definition language := list A -> Prop.
  (** Two languages are equivalent if they agree on every word. *)
  Global Instance eq_lang : SemEquiv language := fun l1 l2 => forall w, l1 w <-> l2 w.
  (** Languages may be ordered by containment. *)
  Global Instance inf_lang : SemSmaller language := fun l1 l2 => forall w, l1 w -> l2 w.

  Global Instance eq_lang_equiv : Equivalence (@sequiv _ eq_lang).
  Proof. split;intro;unfold sequiv,eq_lang;firstorder. Qed.
  Global Instance inf_lang_preorder : PreOrder (@ssmaller _ inf_lang).
  Proof. split;intro;unfold ssmaller,inf_lang;firstorder. Qed.
  Global Instance inf_lang_PartialOrder : PartialOrder sequiv (@ssmaller _ inf_lang).
  Proof.
    split.
    - intro e;split;intro w;rewrite (e w);tauto.
    - intros (h1&h2) w;split.
      + apply h1.
      + apply h2.
  Qed.

  (** The unit language only contains the empty word. *)
  Global Instance unLang : Un language := (fun w => w=[]).
  (** The empty language has no elements. *)
  Global Instance zeroLang : Zero language := fun _ : list A => False.
  (** From any two languages we may define their union and their concatenation. *)
  Global Instance joinLang : Join language:= fun l1 l2 w => l1 w \/ l2 w.
  Global Instance prodLang : Product language := fun l1 l2 w => exists u v, w = u++v /\ l1 u /\ l2 v.

  (** We may iterate the product on a language for any number of times. *)
  Reserved Notation " l ^{ n } " (at level 35).
  Fixpoint iter_lang n l : language :=
    match n with
    | 0 => 𝟭
    | S n => l · (l ^{n})
    end
  where "l ^{ n }" := (iter_lang n l).

  (** The Kleene star of a language is the union of its iterates. *)
  Global Instance starLang : Star language := fun l w => exists n, l^{n} w.

  (** * Compatibily of the operations with the ordering *)
  (** Applying any of the operations we have defined to equivalent
  arguments yields equivalent results. *)
  Global Instance proper_joinLang : Proper (sequiv ==> sequiv ==> sequiv) join.
  Proof. intros l m I l' m' I' w;unfold join,joinLang;rewrite (I w),(I' w);reflexivity. Qed.

  Global Instance proper_prodLang : Proper (sequiv ==> sequiv ==> sequiv) prod.
  Proof.
    intros l m I l' m' I' w;unfold prod,prodLang.
    setoid_rewrite (I _);setoid_rewrite (I' _);reflexivity.
  Qed.

  Global Instance inf_lang_iter_lang n :
    Proper (sequiv ==> sequiv) (iter_lang n).
  Proof.
    intros l1 l2 e;induction n.
    - reflexivity.
    - simpl;rewrite IHn,e;reflexivity.
  Qed.

  Global Instance proper_starLang : Proper (sequiv ==> sequiv) star.
  Proof.
    intros l1 l2 e w;split;intros (n&In);exists n;apply (inf_lang_iter_lang n e),In.
  Qed.

  (** * Algebraic properties *)
  (** The containment order is the natural order stemming from [∪]. *)
  Lemma joinOrderLang : relation_equivalence (leqA sequiv) ssmaller.
  Proof.
    unfold leqA;intros L M;split;intros I w.
    - rewrite (I w);intro;now left.
    - split.
      + intro h;right;apply h.
      + intros [h|h];[apply I|];apply h.
  Qed.

  (** The set of languages is a semi-ring. *)
  Global Instance lang_Semiring : SemiRing language sequiv prod join un zero.
  Proof.
    split.
    - split.
      + typeclasses eauto.
      + intros l1 l2 l3 w';split.
        * intros (u&v1&->&h1&(v&w&->&h2)).
          exists (u++v),w;rewrite app_ass;split;[|split].
          -- reflexivity.
          -- exists u,v;tauto.
          -- tauto.
        * intros (u1&w&->&(u&v&->&h1&h2)&h3).
          exists u,(v++w);rewrite app_ass;split;[|split].
          -- reflexivity.
          -- tauto.
          -- exists v,w;tauto.
      + split;intros L w;(split;[intros (u&v&->&h1&h2)|intro h]).
        * rewrite h1;simpl;tauto.
        * exists [],w;simpl;split;[|split];tauto||reflexivity.
        * rewrite h2,app_nil_r;assumption.
        * exists w,[];rewrite app_nil_r;split;[|split];tauto||reflexivity.
    - split;simpl.
      + typeclasses eauto.
      + intros l1 l2 l3;firstorder.
      + split;intros l w;firstorder.
    - intros l1 l2 w;firstorder.
    - split;intros l w;firstorder.
    - intros l1 l2 l3 w;split.
      + intros (u&v&->&h1&[h2|h2]);[left|right];exists u,v;tauto.
      + intros [h|h];destruct h as (u&v&->&h1&h2);exists u,v;firstorder.
    - intros l1 l2 l3;split.
      + intros (u&v&->&[h1|h1]&h2);[left|right];exists u,v;tauto.
      + intros [h|h];destruct h as (u&v&->&h1&h2);exists u,v;firstorder.
  Qed.

  Remark iter_lang_last n l : l^{S n} ≃ l^{n} · l.
  Proof.
    induction n;simpl.
    - rewrite right_unit,left_unit;reflexivity.
    - rewrite IHn at 1.
      rewrite (mon_assoc l _ l);reflexivity.
  Qed.

  (** It is actually a Kleene algebra. *)
  Global Instance lang_KA : KleeneAlgebra language sequiv.
  Proof.
    split.
    - apply proper_starLang.
    - apply lang_Semiring.
    - intros l w;firstorder.
    - intros L;apply joinOrderLang.
      intros w [->|(u&v&->&h1&(n&h2))].
      + exists 0;reflexivity.
      + exists (S n),u,v;tauto.
    - intros l1 l2 L.
      apply joinOrderLang;apply joinOrderLang in L.
      intros w (u&v&->&(n&h1)&h2).
      revert u v h1 h2;induction n;intros.
      + rewrite h1;simpl;assumption.
      + destruct h1 as (u1&u2&->&h1&h1').
        rewrite app_ass.
        apply L.
        exists u1,(u2++v);firstorder.
    - intros l1 l2 L.
      apply joinOrderLang;apply joinOrderLang in L.
      intros w (u&v&->&h1&(n&h2)).
      revert u v h1 h2;induction n;intros.
      + rewrite h2,app_nil_r;assumption.
      + rewrite (iter_lang_last n _ v) in h2.
        destruct h2 as (v1&v2&->&h2&h2').
        rewrite <- app_ass.
        apply L.
        exists (u++v1),v2;firstorder.
  Qed.

  (* begin hide *)
  Global Instance join_semilattice_Lang : Semilattice language sequiv join := join_semilattice.
  (* end hide *)
End lang.


Require Import CSet.

Definition nr_max X `{OrderedType X} (x y:X) :=
  if [_lt x y] then y else x.

Arguments nr_max {X} {H} x y.

Instance nr_max_eq_proper X `{OrderedType X}
  : Proper (_eq ==> _eq ==> _eq) nr_max.
Proof.
  unfold Proper, respectful; intros.
  unfold nr_max. repeat cases; eauto.
  exfalso. eapply NOTCOND. rewrite <- H1, <- H0. eauto.
  exfalso. eapply NOTCOND. rewrite H1, H0. eauto.
Qed.

Lemma nr_max_sym X `{OrderedType X} (x y:X)
  : nr_max x y === nr_max y x.
Proof.
  unfold nr_max; repeat cases; eauto.
  - eapply lt_trans_eq; eauto.
Qed.

Lemma nr_max_assoc X `{OrderedType X} (x y z:X)
  : nr_max x (nr_max y z) === nr_max (nr_max x y) z.
Proof.
  unfold nr_max.
  decide (_lt y z); decide (_lt x y).
  - assert (_lt x z) by (etransitivity; eauto).
    repeat cases; eauto.
  - repeat cases; eauto.
  - repeat cases; eauto.
    exfalso; eauto.
  - repeat cases; eauto.
    exfalso; eauto.
    eapply le_trans; eauto.
Qed.


Theorem plus_id_exercise : forall n m o : nat,
    n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o. intros H1 H2.
  rewrite H1. rewrite <- H2.
  simpl. reflexivity.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia Relations.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list utils_nat finite.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.FOL.TRAKHTENBROT
  Require Import notations utils fol_ops fo_sig fo_terms fo_logic.

Import fol_notations.

Require Import Undecidability.Shared.ListAutomation.
Import ListAutomationHints.

Set Implicit Arguments.

Local Infix "∊" := In (at level 70, no associativity).
Local Infix "⊑" := incl (at level 70, no associativity).
Local Notation ø := vec_nil.

(* * First order theory of congruences *)

Section congruence.

  Variables (Σ : fo_signature) (ls : list (syms Σ)) (lr : list (rels Σ))
            (X : Type) (M : fo_model Σ X)
            (R : X -> X -> Prop).

  Infix "≈" := R.

  Definition Σ_congruence_wrt :=
          (forall s, s ∊ ls -> forall v w, (forall p, vec_pos v p ≈ vec_pos w p)
                                          -> fom_syms M s v ≈ fom_syms M s w)
       /\ (forall r, r ∊ lr -> forall v w, (forall p, vec_pos v p ≈ vec_pos w p)
                                          -> fom_rels M r v <-> fom_rels M r w).

End congruence.

Section fol_congruence.

  Variables (Σ : fo_signature) (e : rels Σ) (H_ae : ar_rels _ e = 2)
            (ls : list (syms Σ)) (lr : list (rels Σ))
            (He : e ∊ lr).

  Notation 𝕋 := (fol_term Σ).
  Notation 𝔽 := (fol_form Σ).

  Notation "x ≡ y" := (@fol_atom Σ e (cast (x##y##ø) (eq_sym H_ae))) (at level 59).

  Section encode_congruence.

    Variable (X : Type) (M : fo_model Σ X).

    Notation "x ≈ y" := (fom_rels M e (cast (x##y##ø) (eq_sym H_ae))).

    Local Fact fol_sem_e x y φ : fol_sem M φ (x ≡ y) = fo_term_sem M φ x ≈ fo_term_sem M φ y.
    Proof. simpl; f_equal; rewrite H_ae; simpl; auto. Qed.

    Let fol_syms_e x y : fol_syms (x ≡ y) = fo_term_syms x ++ fo_term_syms y.
    Proof. simpl; rewrite H_ae; simpl; auto; rewrite <- app_nil_end; auto. Qed.

    Let fol_rels_e x y : fol_rels (x ≡ y) = e::nil.
    Proof. auto. Qed.

    Local Definition fol_vec_equiv n := fol_vec_fa (vec_set_pos (fun p : pos n => £(pos2nat p+n) ≡ £(pos2nat p))).

    Local Fact fol_vec_equiv_syms n : fol_syms (fol_vec_equiv n) ⊑ nil.
    Proof.
      unfold fol_vec_equiv.
      rewrite fol_syms_vec_fa.
      intros x; rewrite in_flat_map.
      intros (D & HD & H); revert H.
      apply vec_list_inv in HD.
      destruct HD as (p & ->).
      rew vec; rewrite fol_syms_e; simpl; tauto.
    Qed.

    Local Fact fol_vec_equiv_rels n : fol_rels (fol_vec_equiv n) ⊑ e::nil.
    Proof.
      unfold fol_vec_equiv.
      rewrite fol_rels_vec_fa.
      intros x; rewrite in_flat_map.
      intros (D & HD & H); revert H.
      apply vec_list_inv in HD.
      destruct HD as (p & ->); rew vec.
    Qed.

    Local Fact fol_vec_equiv_sem n φ :
                fol_sem M φ (fol_vec_equiv n)
            <-> (forall p : pos n, φ (pos2nat p+n) ≈ φ (pos2nat p)).
    Proof.
      unfold fol_vec_equiv.
      rewrite fol_sem_vec_fa.
      fol equiv; intros p; rew vec.
      rewrite fol_sem_e; simpl; tauto.
    Qed.

    Section congr_syms.

      Variable (s : syms Σ).

      Let n := ar_syms _ s.

      Let A := fol_vec_equiv n.
      Let f : 𝕋 := in_fot s (vec_set_pos (fun p => £(pos2nat p))).
      Let g : 𝕋 := in_fot s (vec_set_pos (fun p => £(pos2nat p+n))).
      Let B := g ≡ f.

      Let HrA : fol_syms A ⊑ nil.     Proof. apply fol_vec_equiv_syms. Qed.
      Let HsA : fol_rels A ⊑ e::nil.  Proof. apply fol_vec_equiv_rels. Qed.

      Let HrB : fol_syms B ⊑ s::nil.
      Proof.
        unfold B; simpl.
        rewrite H_ae; unfold eq_rect_r.
        intros x; do 2 (simpl; rewrite in_app_iff).
        do 2 rewrite in_concat_iff.
        intros [ | [ (l & Hx & H) | [ | [ (l & Hx & H) | [] ] ] ] ]; try tauto; revert Hx;
          apply vec_list_inv in H; destruct H as (p & ->); rew vec.
      Qed.

      Let HsB : fol_rels B ⊑ e::nil.
      Proof. simpl; cbv; tauto. Qed.

      Local Definition congr_syms : 𝔽 := fol_mquant fol_fa n (fol_mquant fol_fa n (A ⤑  B)).

      Local Fact congr_syms_syms : fol_syms congr_syms ⊑ s::nil.
      Proof.
        unfold congr_syms.
        do 2 rewrite fol_syms_mquant.
        rewrite fol_syms_bin.
        apply incl_app; auto.
      Qed.

      Local Fact congr_syms_rels : fol_rels congr_syms ⊑ e::nil.
      Proof.
        unfold congr_syms.
        do 2 rewrite fol_rels_mquant.
        rewrite fol_rels_bin.
        apply incl_app; auto.
      Qed.

      Local Definition congr_syms_spec φ :
               fol_sem M φ congr_syms
           <-> forall v w, (forall p, vec_pos v p ≈ vec_pos w p) -> fom_syms M s v ≈ fom_syms M s w.
      Proof.
        unfold congr_syms.
        rewrite fol_sem_mforall.
        fol equiv; intros v.
        rewrite fol_sem_mforall.
        fol equiv; intros w.
        rewrite fol_sem_bin_fix.
        fol equiv imp.
        + unfold A; rewrite fol_vec_equiv_sem.
          fol equiv; intros p; rew vec; simpl.
          fol equiv; repeat f_equal.
          * rewrite env_vlift_fix1, env_vlift_fix0; auto.
          * rewrite env_vlift_fix0; auto.
        + unfold B.
          rewrite fol_sem_e; simpl.
          apply fol_equiv_ext; repeat f_equal;
            apply vec_pos_ext; intros p; rew vec; rew fot.
          * rewrite env_vlift_fix1, env_vlift_fix0; auto.
          * rewrite env_vlift_fix0; auto.
      Qed.

    End congr_syms.

    Section congr_rels.

      Variable (r : rels Σ).

      Let n := ar_rels _ r.

      Let A := fol_vec_equiv n.
      Let B := @fol_atom Σ r (vec_set_pos (fun p => £(pos2nat p))).
      Let C := @fol_atom Σ r (vec_set_pos (fun p => £(pos2nat p+n))).

      Let HsA : fol_syms A ⊑ nil.     Proof. apply fol_vec_equiv_syms. Qed.
      Let HrA : fol_rels A ⊑ e::nil.  Proof. apply fol_vec_equiv_rels. Qed.

      Let HsB : fol_syms B ⊑ nil.
      Proof.
        unfold B; simpl.
        intros x; rewrite in_flat_map.
        intros (t & H & Ht); revert Ht.
        apply vec_list_inv in H; destruct H as (p & ->); rew vec.
      Qed.

      Let HrB : fol_rels B ⊑ r::nil.
      Proof. simpl; cbv; tauto. Qed.

      Let HsC : fol_syms C ⊑ nil.
      Proof.
        unfold C; simpl.
        intros x; rewrite in_flat_map.
        intros (t & Ht & H); revert H.
        apply vec_list_inv in Ht.
        destruct Ht as (p & ->); rew vec; simpl; tauto.
      Qed.

      Let HrC : fol_rels C ⊑ e::r::nil.
      Proof. simpl; cbv; tauto. Qed.

      Local Definition congr_rels : 𝔽 := fol_mquant fol_fa n (fol_mquant fol_fa n (A ⤑  (C ↔ B))).

      Local Fact congr_rels_syms : fol_syms congr_rels ⊑ nil.
      Proof.
        unfold congr_rels.
        do 2 rewrite fol_syms_mquant.
        repeat rewrite fol_syms_bin.
        repeat (apply incl_app; auto).
      Qed.

      Local Fact congr_rels_rels : fol_rels congr_rels ⊑ e::r::nil.
      Proof.
        unfold congr_rels.
        do 2 rewrite fol_rels_mquant.
        repeat rewrite fol_rels_bin.
        repeat (apply incl_app; auto).
        intros x Hx; destruct (HrA _ Hx); try subst x; simpl; tauto.
      Qed.

      Local Definition congr_rels_spec φ :
             fol_sem M φ congr_rels
         <-> forall v w, (forall p, vec_pos v p ≈ vec_pos w p)
                      -> fom_rels M r v <-> fom_rels M r w.
      Proof.
        unfold congr_rels.
        rewrite fol_sem_mforall.
        fol equiv; intros v.
        rewrite fol_sem_mforall.
        fol equiv; intros w.
        simpl fol_sem at 1.
        fol equiv.
        + unfold A; rewrite fol_vec_equiv_sem.
          fol equiv; intros p; rew vec; simpl.
          fol equiv; repeat f_equal.
          * rewrite env_vlift_fix1, env_vlift_fix0; auto.
          * rewrite env_vlift_fix0; auto.
        + fol equiv iff; fol equiv; f_equal;
            apply vec_pos_ext; intros p; rew vec; rew fot.
          * rewrite env_vlift_fix1, env_vlift_fix0; auto.
          * rewrite env_vlift_fix0; auto.
      Qed.

    End congr_rels.

    Local Definition fol_congruent : 𝔽 :=
        fol_lconj (map congr_syms ls)
      ⟑ fol_lconj (map congr_rels lr).

    Local Fact fol_congruent_syms : fol_syms fol_congruent ⊑ ls.
    Proof.
      unfold fol_congruent.
      rewrite fol_syms_bin.
      repeat rewrite fol_syms_bigop; simpl.
      repeat apply incl_app; try (cbv; tauto).
      + intros s; rewrite in_flat_map.
        intros (A & HA & H); revert HA H.
        rewrite in_map_iff; intros (x & <- & Hx) H.
        apply congr_syms_syms in H; revert H.
        intros [ <- | [] ]; auto.
      + intros r; rewrite in_flat_map.
        intros (A & HA & H); revert HA H.
        rewrite in_map_iff; intros (x & <- & Hx) H.
        apply congr_rels_syms in H; revert H.
        intros [].
    Qed.

    Local Fact fol_congruent_rels : fol_rels fol_congruent ⊑ lr.
    Proof using He.
      unfold fol_congruent.
      rewrite fol_rels_bin.
      repeat rewrite fol_rels_bigop; simpl.
      repeat apply incl_app; try (cbv; tauto).
      + intros s; rewrite in_flat_map.
        intros (A & HA & H); revert HA H.
        rewrite in_map_iff; intros (x & <- & Hx) H.
        apply congr_syms_rels in H; revert H.
        intros [ <- | [] ]; simpl; auto.
      + intros x; simpl.
        rewrite in_flat_map.
        intros (A & HA & H); revert HA H.
        rewrite in_map_iff; intros (y & <- & Hy) H.
        apply congr_rels_rels in H; revert H.
        intros [ | [ <- | [] ] ]; subst; auto.
    Qed.

    (* Σ_eq_congruence_spec encodes that ≈ is a congruence wrt to all
        the symbols in ls and lr *)

    Local Fact fol_congruent_spec φ :
          fol_sem M φ fol_congruent
      <-> Σ_congruence_wrt ls lr M (fun x y => x ≈ y).
    Proof.
      unfold fol_congruent.
      rewrite fol_sem_bin_fix.
      do 2 rewrite fol_sem_lconj.
      fol equiv conj.
      + split.
        * intros H s Hs.
          apply (congr_syms_spec _ φ), H, in_map_iff.
          exists s; auto.
        * intros H f; rewrite in_map_iff.
          intros (s & <- & Hs).
          apply congr_syms_spec, H; auto.
      + split.
        * intros H r Hr.
          apply (congr_rels_spec _ φ), H, in_map_iff.
          exists r; auto.
        * intros H f; rewrite in_map_iff.
          intros (r & <- & Hr).
          apply congr_rels_spec, H; auto.
    Qed.

    Local Definition fol_equivalence :=
            (∀ £0 ≡ £0)
          ⟑ (∀∀∀ £2 ≡ £1 ⤑ £1 ≡ £0 ⤑ £2 ≡ £0)
          ⟑ (∀∀ £1 ≡ £0 ⤑ £0 ≡ £1).

    Local Fact fol_equivalence_syms : fol_syms fol_equivalence = nil.
    Proof.
      unfold fol_equivalence.
      repeat (rewrite fol_syms_bin || rewrite fol_syms_quant).
      repeat rewrite fol_syms_e; auto.
    Qed.

    Local Fact fol_equivalence_rels : fol_rels fol_equivalence ⊑ e::nil.
    Proof. simpl; cbv; tauto. Qed.

    Fact fol_equiv_spec φ :
           fol_sem M φ fol_equivalence <-> equiv _ (fun x y => x ≈ y).
    Proof.
      unfold fol_equivalence.
      repeat (rewrite fol_sem_bin_fix).
      repeat fol equiv conj.
      + rewrite fol_sem_quant_fix; apply forall_equiv; intro.
        rewrite fol_sem_e; simpl; tauto.
      + do 3 (rewrite fol_sem_quant_fix; apply forall_equiv; intro).
        do 2 rewrite fol_sem_bin_fix.
        do 3 rewrite fol_sem_e; simpl; tauto.
      + do 2 (rewrite fol_sem_quant_fix; apply forall_equiv; intro).
        rewrite fol_sem_bin_fix.
        do 2 rewrite fol_sem_e; simpl; tauto.
    Qed.

    (* Σ_eq_congruence encodes the fact that ≈ is a congruence wrt to all
        the symbols in ls and lr and this formula involve only the symbols
        of ls and lr, under the assumption that e belongs to lr *)

    Definition fol_congruence :=
          fol_congruent
        ⟑ fol_equivalence.

    Fact fol_congruence_syms : fol_syms fol_congruence ⊑ ls.
    Proof.
      unfold fol_congruence.
      rewrite fol_syms_bin, fol_equivalence_syms, <- app_nil_end.
      apply fol_congruent_syms.
    Qed.

    Fact fol_congruence_rels : fol_rels fol_congruence ⊑ lr.
    Proof using He.
      unfold fol_congruence.
      rewrite fol_rels_bin.
      apply incl_app.
      + apply fol_congruent_rels.
      + intros x Hx.
        apply fol_equivalence_rels in Hx.
        destruct Hx as [ | [] ]; subst; auto.
    Qed.

    Fact fol_sem_congruence φ :
             fol_sem M φ fol_congruence
         <-> Σ_congruence_wrt ls lr M (fun x y => x ≈ y)
          /\ equiv _ (fun x y => x ≈ y).
    Proof.
      fol equiv conj.
      + apply fol_congruent_spec.
      + apply fol_equiv_spec.
    Qed.

  End encode_congruence.

End fol_congruence.

Arguments fol_congruence { _ _ }.


Set Implicit Arguments.

Require Import
        Arith_base
        Arith.Wf_nat
        List
        Omega
        Wellfounded
        Tactics.Tactics.

Import ListNotations.

Section STALIN.
  Variable A : Set.
  Variable leA : A -> A -> Prop.
  Variable leA_dec : forall (x y : A), {leA x y} + {~ leA x y}.

  Inductive sorted : list A -> Prop :=
  | SortedNil : sorted []
  | SortedSingle : forall x, sorted [x]
  | SortedCons : forall y y' ys, leA y y' ->
                            sorted (y' :: ys) ->
                            sorted (y :: y' :: ys).

  Hint Constructors sorted.

  Inductive In (x : A) : list A -> Prop :=
  | Here : forall xs, In x (x :: xs)
  | There : forall ys y, In x ys -> In x (y :: ys).

  Hint Constructors In.

  Definition sub_list xs ys := forall x, In x xs -> In x ys.

  Lemma sub_list_nil : forall ys, sub_list [] ys.
  Proof.
    intros ys ; unfold sub_list ; intros x H ; inversion H.
  Qed.

  Lemma sub_list_refl : forall xs, sub_list xs xs.
  Proof.
    intros xs ; unfold sub_list ; intros H ; auto.
  Qed.

  Lemma sub_list_skip : forall xs ys x, sub_list xs ys -> sub_list (x :: xs) (x :: ys).
  Proof.
    intros xs ys x H ; unfold sub_list in * ; intros z Hz.
    inversion Hz ; clear Hz ; subst ; auto.
  Qed.

  Hint Resolve sub_list_nil sub_list_refl sub_list_skip.

  Definition length_wf :=
    @wf_inverse_image (list A) nat lt (@length A) lt_wf.

  Definition stalin (xs : list A) :=
    {ys | sorted ys /\ sub_list ys xs}.

  Lemma stalin_nil : stalin [].
  Proof.
    unfold stalin ; exists (@nil A) ; splits*.
  Qed.

  Lemma stalin_single : forall x, stalin [x].
  Proof.
    intros x ; unfold stalin ; exists [x] ; splits*.
  Qed.

  Hint Resolve stalin_nil stalin_single.

  Definition stalin_sort_rec
    : forall xs, (forall ys, length ys < length xs -> stalin ys) -> stalin xs.
    refine (fun xs rec =>
              match xs as xs' return xs = xs' -> stalin xs' with
              | [] => fun _ => _
              | [ _ ] => fun _ => _
              | y :: y' :: ys' => fun _ =>
                match leA_dec y y' with
                | left _ =>
                  match rec (y' :: ys') _ with
                  | exist _ zs _ => _
                  end
                | right _  =>
                  match rec (y :: ys') _ with
                  | exist _ zs _ => exist _ zs _
                  end
                end
              end (eq_refl xs)) ; substs* ; crush.
    -
      destruct zs ; crush.
      unfolds ; exists (@nil A) ; crush.
      unfolds. exists (a :: zs) ; crush.
      unfolds. intros x H1. inverts* H1.
    -
      unfold sub_list in * ; crush.
      specialize (H0 _ H1). inverts* H0.
  Defined.

  Definition stalin_sort : forall xs, stalin xs :=
    (@well_founded_induction _ _ length_wf _ stalin_sort_rec).

End STALIN.


(* File: QpositiveOrder.v
 * Part 1
 *)
Require Import Utf8.
Require Export Qpositive_order.
Require DecidableOrder.

Module QDecidableOrderSig <: DecidableOrder.Sig.

Definition A := Qpositive.
Definition le := Qpositive_le.
Definition le_refl := Qpositive_le_refl.
Definition le_antisym := Qpositive_le_antisym.
Definition le_trans := Qpositive_le_trans.
Definition le_total := Qpositive_le_total.
Infix "≤" := le : Qpos_scope.
Bind Scope Qpos_scope with Qpositive.
Open Scope Qpos_scope.

Lemma le_dec : ∀ x y, {x ≤ y} + {¬ x ≤ y}.
Proof.
intros.
unfold le, Qpositive_le.
decide equality.
Defined.

Print Qpositive_le_total.

End QDecidableOrderSig.


Require Import base.

Lemma swap_hyps {P Q R : Prop} : (P -> Q -> R) -> Q -> P -> R.
Proof. by intros PQR pQ pP; exact (PQR pP pQ). Qed.

Lemma hypothetical_syllogism : forall P Q R : Prop, (P -> Q) -> (Q -> R) -> (P -> R).
Proof.
	by intros P Q R PQ QR pP; exact (QR (PQ pP)).
Qed.

Lemma if_never_then_not_exist {T : Type} (P : T -> Prop)
 : (forall n : T, ~ (P n)) -> ~ (exists n : T, P n).
Proof.
	by intros H [n Pn]; exact (H n Pn).
Qed.
Lemma if_exist_then_exists {T : Type} (P : T -> Prop)
 : forall n : T, P n -> (exists n : T, P n).
Proof.
	by intros n Pn; exists n; exact Pn.
Qed.
Lemma if_not_exists_then_never {T : Type} (P : T -> Prop)
 : (forall n : T, P n \/ ~ P n) -> ~ (exists n : T, P n) -> (forall n : T, ~ P n).
Proof.
	intros middle_excluded nex n.
	destruct (middle_excluded n) as [Pn | nPn].
	by is_false (nex (if_exist_then_exists _ _ Pn)).
	by exact nPn.
Qed.
Lemma if_not_never_then_dont_not_exists {T : Type} (P : T -> Prop)
 : ~ (forall n : T, ~ P n) -> ~ ~ (exists n : T, P n).
Proof.
	intros nnever nexn.
	contradict nnever.
	by intros n Pn; exact (nexn (if_exist_then_exists _ n Pn)).
Qed.
Lemma if_not_exists_then_not_never_false {T : Type} (P : T -> Prop)
 : ~ (exists n : T, P n) -> ~ ~ (forall n : T, ~ P n).
Proof.
	intros nex nalnot.
	by exact (if_not_never_then_dont_not_exists _ nalnot nex).
Qed.

Lemma transform_and_rarrow : forall A B C : Prop, (A /\ B -> C) -> A -> B -> C.
Proof.
	by intros A B C H pA pB; apply H; split; [exact pA | exact pB].
Qed.
Lemma transform_rarrow_and : forall A B C : Prop, (A -> B -> C) -> A /\ B -> C.
Proof.
	by intros A B C H [pA pB]; exact (H pA pB).
Qed.

(* Attempt no 3 at a wlog implementation, pt.1/2 *)
Lemma modus_ponens {P Q : Prop} : P -> (P -> Q) -> Q.
Proof.
	by intros pP PQ; exact (PQ pP).
Qed.
Lemma modus_tonens {P Q : Prop} : (~ Q) -> (P -> Q) -> ~ P.
Proof.
	by intros nQ PQ pP; exact (nQ (PQ pP)).
Qed.

Lemma double_negation_elimination {P : Prop} : (P \/ ~ P) -> ~ ~ P -> P.
Proof.
	by intros [pP | nP] nnP; [exact pP | exfalso; exact (nnP nP)].
Qed.
Lemma double_negation_introduction {P : Prop} : P -> ~ ~ P.
Proof.
	by intros pP nP; exact (nP pP).
Qed.

Lemma disjunctive_syllogism {P Q : Prop} : (P \/ Q) -> ~ P -> Q.
Proof.
	intros [pP | pQ] nP.
	by is_false (nP pP).
	by exact pQ.
Qed.

(* proj1 / proj2 *)
Lemma and_l {P Q : Prop} : (P /\ Q) -> P. Proof. by intros [pP _]; exact pP. Qed.
Lemma and_r {P Q : Prop} : (P /\ Q) -> Q. Proof. by intros [_ pQ]; exact pQ. Qed.

Lemma or_to_impl_l {P Q R : Prop} : (P -> Q) -> (P \/ R) -> (Q \/ R).
Proof.
	by intros PQ [pP | pR]; [left; apply PQ; exact pP | right; exact pR].
Qed.
Lemma or_to_impl_r {P Q R : Prop} : (P -> R) -> (Q \/ P) -> (Q \/ R).
Proof.
	by intros PR [pQ | pP]; [left; exact pQ | right; apply PR; exact pP].
Qed.
Lemma or_swap {P Q : Prop} : (P \/ Q) -> Q \/ P.
Proof. by intros [pP | pQ]; [right; exact pP | left; exact pQ]. Qed.

(* Attempt no 3 at a wlog implementation, pt.2/2 *)
Tactic Notation "without" "loss" ident(n) ":" constr(Q)
	:= lazymatch goal with
		| |- ?H => assert(n : Q)
		| _ => fail "Invalid usage of 'without loss'."
	end.
Tactic Notation "wlog" ident(n) ":" constr(Q)
	:= lazymatch goal with
		| |- ?H => assert(n : Q); swap 1 2
		| _ => fail "Invalid usage of 'wlog'."
	end.


Require Import Frap Modeling Hoare Helpers.

(* This logical formula is a proposition that described what it means
   for an array to be sorted. The array in question here is
   stored in the given heap, between indices [startI, endI) *)
Definition is_sorted (arr: heap) (startI: nat) (endI: nat): Prop :=
  forall (i1 i2: nat), (lt startI i1) /\ (lt i1 i2) /\ (lt i2 endI) -> (le (arr $! i1) (arr $! i2)).

(* The program for merging two arrays:
   1. It assumes that two arrays are already provided on the heap, the
   first between indices [0, len1) and the second between [len1, len1 + len2).
   2. It writes out a merged sorted array to the end of the heap, so
   that the first two arrays are not changed, and are followed by the sorted
   array between indices [len1+len2, 2*(len1+len2) )
   3. The assertion for the for loop is given as a parameter, to allow you
   to define it without having to modify this program. The parameters to the
   assertion will be len1 and len2. *)
Definition merge_program (len1 len2: nat) (I: nat -> nat -> assertion): cmd := (
  (* i will be the current index in the merged resulting array *)
  "i" <- (len1 + len2) ;;
  "i1" <- 0 ;; (* current index in first array *)
  "i2" <- len1 ;; (* current index in the second array *)

  {{ I len1 len2 }} (* you will define this invariant *)
  _while_ "i" < (len1 + len2 + len1 + len2) _loop_
    (* standard merge: if arr1[i1] < arr2[i2], we add arr[i1] to the
        end of the merged array and increment i1, if arr1[i1] >= arr[i2],
        we choose arr[i2]. We must pay attention to special cases where
        i1 or i2 are out of range. *)
    _if_ "i1" < len1 _then_
      _if_ "i2" < len1 + len2 _then_
        _if_ *["i1"] < *["i2"] _then_
          *["i"] <- *["i1"] ;;
          "i1" <- "i1" + 1
        _else_
          *["i"] <- *["i2"] ;;
          "i2" <- "i2" + 1
        _done_
      _else_
        *["i"] <- *["i1"] ;;
        "i1" <- "i1" + 1
      _done_
    _else_
      (* i2 must be < len2 *)
      *["i"] <- *["i2"] ;;
      "i2" <- "i2" + 1
    _done_
  _done_) % cmd.

Module Type Problem4.
  (* Start off by proving this simple lemma:
     if the array starting at startI and ending at endI is sorted,
     then the sub array starting at startI and ending at endI' is also sorted,
     where endI' <= endI. *)
  Axiom is_sorted_smaller: forall (arr: heap) (startI endI endI': nat),
    is_sorted arr startI endI -> endI' <= endI -> is_sorted arr startI endI'.

  (* You must define the invariant for the while loop of the program above:
     Remember, the invariant must:
     1. Be true before the execution of the while loop start.
     2. Remain true after each execution of the while loop.
     3. Imply the post condition we desired (defined below) *)
  Parameter merge_invariant: nat -> nat -> assertion.

  (* The first version of correctness: the resulting array must be sorted,
     given that the two input arrays are sorted *)
  (* Helpers.v contain some helpful tactics that will automate a large chunk of
     this proof, as well as some hints, read the comments there carefully *)
  (* HINT: At some point in the proof, you will reach the body of the while loop,
     using [ht1] or [ht] or manually applying the HtIf rule will spit out
     4 goals for you, this is because we have 4 cases in the body of the loop:
     1. i1 is out of range
     2. i2 is out of range
     3. both in range but the element at i1 < element at i2.
     4. both in range but the element at i1 >= element at i2.
     The goals produces at all these cases are very similar, and can be
     solved by exactly the same proof if written generally enough. Consider
     using the tactic [first_order] in these proofs! *)
  (* HINT: In both the manual and automatic version of my solutions, I got a total
     of 6 proof obligations.
     1. for showing the invariant of the while loop is initally true.
     2-5. the proof obligations corresponding to the cases above.
     6. Obligation for showing that the loop invariant implies the post condition
        when the loop is done. You will want to use 'is_sorted_smaller' here. *)
  Axiom merge_correct: forall (len1 len2: nat),
    {{ fun h v => is_sorted h 0 len1 /\ is_sorted h len1 (len1 + len2) }}
    merge_program len1 len2 merge_invariant
    {{ fun h v => (is_sorted h (len1 + len2) (len1 + len2 + len1 + len2)) }}.
End Problem4.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (lf3 : natural) (lf2 : natural) : natural :=
  plus lf1 Zero.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (x : natural) (y : natural) (lf1 : natural) : natural :=
  plus x (Succ Zero).


(***********************************************************************)
(**  * Connecting nominal and LN semantics *)
(***********************************************************************)

(** Our final goal is to show that the abstract nominal machine implements the
    same semantics as the LN substitution-based small step relation.

    We'll do this by proving that any time the abstract machine takes a step,
    we can decode the machine configuration before and after the step to LN
    expressions, and those expressions are either identical or related by the
    LN step relation.

<<
                    machine_step
             (h,t,s)  ------>  (h',t',s')            nominal terms
                |                  |
                | decode           | decode
                v                  v
                e       - - ->     e'           locally nameless terms
                      step e e'
                         or
                        e = e'
>>

    This result is the [simulate_step] lemma near the end of this file.

 *)

Require Import String.
Require Import Metalib.Metatheory.

Require Import Stlc.Nominal.
Require Import Stlc.Lemmas.

Import StlcNotations.

(***********************************************************************)
(** ** Translating nominal terms to LN terms *)
(***********************************************************************)

(** We decode named terms to LN terms through the use of the
    [close_exp_wrt_exp] function. This function replaces all occurrences of
    a given atom by a new bound variable.

    This function is defined in the [Stlc.Lemmas] module and can be
    automatically generated by LNgen.  *)

Fixpoint nom_to_exp (ne : n_exp) : exp :=
  match ne with
  | n_var x => var_f x
  | n_app e1 e2 => app (nom_to_exp e1) (nom_to_exp e2)
  | n_abs x e1 => abs (close_exp_wrt_exp x (nom_to_exp e1))
end.

(** We also define a translation from machine configurations to LN
    terms. In this case we must substitute all definitions in the
    heap through the terms and create all of the applications in
    the stack. *)

Fixpoint apply_heap (h : heap) (e : exp) : exp  :=
  match h with
  | nil => e
  | (x , e') :: h' => apply_heap h' ([x ~> nom_to_exp e'] e)
  end.

(* Note that the stack could have some heap definitions in it,
   so we apply the substitutions in the heap there too. *)

Fixpoint apply_stack h (s : list frame) (e :exp) : exp :=
  match s with
  | nil => e
  | n_app2 e' :: s' => apply_stack h s' (app e (apply_heap h (nom_to_exp e')))
  end.

(** The full decode function puts all of these parts together. *)

Definition decode (c:configuration) : exp  :=
  match c with
  | (h,e,s) => apply_stack h s (apply_heap h (nom_to_exp e))
  end.

(** Here's an example translation from the machine step demo. *)

Definition conf1 := ([(Y,n_var Z)], n_abs X (n_var X), [n_app2 (n_var Y)]).

Example decode1 : decode conf1 = (app (abs (var_b 0)) (var_f Z)).
Proof. (* WORKINCLASS *)
  default_simp.
  unfold close_exp_wrt_exp.
  default_simp.
Qed. (* /WORKINCLASS *)

(***********************************************************************)
(** ** Connecting free variable functions.                             *)
(***********************************************************************)

(** Here is the first result about our decoding: that the two free
    variable functions agree.

    In this part of the file, we will take advantage of automation
    provided by the Lemmas module. In particular, this module defines a
    database of rewriting hints (called [lngen]) that can be used to
    automatically rewrite LN terms into simpler form. *)

Lemma fv_nom_fv_exp_eq : forall n,
    fv_nom n [=] fv_exp (nom_to_exp n).
Proof.
  induction n; intros; simpl; autorewrite with lngen; fsetdec.
Qed.

(** As we prove new lemmas, we can also extend the hint database with new
    rewritings. *)
#[export] Hint Rewrite fv_nom_fv_exp_eq : lngen.
#[export] Hint Resolve fv_nom_fv_exp_eq : lngen.

(** The Metatheory library contains two powerful tactics for simplifying
    goals:

     - [default_steps]: repeat a bunch of simplifying steps, such as
       simplifying the goal, inverting simple hypotheses, etc.

     - [default_simp]: above plus case analysis for booleans and other sums

    Below, we modify the behavior of these tactics by updating the following
    two definitions, so that the [lngen] hint databases will be available.  *)

Ltac default_auto        ::= auto with lngen.
Ltac default_autorewrite ::= autorewrite with lngen.

(** We also add a few more rewriting lemmas to the hint database to
    automate our proofs. *)

#[export] Hint Rewrite subst_exp_open_exp_wrt_exp : lngen.
#[export] Hint Rewrite swap_size_eq : lngen.
#[export] Hint Resolve le_S_n : lngen.

(***********************************************************************)
(** ** Decoded terms are locally closed *)
(***********************************************************************)

(** Next, we show that our decoding of nominal terms and
    configurations produces locally closed LN terms.

    Again, these proofs are highly automatable.
*)

Lemma nom_to_exp_lc : forall t, lc_exp (nom_to_exp t).
Proof.
  induction t; default_steps.
Qed.
#[export] Hint Resolve nom_to_exp_lc : lngen.

Lemma apply_heap_lc : forall h e,
    lc_exp e -> lc_exp (apply_heap h e).
Proof.
  alist induction h; default_simp.
Qed.
#[export] Hint Resolve apply_heap_lc : lngen.

(** *** Exercise: [apply_stack_lc]

    State and prove a lemma called [apply_stack_lc] and add it to the
    [lngen] hint database so that the proof for [decode_lc] goes
    through. *)

(* SOLUTION *)
Lemma apply_stack_lc : forall s h e,
    lc_exp e -> lc_exp (apply_stack h s e).
Proof.
  induction s; try destruct a; default_simp.
Qed.
#[export] Hint Resolve apply_stack_lc : lngen.
(* /SOLUTION *)

Lemma decode_lc : forall c, lc_exp (decode c).
Proof.
  intros [[h e] s]; default_simp.
  (* ADMITTED *)
Qed. (* /ADMITTED *)

(***********************************************************************)
(** ** Properties of apply_heap *)
(***********************************************************************)

(** Since the heap is just an iterated substitution, it inherits
    properties from [subst_exp].

    Below, [alist induction] is a tactic from the metatheory library for
    induction over association lists (such as the heap).  *)

Lemma apply_heap_abs : forall h e,
  apply_heap h (abs e) = abs (apply_heap h e).
Proof.
  alist induction h; default_simp.
Qed.

#[export] Hint Rewrite apply_heap_abs : lngen.

Lemma apply_heap_app : forall h e1 e2,
  apply_heap h (app e1 e2) = app (apply_heap h e1) (apply_heap h e2).
Proof.
  alist induction h; default_simp.
Qed.

#[export] Hint Rewrite apply_heap_app : lngen.

(** *** Exercise: [apply_heap_open]

    This function is the [apply_heap] analogue to
    [subst_exp_open_exp_wrt_exp], commuting the heap-based
    substitution with the [open_exp_wrt_exp] operation.
 *)

Lemma apply_heap_open : forall h e e0,
    lc_exp e0 ->
    apply_heap h (open e e0)  =
       open (apply_heap h e) (apply_heap h e0).
Proof.
(* ADMITTED *)
  alist induction h; intros; default_simp.
Qed. (* /ADMITTED *)

#[export] Hint Rewrite apply_heap_open : lngen.

(** This last lemma "unsimpl"s the [apply_heap] function. *)

Lemma combine : forall h x e e',
  apply_heap h ([x ~> nom_to_exp e] e') = (apply_heap ((x,e)::h) e').
Proof.
  simpl. auto.
Qed.

(***********************************************************************)
(** ** Stacks as evaluation contexts                                    *)
(***********************************************************************)

(** Here is a quick lemma that uses the properties defined above.
    It shows that the stack behaves like an *evaluation context*,
    lifting a small-step reduction to a larger term.
 *)

Lemma apply_stack_cong : forall s h e e',
    step e e' ->
    step (apply_stack h s e) (apply_stack h s e').
Proof.
  induction s; intros; try destruct a; default_simp.
Qed.

(***********************************************************************)
(** * Connecting "freshening" *)
(***********************************************************************)

(** The abstract machine uses the nominal [swap] operation to make sure
    that the variables in abstractions are "fresh".  To be able prove that
    this machine implements the step relation for LN terms, we need to
    connect this operation to a LN version of "freshening".

    The [swap_spec] lemma below states that connection. If a variable [y]
    is "fresh", then substituting with it (in the LN representation) is the
    same as swapping with it (in the nominal representation).

<<
Lemma swap_spec : forall  n w y,
    y `notin` fv_exp (nom_to_exp n) ->
    w <> y ->
    [w ~> var_f y] (nom_to_exp n) =
    nom_to_exp (swap w y n).
>>

 *)

(** *** Exercise [close_exp_wrt_exp_freshen] *)

(** The [swap_spec] proof depends on the following auxiliary lemma about the
    close operation --- that we can equivalently rename the atom that
    we are closing with. *)
(* LATER *)
(* SCW: Make LNgen generate this? *)
(* /LATER *)
Lemma close_exp_wrt_exp_freshen : forall x y e,
    y `notin` fv_exp e ->
    close_exp_wrt_exp x e =
    close_exp_wrt_exp y ([x ~> var_f y] e).
Proof.
(* ADMITTED *)
  intros x y e.
  unfold close_exp_wrt_exp.
  generalize 0 as k.
  generalize e. clear e.
  induction e; default_simp.
Qed. (* /ADMITTED *)

(** One difficulty of [swap_spec] is that we need to use the induction
    not on direct subterms, but on those that have had a swapping applied
    to them. Swapping preserves the size of a nominal term, so we can
    prove this result by induction on [m], a bound on the size of the
    term.

    The difficulty in this proof comes from the [n_abs] case. In this
    case, the term is is of the form [n_abs x t] for some binding
    variable [x]. We don't know much about [x]; it could be [w], or [y]
    or some other variable. The first and last case are straightforward,
    but the middle case causes difficulty: even though [x] is not free in
    [n_abs x t], it _is_ free in [t]. Therefore, our induction hypothesis
    doesn't apply.

    To solve this problem, we need to generate a completely fresh
    variable [z] for the binder, use the lemma above to replace [y] and
    [w] with it, and then use the induction hypothesis.

 *)
Lemma swap_spec_aux : forall m t w y,
    size t <= m ->
    y `notin` fv_exp (nom_to_exp t) ->
    w <> y ->
    [w ~> var_f y] (nom_to_exp t) =
    nom_to_exp (swap w y t).
Proof.
  induction m; intros t w y SZ;
  destruct t; simpl in *; try lia;
  intros.
  + unfold swap_var; default_simp.
  + unfold swap_var; default_simp.
    { (* w is the binder *)
      rewrite subst_exp_fresh_eq; default_simp.
      autorewrite with lngen in *.
      rewrite (close_exp_wrt_exp_freshen w y); try fsetdec.
      rewrite IHm; default_simp.  }
    { (* y is the binder *)
       autorewrite with lngen in *.
       (* don't know anything about w or y. Either one could
          appear in n. So our IH is useless now. *)
       (* Let's pick a fresh variable z and use it with that. *)
       pick fresh z for (
              fv_exp (nom_to_exp t) \u
              fv_exp (nom_to_exp (swap w y t)) \u {{w}} \u {{y}}).

       (* Use the lemma above to change out the closed variables with
          the fresh one. *)
       rewrite (close_exp_wrt_exp_freshen y z); auto.
       rewrite (close_exp_wrt_exp_freshen w z); auto.

       (* Push the outer substitution into the expression *)
       rewrite subst_exp_close_exp_wrt_exp; auto.

       (* Now use IH three times to rearrange the swaps and substitutions. *)
       rewrite IHm with (y:=z); default_steps.
       rewrite IHm with (y:=z); default_steps.
       rewrite IHm with (y:=y); default_steps.

       rewrite shuffle_swap; auto.

       (* show freshness from last IH *)
       rewrite <- fv_nom_fv_exp_eq.
       apply fv_nom_swap.
       rewrite fv_nom_fv_exp_eq.
       fsetdec.
    }
    { (* neither w or y are binder in the abs case *)
       rewrite <- IHm; default_steps.
       autorewrite with lngen in *.
       fsetdec.
    }
  + rewrite IHm; auto; try lia; try fsetdec.
    rewrite IHm; auto; try lia; try fsetdec.
Qed.

Lemma swap_spec : forall t w y,
    y `notin` fv_exp (nom_to_exp t) ->
    w <> y ->
    [w ~> var_f y] (nom_to_exp t) =
    nom_to_exp (swap w y t).
Proof.
  intros.
  eapply swap_spec_aux with (t:=t)(m:=size t); auto.
Qed.

(***********************************************************************)
(** ** Connection for alpha-equivalence                                 *)
(***********************************************************************)

(** *** Challenge Exercise: [aeq_nom_to_exp]

    Show that alpha-equivalence for the nominal representation is definitional
    equality for LN terms.

    This result is not necessary for the simulation lemmas below, but it
    is another example of the a proof that takes advantage of the
    [swap_spec] and [close_exp_wrt_exp_freshen] lemmas  above.

    The second proof is much more challenging than the first and requires
    lemmas from [Lemmas.v].

*)

Lemma aeq_nom_to_exp : forall n1 n2, aeq n1 n2 -> nom_to_exp n1 = nom_to_exp n2.
Proof.
  (* ADMITTED *)
  induction 1; default_simp;
  autorewrite with lngen in *.
  - congruence.
  - rewrite (close_exp_wrt_exp_freshen y x); auto.
    rewrite swap_spec; auto.
    congruence.
Qed. (* /ADMITTED *)

Lemma nom_to_exp_eq_aeq : forall n1 n2, nom_to_exp n1 = nom_to_exp n2 -> aeq n1 n2.
Proof.
  (* ADMITTED *)
  induction n1; intro n2; destruct n2; default_simp.
  destruct (x == x0).
  - subst. eauto with lngen.
  - assert (FX : x `notin` fv_exp (nom_to_exp n2)).
    { intro IN.
      assert (x `in` fv_exp (nom_to_exp (n_abs x0 n2))).
      { simpl. autorewrite with lngen. fsetdec. }
      simpl in *.
      rewrite <- H0 in H.
      autorewrite with lngen in *.
      fsetdec. }
    eapply aeq_abs_diff; auto.
    + autorewrite with lngen. auto.
    + eapply IHn1.
      rewrite <- swap_spec; eauto.
      rewrite subst_exp_spec.
      rewrite <- H0.
      autorewrite with lngen.
      auto.
Qed. (* /ADMITTED *)

(***********************************************************************)
(** * Scoped configurations                                            *)
(***********************************************************************)

(** Not all abstract machine steps simulate small-steps of the
    substitution-based STLC.

    For example, if the domain of the heap is not unique (i.e. it has
    multiple definitions for the same variable) then its evaluation may
    not produce expected results.

    Similarly, if the [avoid] set that we pass to each machine step does
    not include initial the free variables of the term, then we could
    capture them in strange ways.

    Therefore, we will restrict our correctness lemmas so that they only
    apply to _well-scoped_ configurations; as defined below. *)

(***********************************************************************)
(** ** Scoped heaps                                                    *)
(***********************************************************************)

(** Well-scoped heaps behave "telescopically".  Each binding (x,e) added
    to the heap is for a unique name x and the free variables of e are
    bound in the remainder of the heap.

    The scoping relation is parameterized by [D], an "ambient
    scope". This will let us reason about the execution of the abstract
    machine for terms with free variables. *)

Inductive scoped_heap (D : atoms) : heap -> Prop :=
  | scoped_nil  : scoped_heap D nil
  | scoped_cons : forall x e h,
      x `notin` dom h \u D ->
      fv_exp (nom_to_exp e) [<=] dom h \u D ->
      scoped_heap D h ->
      scoped_heap D ((x,e)::h).

(** *** Recommended (Challenge) Exercise [apply_heap_get]

    We can use [get] to look up expressions in the heap. However, to know that
    we have the right result we need to know that the heap is well-scoped,
    i.e.  that later bindings do not affect earlier ones.

    State a lemma about the scoping of expressions that appear in the heap and
    use it to finish the [apply_heap_get] lemma below.  *)

(* SOLUTION *)
Lemma scoped_get : forall h D1 D2 x e,
  scoped_heap D1 h ->
  get x h = Some e ->
  dom h \u D1 [<=] D2 ->
  fv_exp (nom_to_exp e) [<=] D2.
Proof.
  induction 1; intros; default_simp.
  fsetdec.
  eapply IHscoped_heap; auto; fsetdec.
Qed.
(* /SOLUTION *)

Lemma apply_heap_get :  forall h D x e,
    scoped_heap D h ->
    get x h = Some e ->
    apply_heap h (var_f x) = apply_heap h (nom_to_exp e).
Proof.
  induction 1; intros; default_simp.
  - Case "x is at the current heap location".
    rewrite subst_exp_fresh_eq; auto. fsetdec.
  - Case "x is later in the heap".
    rewrite subst_exp_fresh_eq; auto.
    (* ADMITTED *)
    rewrite scoped_get with (D2:= dom h\u D ); default_simp; eauto.
Qed. (* /ADMITTED *)

(***********************************************************************)
(** ** Scoped stacks                                                    *)
(***********************************************************************)

(** We also care about the free variables that can appear in stacks. (We
    will use this in the definition of well-scoped configurations below.)
*)

Fixpoint fv_stack s :=
  match s with
    nil => {}
  | n_app2 e :: s => fv_exp (nom_to_exp e) \u fv_stack s
  end.

(** Stacks that are well-scoped can discard irrelevant bindings
    from the heap. *)

(* LATER *)
(* TODO: how do we get inductive proofs to automatically
   rewrite with the IH? *)
(* /LATER *)
Lemma apply_stack_fresh_eq : forall s x e1 h ,
    x `notin` fv_stack s ->
    apply_stack ((x, e1) :: h) s = apply_stack h s.
Proof.
  (* WORKINCLASS *)
  induction s; intros; try destruct a; default_simp.
  rewrite IHs; auto.
Qed. (* /WORKINCLASS *)

(***********************************************************************)
(** * Simulation                                                       *)
(***********************************************************************)

(** A scoped configuration is one where all free variables in terms
    are either bound in the heap or come from [D] *)
Inductive scoped_conf : atoms -> configuration -> Prop :=
  scoped_conf_witness : forall D h e s,
    scoped_heap D h ->
    fv_exp (nom_to_exp e) [<=] dom h \u D ->
    fv_stack s [<=] dom h \u D  ->
    scoped_conf D (h,e,s).

(** *** Exercise [simulate_step]

    After stepping through the simulation result below, finish the
    missing case.

*)

(* Could be zero or one steps! *)
Lemma simulate_step : forall D h e s h' e' s' ,
    machine_step D (h,e,s) = TakeStep _ (h',e',s') ->
    scoped_conf D (h,e,s) ->
    decode (h,e,s) = decode (h',e',s') \/
    step (decode (h,e,s)) (decode (h',e',s')).
Proof.
  intros D h e s h' e' s' STEP SCOPE.
  inversion SCOPE; subst; clear SCOPE.
  simpl in *.
  destruct (isVal e) eqn:?.
  destruct s.
  - inversion STEP.
  - destruct f eqn:?.
    + destruct e eqn:?; try solve [inversion STEP].
      right.
      destruct AtomSetProperties.In_dec.
      * (* Application case, we need to generate a fresh
           variable. *)

        destruct atom_fresh.
        inversion STEP; subst; clear STEP.

        (* simplify the context. *)
        simpl in *; autorewrite with lngen in *.
        (* but not too much *)
        rewrite combine.

        (* x0 is a fresh variable, so we can drop it from
           the heap in apply_stack. *)
        rewrite apply_stack_fresh_eq; auto; try fsetdec.
        (* before and after confs use the same stack. So we can step
           congruently. *)
        apply apply_stack_cong.

        simpl.

        (* pull the swap out as a freshening substitution *)
        assert (x <> x0) by fsetdec.
        rewrite <- swap_spec; auto; try fsetdec.
        rewrite (subst_exp_spec _ _ x).
        autorewrite with lngen; auto with lngen.
        default_simp.
        rewrite subst_exp_fresh_eq; autorewrite with lngen; auto.

        (* in the form that matches step beta *)
        apply step_beta; auto with lngen.
        rewrite <- apply_heap_abs.
        eapply apply_heap_lc.
        auto with lngen.

        rewrite H4. fsetdec.
      * (* Homework: Application case, the variable in the abstraction
           is fresh enough. *)
        (* ADMIT *)
        inversion STEP; subst; clear STEP;
          simpl in *;
          rewrite combine;
          rewrite apply_stack_fresh_eq; auto; try fsetdec.
        apply apply_stack_cong;
          autorewrite with lngen in *;
          simpl.
        rewrite subst_exp_spec.
        rewrite apply_heap_open; auto with lngen.

        apply step_beta; auto with lngen.
        rewrite <- apply_heap_abs.
        eapply apply_heap_lc.
        auto with lngen.
        (* /ADMIT *)
  - destruct e eqn:?; try solve [inversion STEP].
    + (* Expression is a variable, lookup in heap *)
      destruct (get x h) eqn:?; inversion STEP; subst; clear STEP.
      left.
      f_equal.
      apply apply_heap_get with (D:= D); auto.
    + (* Expression is an application, push arg on stack *)
      inversion STEP; subst; clear STEP.
      left.
      simpl.
      rewrite apply_heap_app.
      auto.
(* ADMITTED *) Qed. (* /ADMITTED *)

(** *** Exercise [simulate_done]

    Show that if the machine says [Done] then the LN term is a value.
*)

Lemma simulate_done : forall D h e s,
    machine_step (dom h \u D) (h,e,s) = Done _ ->
    scoped_conf D (h,e,s) ->
    is_value (nom_to_exp e).
Proof. (* ADMITTED *)
  intros.
  inversion H0; subst.
  simpl in *.
  destruct (isVal e) eqn:?.
  destruct s eqn:?.
  - destruct e; simpl in Heqb; inversion Heqb.
    econstructor; eauto.
  - destruct f eqn:?.
     + destruct e eqn:?; simpl; try solve [inversion H].
       econstructor; eauto.
  - destruct e; inversion H.
    simpl in Heqb. destruct (get x h); inversion H.
Qed. (* /ADMITTED *)

(** *** Challenge exercise [simulate_error]

    Show that if the machine produces an error, the small step relation
    is stuck.

    This is a challenge exercise because you will need to figure out
    at least one nontrivial auxiliary lemma.

*)

(* SOLUTION *)
Lemma apply_heap_get_none : forall x h,
    get x h = None ->
    apply_heap h (var_f x) = var_f x.
Proof.
  intros.
  alist induction h; simpl in *; auto.
  default_simp.
Qed.

Lemma no_step_stack : forall s h e0,
  not (is_value e0) ->
  not (exists e0', step e0 e0') ->
  not (exists e1, step (apply_stack h s e0) e1).
Proof.
  induction s; intros; try destruct a; simpl in *; auto.
  intros [e1 STEP].
  assert (K1: not (exists e1', step (app e0 (apply_heap h (nom_to_exp n))) e1')).
  { intros [e1' SS].
    inversion SS. subst. simpl in *. contradiction.
    subst. eauto. }
  assert (K2: not (is_value (app e0 (apply_heap h (nom_to_exp n))))).
  { simpl. auto. }
  pose (K := IHs h _ K2 K1). clearbody K.
  eauto.
Qed.
(* /SOLUTION *)

Lemma simulate_error : forall D h e s,
    machine_step (dom h \u D) (h,e,s) = Error _ ->
    scoped_conf D (h,e,s) ->
    not (exists e0, step (decode (h,e,s)) e0).
Proof.
(* ADMITTED *)
  intros.
  simpl in *.
  destruct (isVal e) eqn:?.
  destruct s.
  - destruct e; try solve [inversion H]; simpl in Heqb; inversion Heqb.
  - destruct f eqn:?.
    destruct e eqn:?; try solve [inversion H]; simpl in Heqb; inversion Heqb.
    destruct (AtomSetProperties.In_dec).
    + destruct atom_fresh. inversion H.
    + inversion H.
  - destruct e; try solve [inversion H]; simpl in Heqb; inversion Heqb.
    destruct (get x h) eqn:?. inversion H.
    intros [e0 STEP].
    simpl in *.
    rewrite apply_heap_get_none in STEP; auto.
    eapply no_step_stack with (e0 := var_f x); auto.
       intros [e0' SS]. inversion SS. eauto.
Qed. (* /ADMITTED *)

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

(** *** Challenge exercise [machine_is_scoped]

    Show that if the abstract machine is scoped, then any resulting
    configurations are also scoped. *)

Lemma machine_is_scoped: forall D h e s conf',
    machine_step (dom h \u D) (h,e,s) = TakeStep _ conf' ->
    scoped_conf D (h,e,s) ->
    scoped_conf D conf'.
Proof.
  (* ADMITTED *)
  intros.
  simpl in H.
  inversion H0. subst.
  destruct (isVal e) eqn:?.
  destruct s eqn:?.
  - inversion H.
  - destruct f eqn:?.
     + destruct e eqn:?; try solve [inversion H].
       destruct AtomSetProperties.In_dec.
       ++ destruct atom_fresh.
          inversion H; subst; clear H.
          simpl in *.
          econstructor.
            -- econstructor; eauto. fsetdec.
            -- assert (x <> x0). fsetdec.
               autorewrite with lngen in *.
               rewrite <- swap_spec; try fsetdec.
               rewrite fv_exp_subst_exp_upper.
               simpl.
               fsetdec.
            -- simpl. fsetdec.
       ++ inversion H; subst; clear H.
          simpl in *.
          autorewrite with lngen in *.
          econstructor.
          -- econstructor; eauto. fsetdec.
          -- simpl.
             assert ((union (add x (dom h)) D) [=] (add x (union (dom h) D))).
             fsetdec. rewrite H.
             rewrite <- H6.
             eapply FSetDecideTestCases.test_Subset_add_remove.
          -- simpl. fsetdec.
  - destruct e eqn:?; try solve [inversion H].
    destruct (get x h) eqn:?;
    inversion H; subst; clear H.
    + split. auto.
      simpl in *.
      eapply scoped_get; eauto.
      fsetdec.
      auto.
    + simpl in *.
    inversion H; subst; clear H.
    econstructor.
    auto.
    fsetdec.
    simpl. fsetdec.
Qed. (* /ADMITTED *)