Require Export Defs.
Require Export SfLib.
Require Import LibTactics.

Module STLCHoles.

(* ###################################################################### *)
(** *** Syntax and Operational Semantics *)

Inductive ty : Type :=
  | ty_arrow : ty -> ty -> ty
  | ty_bool  : ty
  | ty_nat   : ty
  | ty_hole  : ty -> ty.

Tactic Notation "ty_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ty_arrow" | Case_aux c "ty_bool"
  | Case_aux c "ty_nat"   | Case_aux c "ty_hole"].

Inductive tm : Type :=
  (* pure STLC *)
  | tm_var : id -> tm
  | tm_app : tm -> tm -> tm
  | tm_abs : id -> ty -> tm -> tm
  (* numbers *)
  | tm_nat : nat -> tm
  | tm_mult : tm -> tm -> tm
  | tm_succ : tm -> tm
  | tm_pred : tm -> tm
  (* bools *)
  | tm_if  : tm -> tm -> tm -> tm
  | tm_tt : tm
  | tm_ff : tm
  (* holes *)
  | tm_hole : ty -> tm.

Tactic Notation "tm_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tm_var" | Case_aux c "tm_app" | Case_aux c "tm_abs"
  | Case_aux c "tm_nat" | Case_aux c "tm_mult" | Case_aux c "tm_succ"
  | Case_aux c "tm_pred" | Case_aux c "tm_if" | Case_aux c "tm_tt"
  | Case_aux c "tm_ff" | Case_aux c "tm_hole" ].

(* ###################################################################### *)
(** *** Substitution *)

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tm_var y =>
      if beq_id x y then s else t
  | tm_abs y T t1 =>
      tm_abs y T (if beq_id x y then t1 else (subst x s t1))
  | tm_app t1 t2 =>
      tm_app (subst x s t1) (subst x s t2)
  | tm_nat n => t
  | tm_succ t1 =>
      tm_succ (subst x s t1)
  | tm_pred t1 =>
      tm_pred (subst x s t1)
  | tm_mult t1 t2 =>
      tm_mult (subst x s t1) (subst x s t2)
  | tm_if t1 t2 t3 =>
      tm_if (subst x s t1) (subst x s t2) (subst x s t3)
  | tm_tt => tm_tt
  | tm_ff => tm_ff
  | tm_hole T => tm_hole T
  end.

(* ###################################################################### *)
(** *** Reduction *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T11 t12,
      value (tm_abs x T11 t12)
  | v_nat : forall x,
      value (tm_nat x)
  | v_tt :
      value tm_tt
  | v_ff :
      value tm_ff
  | v_hole : forall T,
      value (tm_hole T).

Hint Constructors value.

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T11 t12 v2,
      value v2 ->
      (tm_app (tm_abs x T11 t12) v2) ==> (subst x v2 t12)
  | ST_App1 : forall t1 t1' t2,
      t1 ==> t1' ->
      (tm_app t1 t2) ==> (tm_app t1' t2)
  | ST_App2 : forall v1 t2 t2',
      value v1 ->
      t2 ==> t2' ->
      (tm_app v1 t2) ==> (tm_app v1 t2')
  | ST_If : forall b b' x y,
      b ==> b' ->
      (tm_if b x y) ==> (tm_if b' x y)
  | ST_IfTrue : forall x y,
      (tm_if tm_tt x y) ==> x
  | ST_IfFalse : forall x y,
      (tm_if tm_ff x y) ==> y
  | ST_Succ : forall t1 t1',
      t1 ==> t1' ->
      (tm_succ t1) ==> (tm_succ t1')
  | ST_Succ1 : forall n,
      (tm_succ (tm_nat n)) ==> (tm_nat (plus 1 n))
  | ST_PredSucc : forall t1,
      (tm_pred (tm_succ t1)) ==> t1
  | ST_Pred : forall t1 t1',
      t1 ==> t1' ->
      (tm_pred t1) ==> (tm_pred t1')
  | ST_Pred2 : forall n,
      (tm_pred (tm_nat n)) ==> (tm_nat (pred n))
  | ST_PredZero :
      (tm_pred (tm_nat 0)) ==> (tm_nat 0)
  | ST_Mult1 : forall x x' y,
      x ==> x' ->
      (tm_mult x y) ==> (tm_mult x' y)
  | ST_Mult2 : forall x y y',
      y ==> y' ->
      (tm_mult x y) ==> (tm_mult x y')
  | ST_Mult3 : forall x y,
      (tm_mult (tm_nat x) (tm_nat y)) ==> (tm_nat (mult x y))
  (* Hole reductions *)
  | ST_AppH : forall v2 T1 T2,
      value v2 ->
      (tm_app (tm_hole (ty_arrow T1 T2)) v2) ==> tm_hole T2
  | ST_AppAbsH : forall x t T1,
      tm_app (tm_abs x T1 t) (tm_hole T1) ==> (subst x (tm_hole T1) t)
  | ST_IfH1 : forall e1 e2,
      tm_if (tm_hole ty_bool) e1 e2 ==> e1
  | ST_IfH2 : forall e1 e2,
      tm_if (tm_hole ty_bool) e1 e2 ==> e2
  | ST_MultH1 : forall n1,
      tm_mult (tm_hole ty_nat) n1 ==> (tm_hole ty_nat)
  | ST_MultH2 : forall n1,
      tm_mult n1 (tm_hole ty_nat) ==> (tm_hole ty_nat)
  | ST_SuccH :
      tm_succ (tm_hole ty_nat) ==> tm_hole ty_nat
  | ST_PredH :
      tm_pred (tm_hole ty_nat) ==> tm_hole ty_nat

where "t1 '==>' t2" := (step t1 t2).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App1" | Case_aux c "ST_App2"
  | Case_aux c "ST_If" | Case_aux c "ST_IfTrue" | Case_aux c "ST_IfFalse"
  | Case_aux c "ST_Succ" | Case_aux c "ST_Succ1" | Case_aux c "ST_PredSucc"
  | Case_aux c "ST_Pred" | Case_aux c "ST_Pred2" | Case_aux c "ST_PredZero"
  | Case_aux c "ST_Mult1" | Case_aux c "ST_Mult2" | Case_aux c "ST_Mult3"
  | Case_aux c "ST_AppH" | Case_aux c "ST_AppAbsH" | Case_aux c "ST_IfH1"
  | Case_aux c "ST_IfH2" | Case_aux c "ST_MultH1" | Case_aux c "ST_MultH2"
  | Case_aux c "ST_SuccH" | Case_aux c "ST_PredH" ].

Notation stepmany := (refl_step_closure step).
Notation "t1 '==>*' t2" := (stepmany t1 t2) (at level 40).

Hint Constructors step.

Theorem congruence_ST_App1 : forall t1 t1' t2,
  t1 ==>* t1' ->
  tm_app t1 t2 ==>* tm_app t1' t2.
Proof.
  intros.
  rsc_cases (induction H) Case.
  Case "rsc_refl". apply rsc_refl.
  Case "rsc_step". apply rsc_step with (tm_app y t2).
    apply ST_App1. apply H.
    apply IHrefl_step_closure.
Qed.

Theorem congruence_ST_App2 : forall t1 t2 t2',
  value t1 ->
  t2 ==>* t2' ->
  tm_app t1 t2 ==>* tm_app t1 t2'.
Proof with auto.
  introv t1Value t2Step.
  rsc_cases (induction t2Step) Case.
  Case "rsc_refl". apply rsc_refl.
  Case "rsc_step". apply rsc_step with (tm_app t1 y)...
 Qed.

Theorem congruence_ST_If : forall b b' x y,
  b ==>* b' ->
  (tm_if b x y) ==>* (tm_if b' x y).
Proof with auto.
  introv bStep.
  rsc_cases (induction bStep) Case.
  Case "rsc_refl". apply rsc_refl.
  Case "rsc_step". apply rsc_step with (tm_if y0 x y)...
Qed.

Theorem congruence_ST_Mult1 : forall x x' y,
  x ==>* x' ->
  (tm_mult x y) ==>* (tm_mult x' y).
Proof with auto.
  introv xStep.
  rsc_cases (induction xStep) Case.
  Case "rsc_refl". apply rsc_refl.
  Case "rsc_step". apply rsc_step with (tm_mult y0 y)...
Qed.

Theorem congruence_ST_Mult2 : forall x y y',
  y ==>* y' ->
  (tm_mult x y) ==>* (tm_mult x y').
Proof with auto.
  introv yStep.
  rsc_cases (induction yStep) Case.
  Case "rsc_refl". apply rsc_refl.
  Case "rsc_step". apply rsc_step with (tm_mult x y)...
Qed.

(* ###################################################################### *)
(** *** Typing *)

Definition context := partial_map ty.

Inductive has_type : context -> tm -> ty -> Prop :=
  (* Typing rules for proper terms *)
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      has_type Gamma (tm_var x) T
  | T_Abs : forall Gamma x T11 T12 t12,
      has_type (extend Gamma x T11) t12 T12 ->
      has_type Gamma (tm_abs x T11 t12) (ty_arrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      has_type Gamma t1 (ty_arrow T1 T2) ->
      has_type Gamma t2 T1 ->
      has_type Gamma (tm_app t1 t2) T2
  | T_Nat : forall Gamma n,
      has_type Gamma (tm_nat n) ty_nat
  | T_Mult : forall Gamma n m,
      has_type Gamma n ty_nat ->
      has_type Gamma m ty_nat ->
      has_type Gamma (tm_mult n m) ty_nat
  | T_Succ : forall Gamma n,
      has_type Gamma n ty_nat ->
      has_type Gamma (tm_succ n) ty_nat
  | T_Pred : forall Gamma n,
      has_type Gamma n ty_nat ->
      has_type Gamma (tm_pred n) ty_nat
  | T_True : forall Gamma,
      has_type Gamma tm_tt ty_bool
  | T_False : forall Gamma,
      has_type Gamma tm_ff ty_bool
  | T_If : forall Gamma b x y T,
      has_type Gamma b ty_bool ->
      has_type Gamma x T ->
      has_type Gamma y T ->
      has_type Gamma (tm_if b x y) T
  | T_Hole : forall Gamma T,
      has_type Gamma (tm_hole T) T.

Hint Constructors has_type.

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs" | Case_aux c "T_App"
  | Case_aux c "T_Nat"  | Case_aux c "T_Mult" | Case_aux c "T_Succ"
  | Case_aux c "T_Pred" | Case_aux c "T_True" | Case_aux c "T_False"
  | Case_aux c "T_If" | Case_aux c "T_Hole" ].

(* ------------------------------------------------------ *)
(** Refinement relation **)

Inductive Refines : context -> tm -> tm -> ty -> Prop :=
    R_base : forall Gamma e T,
      has_type Gamma e T ->
      Refines Gamma e (tm_hole T) T
  | R_refl : forall Gamma e T,
      has_type Gamma e T ->
      Refines Gamma e e T
  | R_if : forall Gamma b b' e1 e1' e2 e2' T,
      Refines Gamma b b' ty_bool ->
      Refines Gamma e1 e1' T ->
      Refines Gamma e2 e2' T ->
      Refines Gamma (tm_if b e1 e2) (tm_if b' e1' e2') T
  | R_app : forall Gamma e1 e1' e2 e2' T1 T2,
      Refines Gamma e1 e1' (ty_arrow T1 T2) ->
      Refines Gamma e2 e2' T1 ->
      Refines Gamma (tm_app e1 e2) (tm_app e1' e2') T2
  | R_abs : forall Gamma e1 e1' x T1 T2,
      Refines (extend Gamma x T1) e1 e1' T2 ->
      Refines Gamma (tm_abs x T1 e1) (tm_abs x T1 e1') (ty_arrow T1 T2)
  | R_mult : forall Gamma e1 e1' e2 e2',
      Refines Gamma e1 e1' ty_nat ->
      Refines Gamma e2 e2' ty_nat ->
      Refines Gamma (tm_mult e1 e2) (tm_mult e1' e2') ty_nat.
Tactic Notation "refines_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "R_base" | (* Case_aux c "R_trans" | *) Case_aux c "R_refl"
  | Case_aux c "R_if" | Case_aux c "R_app" | Case_aux c "R_abs"
  | Case_aux c "R_mult" ].

Hint Constructors Refines.

(* ###################################################################### *)
(** ** Properties of Typing *)

(** The proofs of progress and preservation for this system are
    essentially the same (though of course somewhat longer) as for the
    pure simply typed lambda-calculus. *)

(* ###################################################################### *)
(** *** Progress *)

Theorem progress : forall t T,
     has_type empty t T ->
     value t \/ exists t', t ==> t'.
Proof with eauto.
  (* Theorem: Suppose empty |- t : T.  Then either
       1. t is a value, or
       2. t ==> t' for some t'.
     Proof: By induction on the given typing derivation. *)
  intros t T Ht.
  remember (@empty ty) as Gamma.
  generalize dependent HeqGamma.
  has_type_cases (induction Ht) Case; intros HeqGamma; subst.
  Case "T_Var".
    (* The final rule in the given typing derivation cannot be [T_Var],
       since it can never be the case that [empty |- x : T] (since the
       context is empty). *)
    inversion H.
  Case "T_Abs".
    (* If the [T_Abs] rule was the last used, then [t = tm_abs x T11 t12],
       which is a value. *)
    left...
  Case "T_App".
    (* If the last rule applied was T_App, then [t = t1 t2], and we know
       from the form of the rule that
         [empty |- t1 : T1 -> T2]
         [empty |- t2 : T1]
       By the induction hypothesis, each of t1 and t2 either is a value
       or can take a step. *)
    right.
    destruct IHHt1; subst...
    SCase "t1 is a value".
      destruct IHHt2; subst...
      SSCase "t2 is a value".
      (* If both [t1] and [t2] are values, then we know that
         [t1 = tm_abs x T11 t12], since abstractions are the only values
         that can have an arrow type.  But
         [(tm_abs x T11 t12) t2 ==> subst x t2 t12] by [ST_AppAbs]. *)
        inversion H; subst; try (solve by inversion).
        exists (subst x t2 t12)...
        inversion Ht1. subst.
        exists (tm_hole T2). apply ST_AppH...
      SSCase "t2 steps".
        (* If [t1] is a value and [t2 ==> t2'], then [t1 t2 ==> t1 t2']
           by [ST_App2]. *)
        destruct H0 as [t2' Hstp]. exists (tm_app t1 t2')...
    SCase "t1 steps".
      (* Finally, If [t1 ==> t1'], then [t1 t2 ==> t1' t2] by [ST_App1]. *)
      destruct H as [t1' Hstp]. exists (tm_app t1' t2)...
  Case "T_Nat".
    left...
  Case "T_Mult".
    right.
    destruct IHHt1; subst...
    SCase "t1 is a value".
      destruct IHHt2; subst...
      SSCase "t2 is a value".
        inversion H; subst; try (solve by inversion).
        inversion H0; subst; try (solve by inversion).

        exists (tm_nat (mult x x0)). auto.
        inversion Ht2; subst.
        exists (tm_hole ty_nat). apply ST_MultH2.
        inversion Ht1; subst.
        exists (tm_hole ty_nat). apply ST_MultH1.
      SSCase "t2 steps".
        inversion H0 as [m' Hstp].
        exists (tm_mult n m')...
    SCase "t1 steps".
        inversion H as [n' Hstp].
        exists (tm_mult n' m)...
  Case "T_Succ".
    right.
    destruct IHHt; subst...
    inversion H; subst; try (solve by inversion).
    exists (tm_nat (plus 1 x)). auto.
    inversion Ht; subst.
    exists (tm_hole ty_nat). apply ST_SuccH.
    destruct H as [n' Hstp]...
  Case "T_Pred".
    right.
    destruct IHHt; subst...
    inversion H; subst; try (solve by inversion).
    exists (tm_nat (pred x)). auto.
    inversion Ht; subst.
    exists (tm_hole ty_nat). apply ST_PredH.
    destruct H as [n' Hstp]...
  Case "T_True".
    left...
  Case "T_False".
    left...
  Case "T_If".
    right.
    destruct IHHt1...
    (* value b *)
    inversion H; subst; try (solve by inversion).
    exists x...
    exists y...
    inversion Ht1; subst.
    exists x...
    (* b ==> b' *)
    inversion H.
    exists (tm_if x0 x y)...
  Case "T_Hole".
    left...
Qed.

(* ###################################################################### *)
(** *** Context Invariance *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tm_var x)
  | afi_succ : forall x n,
      appears_free_in x n ->
      appears_free_in x (tm_succ n)
  | afi_pred : forall x n,
      appears_free_in x n ->
      appears_free_in x (tm_pred n)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tm_app t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tm_app t1 t2)
  | afi_abs : forall x y T11 t12,
      y <> x  ->
      appears_free_in x t12 ->
      appears_free_in x (tm_abs y T11 t12)
  | afi_if1 : forall x t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x (tm_if t1 t2 t3)
  | afi_if2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (tm_if t1 t2 t3)
  | afi_if3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (tm_if t1 t2 t3)
  | afi_mult2 : forall x t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (tm_mult t1 t2)
  | afi_mult1 : forall x t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (tm_mult t1 t2).

Hint Constructors appears_free_in.

Lemma context_invariance : forall Gamma Gamma' t S,
     has_type Gamma t S  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x)  ->
     has_type Gamma' t S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  has_type_cases (induction H) Case;
    intros Gamma' Heqv...
    Case "T_Var".
      apply T_Var... rewrite <- Heqv...
    Case "T_Abs".
      apply T_Abs... apply IHhas_type. intros y Hafi.
      unfold extend. remember (beq_id x y) as e.
      destruct e... apply Heqv. apply afi_abs.
      apply beq_id_false_not_eq. symmetry. assumption.
      assumption.
    Case "T_App".
      apply T_App with T1...
    Case "T_Mult".
      apply T_Mult...
    Case "T_If".
      apply T_If...
Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   has_type Gamma t T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  has_type_cases (induction Htyp) Case; inversion Hafi; subst...
  Case "T_Abs".
    destruct IHHtyp as [T' Hctx]... exists T'.
    unfold extend in Hctx.
    apply not_eq_beq_id_false in H2. rewrite H2 in Hctx...
Qed.

(* ###################################################################### *)
(** *** Preservation *)

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     has_type (extend Gamma x U) t S  ->
     has_type Gamma v U ->
     has_type Gamma (subst x v t) S.
Proof with eauto.
  (* Theorem: If Gamma,x:U |- t : S and empty |- v : U, then
     Gamma |- (subst x v t) S. *)
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent Gamma. generalize dependent S.
  (* Proof: By induction on the term t.  Most cases follow directly
     from the IH, with the exception of tm_var and tm_abs.
     The former aren't automatic because we must reason about how the
     variables interact. *)
  tm_cases (induction t) Case;
    intros S Gamma Htypt; simpl; inversion Htypt; subst...
  Case "tm_var".
    simpl. rename i into y.
    (* If t = y, we know that
         [empty |- v : U] and
         [Gamma,x:U |- y : S]
       and, by inversion, [extend Gamma x U y = Some S].  We want to
       show that [Gamma |- subst x v y : S].

       There are two cases to consider: either [x=y] or [x<>y]. *)
    remember (beq_id x y) as e. destruct e.
    SCase "x=y".
    (* If [x = y], then we know that [U = S], and that [subst x v y = v].
       So what we really must show is that if [empty |- v : U] then
       [Gamma |- v : U].  We have already proven a more general version
       of this theorem, called context invariance. *)
      apply beq_id_eq in Heqe. subst.
      unfold extend in H1. rewrite <- beq_id_refl in H1.
      inversion H1; subst. clear H1.
      admit.
      (* eapply context_invariance... *)
      (* intros x Hcontra. *)
      (* destruct (free_in_context _ _ S empty Hcontra) as [T' HT']... *)
      (* inversion HT'. *)
    SCase "x<>y".
    (* If [x <> y], then [Gamma y = Some S] and the substitution has no
       effect.  We can show that [Gamma |- y : S] by [T_Var]. *)
      admit.
      (* apply T_Var... unfold extend in H1. rewrite <- Heqe in H1... *)
  Case "tm_abs".
    rename i into y. rename t into T11.
    (* If [t = tm_abs y T11 t0], then we know that
         [Gamma,x:U |- tm_abs y T11 t0 : T11->T12]
         [Gamma,x:U,y:T11 |- t0 : T12]
         [empty |- v : U]
       As our IH, we know that forall S Gamma,
         [Gamma,x:U |- t0 : S -> Gamma |- subst x v t0 S].

       We can calculate that
         subst x v t = tm_abs y T11 (if beq_id x y
                                      then t0
                                      else subst x v t0)
       And we must show that [Gamma |- subst x v t : T11->T12].  We know
       we will do so using [T_Abs], so it remains to be shown that:
         [Gamma,y:T11 |- if beq_id x y then t0 else subst x v t0 : T12]
       We consider two cases: [x = y] and [x <> y].
    *)
    admit.
    (* apply T_Abs... *)
    (* remember (beq_id x y) as e. destruct e. *)
    (* SCase "x=y". *)
    (* If [x = y], then the substitution has no effect.  Context
       invariance shows that [Gamma,y:U,y:T11] and [Gamma,y:T11] are
       equivalent.  Since the former context shows that [t0 : T12], so
       does the latter. *)
    (*   eapply context_invariance... *)
    (*   apply beq_id_eq in Heqe. subst. *)
    (*   intros x Hafi. unfold extend. *)
    (*   destruct (beq_id y x)... *)
    (* SCase "x<>y". *)
    (* If [x <> y], then the IH and context invariance allow us to show that
         [Gamma,x:U,y:T11 |- t0 : T12]       =>
         [Gamma,y:T11,x:U |- t0 : T12]       =>
         [Gamma,y:T11 |- subst x v t0 : T12] *)
      (* apply IHt. eapply context_invariance... *)
      (* intros z Hafi. unfold extend. *)
      (* remember (beq_id y z) as e0. destruct e0... *)
      (* apply beq_id_eq in Heqe0. subst. *)
      (* rewrite <- Heqe... *)
Qed.

Theorem preservation : forall Gamma t t' T,
     has_type Gamma t T  ->
     t ==> t'  ->
     has_type Gamma t' T.
Proof with eauto.
  intros Gamma t t' T HT.
  (* Theorem: If [empty |- t : T] and [t ==> t'], then [empty |- t' : T]. *)
  (* remember (@empty ty) as Gamma.  *)
  (* generalize dependent HeqGamma. *)
  generalize dependent t'.
  (* Proof: By induction on the given typing derivation.  Many cases are
     contradictory ([T_Var], [T_Abs]).  We show just the interesting ones. *)
  has_type_cases (induction HT) Case;
    intros t' HE; subst; inversion HE; subst...
  Case "T_App".
    (* If the last rule used was [T_App], then [t = t1 t2], and three rules
       could have been used to show [t ==> t']: [ST_App1], [ST_App2], and
       [ST_AppAbs]. In the first two cases, the result follows directly from
       the IH. *)
    inversion HE; subst...
    SCase "ST_AppAbs".
      (* For the third case, suppose
           [t1 = tm_abs x T11 t12]
         and
           [t2 = v2].
         We must show that [empty |- subst x v2 t12 : T2].
         We know by assumption that
             [empty |- tm_abs x T11 t12 : T1->T2]
         and by inversion
             [x:T1 |- t12 : T2]
         We have already proven that substitution_preserves_typing and
             [empty |- v2 : T1]
         by assumption, so we are done. *)
      apply substitution_preserves_typing with T1...
      inversion HT1...
    SCase "ST_AppAbsH".
      apply substitution_preserves_typing with T11.
      inversion HT1...
      apply T_Hole.
    SCase "ST_AppH".
      inversion HT1; subst...
    SCase "ST_AppAbsH??".
      apply substitution_preserves_typing with T1.
      inversion HT1... auto.
  Case "T_Pred".
    inversion HT; subst. assumption.
Qed.

(** Proofs **)

Theorem refinement_implies_welltypedness : forall Gamma v u T,
  Refines Gamma v u T ->
  has_type Gamma v T.
Proof with eato.
  intros.
  refines_cases (induction H) Case; try (assumption).
  Case "R_if".
    apply T_If.
    assumption. assumption. assumption.
  Case "R_app".
    eapply T_App. apply IHRefines1. apply IHRefines2.
  Case "R_abs".
    eapply T_Abs. apply IHRefines.
  Case "R_mult".
    apply T_Mult. assumption. assumption.
Qed.

Theorem refinement_implies_welltypedness_right : forall Gamma v u T,
  Refines Gamma v u T ->
  has_type Gamma u T.
Proof with eato.
  intros.
  refines_cases (induction H) Case; try (assumption).
  Case "R_base".
    apply T_Hole.
  Case "R_if".
    apply T_If.
    assumption. assumption. assumption.
  Case "R_app".
    eapply T_App. apply IHRefines1. apply IHRefines2.
  Case "R_abs".
    eapply T_Abs. apply IHRefines.
  Case "R_mult".
    apply T_Mult. assumption. assumption.
Qed.

Theorem extension_aliasing : forall Gamma x y (T1:ty) (T2:ty),
  true = beq_id x y ->
  (extend (extend Gamma x T1) y T2) = (extend Gamma y T2).
Proof.
  admit.

Qed.

Theorem extension_aliasing_w_app : forall Gamma x y z (T1:ty) (T2:ty),
  beq_id x y = true ->
  (extend (extend Gamma x T1) y T2) z = (extend Gamma y T2) z.
Proof.
  intros.
  unfold extend.
  assert (x=y). apply beq_id_eq. symmetry. assumption.
  rewrite <- H0.
  remember (beq_id x z) as E.
  destruct (beq_id x z). rewrite -> HeqE. reflexivity.

  rewrite -> HeqE.
  reflexivity.
Qed.

Theorem substitution_lemma : forall Gamma v u x Tx e1 e2 Te,
  Refines (extend Gamma x Tx) e1 e2 Te ->
  Refines Gamma v u Tx ->
  Refines Gamma (subst x v e1) (subst x u e2) Te.
Proof with eauto.
  intros Gamma v u x Tx e1 e2 Te H.

  remember (extend Gamma x Tx) as GammaX.
  (* generalize dependent Tx. *)

  refines_cases (induction H) Case; intros; simpl...
  Case "R_base".
    simpl. apply R_base. apply substitution_preserves_typing with (U:= Tx).
    rewrite -> HeqGammaX in H. assumption.

    eapply refinement_implies_welltypedness. apply H0.
  Case "R_refl".
    rewrite -> HeqGammaX in H.

    tm_cases (induction H) SCase.
    SCase "tm_var".
      unfold subst. remember (beq_id x x0) as e. destruct e...
      SSCase "x=x0".
        admit. (* fix empty/Gamma problem... *)
      SSCase "x<>x0".
        apply R_refl. apply T_Var.
        rewrite <- HeqGammaX in H.
        admit.
        (* rewrite -> extend_neq in H. apply H. symmetry. apply Heqe. *)
    SCase "tm_app".
      remember (beq_id x x0) as e.
      destruct e.
      SSCase "x = x0".
        simpl. rewrite <- Heqe.
        apply R_refl.
        admit.
        (*
        apply T_Abs. rewrite -> HeqGammaX in H.
        assert (x = x0) as xEq. apply beq_id_eq. assumption.
        rewrite -> xEq in H.
        assert ((extend Gamma x0 T11) = (extend (extend Gamma x0 Tx) x T11)).
        admit.
        (* fix to give Gamma an argument so that the shadowing lemma can be used *)
        admit.
*)

      SSCase "x <> x0".
        simpl. rewrite <- Heqe.
        apply R_abs.
        admit.
    SCase "tm_abs".
      admit.
    SCase "tm_nat".
      admit.
    SCase "tm_mult".
      admit.
    SCase "tm_succ".
      admit.
    SCase "tm_pred".
      admit.
    SCase "tm_if".
      admit.
    SCase "tm_tt".
      admit.
    SCase "tm_ff".
      admit.
    SCase "tm_hole".
      admit.
  Case "R_abs".
    remember (beq_id x x0) as b.
    destruct b.
    SCase "x == x0".
      apply R_abs...
      rewrite -> HeqGammaX in H.
      assert ((extend (extend Gamma x Tx) x0 T1) = (extend Gamma x0 T1)) as HShadow.
      apply extension_aliasing with (x:=x) (T1:=Tx) (y:=x0) (T2:=T1)...
      rewrite -> HShadow in H...
    SCase "x <> x0".
      apply R_abs...
      (* stuck... *)
      admit.
Qed.

Theorem type_uniqueness : forall Gamma e T1 T2,
  has_type Gamma e T1 ->
  has_type Gamma e T2 ->
  T1 = T2.
Proof with eauto.
  intros.
  generalize dependent T2.
  (* why doesn't 'solve by inversion' work below? *)
  has_type_cases (induction H) Case; intros; try (solve by inversion).
  Case "T_Var".
    inversion H0; subst.
    rewrite -> H3 in H.
    inversion H...
  Case "T_Abs".
    inversion H0; subst.
    f_equal.
    eapply IHhas_type...
  Case "T_App".
    inversion H1; subst.

    assert ((ty_arrow T1 T2) = (ty_arrow T3 T0)) as Harrow.
    eapply IHhas_type1...

    inversion Harrow...
  Case "T_Nat".
    inversion H0; subst...
  Case "T_Mult".
    inversion H1; subst...
  Case "T_Succ".
    inversion H0; subst...
  Case "T_Pred".
    inversion H0; subst...
  Case "T_True".
    inversion H0; subst...
  Case "T_False".
    inversion H0; subst...
  Case "T_If".
    inversion H2; subst...
  Case "T_Hole".
    inversion H0; subst...
Qed.

Theorem trans_type_refinement : forall Gamma e1 e2 e3 T1 T2,
  Refines Gamma e1 e2 T1 ->
  Refines Gamma e2 e3 T2 ->
  T1 = T2.
Proof with eauto.
  intros.
  generalize dependent T2.
  generalize dependent e3.
  refines_cases (induction H) Case; intros; try (solve by inversion).
  Case "R_base".
    inversion H0; subst...
    inversion H1; subst...

    inversion H1; subst...
  Case "R_refl".
    inversion H0; subst; try (eapply type_uniqueness)...
    (* tm_if *)
    eapply T_If; try (eapply refinement_implies_welltypedness)...
    (* tm_app *)
    eapply T_App; try (eapply refinement_implies_welltypedness)...
    (* tm_abs *)
    eapply T_Abs; try (eapply refinement_implies_welltypedness)...
    (* tm_mult *)
    eapply T_Mult; try (eapply refinement_implies_welltypedness)...
  Case "R_if".
    inversion H2; subst; try (inversion H3; subst)...
   Case "R_app".
     eapply refinement_implies_welltypedness in H1.
     inversion H1; subst.
     eapply refinement_implies_welltypedness_right in H.
     eapply refinement_implies_welltypedness_right in H0.
     assert ((ty_arrow T1 T2) = (ty_arrow T3 T0)) as ArrowEq.
       eapply type_uniqueness...
     inversion ArrowEq...
   Case "R_abs".
     eapply refinement_implies_welltypedness_right in H.
     eapply refinement_implies_welltypedness in H0.
     inversion H0; subst.
     f_equal.
     eapply type_uniqueness...
   Case "R_mult".
     eapply refinement_implies_welltypedness in H1.
     inversion H1; subst...
Qed.

Theorem transitivity_of_refines : forall Gamma a b c T,
  Refines Gamma a b T ->
  Refines Gamma b c T ->
  Refines Gamma a c T.
Proof with eauto.
  intros Gamma a b c T Hab Hbc.
    generalize dependent c.
  refines_cases (induction Hab) Case; intros c Hbc; inversion Hbc; subst...
  Case "R_if".
    SCase "c hole".
      apply R_base...
      apply T_If.
      eapply refinement_implies_welltypedness. apply Hab1.
      eapply refinement_implies_welltypedness. apply Hab2.
      eapply refinement_implies_welltypedness. apply Hab3.
  Case "R_app".
    SCase "tm_hole".
     apply R_base...
     eapply T_App.
     eapply refinement_implies_welltypedness. apply Hab1.
     eapply refinement_implies_welltypedness. apply Hab2.
    SCase "c is tm_app".
      eapply R_app...
      SSCase "ty_arrow".
        inversion Hbc; subst...
        eapply IHHab1.

        assert (T1 = T3) as Teq.
          eapply trans_type_refinement. apply Hab2. apply H8.

        rewrite -> Teq...
      SSCase "argument".
        inversion Hbc; subst...
        eapply IHHab2.
        assert (T1 = T3) as Teq.
          eapply trans_type_refinement. apply Hab2. apply H8.
        rewrite -> Teq...
  Case "R_abs".
    SCase "tm_hole".
      apply R_base...
      apply T_Abs. eapply refinement_implies_welltypedness. apply Hab.
  Case "R_mult".
    SCase "tm_hole".
      apply R_base.
      eapply T_Mult.
        eapply refinement_implies_welltypedness. apply Hab1.
        eapply refinement_implies_welltypedness. apply Hab2.
Qed.

Theorem refinement_implies_value : forall Gamma v e T,
  value v ->
  Refines Gamma v e T ->
  value e.
Proof with eauto.
  intros.
  inversion H; subst.
  remember H0. clear Heqr.
  remember H0. clear Heqr0.
  inversion H0; subst...
  inversion H0; subst...
  inversion H0; subst...
  inversion H0; subst...
  inversion H0; subst...
Qed.

Theorem soundness : forall Gamma p q p' T,
  Refines Gamma p q T ->
  p ==> p' ->
  exists q', q ==>* q' /\
  Refines Gamma p' q' T.
Proof with eauto.
  introv H S.
  gen q T.
  step_cases (induction S) Case.
  Case "ST_AppAbs".
    intros.
    inversion H0; subst.
    SCase "R_hole".
      exists (tm_hole T).
      split. apply rsc_refl.
      apply R_base.
      inversion H1; subst.
      eapply substitution_preserves_typing with (U:=T1).
      inversion H5; subst.
      assumption...
      assumption...
    SCase "R_refl".
      exists (subst x v2 t12).
      split. eapply rsc_step. eapply ST_AppAbs. assumption. apply rsc_refl.
      eapply substitution_lemma.
      eapply R_refl.
      inversion H1; subst. inversion H5; subst. apply H4.
      eapply R_refl. inversion H1; subst. inversion H5; subst. assumption.
    SCase "R_app".
      inversion H4; subst.
      SSCase "R_hole".
        exists (tm_hole T).
        split.
        eapply rsc_step. eapply ST_AppH.
        eapply refinement_implies_value...
        apply rsc_refl.
        eapply R_base.
        inversion H1; subst.
        eapply substitution_preserves_typing with (U:=T1)...
        apply refinement_implies_welltypedness in H7...
      SSCase "R_refl".
        exists (subst x e2' t12).
        split.
        eapply rsc_step.
        eapply ST_AppAbs.
        eapply refinement_implies_value in H7...
        eapply rsc_refl.
        eapply substitution_lemma...
        eapply R_refl.
        inversion H1; subst...
      SSCase "R_abs".
        exists (subst x e2' e1'0).
        split.
        eapply rsc_step. eapply ST_AppAbs.
        eapply refinement_implies_value in H7...
        eapply rsc_refl.
        eapply substitution_lemma...
  Case "ST_App1".
    introv R.
    inverts R.
    SCase "R_hole".
      exists (tm_hole T).
      split...
      (* right: refines *)
      eapply R_base.
      inversion H; subst.
      eapply T_App.
      eapply preservation...
      assumption.
    SCase "R_refl".
      exists (tm_app t1' t2).
      split.
      eapply rsc_step...
      eapply R_refl.
      eapply preservation.
      apply H.
      eapply ST_App1...
    SCase "R_app".
      specialize IHS with (q:=e1') (T:=(ty_arrow T1 T)).
      specialize (IHS H2).

      destruct IHS as (e1'' & e1Step & e1Refine).
      exists (tm_app e1'' e2').
      split.
      eapply congruence_ST_App1...
      eapply R_app...
  Case "ST_App2".
    intros.
    inversion H0; subst.
    SCase "R_hole".
      exists (tm_hole T).
      split...
      apply R_base.
      eapply preservation...
    SCase "R_refl".
      exists (tm_app v1 t2').
      split...
      apply R_refl.
      eapply preservation...
    SCase "R_app".
      specialize IHS with (q:=e2') (T:=T1).
      specialize (IHS H7).

      destruct IHS as (e2'' & e2Step & e2Refine).
      exists (tm_app e1' e2'').
      split.
      eapply congruence_ST_App2...
      eapply refinement_implies_value...
      eapply R_app...
  Case "ST_If".
    introv R.
    inversion R; subst.
    SCase "R_base".
      exists (tm_hole T).
      split...
      eapply R_base...
      eapply refinement_implies_welltypedness in R.
      eapply preservation...
    SCase "R_refl".
      exists (tm_if b' x y).
      split...
      eapply R_refl...
      eapply refinement_implies_welltypedness in R.
      eapply preservation...
    SCase "R_If".
      specialize IHS with (q:=b'0) (T:=ty_bool).
      specialize (IHS H3).
      destruct IHS as (b'' & bStep & bRefine).
      exists (tm_if b'' e1' e2').
      split.
      eapply congruence_ST_If...
      eapply R_if...
  Case "ST_IfTrue".
    introv R.
    inversion R; subst.
    SCase "R_base".
      inverts H.
      exists (tm_hole T).
      split...
    SCase "R_refl".
      inverts H.
      exists x.
      split...
    SCase "R_if".
      inverts H3.
      exists e1'...
      exists e1'...
  Case "ST_IfFalse".
    introv R.
    inversion R; subst.
    SCase "R_base".
      inverts H.
      exists (tm_hole T).
      split...
    SCase "R_refl".
      inverts H.
      exists y.
      split...
    SCase "R_if".
      inverts H3.
      exists e2'...
      exists e2'...
  Case "ST_Succ".
    introv R.
    inversion R; subst.
    SCase "R_base".
      exists (tm_hole T).
      inverts H.
      split...
      eapply R_base.
      eapply T_Succ.
      eapply preservation...
    SCase "R_refl".
      exists (tm_succ t1').
      inverts H.
      split...
      eapply R_refl...
      eapply T_Succ...
      eapply preservation...
  Case "ST_Succ1".
    introv R.
    inversion R; subst.
    exists (tm_hole T).
    inverts H.
    split...
    exists (tm_nat (S n)).
    inverts H.
    split...
  Case "ST_PredSucc".
    introv R.
    inversion R; subst.
    exists (tm_hole T).
    inverts H.
    split...
    inverts H2.
    eapply R_base...
    exists t1.
    inverts H; inverts H2.
    split...
  Case "ST_Pred".
    introv R.
    inversion R; subst.
    exists (tm_hole T).
    inverts H.
    split...
    eapply R_base.
    eapply T_Pred.
    eapply preservation...
    exists (tm_pred t1').
    inverts H.
    split...
    eapply R_refl.
    eapply T_Pred.
    eapply preservation...
  Case "ST_Pred2".
    introv R.
    inversion R; subst.
    exists (tm_hole T).
    inverts H.
    split...

    exists (tm_nat (pred n)).
    inverts H.
    split...
  Case "ST_PredZero".
    introv R.
    inversion R; subst.
    exists (tm_hole T).
    inverts H.
    split...

    exists (tm_nat 0).
    inverts H.
    split...
  Case "ST_Mult1".
    introv R.
    inversion R; subst.
    exists (tm_hole T).
    inverts H.
    split...
    eapply R_base.
    eapply T_Mult...
    apply preservation with (t':=x') (t:=x)...

    exists (tm_mult x' y).
    inverts H.
    split...
    eapply R_refl.
    eapply T_Mult.
    apply preservation with (t':=x') (t:=x)...
    auto.

    specialize IHS with (q:=e1') (T:=ty_nat).
    specialize (IHS H2).
    destruct IHS as (e1'' & e1Step & e1Refines).

    exists (tm_mult e1'' e2').
    split...
    eapply congruence_ST_Mult1...
  Case "ST_Mult2".
    introv R.
    inversion R; subst.
    exists (tm_hole T).
    inverts H.
    split...
    eapply R_base.
    eapply T_Mult...
    apply preservation with (t':=y') (t:=y)...

    exists (tm_mult x y').
    inverts H.
    split...
    eapply R_refl.
    eapply T_Mult...
    apply preservation with (t':=y') (t:=y)...

    specialize IHS with (q:=e2') (T:=ty_nat).
    specialize (IHS H5).
    destruct IHS as (e2'' & e2Step & e2Refines).

    exists (tm_mult e1' e2'').
    split...
    eapply congruence_ST_Mult2...
  Case "ST_Mult3".
    introv R.
    inversion R; subst.
    exists (tm_hole T).
    inverts H.
    split...

    exists (tm_nat (mult x y)).
    inverts H.
    split...

    inverts H2.
    exists (tm_hole ty_nat).
    split...
    inverts H5.
    exists (tm_hole ty_nat).
    split...
    exists (tm_nat (mult x y)).
    split...
  Case "ST_AppH".
    introv R.
    inversion R; subst.
    SCase "R_hole".
      exists (tm_hole T).
      split...
      inverts H0.
      inverts H4...
    SCase "R_refl".
      exists (tm_hole T2).
      inverts H0. inverts H4.
      split...
    SCase "R_app".
      inverts H3.
      (* tm_hole (ty_arrow T0 T) *)
        inverts H0.
        exists (tm_hole T).
        split...
        eapply refinement_implies_value in H6...
      (* tm_hole (ty_arrow T1 T2) *)
        inverts H0.
        exists (tm_hole T).
        split...
        eapply refinement_implies_value in H6...
  Case "ST_AppAbsH".
    introv R.
    inversion R; subst.
    SCase "R_hole".
      exists (tm_hole T).
      split...
      eapply R_base.
      inverts H.
      inverts H3.
      eapply substitution_preserves_typing...
    SCase "R_refl".
      exists (subst x (tm_hole T1) t).
      split...
      eapply R_refl.
      inverts H.
      inverts H3.
      eapply substitution_preserves_typing...
    SCase "R_app".
      inverts H2.

      exists (tm_hole T).
      split...
      eapply rsc_step.
      eapply ST_AppH.
      inverts H5...
      eapply rsc_refl.
      eapply R_base.
      inverts H.
      eapply substitution_preserves_typing...

      inverts H5. inverts H.
      exists (subst x (tm_hole T0) t).
      split...
      eapply R_refl.
      eapply substitution_preserves_typing...

      inverts H.
      exists (subst x (tm_hole T0) t).
      split...
      eapply R_refl.
      eapply substitution_preserves_typing...

      inverts H5.
      skip.
      exists (subst x (tm_hole T0) e1'0).
      split...
      eapply substitution_lemma...
  Case "ST_IfH1".
    introv R.
    inverts R.
    SCase "R_hole".
      exists (tm_hole T).
      inverts H.
      split...
    SCase "R_refl".
      exists e1.
      inverts H.
      split...
    SCase "R_if".
      inverts H3.
      exists e1'; split...
      exists e1'; split...
  Case "ST_IfH2".
    introv R.
    inverts R.
    SCase "R_hole".
      exists (tm_hole T).
      inverts H.
      split...
    SCase "R_refl".
      inverts H.
      exists e2.
      split...
    SCase "R_if".
      inverts H3.
      exists e2'; split...
      exists e2'; split...
  Case "ST_MultH1".
    introv R.
    inverts R.
    SCase "R_hole".
      exists (tm_hole T).
      inverts H.
      split...
    SCase "R_refl".
      inverts H.
      exists (tm_hole ty_nat).
      split...
    SCase "R_mult".
      inverts H2.
      exists (tm_hole ty_nat).
      split...
      exists (tm_hole ty_nat).
      split...
  Case "ST_MultH2".
    introv R.
    inverts R.
    SCase "R_hole".
      exists (tm_hole T).
      inverts H.
      split...
    SCase "R_refl".
      inverts H.
      exists (tm_hole ty_nat).
      split...
    SCase "R_mult".
      inverts H5.
      exists (tm_hole ty_nat).
      split...
      exists (tm_hole ty_nat).
      split...
  Case "ST_SuccH".
    introv R.
    inverts R.
    exists (tm_hole T).
    inverts H.
    split...
    exists (tm_hole T).
    inverts H.
    split...
  Case "ST_PredH".
    introv R.
    inverts R.
    exists (tm_hole T).
    inverts H.
    split...
    exists (tm_hole T).
    inverts H.
    split...
Qed.


(*

  Copyright 2014 Cornell University

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

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

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

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

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

*)

Require Export list.
Require Import Omega.

(** printing #  $\times$ #×# *)
(** printing <=>  $\Leftrightarrow$ #⇔# *)
(** printing &  $\times$ #×# *)

(* ------ variables ------ *)

(** We define our variables exactly as that in Software Foundations
  %  \footnote{\url{http://www.cis.upenn.edu/~bcpierce/sf/}} %.
  Basically, variables are wrappers around numbers.
  We could have defined them as wrappers around any (countably) infinite
  type with decidable equality.
 *)

Inductive NVar : Set :=
| nvar : nat -> NVar.

(** %\noindent% Here are some examples of variables.

 *)

Definition nvarx := nvar 0.
Definition nvary := nvar 1.
Definition nvarz := nvar 2.

(* begin hide *)

Definition nvarf := nvar 3.
Definition nvarg := nvar 4.
Definition nvarh := nvar 5.

Definition nvari := nvar 6.
Definition nvarj := nvar 7.
Definition nvark := nvar 8.
Definition nvarl := nvar 9.

Definition nvara := nvar 10.
Definition nvarb := nvar 11.
Definition nvarc := nvar 12.
Definition nvard := nvar 13.

Definition beq_var v1 v2 :=
  match (v1, v2) with
    (nvar n1, nvar n2) => beq_nat n1 n2
  end.

Definition le_var v1 v2 :=
  match (v1, v2) with
      (nvar n1, nvar n2) => n1 <= n2
  end.

Definition lt_var v1 v2 :=
  match (v1, v2) with
      (nvar n1, nvar n2) => n1 < n2
  end.

(* After we "wrap" numbers as identifiers in this way, it is
    convenient to recapitulate a few properties of numbers as
    analogous properties of identifiers, so that we can work with
    identifiers in definitions and proofs abstractly, without
    unwrapping them to expose the underlying numbers.  Since all we
    need to know about identifiers is whether they are the same or
    different, just a few basic facts are all we need. *)

Theorem beq_var_refl : forall X,
  true = beq_var X X.
Proof.
  intros. destruct X.
  apply beq_nat_refl.
Qed.

Theorem beq_var_eq : forall i1 i2,
  true = beq_var i1 i2 -> i1 = i2.
Proof.
 intros.
 destruct i1; destruct i2.
 unfold beq_var in H.
 apply beq_nat_eq in H; auto.
Defined.

(* same as beq_var_eq *)
Theorem beq_var_true :
  forall i1 i2,
    true = beq_var i1 i2 -> i1 = i2.
Proof.
  apply beq_var_eq.
Qed.

Theorem beq_var_false_not_eq : forall i1 i2,
  beq_var i1 i2 = false -> i1 <> i2.
Proof.
 intros.
 destruct i1; destruct i2.
 unfold beq_var in H.
 apply beq_nat_false_iff in H.
 intro; apply H; inversion H0; auto.
Defined.

(* same as beq_var_false_not_eq *)
Theorem beq_var_false :
  forall i1 i2,
    false = beq_var i1 i2 -> i1 <> i2.
Proof.
  sp; symmetry in H.
  apply beq_var_false_not_eq in H; sp.
Qed.

Theorem not_eq_beq_var_false : forall i1 i2,
  i1 <> i2 -> beq_var i1 i2 = false.
Proof.
 intros; destruct i1; destruct i2; unfold beq_var.
 rewrite beq_nat_false_iff; intro. apply H; auto.
Qed.

Theorem beq_var_sym: forall i1 i2,
  beq_var i1 i2 = beq_var i2 i1.
Proof.
 intros; destruct i1; destruct i2; unfold beq_var.
 rewrite beq_nat_sym; auto.
Qed.

Lemma true_eq_nvar : forall t : NVar, t = t <=> True.
Proof. sp; split; sp. Qed.

(* end hide *)

(** We need decidable equality on variables so that
  many useful relations on our future definitions of Terms, like equality,
  alpha equality, etc. will be decidable.
  Also our substitution function will need this decidable equality to
  decide whether it needs to come up with fresh variables.
  Decidable equality on variables is a  straightforward consequence
  of decidable equality on the underlying type.

*)

Theorem eq_var_dec: forall x y : NVar, {x = y} + {x <> y}.
(* begin hide *)
Proof.
  intros.
  remember (beq_var x y) as b.
  destruct b.
  left. apply beq_var_eq. auto.
  right. apply beq_var_false_not_eq. auto.
Defined.

Lemma in_nvar_list_dec: forall (x : NVar) l, LIn x l [+] ! LIn x l.
Proof.
  induction l; simpl; sp. try (complete (right; sp)).
  destruct (eq_var_dec a x); subst; sp.
  right; sp.
Defined.

Theorem deq_nvar: Deq NVar.
Proof.
  unfold Deq. apply eq_var_dec.
Defined.
Hint Immediate deq_nvar.
Hint Resolve deq_nvar : Deq.

(** boolean membership of variable in a list of variables *)
Definition memvar := memberb eq_var_dec.

Lemma assert_memvar :
  forall v vars,
    assert (memvar v vars) <=> LIn v vars.
Proof.
  unfold memvar; intros.
  apply assert_memberb.
Qed.

Lemma memvar_app :
  forall v vs1 vs2,
    memvar v (vs1 ++ vs2) = memvar v vs1 || memvar v vs2.
Proof.
  unfold memvar; sp.
  apply memberb_app.
Qed.

Lemma memvar_singleton :
  forall a b,
    memvar a [b] = beq_var a b.
Proof.
  sp.
  unfold memvar; simpl.
  destruct (eq_var_dec b a); subst; sp.
  apply beq_var_refl.
  symmetry; apply not_eq_beq_var_false; sp.
Qed.

(** removes the elements of l1 from l2 *)
Definition remove_nvars (l1 l2 : list NVar) :=
 @diff _ eq_var_dec l1 l2.

Definition remove_nvar (l : list NVar) (v : NVar) :=
 remove_nvars [v] l.

Lemma null_remove_nvars :
  forall l1 l2,
    null (remove_nvars l1 l2) <=> forall x, LIn x l2 -> LIn x l1.
Proof.
  unfold remove_nvars.
  apply null_diff.
Qed.

Lemma in_remove_nvars :
  forall x l1 l2,
    LIn x (remove_nvars l1 l2) <=> (LIn x l2 # ! LIn x l1).
Proof.
  intros; apply in_diff.
Qed.

Lemma in_remove_nvar :
  forall x v l,
    LIn x (remove_nvar l v) <=> (LIn x l # x <> v).
Proof.
  intros; unfold remove_nvar; trw in_remove_nvars; simpl; split; sp.
Qed.

Lemma remove_nvar_nil : forall v, remove_nvar [] v = [].
Proof.
  sp.
Qed.

Lemma remove_nvars_unchanged :
  forall l1 l2,
    disjoint l2 l1 <=> remove_nvars l1 l2 = l2.
Proof.
  unfold remove_nvars.
  apply disjoint_iff_diff.
Qed.

Lemma remove_nvars_nil_l : forall l, remove_nvars [] l = l.
Proof.
  unfold remove_nvars; simpl; auto.
Qed.

Hint Rewrite remove_nvars_nil_l.

(* same as remove_nvars_nil_l *)
Lemma remove_var_nil : forall l, remove_nvars [] l = l.
Proof.
  sp; autorewrite with core.
Qed.

Lemma remove_nvars_nil_r : forall l, remove_nvars l [] = [].
Proof.
  unfold remove_nvars. apply diff_nil.
Qed.

Hint Rewrite remove_nvars_nil_r.

Lemma remove_nvars_app_r :
  forall l1 l2 l3,
    remove_nvars l1 (l2 ++ l3) = remove_nvars l1 l2 ++ remove_nvars l1 l3.
Proof.
  unfold remove_nvars.
  apply diff_app_r.
Qed.

Lemma remove_nvars_app_l :
  forall l1 l2 l3,
     remove_nvars l1 (remove_nvars l2 l3) = remove_nvars (l1 ++ l2) l3.
Proof.
  unfold remove_nvars.
  apply diff_app_l.
Qed.

Lemma remove_nvars_flat_map :
  forall T,
  forall f : T -> list NVar,
  forall l : list T,
  forall vars : list NVar,
   remove_nvars vars (flat_map f l) =
   flat_map (compose (fun vs => remove_nvars vars vs) f) l.
Proof.
  induction l; simpl; sp.
  apply remove_nvars_nil_r.
  rewrite remove_nvars_app_r.
  rewrite IHl.
  unfold compose.
  auto.
Qed.

Lemma remove_nvars_comm :
  forall l1 l2 l3,
    remove_nvars l1 (remove_nvars l2 l3) = remove_nvars l2 (remove_nvars l1 l3).
Proof.
  unfold remove_nvars; apply diff_comm.
Qed.

Lemma remove_nvars_dup :
  forall l1 l2 x l3,
    LIn x l1 -> remove_nvars (l1 ++ l2) l3 = remove_nvars (l1 ++ x :: l2) l3.
Proof.
  unfold remove_nvars; intros.
  apply diff_dup2; auto.
Qed.

Lemma remove_nvars_move :
  forall l1 l2 l3 x,
    remove_nvars (l1 ++ x :: l2) l3 = remove_nvars (x :: l1 ++ l2) l3.
Proof.
  unfold remove_nvars; intros.
  apply diff_move; auto.
Qed.

Lemma remove_nvars_cons :
  forall v l1 l2,
    remove_nvars (v :: l1) l2 = remove_nvars l1 (remove eq_var_dec v l2).
Proof.
  unfold remove_nvars; simpl; auto.
Qed.

Lemma remove_nvars_cons_l_weak :
  forall v vs vars,
    !LIn v vars
    -> remove_nvars (v :: vs) vars
       = remove_nvars vs vars.
Proof.
  intros; unfold remove_nvars.
  rewrite diff_cons_r_ni; auto.
Qed.

Lemma remove_nvars_cons_r :
  forall l v vars,
    remove_nvars l (v :: vars)
    = if memvar v l then remove_nvars l vars
      else v :: remove_nvars l vars.
Proof.
  intros; unfold remove_nvars.
  rewrite diff_cons_r; auto.
Qed.

Lemma remove_nvar_cons :
  forall v x xs,
    remove_nvar (x :: xs) v
    = if beq_var v x then remove_nvar xs v
      else x :: remove_nvar xs v.
Proof.
  unfold remove_nvar; sp.
  rewrite remove_nvars_cons_r; simpl.
  rewrite memvar_singleton.
  rewrite beq_var_sym; sp.
Qed.

Lemma disjoint_remove_nvars_l :
  forall l1 l2 l3,
    disjoint (remove_nvars l1 l2) l3 <=> disjoint l2 (remove_nvars l1 l3).
Proof.
  unfold remove_nvars; intros.
  apply disjoint_diff_l.
Qed.

Lemma remove_nvars_eq :
  forall l,
    remove_nvars l l = [].
Proof.
  unfold remove_nvars; sp.
  rw <- null_iff_nil.
  apply null_diff; sp.
Qed.

(** equals variable sets *)
Definition eq_vars := eqsetb eq_var_dec.

Definition eqvars (vs1 vs2 : list NVar) :=
  assert (eq_vars vs1 vs2).

Lemma assert_eq_vars :
  forall vs1 vs2,
    assert (eq_vars vs1 vs2) <=> forall x, LIn x vs1 <=> LIn x vs2.
Proof.
  sp; unfold eq_vars.
  trw assert_eqsetb; sp.
Qed.

Lemma eqvars_prop :
  forall vs1 vs2,
    eqvars vs1 vs2 <=> forall x, LIn x vs1 <=> LIn x vs2.
Proof.
  sp; unfold eqvars, eq_vars.
  trw assert_eqsetb; sp.
Qed.

Lemma eqvars_sym :
  forall s1 s2, eqvars s1 s2 <=> eqvars s2 s1.
Proof.
  introv.
  repeat (rw eqvars_prop); split; intro k; introv.
  rw k; sp.
  rw <- k; sp.
Qed.

Lemma eqvars_disjoint :
  forall s1 s2 s3,
    eqvars s1 s2
    -> disjoint s1 s3
    -> disjoint s2 s3.
Proof.
  introv eqv disj.
  unfold disjoint.
  unfold disjoint in disj.
  introv i.
  rw eqvars_prop in eqv.
  apply eqv in i.
  apply disj in i; sp.
Qed.

Lemma eqvars_cons_l_iff :
  forall v vs1 vs2,
    eqvars (v :: vs1) vs2
    <=> (LIn v vs2 # eqvars (remove_nvar vs1 v) (remove_nvar vs2 v)).
Proof.
  sp; repeat (rw eqvars_prop).
  split; intro i; sp; allrw in_remove_nvar; allsimpl.
  rw <- i; sp.
  split; sp.
  rw <- i; sp.
  apply_in_hyp p; sp; subst; sp.
  split; sp; subst; sp.
  destruct (eq_var_dec v x); subst; sp.
  gen_some x; allrw in_remove_nvar.
  discover; sp.
  destruct (eq_var_dec v x); subst; sp.
  gen_some x; allrw in_remove_nvar.
  discover; sp.
Qed.

Lemma eqvars_remove_nvar :
  forall vars1 vars2 v,
    eqvars vars1 vars2
    -> eqvars (remove_nvar vars1 v) (remove_nvar vars2 v).
Proof.
  introv.
  trw eqvars_prop.
  allrw eqvars_prop; sp.
  allrw in_remove_nvar.
  allrw; sp.
Qed.

(** insertion of a nat in a list of variables in an ordered way *)
Fixpoint insert (v : nat) (vars : list NVar) : list NVar :=
  match vars with
    | [] => [nvar v]
    | (nvar x) :: xs =>
        if lt_dec x v then nvar x :: insert v xs
        else if eq_nat_dec x v then vars
             else (nvar v) :: vars
  end.

Lemma insert_in :
  forall v vars,
    LIn (nvar v) (insert v vars).
Proof.
  induction vars; simpl; sp.
  destruct a.
  destruct (lt_dec n v); simpl; sp.
  destruct (eq_nat_dec n v); subst; simpl; sp.
Qed.

Ltac invs2 :=
  match goal with
    | [ H : _ :: _ = _ :: _ |- _ ] => inversion H; try subst; GC
    | [ H : nvar _ = nvar _ |- _ ] => inversion H; try subst; GC
  end.

Lemma in_insert :
  forall v x vars,
    LIn (nvar v) (insert x vars)
    <=> (v = x [+] LIn (nvar v) vars).
Proof.
  induction vars; simpl; sp.
  split; sp; invs2; sp.
  destruct a.
  destruct (eq_nat_dec n x); subst; allsimpl.
  destruct (lt_dec x x); sp; try omega; allsimpl.
  split; sp.
  destruct (lt_dec n x); sp; try omega; allsimpl.
  trewrite IHvars; split; sp.
  split; sp; invs2; sp.
Qed.

Lemma remove_nvar_insert :
  forall vars n,
    remove_nvar (insert n vars) (nvar n)
    = remove_nvar vars (nvar n).
Proof.
  induction vars; simpl; sp.
  rewrite remove_nvar_nil.
  rewrite remove_nvar_cons.
  rewrite remove_nvar_nil.
  rewrite <- beq_var_refl; sp.
  destruct a.
  destruct (lt_dec n0 n).
  rewrite remove_nvar_cons.
  destruct (eq_nat_dec n n0); subst; try omega.
  rewrite not_eq_beq_var_false; sp.
  rewrite remove_nvar_cons.
  rewrite not_eq_beq_var_false; sp.
  rewrite IHvars; sp.
  inversion H; subst; sp.
  inversion H; subst; sp.
  destruct (eq_nat_dec n0 n); subst; sp.
  repeat (rewrite remove_nvar_cons).
  rewrite <- beq_var_refl; sp.
Qed.

Fixpoint sort (vars : list NVar) : list NVar :=
  match vars with
    | [] => []
    | (nvar x) :: xs => insert x (sort xs)
  end.

Inductive issorted : list NVar -> Type :=
  | issorted_nil : issorted []
  | issorted_cons :
    forall v vs,
      (forall x, LIn x vs -> le_var v x)
      -> issorted vs
      -> issorted (v :: vs).

Hint Constructors issorted.

Lemma sort_eqvars :
  forall vars,
    eqvars vars (sort vars).
Proof.
  induction vars; simpl; sp.
  destruct a.
  trw eqvars_cons_l_iff; sp.
  apply insert_in.
  rewrite remove_nvar_insert.
  apply eqvars_remove_nvar; sp.
Qed.

Lemma sort_issorted :
  forall vars,
    issorted (sort vars).
Proof.
  induction vars; simpl; sp.
  destruct a.
  induction IHvars; simpl; sp.
  constructor; simpl; sp.
  destruct v.
  destruct (lt_dec n0 n).
  constructor; simpl; sp.
  destruct x; unfold le_var.
  allrw in_insert; sp; subst; try omega.
  apply_in_hyp p.
  unfold le_var in p; sp.
  destruct (eq_nat_dec n0 n); subst; sp.
  constructor; simpl; sp; subst.
  unfold le_var; omega.
  apply_in_hyp p; destruct x; allunfold le_var; omega.
Qed.

Fixpoint fresh_var_aux (v : nat) (vars : list NVar) : nat :=
  match vars with
    | [] => v
    | (nvar x) :: xs =>
      if lt_dec v x then v
      else if eq_nat_dec v x
           then fresh_var_aux (S v) xs
           else fresh_var_aux v xs
  end.

Lemma fresh_var_aux_le :
  forall vars v,
    v <= fresh_var_aux v vars.
Proof.
  induction vars; simpl; sp.
  destruct a.
  destruct (lt_dec v n); sp.
  destruct (eq_nat_dec v n); subst; auto.
  generalize (IHvars (S n)); sp; omega.
Qed.

Lemma fresh_var_aux_sorted_not_in :
  forall vars,
    issorted vars
    -> forall n, ! LIn (nvar (fresh_var_aux n vars)) vars.
Proof.
  intros vars H.
  induction H; simpl; sp.
  destruct v.
  destruct (lt_dec n n0).
  invs2; omega.
  destruct (eq_nat_dec n n0); subst.
  generalize (fresh_var_aux_le vs (S n0)); sp.
  invs2; omega.
  assert (n0 < n) by omega; clear n1 n2.
  generalize (fresh_var_aux_le vs n); sp.
  invs2; sp; omega.
  destruct v.
  destruct (lt_dec n n0).
  apply_in_hyp p.
  unfold le_var in p; omega.
  destruct (eq_nat_dec n n0); subst.
  allapply IHissorted; sp.
  allapply IHissorted; sp.
Qed.

Definition fresh_var (vars : list NVar) : NVar :=
  nvar (fresh_var_aux 0 (sort vars)).

Lemma fresh_var_not_in :
  forall vars,
    ! LIn (fresh_var vars) vars.
Proof.
  unfold fresh_var; introv X.
  generalize (sort_eqvars vars); introv H.
  trw_h eqvars_prop  H.
  trw_h H  X.
  apply fresh_var_aux_sorted_not_in in X. sp.
  apply sort_issorted.
Qed.

Lemma ex_fresh_var :
  forall vars, {v : NVar $ !LIn v vars}.
Proof.
  introv.
  exists (fresh_var vars); apply fresh_var_not_in.
Qed.

Lemma fresh_var_aux_0 :
  forall vars,
    ! LIn (nvar 0) vars
    -> issorted vars
    -> fresh_var_aux 0 vars = 0.
Proof.
  intros nin H iss; induction iss; simpl; sp.
  destruct v; allsimpl.
  allapply not_or; sp.
  destruct (lt_dec 0 n); sp.
  destruct n; allsimpl; sp;
  try omega;
  try (provefalse; apply H; auto).
Qed.

Lemma fresh_var_nvarx :
  forall vars,
    ! LIn nvarx vars
    -> fresh_var vars = nvarx.
Proof.
  unfold fresh_var; sp.
  rewrite fresh_var_aux_0; sp.
  generalize (sort_eqvars vars); sp.
  alltrewrite eqvars_prop.
  apply_in_hyp p; sp.
  apply sort_issorted.
Qed.

Lemma fresh_var_nil :
  fresh_var [] = nvarx.
Proof.
  sp.
Qed.

Hint Immediate fresh_var_nil.

Fixpoint fresh_distinct_vars (n:nat) (lv_avoid : list NVar) : (list NVar) :=
  match n with
    | O => []
    | S m =>
      let newvar := fresh_var lv_avoid in
      newvar :: (fresh_distinct_vars m (newvar :: lv_avoid))
  end.

Lemma fresh_distinct_vars_spec :
  forall n lv,
    let op := fresh_distinct_vars n lv in
    (no_repeats op) # (disjoint  op lv) # length(op)=n.
Proof. induction n as [ | n Hind]; introv.
  simpl; split; sp.
  allsimpl. pose proof (Hind ((fresh_var lv :: lv))) as Hind1; clear Hind.
  repnd. split; [| split].
  - constructor; auto. apply disjoint_sym in Hind2. apply Hind2. left. auto.
  - apply disjoint_cons_l. split;[ | (apply fresh_var_not_in)].
    apply disjoint_cons_r in Hind2. repnd; auto.
  - rewrite Hind1; reflexivity.
Qed.

(**another form of above which can be applied to remembered ops*)
Lemma fresh_distinct_vars_spec1 : forall n lv op,
    (op = fresh_distinct_vars n lv)
    -> (no_repeats op) # (disjoint  op lv) # length(op)=n.
Proof. intros. subst. apply fresh_distinct_vars_spec.
Qed.
(* end hide *)

(** Another key requirement for a sensible formalization of variables
  is to have an unbounded supply of fresh variables. Hence,
  we prove the following lemma.
  % The notation \coqdocnotation{\{\_:\_ $\times$ \_\}} denotes sigma types
  (\coqexternalref{sigT}
  {http://coq.inria.fr/V8.1/stdlib/Coq.Init.Specif}{\coqdocinductive{sigT}})%
  To those who are unfamiliar
  with constructive logic, the following lemma might just
  say that that for any [n] and [lv], there exists a list [lvn]
  of length [n] of distinct variables  such that the members of [lvn]
  are disjoint from the members of [lv].

  However, because of the propositions as types principle%\footnote{we are not using Prop.}%,
  We are actually defining a function [fresh_vars] that takes a number
  [n] and a list [lv] of variables and returns a 4-tuple.
  The first member of that tuple is [lvn], a list of variables with
  the above mentioned properties. The next three members are proofs
  of the desired properties of [lvn].

 An important use [free_vars] of it will be in defining
 the substitution function.

*)

Lemma fresh_vars :
  forall (n: nat) (lv : list NVar),
    {lvn : (list NVar) & no_repeats lvn # disjoint lvn lv # length lvn = n}.
Proof.
  intros. exists (fresh_distinct_vars n lv).
  apply fresh_distinct_vars_spec.
Qed.

(* begin hide *)

Ltac rem_fresh_vars :=
  match goal with
    | [ |- context[fresh_vars ?n ?lv] ] =>
      remember (fresh_vars n lv)
  end.

(*
Definition list_vars (vars : list NVar) : list nat :=
  map (fun x => match x with nvar n => n end) vars.

Definition fresh_var (vars : list NVar) : NVar :=
  let nats := list_vars vars in
  if nullb nats then nvar 0
  else let n := maxl nats in nvar (S n).

Lemma list_vars_eq :
  forall vars : list NVar,
    exists nats, vars = map nvar nats.
Proof.
  induction vars; simpl; sp.
  exists (nil : list nat); simpl; auto.
  destruct a.
  exists (n :: nats); simpl.
  rewrite <- H; auto.
 Qed.

Lemma list_vars_eq2 :
  forall nats : list nat,
    list_vars (map (fun n => nvar n) nats) = nats.
Proof.
  induction nats; simpl; sp.
  rewrite IHnats; auto.
 Qed.

Lemma fresh_var_in :
  forall vars,
    ! LIn (fresh_var vars) vars.
Proof.
  unfold fresh_var; intros.
  assert (exists nats, vars = map (fun n => nvar n) nats)
    by apply list_vars_eq; sp.
  rewrite H in H0.
  rewrite in_map_iff in H0; sp.
  rewrite list_vars_eq2 in H0.
  remember (nullb nats); symmetry in Heqb; destruct b; inversion H0; subst; GC.
  rewrite fold_assert in Heqb.
  rewrite assert_nullb in Heqb.
  rewrite null_iff_nil in Heqb; subst; allsimpl; sp.
  apply maxl_prop in H1; omega.
Qed.
*)

Definition sub_vars := subsetb eq_var_dec.

Definition subvars (vs1 vs2 : list NVar) :=
  assert (sub_vars vs1 vs2).

Lemma assert_sub_vars :
  forall vs1 vs2,
    assert (sub_vars vs1 vs2) <=> forall x, LIn x vs1 -> LIn x vs2.
Proof.
  sp; unfold sub_vars.
  trw assert_subsetb; sp.
Qed.

Lemma subvars_eq :
  forall vs1 vs2,
    subvars vs1 vs2 <=> subset vs1 vs2.
Proof.
  sp; unfold subvars, sub_vars.
  trw assert_subsetb; sp.
Qed.

Lemma subvars_refl :
  forall vs,
    subvars vs vs.
Proof.
  sp.
  trw subvars_eq.
  apply subset_refl.
Qed.

Hint Immediate subvars_refl.

Lemma subvars_prop :
  forall vs1 vs2,
    subvars vs1 vs2 <=> forall x, LIn x vs1 -> LIn x vs2.
Proof.
  sp; trw subvars_eq; unfold subset; split; sp.
Qed.

Tactic Notation "prove_subvars" ident(h) :=
  let v := fresh "v" in
  let x := fresh "x" in
    trw_h subvars_prop h;
  trw subvars_prop;
  intros v x;
  apply h in x.

Ltac provesv :=
  match goal with
    | [ H : subvars ?v ?vs1 |- subvars ?v ?vs2 ] =>
        let v := fresh "v" in
        let x := fresh "x" in
        let y := fresh "y" in
          trw_h subvars_prop H;
        trw subvars_prop;
        intros v x;
        applydup H in x as y
  end.

Lemma subvars_app_weak_l :
  forall vs1 vs2 vs3, subvars vs1 vs2 -> subvars vs1 (vs2 ++ vs3).
Proof.
  intros.
  allrw subvars_prop; sp; discover; allrw in_app_iff; sp.
Qed.

Lemma subvars_singleton_l :
  forall v vs,
    subvars [v] vs <=> LIn v vs.
Proof.
  intros; rw subvars_prop; simpl; split; sp; subst; sp.
Qed.

Lemma subvars_singleton_r :
  forall v vs, subvars vs [v] <=> (forall x, LIn x vs -> x = v).
Proof.
  intros; rw subvars_prop; simpl; split; sp; apply_in_hyp p; sp.
Qed.

Lemma subvars_comm_r :
  forall vs vs1 vs2,
    subvars vs (vs1 ++ vs2) <=> subvars vs (vs2 ++ vs1).
Proof.
  introv. trw subvars_prop.  alltrewrite subvars_prop; split; introv Hyp Hin;
  apply Hyp in Hin; alltrewrite in_app_iff; sp; auto.
Qed.

Lemma subvars_flat_map :
  forall A,
  forall f : A -> list NVar,
  forall l k,
    subvars (flat_map f l) k
    <=>
    forall x, LIn x l -> subvars (f x) k.
Proof.
  intros.
  unfold subvars, sub_vars.
  repeat (trw subsetb_subset).
  trw subset_flat_map; split; sp.
  repeat (trw subsetb_subset).
  apply_hyp; sp.
  apply_in_hyp p.
  repeat (allrw subsetb_subset); auto.
Qed.

Lemma subvars_remove_nvars :
  forall vs1 vs2 vs3,
    subvars (remove_nvars vs1 vs2) vs3
    <=>
    subvars vs2 (vs3 ++ vs1).
Proof.
  sp; repeat (trw subvars_eq); unfold remove_nvars.
  trw subset_diff; sp.
Qed.

Lemma null_remove_nvars_subvars :
  forall vs1 vs2,
    null (remove_nvars vs1 vs2) <=> subvars vs2 vs1.
Proof.
  unfold remove_nvars; sp.
  trw subvars_eq.
  trw null_diff_subset; split; sp.
Qed.

Lemma subvars_cons_l :
  forall v vs1 vs2,
    subvars (v :: vs1) vs2 <=> LIn v vs2 # subvars vs1 vs2.
Proof.
  sp; alltrewrite subvars_eq.
  apply subset_cons_l.
Qed.

Lemma subvars_cons_r :
  forall v vs1 vs2,
    subvars vs1 vs2
    -> subvars vs1 (v :: vs2).
Proof.
  sp; alltrewrite subvars_eq.
  apply subset_cons1; sp.
Qed.

Lemma subvars_nil_l :
  forall s, subvars [] s.
Proof.
  sp; trw subvars_eq.
  apply subset_nil_l.
Qed.

Hint Immediate subvars_nil_l.

Lemma subvars_nil_l_iff :
  forall s, subvars [] s <=> True.
Proof.
  sp; rewrite subvars_eq; split; sp; auto.
Qed.

Hint Rewrite subvars_nil_l_iff.

Lemma subvars_snoc_weak :
  forall vs1 vs2 v,
    subvars vs1 vs2
    -> subvars vs1 (snoc vs2 v).
Proof.
  intros.
  alltrewrite subvars_eq.
  apply subset_snoc_r; auto.
Qed.

Lemma subvars_app_l :
  forall vs1 vs2 vs,
    subvars (vs1 ++ vs2) vs <=> subvars vs1 vs # subvars vs2 vs.
Proof.
  sp; alltrewrite subvars_eq.
  trw subset_app; sp.
Qed.

Lemma subvars_app_remove_nvars_r :
  forall vs1 vs2 vs,
    subvars vs (vs1 ++ remove_nvars vs1 vs2) <=> subvars vs (vs1 ++ vs2).
Proof.
  sp; alltrewrite subvars_eq; unfold subset; split; sp.
  apply_in_hyp p; alltrewrite in_app_iff; sp.
  alltrewrite in_remove_nvars; sp.
  apply_in_hyp p; alltrewrite in_app_iff; sp.
  alltrewrite in_remove_nvars; sp.
  destruct (in_nvar_list_dec x vs1); sp.
Qed.

Lemma subvars_swap_r :
  forall vs1 vs2 vs,
    subvars vs (vs1 ++ vs2) <=> subvars vs (vs2 ++ vs1).
Proof.
  sp; alltrewrite subvars_eq; unfold subset; split; sp; alltrewrite in_app_iff;
  apply_in_hyp p; allrw in_app_iff; sp.
Qed.

Lemma subvars_trans :
  forall vs1 vs2 vs3,
    subvars vs1 vs2
    -> subvars vs2 vs3
    -> subvars vs1 vs3.
Proof.
  sp; alltrewrite subvars_eq.
  apply subset_trans with (l2 := vs2); sp.
Qed.

Theorem subvars_app_trivial_l :
  forall vs1 vs2, subvars vs1 (vs1++vs2).
Proof.
  intros. apply subvars_prop. intros.
  apply in_app_iff; sp.
Qed.

Theorem subvars_app_trivial_r :
  forall vs1 vs2, subvars vs2 (vs1++vs2).
Proof.
  intros. apply subvars_prop. intros.
  apply in_app_iff; sp.
Qed.

Lemma memvar_singleton_diff_r :
  forall x z, x <> z -> memvar x [z] = false.
Proof.
  sp.
  rw not_of_assert.
  rw assert_memvar; simpl; sp.
Qed.

Lemma eqvars_refl :
  forall vs, eqvars vs vs.
Proof.
  sp.
  rw eqvars_prop; sp.
Qed.

Hint Immediate eqvars_refl.

Lemma remove_nvar_comm :
  forall vs a b,
    remove_nvar (remove_nvar vs a) b
    = remove_nvar (remove_nvar vs b) a.
Proof.
  sp.
  unfold remove_nvar.
  rewrite remove_nvars_comm; sp.
Qed.

(* Some tactics *)

Tactic Notation "simpl_vlist" :=
       repeat (progress (try (allrewrite remove_var_nil);
                         try (allapply app_eq_nil);repnd;
                         try (allrewrite app_nil_r);
                         try (allrewrite null_iff_nil))).

Lemma dmemvar :
  forall (v: NVar) lv,  (LIn v lv) + (notT (LIn v lv)).
Proof.
  apply (in_deq NVar deq_nvar).
Qed.

Theorem assert_memvar_false:
  forall (v : NVar) (vars : list NVar),
    memvar v vars = false <=> ! LIn v vars.
Proof.
  intros.
  rw <- assert_memvar.
  rw <- not_of_assert; sp.
Qed.

Lemma memvar_dmemvar : forall T v lv (ct cf:T) ,
  (if (memvar v lv)  then ct else cf) = (if (dmemvar v lv)  then ct else cf).
  intros. cases_if as  Hb; auto; cases_if as Hd ; auto; subst.
  apply assert_memvar in Hb. sp.
  apply assert_memvar_false in Hb.
  sp; try contradiction.
Qed.

Lemma eq_vars_nil: forall lv, eqvars [] lv -> lv=[].
Proof.
  introv Heq. rw eqvars_prop in Heq.
  destruct lv;sp;[].
  pose proof (Heq n).
  allsimpl.
  discover; sp.
Qed.

Lemma eqvars_nil : forall lva lvb,
  lva=[] -> eqvars lva lvb -> lvb=[].
Proof.
  introv  Ha Heq.
  rw Ha in Heq.
  apply eq_vars_nil in Heq. auto.
Qed.
Lemma eqvars_trans : forall lva lvb lvc,
  eqvars lva lvb
  -> eqvars lvb lvc
  -> eqvars lva lvc.
Proof.
  introv He1 He2.
  allrw (eqvars_prop).
  split; intro Hin;
  repeat (try(apply He1 in Hin); try(apply He2 in Hin); auto).
Qed.

Lemma eq_vars_sym: forall lv1 lv2,
  eqvars lv1 lv2 -> eqvars lv2 lv1.
Proof.
  introv. rw eqvars_prop. rw eqvars_prop.
  intros X x. rw X.
  dtiffs2. split; auto.
Qed.

(*
Ltac inj :=
  repeat match goal with
             [ H : _ |- _ ] =>
             (apply pair_inj in H
              || apply S_inj in H
              || apply S_lt_inj in H
              || apply snoc_inj in H);
               repd; subst; GC
         end; try (complete sp).
*)

Lemma eqvars_remove_nvars :
  forall la lb ra rb,
    eqvars la lb
    -> eqvars ra rb
    -> eqvars (remove_nvars la ra) (remove_nvars lb rb).
Proof.
  introv Ha Hb. allrw eqvars_prop.
  dtiffs2.
  split; introv Hin; apply in_remove_nvars in Hin; repnd;
  apply in_remove_nvars; split; cpx; eauto.
Qed.

Lemma eqvars_app :
  forall la lb ra rb,
    eqvars la lb
    -> eqvars ra rb
    -> eqvars (app la ra) (app lb rb).
Proof.
  introv Ha Hb. allrw eqvars_prop.
  dtiffs2.
  split; introv Hin; apply in_app_iff; apply in_app_iff in Hin;
  dorn Hin; try (left;eauto;fail) ; try (right;eauto;fail).
Qed.

Hint Resolve eqvars_trans eq_vars_sym eqvars_refl eqvars_remove_nvar eqvars_remove_nvars eqvars_app: eqvars.

Definition dec_disjointv := dec_disjoint deq_nvar.

Lemma disjoint_remove_nvars: forall lva lvb,
  disjoint (remove_nvars lva lvb) lva.
Proof.
  introv Hin Hc.
  apply in_remove_nvars in Hin.
  sp.
Qed.

Lemma disjoint_remove_nvars2: forall lva lvb lvc,
  disjoint lvb lva
  -> disjoint (remove_nvars lvc lvb) lva.
Proof.
  introv Hin Hc.
  apply in_remove_nvars in Hc.
  exrepnd.
  introv Hinc. disjoint_lin_contra.
Qed.

Ltac sp3 :=
  (repeat match goal with
  | [ H: _ <=> _ |- _ ] => destruct H end); spc.

Lemma subvars_cons_r_weak_if_not_in :
  forall vs1 v vs2,
    subvars vs1 (v :: vs2)
    -> !LIn v vs1
    -> subvars vs1 vs2.
Proof.
  introv sv ni.
  allrw subvars_prop.
  introv i.
  applydup sv in i as j.
  allsimpl; sp; subst; sp.
Qed.

Lemma subvars_nil_r :
  forall vs,
    subvars vs [] <=> vs = [].
Proof.
  introv; split; intro k; allrw; sp.
  allrw subvars_prop.
  apply null_iff_nil.
  unfold null; introv i.
  discover; sp.
Qed.

Lemma eq_var_iff :
  forall v : NVar, v = v <=> True.
Proof. sp. Qed.

Lemma subvars_eqvars :
  forall s1 s2 s3,
    subvars s1 s2 -> eqvars s1 s3 -> subvars s3 s2.
Proof.
  introv s e.
  allrw subvars_prop.
  allrw eqvars_prop.
  introv i.
  apply e in i.
  apply s in i; auto.
Qed.

Lemma subvars_not_in :
  forall vs1 vs2 v, subvars vs2 vs1 -> !LIn v vs1 -> !LIn v vs2.
Proof.
  introv sv ni1 ni2.
  rw subvars_prop in sv.
  discover; sp.
Qed.

Lemma not_over_not_lin_nvar :
  forall (v : NVar) l t,
    !(LIn v l # t) <=> (!LIn v l [+] !t).
Proof.
  introv; split; intro k; repnd; sp.
  generalize (in_deq NVar deq_nvar v l); intro o; sp.
  right; intro j.
  apply k; sp.
Qed.

Lemma subvars_cons_lr :
  forall v vs1 vs2,
    subvars vs1 vs2
    -> subvars (v :: vs1) (v :: vs2).
Proof.
  introv sv.
  allrw subvars_prop; introv i; allsimpl; sp.
Qed.

Lemma eqvars_disjoint_r:
  forall s s1 s2 : list NVar,
    eqvars s1 s2 -> disjoint s s1 -> disjoint s s2.
Proof.
  unfold disjoint.
  introv eqv disj i k.
  rw eqvars_prop in eqv.
  applydup disj in i as j.
  apply eqv in k; sp.
Qed.

Lemma subvars_disjoint_l :
  forall (l1 l2 l3 : list NVar),
    subvars l1 l2
    -> disjoint l2 l3
    -> disjoint l1 l3.
Proof.
  introv.
  rw subvars_eq.
  pose proof (subset_disjoint NVar l1 l2 l3); sp.
Qed.

Lemma subvars_disjoint_r :
  forall l1 l2 l3 : list NVar,
    subvars l1 l2 -> disjoint l3 l2 -> disjoint l3 l1.
Proof.
  introv sv disj.
  allrw subvars_prop.
  introv i j.
  apply sv in j.
  apply disj in i; sp.
Qed.

Lemma eqvars_cons_lr :
  forall v vs1 vs2,
    eqvars vs1 vs2 -> eqvars (v :: vs1) (v :: vs2).
Proof.
  introv.
  allrw eqvars_prop; split; intro k;
  allsimpl; sp; discover; sp.
Qed.

Lemma eqvars_remove_nvars_implies :
  forall vs1 vs2 vs3,
    eqvars vs1 (remove_nvars vs2 vs3)
    -> disjoint vs1 vs2 # subvars vs1 vs3.
Proof.
  introv eqv.
  allrw eqvars_prop.
  unfold disjoint.
  rw subvars_prop; dands; introv i;
  apply eqv in i; rw in_remove_nvars in i; sp.
Qed.

(* end hide *)


From Coq Require Import MSets.

Require Import Base AtomImpl.
Require MSetNotin.

(** *Conjunto de Átomos *)
(** Conjunto de átomos (não ordenado), com estrutura opaca, é implementado utilizando listas. *)
(* Exporta as operações de conjunto definidas por WSetsOn *)
Module AtomSet: (MSetInterface.WSetsOn Atom) := MSetWeakList.Make Atom.

(* Procedimento de decisão sobre conjuntos: fsetdec *)
Module Export AtomSetDec := MSetDecide.WDecideOn Atom AtomSet.

(* Fatos adicionais sobre conjuntos *)
Module Export AtomSetFac := MSetFacts.WFactsOn Atom AtomSet.

(* Táticas para lidar com notin. *)
Module Export AtomSetNotin := MSetNotin.WNotinOn Atom AtomSet.

(* Propriedades de conjuntos *)
Module Export AtomSetProp := MSetProperties.WPropertiesOn Atom AtomSet.

(** *Propriedades lista de átomos para conjunto de átomos *)
Definition fresh (L: AtomSet.t): Atom.t := Atom.fresh (AtomSet.elements L).

Lemma fresh_spec L: ~ AtomSet.In (fresh L) L.
Proof.
  unfold fresh; lets H: (Atom.fresh_notin_list (AtomSet.elements L));
    intros J; apply H; apply elements_iff in J;
      apply InA_alt in J as [x []]; subst; auto.
Qed.

(* Manter compatibildade com as táticas AtomTactics *)
Lemma fresh_spec_compat (L: AtomSet.t): {x: Atom.t | ~ AtomSet.In x L}.
Proof. exists (fresh L); apply fresh_spec. Qed.

Lemma fresh_set_eq a b: AtomSet.Equal a b -> fresh a = fresh b.
Proof. Admitted.

(* Definition atom_singleton: Atom.t -> AtomSet.t := fun a => AtomSet.singleton a. *)
(* Coercion atom_singleton : atom >-> ASet. *)

(* (* Notations *) *)
(* Notation "∅" :=  (AtomSet.empty). *)
(* Notation "{{ x }}" := (AtomSet.singleton (x%atom)) (format "{{ x }}"). *)
(* Infix "∈" := AtomSet.In (at level 70). *)
(* (* Infix "∉" := (fun a b => not (AtomSet.In (a%atom) b)) (at level 70). *) *)
(* Notation "x ∉ s" := (not (AtomSet.In (x%atom) s)) (at level 70). *)
(* Infix "∪" := AtomSet.union (at level 65, right associativity). *)
(* Infix "∩" := AtomSet.inter (at level 65, right associativity). *)
(* Notation "a \ b" := (AtomSet.remove (a%atom) b) (at level 65, right associativity). *)
(* (* Infix "\" := AtomSet.remove (at level 65, right associativity) *) *)
(* Notation "E [=] F" := (AtomSet.Equal E F) (at level 70, no associativity). *)
(* Hint Extern 5 (AtomSet.notin _ _) => fsetdec: core. *)


(** Definition of initial object as a colimit *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.graphs.eqdiag.
Require Import UniMath.CategoryTheory.limits.initial.

Local Open Scope cat.

Section def_initial.

Context {C : category}.

Definition empty_graph : graph.
Proof.
  exists empty.
  exact (λ _ _, empty).
Defined.

Definition initDiagram : diagram empty_graph C.
Proof.
exists fromempty.
intros u; induction u.
Defined.

(** All diagrams over the empty graph are equal *)
Lemma empty_graph_eq_diag (d d' : diagram empty_graph C) :
  eq_diag d d'.
Proof.
  use tpair; use empty_rect.
Defined.

Definition initCocone (c : C) : cocone initDiagram c.
Proof.
use make_cocone; intro v; induction v.
Defined.

Definition isInitial (a : C) :=
  isColimCocone initDiagram a (initCocone a).
 (* ∏ b : C, iscontr (a --> b). *)

Definition make_isInitial (a : C) (H : ∏ (b : C), iscontr (a --> b)) :
  isInitial a.
Proof.
intros b cb.
use tpair.
- exists (pr1 (H b)); intro v; induction v.
- intro t.
  apply subtypePath; simpl;
    [intro; apply impred; intro v; induction v|].
  apply (pr2 (H b)).
Defined.

Definition Initial : UU := ColimCocone initDiagram.
(* total2 (λ a, isInitial a). *)

Definition make_Initial (a : C) (H : isInitial a) : Initial.
Proof.
use (make_ColimCocone _ a (initCocone a)).
apply make_isInitial.
intro b.
set (x := H b (initCocone b)).
use tpair.
- apply (pr1 x).
- simpl; intro f; apply path_to_ctr; intro v; induction v.
Defined.

Definition InitialObject (O : Initial) : C := colim O.
(* Coercion InitialObject : Initial >-> ob. *)

Definition InitialArrow (O : Initial) (b : C) : C⟦InitialObject O,b⟧ :=
  colimArrow _ _ (initCocone b).

Lemma InitialArrowUnique (I : Initial) (a : C)
  (f : C⟦InitialObject I,a⟧) : f = InitialArrow I _.
Proof.
now apply colimArrowUnique; intro v; induction v.
Defined.

Lemma ArrowsFromInitial (I : Initial) (a : C) (f g : C⟦InitialObject I,a⟧) : f = g.
Proof.
eapply pathscomp0.
apply InitialArrowUnique.
now apply pathsinv0, InitialArrowUnique.
Qed.

Lemma InitialEndo_is_identity (O : Initial) (f : C⟦InitialObject O,InitialObject O⟧) :
  identity (InitialObject O) = f.
Proof.
now apply colim_endo_is_identity; intro u; induction u.
Qed.

Lemma isiso_from_Initial_to_Initial (O O' : Initial) :
  is_iso (InitialArrow O (InitialObject O')).
Proof.
  apply (is_iso_qinv _ (InitialArrow O' (InitialObject O))).
  split; apply pathsinv0, InitialEndo_is_identity.
Defined.

Definition iso_Initials (O O' : Initial) : iso (InitialObject O) (InitialObject O') :=
   tpair _ (InitialArrow O (InitialObject O')) (isiso_from_Initial_to_Initial O O') .

Definition hasInitial := ishinh Initial.

(* TODO: This should be an instance of a general result for colimits *)
(* Section Initial_Unique. *)

(* Hypothesis H : is_univalent C. *)

(* Lemma isaprop_Initial : isaprop Initial. *)
(* Proof. *)
(*   apply invproofirrelevance. *)
(*   intros O O'. *)
(*   apply (total2_paths_f (isotoid _ H (iso_Initials O O')) ). *)
(*   apply proofirrelevance. *)
(*   unfold isInitial. *)
(*   apply impred. *)
(*   intro t ; apply isapropiscontr. *)
(* Qed. *)

(* End Initial_Unique. *)

Lemma isInitial_Initial (I : Initial) :
  isInitial (InitialObject I).
Proof.
  use make_isInitial.
  intros b.
  use tpair.
  - exact (InitialArrow I b).
  - intros t. use (InitialArrowUnique I).
Qed.

(** ** Maps between initial as special colimit and direct definition *)
Lemma equiv_isInitial1 (c : C) :
  limits.initial.isInitial C c -> isInitial c.
Proof.
  intros X.
  use make_isInitial.
  intros b.
  apply (X b).
Qed.

Lemma equiv_isInitial2 (c : C) :
  limits.initial.isInitial C c <- isInitial c.
Proof.
  intros X.
  set (XI := make_Initial c X).
  intros b.
  use tpair.
  - exact (InitialArrow XI b).
  - intros t. use (InitialArrowUnique XI b).
Qed.

Definition equiv_Initial1 (c : C) :
  limits.initial.Initial C -> Initial.
Proof.
  intros I.
  use make_Initial.
  - exact I.
  - use equiv_isInitial1.
    exact (pr2 I).
Defined.

Definition equiv_Initial2 (c : C) :
  limits.initial.Initial C <- Initial.
Proof.
  intros I.
  use limits.initial.make_Initial.
  - exact (InitialObject I).
  - use equiv_isInitial2.
    use (isInitial_Initial I).
Defined.

End def_initial.

Arguments Initial : clear implicits.
Arguments isInitial : clear implicits.

Lemma Initial_from_Colims (C : category) :
  Colims_of_shape empty_graph C -> Initial C.
Proof.
now intros H; apply H.
Defined.


(**********************************************************************)
(* This Program is free sofut 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 *)
(* 021101301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                 Abstraction_to_Tree.v                              *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import Omega Max Bool List.
Require Import IntensionalLib.SF_calculus.Test.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Tree_calculus.Abstraction_Terms.
Require Import IntensionalLib.Tree_calculus.Abstraction_Reduction.
Require Import IntensionalLib.Tree_calculus.Tree_Terms.
Require Import IntensionalLib.Tree_calculus.Tree_Tactics.
Require Import IntensionalLib.Tree_calculus.Tree_reduction.
Require Import IntensionalLib.Tree_calculus.Tree_Normal.
Require Import IntensionalLib.Tree_calculus.Tree_Closed.
Require Import IntensionalLib.Tree_calculus.Substitution.
Require Import IntensionalLib.Tree_calculus.Tree_Eval.
Require Import IntensionalLib.Tree_calculus.Star.
Require Import IntensionalLib.Tree_calculus.Wait.
Require Import IntensionalLib.Tree_calculus.Fixpoints.
Require Import IntensionalLib.Tree_calculus.Wave_Factor.
Require Import IntensionalLib.Tree_calculus.Wave_Factor2.
Require Import IntensionalLib.Tree_calculus.Equal.
Require Import IntensionalLib.Tree_calculus.Case.
Require Import IntensionalLib.Tree_calculus.Extensions.
Require Import IntensionalLib.Tree_calculus.Wait2.
Require Import IntensionalLib.Tree_calculus.Abstraction.
Require Import IntensionalLib.Tree_calculus.Abstraction2.
Require Import IntensionalLib.Tree_calculus.Abstraction3.
Require Import IntensionalLib.Tree_calculus.Abstraction4.
Require Import IntensionalLib.Tree_calculus.Abstraction5.

Definition op_to_tree o :=
match o with
| Jop => j_op
| Rop => r_op
| Hop => h_op
| Aop => abs_op
| Iop => i_op
| Bop => b_op
end.

Fixpoint abs_to_tree M :=
match M with
| Abstraction_Terms.Op o => op_to_tree o
| Abstraction_Terms.App M1 M2 => App (abs_to_tree M1) (abs_to_tree M2)
end.

Theorem translation_preserves_abs_reduction:
forall M N, abs_red1 M N -> sf_red (abs_to_tree M) (abs_to_tree N).
Proof.
intros M N r; induction r; intros;
unfold abs_to_tree; fold abs_to_tree; unfold op_to_tree.
(* 14 *)
auto.
eapply2 j_red.
eapply2 r_red.
eapply2 h_red.
eapply2 abs_red.
unfold_op. repeat eval_tac.
eapply2 b_j_red.
eapply2 b_r_red.
eapply2 b_h_red.
eapply2 b_a_red.
eapply2 b_i_red.
eapply2 b_b_red.
(* 2 *)
generalize H; case o; intro.
congruence.
eapply2 b_r_op_red.
eapply2 b_h_op_red.
eapply2 b_abs_op_red.
eapply2 b_i_op_red.
eapply2 b_b_op_red.
(* 1 *)
inversion H; subst; unfold abs_to_tree; fold abs_to_tree;
unfold op_to_tree; subst.
eapply2 b_h1_red.
eapply2 b_a1_red.
eapply2 b_b1_red.
Qed.


(*Pre-req*)
Require Import ssreflect.
(*ssreflext provides an extension of Coq for tactics *)
Require Import Coq.omega.Omega.
Require Import BinNums.
Require Coq.Init.Nat.
Require Import Bool Morphisms Setoid.
Require Import ssreflect ssrfun ssrbool.
Require Import BinNat.
Require BinPos Ndec.
Require Import Coq.Classes.Equivalence.
Require Import ssreflect.
Require Import ssrbool.
Require Import ssrfun.

Set Implicit Arguments.

(*Introducing ~ as a new notation for describing binaries and should be left associative
which means that during compilations they are grouped from the left. eg, if '*' is left
associative a*b*c will be interpreted as (a*b)*c

Here ~ is an assignment of a binary.
For More: https://en.wikipedia.org/wiki/Operator_associativity

positive_scope defines that binary is strictly positive.

 *)
Notation "p ~ 1" := (xI p)
 (at level 7, left associativity, format "p '~' '1'") : positive_scope.

Notation "p ~ 0" := (xO p)
 (at level 7, left associativity, format "p '~' '0'") : positive_scope.

Local Open Scope positive_scope.
Module Pos.

(*Fermat's Last Theorem

    Given the whole numbers a,b,c,n there exists no case of

              a^n + b^n = c^n st. n > 2
Defn. A Fermat Triplet- A set of (a,b,c) for which the fermat theorem holds true.

Before we go to Fermat's Theorem there's quite an interesting conjecture given by Euler
which states that or all integers n and k greater than 1, if the sum of n kth powers of positive
integers is itself a kth power, then n is greater than or equal to k. Fermat's Last Theorem
comes close to this at n=2 but Fermat's exists only beyond n > 2, but this provides a great
inutition for Fermat's, it's also been proved false by arguably the first supercomputer
CDC 6600, so there is scope for proving Fermat's as well.
*)

(*To prove Fermat's Last Theorem we can start to work with Wiles but the proof is skeched
by proving 4 thoerems(http://www.cs.rug.nl/~wim/fermat/wilesEnglish.html#cite)

Th1: If there is a Fermat triple for exponent n, there is a Fermat triple (a,b,c) for exponent n with a and b coprime.
Th2: There is no Fermat triple for exponent 4.
Th3: There is no Fermat triple for exponent 3.
Th4:  If there is a Fermat triple for an exponent > 4, then there is a Fermat triple for an exponent which is a prime number > 4.

There are actually 7 theorems that need to be satisfied, but they're too compicated and I don't know Coq that well but we can make do with 4. *)

(*

To check if ~ works
Fixpoint succ x :=
  match x with
    | p~1 => (succ p)~0
    | p~0 => p~1
    | 1 => 1~0
  end.
*)

(*Numbers are Coprime iff. the common factor is 1*)
(*Fixpoint is used for Recursive Functions and Multiple args*)
(*Th1-Proof: Let (x,y,z) be some Fermat triple for exponent n.
  Let d be the greatest common divisor of x and y. Since xn + yn = zn, the number dn divides zn; therefore d divides z.
  Put a = x/d, b = y/d, c = z/d. Then (a,b,c) is a Fermat triple for exponent n with a and b coprime. *)
Fixpoint gcdn (n : nat) (a b : positive) : positive :=
  match n with
    | O => 1 (* when 0 *)
    | S n => (*Natural Number*)
      match a,b with
        | 1, _ => 1
        | _, 1 => 1
        | a~0, b~0 => (gcdn n a b)~0
        | _ , b~0 => gcdn n a b
        | a~0, _ => gcdn n a b
        | a'~1, b'~1 =>
          match a' ?= b' with
            | Eq => a
            | Lt => gcdn n (b'-a') a
            | Gt => gcdn n (a'-b') b
          end
      end
  end.
(*The reduction for gcdn given for all x,y,t if t divides x and for all t' if t' divides x and t' divides y then the gcd of x,y is t  *)
(*Can be reduced using Peirces lemma *)
Lemma gcdn_red: forall t x y, t %| x -> (forall t', t' %| x -> t' %| y -> t' %| t) -> gcdn x y = t.
Lemma gcdwithx x a b : gcdn ((x*a) (x*b)) == x -> gcdn a b == 1.
Proof.
  move.
  intros k.
  apply/eqP/gcdn_red; try by [].
  intros.
Admitted.
(* a%%b remainder of 'a' when divided by 'b'
  a %/b quotient of a when divided by b *)

Lemma coprime_gcd a b : coprime (a %/ (gcdn a b)) (b %/ (gcdn a b)).
Proof.
  unfold coprime.
  apply (gcdwithx (gcdn a b)).
  apply/eqP.
  apply gcdn_def; try by [].
  admit.
  admit.
  intros d' H H0
admit.

Admitted.

(*Adding every component together*)
Theorem Th1 : forall n, (exists x y z, x^n + y^n = z^n) -> (exists a b c, a^n + b^n = c^n /\ (coprime a b)).
Proof.
  intros n [x [y [z H]]].
  pose (d := gcdn x y).

  (* assert (ddivx : d %| x). *)

  exists (x %/ d).
  exists (y %/ d).
  exists (z %/ d).
  split.

unfold d.
Admitted.

(*Proof for these is quite straight forward so not doing this a good resource to understand these is https://www.math.uci.edu/~brusso/vanderPoortenpp1-6.pdf

*)
Theorem Th2 : forall a b c, a^4 + b^4 <> c^4.
Proof.
Admitted.

Theorem Th3 : forall a b c, a^3 + b^3 <> c^3.
Proof.
Admitted.

Theorem Th3 : (exists a b c n, n > 4 /\ a^n + b^n = c^n) ->
                                    (exists a b c n, n > 4 /\ prime n /\ a^n + b^n = c^n).
Proof.
  simpl.
Admitted.

(*Proof By Contradiction*)
Theorem fermats_last_theorem : ~exists a b c n, a^n + b^n = c^n /\ n > 2.
Proof.
  red.

  intros [a [b [c [n [eq ngt]]]]].
  assert (nn4 : n <> 4). {
    specialize (Th2 a b c).
    red; intros; rewrite H0 in eq; rewrite eq in H; contradiction.
  }
  assert (nn3 : n <> 3). {
    specialize (Th3 a b c).
    red; intros; rewrite H0 in eq; rewrite eq in H; contradiction.
  }

  assert (ngt4 : n > 4). {
    rewrite ltn_neqAle ltn_neqAle.
    case and3P.
    intros; by [].
    intros.
    destruct n0.
    split.
    apply/eqnP; auto.
    apply/eqnP; auto.
    assumption.
  }
  clear ngt nn4 nn3.

  specialize (Th4).
  intros.
  destruct H.
  exists a, b, c, n.
  split; assumption.
  clear a b c n eq ngt4.
  rename x into a.
  destruct H as [b [c [n [ngt [pn eq]]]]].

  specialize (Th1 n).
  intros.
  destruct H.
  exists a,b,c.
  assumption.
  clear a b c eq.
  rename x into a.
  destruct H as [b [c [eq coab]]].
Admitted.


Require Import List Nat Bool egalite Omega.
Import ListNotations.

(** Compute Djikstra's final table *)

Definition Triplet :Type := nat*nat*nat.

Fixpoint Absence (b':nat)(list:@list Triplet) :=
  match list with
  | []                => true
  | (a,b,n) :: l' => if (b =? b') then false else Absence b' l'
  end.

Fixpoint Presence (b':nat)(list:@list Triplet) :=
  match list with
  | []                => None
  | (a,b,n) :: l' => if (b =? b') then Some (a,b,n) else Presence b' l'
  end.

Fixpoint GenerateCandidates (arc:Triplet)(graph candidates table:@list Triplet): (@list Triplet) :=
  let (x, db) := arc in
  let (a, b) := x in
  (match graph with
  | []             => candidates
  | arc' :: graph' => let recursiveCall := (GenerateCandidates arc graph' candidates table) in
                        (
                        let (y, n) := arc' in
                        let (b'', b') := y in
                        if ((b'' =? b) && Absence b' table)
                        then (if (Absence b' candidates)
                              then (b, b', db+n) :: recursiveCall
                              else match Presence b' candidates with
                                   | None              => recursiveCall
                                   | Some (a', _, db') => if ((db+n) <? db')
                                                          then let newCandidates := (replace (a', b', db')
                                                                                (b, b', db+n) candidates cons)
                                                                                in
                                                                   (GenerateCandidates arc graph' newCandidates table)
                                                          else recursiveCall
                                      end)
                        else recursiveCall )
  end).

Definition overflow := 1000.

Definition tripletsMin (c:@list Triplet) :=
  match c with
  |[]     => None
  |x :: l => Some ((fix tripletsMinRec l' min :=
               match l' with
               | []       => min
               | y :: l'' => let c := (snd y) in let c' := (snd min) in
                             if (c <? c') then tripletsMinRec l'' y else tripletsMinRec l'' min
               end) l x)
  end.

Definition removeMin (c:@list Triplet) :=
  let min := (tripletsMin c) in
  match min with
  | None    => (None, c)
  | Some c' => (min, remove c' c)
  end.

Definition uniqueApp{A:Type}`{Eqb A} (l1 l2: @list A) :=
  l1 ++
  (fix uniqueAppRec li lj :=
  match lj with
  | [] => []
  | x :: lj' => let res := uniqueAppRec li lj' in
                if (list_mem x li) then res else (x :: res)
  end) l1 l2.

Notation "x +++ y" := (uniqueApp x y) (at level 60, right associativity) : list_scope.

(** Necessary here to show the decreasing argument *)
Fixpoint ConsumeCandidates(graph candidates table : @list Triplet)(overflow : nat) : (@list Triplet)*(@list Triplet):=
  let nilCase := ([], table) in
  match overflow with
  | 0    => nilCase
  | S n' => match candidates with
            | [] => nilCase
            | _  => let (arc, newCandidates) := (removeMin candidates) in
                    match arc with
                    | Some triplet => let candidatesRecord := (GenerateCandidates triplet graph newCandidates table) in
                                      let res := (ConsumeCandidates graph candidatesRecord (triplet::table) n') in
                                      (triplet :: candidatesRecord +++ fst res, snd res)
                    | None         => nilCase
                    end
            end
  end.

Definition DjikstraTriplets(root:nat)(l:@list Triplet) : (@list Triplet)*(@list Triplet) :=
  ConsumeCandidates l [(root, root, 0)][] overflow.

Require Import dijkstra molecules.
Import Pondéré.

Definition AtomeToTriplet(atome : At) :=
  match atome with
  | G a b n => (a, b, n)
  | T a b n => (a, b, n)
  | C a b n => (a, b, n)
  end.

Fixpoint MoleculeToTriplets(molecule : @Molecule At): (@list Triplet) :=
  match molecule with
  |un => []
  |atome x => [AtomeToTriplet x]
  |conjonctionMultiplicative M1 M2 => (MoleculeToTriplets M1)++(MoleculeToTriplets M2)
  end.

Fixpoint TripletsToTable(list : @list Triplet): (@Molecule At) :=
  match list with
  |[]               => un
  |[(a,b,n)]        => t a b n
  |(a,b,n) :: list' => TripletsToTable list' ⊗ (t a b n)
  end.

Definition Dijkstra(root:nat)(M:@Molecule At): (@list Triplet)*(@Molecule At) :=
  let calculation := (DjikstraTriplets root (MoleculeToTriplets M)) in
  (fst calculation, TripletsToTable (snd calculation)).

(** Tactics *)

Fixpoint findFirst{A:Type} (l:list A)(f:A -> bool) :=
  match l with
  |nil     => None
  |x :: l' => if (f x) then Some x else findFirst l' f
  end.

Definition previousCovered (t:Triplet)(a':nat) : bool :=
  let (x,c) := t in let (a,b) := x in b =? a'.

Require Import tactics.

Ltac addArcsRec l triplets :=
  match l with
  | nil                => idtac "No more arcs to generate"; idtac ""
  | (?a,?b,?n) :: ?l'  => match eval compute
                          in (findFirst triplets (fun (t:Triplet) => previousCovered t a)) with
                          | None                  => idtac "No more candidate to cover"
                          | Some (?a', _, ?da)  => idtac "Generate candidate C " a b n " from T " a' a da;
                                                     dupliquerExponentielle 0; Candidat1 a b (n-da) a' da;
                                                     idtac "Generate vertice T " a b n;
                                                     dupliquerExponentielle 2; Recouvrement1 a b n;
                                                     idtac ""; addArcsRec l' triplets
                          end
  end.

Ltac addArcs candidates triplets :=
  idtac "Generating automatically the arcs with Djikstra"; idtac "";
  match eval compute in
(intersection candidates triplets) with
  |nil               => idtac "No obvious arcs"
  |(?a,?b,?n) :: ?l  => addArcsRec l triplets
  end.

Require Import dijkstra.
Import Pondéré.

Definition ProveDijkstra Graph Root :=
  let pair := (Dijkstra Root Graph) in
  let FinalTableGraph := snd pair in
  Transformation règles (Graph ⊗ t Root Root 0)(Graph ⊗ FinalTableGraph).

Ltac TacticDijkstra Graph Root :=
  (** Compute Final Graph and its associated tactic *)
  unfold ProveDijkstra;
  remember (Dijkstra Root Graph) as c eqn:Hc; cbv in Hc;
  remember (fst c) as p eqn:Hp; remember (snd c) as fg eqn:Hfg;
  rewrite Hc in Hp, Hfg; cbv in Hp, Hfg; clear Hc;
  rewrite Hfg;
  (** Run the custom tactic *)
  match goal with
  | Hp: _ = ?x, Hfg : _ = ?y |- _ => idtac "Final reached graph is "x; addArcs x (MoleculeToTriplets y)
  end;
	(** Check the final constraints *)
	ChoisirNeutrePartout;
	ConclureCandidat1;
	ConclureCandidat2.

Definition Graph := g 1 2 4 ⊗ g 1 4 1 ⊗ g 1 5 2 ⊗ g 4 5 2 ⊗ g 4 6 3 ⊗ g 5 6 1 ⊗ g 5 3 0 ⊗ g 3 2 3 ⊗ g 4 2 4.

Definition Root := 1.

Theorem test : ProveDijkstra Graph Root.
Proof.
  TacticDijkstra Graph Root.
Qed.