Require Import Arith.
Require Import List.

Require Import Omega.

Ltac numerical :=
  let XP := fresh "XP" in
    let XW := fresh "XW" in
  match goal with
    | H : False |- _ => inversion H
    | _ : _ |- context [ eq_nat_dec ?x ?y ] =>
      case_eq (eq_nat_dec x y) ; intros XP XW ;
        try (rewrite XW in *) ; clear XW ; simpl in * ; numerical
    | _ : _ |- context [ le_lt_dec ?x ?y ] =>
      case_eq (le_lt_dec x y) ; intros XP XW ;
        try (rewrite XW in *) ; clear XW ; simpl in * ; numerical
    | H : context [ eq_nat_dec ?x ?y ] |- _ =>
      case_eq (eq_nat_dec x y) ; intros XP XW ;
        rewrite XW in * ; clear XW ; simpl in * ; numerical
    | H : context [ le_lt_dec ?x ?y ] |- _ =>
      case_eq (le_lt_dec x y) ; intros XP XW ;
            rewrite XW in * ; clear XW ; simpl in * ; numerical
    | _ : _ |- ?x = ?y => auto ; try (elimtype False ; simpl in * ; firstorder ; fail)
    | _ : _ |- context [ False_rec ?x ?y ] => elimtype False
(*  | _ : _ |- context [ False_rec ?x ?y ] => elimtype False ; simpl in * ; omega
    | _ : _ |- ?x = ?y => elimtype False ; simpl in * ; omega *)
    | _ : _ |- False => firstorder
    | _ : _ |- _ => auto
  end.

(*
Require Import Peano.
Require Import Peano_dec.
*)

Inductive Ty : Set :=
| TV : nat -> Ty
| Imp : Ty -> Ty -> Ty
| All : Ty -> Ty.

Lemma ty_eq_dec : forall (ty1 ty2 : Ty), {ty1 = ty2} + {ty1 <> ty2}.
Proof.
  decide equality. decide equality.
Defined.

Inductive Term : Set :=
| F : nat -> Term
| V : nat -> Term
| App : Term -> Term -> Term
| TApp : Term -> Ty -> Term
| Abs : Ty -> Term -> Term
| Lam : Term -> Term.

Definition Zero := (All (TV 0)).
Definition One := (Imp Zero Zero).
Definition Unit := Abs Zero (V 0).

Definition FCtx := nat -> Ty.

Inductive Ctx : Set :=
| ctx : FCtx -> nat -> list Ty -> Ctx.

Inductive Holds : Set :=
| H : Ctx -> Term -> Ty -> Holds.

Notation "[ d ; n ; l  |= t @ ty ]" := (H (ctx d n l) t ty) (at level 0).
Open Scope list_scope.

Fixpoint tyshiftn (n : nat) (d : nat) (ty : Ty) {struct ty} : Ty :=
  match ty with
    | TV m => if le_lt_dec d m then TV (n+m) else TV m
    | Imp t s => Imp (tyshiftn n d t) (tyshiftn n d s)
    | All t => All (tyshiftn n (S d) t)
  end.

Definition tyshift := tyshiftn 1 0.

Definition tysub : forall (ty : Ty) (n : nat) (s : Ty), Ty.
Proof.
  refine
    (fix tysub (ty : Ty) (n : nat) (s : Ty) {struct ty} : Ty :=
      match ty with
        | TV m => match le_lt_dec n m with
                    | left p => match eq_nat_dec n m with
                                  | left _ => s
                                  | right p' =>
                                    (match m as m' return (m = m' -> Ty) with
                                      | 0 => (fun p'' => False_rec _ _)
                                      | S m' => (fun _ => TV m')
                                     end) (refl_equal m)
                                end
                    | right _ => TV m
                  end
        | Imp ty1 ty2 => Imp (tysub ty1 n s) (tysub ty2 n s)
        | All t => All (tysub t (S n) (tyshift s))
      end).
  destruct m. apply le_n_O_eq in p. apply p'. auto. inversion p''.
Defined.

Fixpoint tysubt (t : Term) (n : nat) (s : Ty) {struct t} : Term :=
  match t with
    | F m => F m
    | V m => V m
    | Abs ty t => Abs (tysub ty n s) (tysubt t n s)
    | Lam t => Lam (tysubt t (S n) (tyshift s))
    | App f g => App (tysubt f n s) (tysubt g n s)
    | TApp f ty => TApp (tysubt f n s) (tysub ty n s)
  end.

Eval compute in tysubt (tysubt (Lam (TApp (V 0) (TV 2))) 0 (TV 0)) 0 (TV 3).

Fixpoint valid (ty : Ty) (n : nat) {struct ty} : Prop :=
  match ty with
    | TV m =>
      if le_lt_dec n m
        then False
        else True
    | Imp s t => valid s n /\ valid t n
    | All t => valid t (S n)
  end.

Definition valid_dec : forall (ty : Ty) (n : nat), {valid ty n}+{~ valid ty n}.
Proof.
  induction ty ; intros.
  (* TV *)
  case_eq (le_lt_dec n0 n).
  intros. right. simpl. rewrite H0. auto.
  intros. left. simpl. rewrite H0. auto.
  (* Imp *)
  firstorder.
  (* All *)
  firstorder.
Defined.

Lemma valid_weaken : forall ty n m,
  n <= m -> valid ty n -> valid ty m.
Proof.
  induction ty ; simpl ; intros.
  numerical.
  inversion H1.
  split. apply IHty1 with (n:=n). auto. auto. auto.
  apply IHty2 with (n:=n). auto. auto.
  apply IHty with (n:=S n). firstorder. auto.
Defined.

Lemma tyshift_level : forall ty1 n m,
  valid ty1 n -> valid (tyshiftn 1 m ty1) (S n).
Proof.
  induction ty1 ; simpl ; intros ; numerical.
  destruct n ; numerical.
  firstorder.
Qed.

Lemma tysub_level : forall ty1 ty2 n,
  valid ty1 (S n) -> valid ty2 n -> valid (tysub ty1 n ty2) n.
Proof.
  induction ty1 ; simpl ; intros ; numerical.
  (* TV *)
  destruct n ; numerical.
  firstorder.
  firstorder.

  apply IHty1. auto. unfold tyshift.
  apply tyshift_level. auto.
Qed.

Lemma tysub_level_gen : forall ty1 ty2 m n,
  m <= n -> valid ty1 (S n) -> valid ty2 n -> valid (tysub ty1 m ty2) n.
Proof.
  induction ty1 ; simpl ; intros ; numerical.
  (* TV *)
  destruct n ; numerical.
  firstorder.
  split.
  apply IHty1_1 ; auto ; firstorder.
  apply IHty1_2 ; auto ; firstorder.
  apply IHty1. firstorder.  auto.
  apply tyshift_level. auto.
Qed.

Lemma tysub_level_Z : forall ty1 ty2 n,
  valid ty1 (S n) -> valid ty2 n -> valid (tysub ty1 0 ty2) n.
Proof.
  intros; apply tysub_level_gen ; firstorder.
Defined.

Inductive Derivation : Holds -> Set :=
| FunIntro : forall d n m l ty,
  d m = ty ->
  valid ty 0 ->
  Derivation [d ; n ; l |= F m @ ty]
| ImpIntro : forall d n l t ty xty,
  valid xty n ->
  Derivation [d ; n ; xty::l |= t @ ty] ->
  Derivation [d ; n ; l |= (Abs xty t) @ (Imp xty ty)]
| ImpElim : forall d n l t f ty xty,
  Derivation [d ; n ; l |= t @ xty] ->
  Derivation [d ; n ; l |= f @ (Imp xty ty)] ->
  Derivation [d ; n ; l |= (App f t) @ ty]
| AllIntro : forall d n l t ty,
  Derivation [d ; S n ; map tyshift l |= t @ ty] ->
  Derivation [d ; n ; l |= (Lam t) @ All ty]
| AllElim : forall d n l t ty xty,
  valid xty n ->
  Derivation [d ; n ; l |= t @ All ty] ->
  Derivation [d ; n ; l |= TApp t xty @ (tysub ty 0 xty)]
| VarIntro : forall d n l ty i,
  valid ty n -> i < length l -> nth i l Zero = ty ->
  Derivation [d ; n ; l |= V i @ ty].

Lemma type_valid_at_n : forall t d n l ty, Derivation [d ; n ; l |= t @ ty] -> valid ty n.
Proof.
  induction t.
  (* F *)
  intros ; inversion H0 ; subst.
  apply valid_weaken with (n:=0). firstorder. auto.
  (* V *)
  intros. inversion H0. auto.
  (* App *)
  intros. inversion H0 ; subst.
  apply IHt1 in H8. simpl in H8.  inversion H8. auto.
  (* TApp *)
  intros. inversion H0.
  subst. apply IHt in H8. simpl in *.
  apply tysub_level_Z. auto. auto.
  (* Abs *)
  intros. inversion H0 ; subst.
  simpl. split ; auto. apply IHt in H8. auto.
  (* Lam *)
  intros. inversion H0 ; subst.
  simpl. apply IHt in H2. auto.
Defined.

Fixpoint typeof (d : FCtx) (n : nat) (l : list Ty) (t : Term) {struct t} : option Ty :=
  match t with
    | F m =>
      if valid_dec (d m) 0
        then Some (d m)
        else None
    | V n' =>
      if le_lt_dec (length l) n'
        then None
        else (fun ty =>
          if valid_dec ty n
            then Some ty
            else None) (nth n' l Zero)
    | App r s =>
      (fun mrty msty =>
        match mrty,msty with
          | Some (Imp xty yty),Some xty' =>
            if ty_eq_dec xty' xty
              then Some yty
              else None
          | _,_ => None
        end) (typeof d n l r) (typeof d n l s)
    | TApp r ty =>
      (fun mrty =>
        match mrty with
          | Some (All ty') =>
            if valid_dec ty n
              then if valid_dec ty' (S n)
                then Some (tysub ty' 0 ty)
                else None
              else None
          | _ => None
        end) (typeof d n l r)
    | Abs ty r =>
      (fun mrty =>
        match mrty with
          | Some ty' =>
            if valid_dec ty n
              then Some (Imp ty ty')
              else None
          | _ => None
        end) (typeof d n (ty::l) r)
    | Lam r =>
      (fun mrty =>
        match mrty with
          | Some ty' =>
            if valid_dec ty' (S n)
              then Some (All ty')
              else None
          | _ => None
        end) (typeof d (S n) (map tyshift l) r)
  end.

Require Import Sumbool.

Theorem typeof_has_derivation :
  forall t d n l ty,
    typeof d n l t = Some ty -> Derivation [d ; n ; l |= t @ ty].
Proof.
  induction t ; intros.
  (* F *)
  simpl in H0.
  apply FunIntro.
  case_eq (valid_dec (d n) 0); intros Ple Hle ; try (rewrite Hle in *) ; try congruence.
  case_eq (valid_dec (d n) 0); intros Ple Hle ; try (rewrite Hle in *) ; try congruence.

  (* V *)
  simpl in H0.
  case_eq (le_lt_dec (length l) n) ;
    intros Ple Hle ; try (rewrite Hle in *) ; try congruence.
  case_eq (valid_dec (nth n l Zero) n0) ;
    intros Pval Hval ; try (rewrite Hval in *) ; try congruence.
  apply VarIntro ; auto ; try congruence.

  (* App *)
  simpl in H0.
  case_eq (typeof d n l t1) ; intros ; try (rewrite H1 in *) ; try congruence ;
    destruct t ; try congruence.
  case_eq (typeof d n l t2) ; intros ; try (rewrite H2 in *) ; try congruence.
  case_eq (ty_eq_dec t t3) ; intros ; try (rewrite H3 in *) ; try congruence.
  inversion H0.
  eapply(ImpElim d n l t2 t1 ty t3).
  apply IHt2. rewrite <- e. auto.
  apply IHt1. rewrite <- H5. auto.

  (* TApp *)
  intros. simpl in H0.
  case_eq (typeof d n l t). intros. rewrite H1 in H0.
  destruct t1 ; try congruence.
  case_eq (valid_dec t0 n) ; intros ; try (rewrite H2 in *) ; try congruence.
  case_eq (valid_dec t1 (S n)) ; intros ; try (rewrite H3 in *) ; try congruence.
  inversion H0. subst.
  apply AllElim. auto. auto.
  intros. rewrite H1 in H0. inversion H0.

  (* Abs *)
  simpl in H0. case_eq (typeof d n (t::l) t0) ; intros ; try (rewrite H1 in *) ; try congruence.
  case_eq (valid_dec t n) ; intros ; try (rewrite H2 in *) ; try congruence.
  inversion H0.
  eapply ImpIntro. auto. apply IHt. auto.

  (* Lam *)
  simpl in H0. case_eq (typeof d (S n) (map tyshift l) t) ; intros ; try (rewrite H1 in *) ; try congruence.
  case_eq (valid_dec t0 (S n)). intros. rewrite H2 in H0. inversion H0.
  eapply AllIntro. apply IHt in H1. auto.
  intros. rewrite H2 in H0. inversion H0.
Defined.

Fixpoint shift (d : nat) (t : Term) {struct t} : Term :=
  match t with
    | F m => F m
    | V m => if le_lt_dec d m then V (S m) else V m
    | App r s => App (shift d r) (shift d s)
    | Lam r => Lam (shift d r)
    | Abs ty r => Abs ty (shift (d+1) r)
    | TApp r ty => TApp (shift d r) ty
  end.

Fixpoint tyshift_term (d : nat) (t : Term) {struct t} : Term :=
  match t with
    | F m => F m
    | V m => V m
    | App r s => App (tyshift_term d r) (tyshift_term d s)
    | Lam r => Lam (tyshift_term (S d) r)
    | Abs ty r => Abs (tyshiftn 1 d ty) (tyshift_term d r)
    | TApp r ty => TApp (tyshift_term d r) (tyshiftn 1 d ty)
  end.

Definition sub : forall (t : Term) (n : nat) (s : Term), Term.
Proof.
  refine
    (fix sub (t : Term) (n : nat) (s : Term) {struct t} : Term :=
      match t with
        | F m => F m
        | V m => match le_lt_dec n m with
                   | left p => match eq_nat_dec n m with
                                 | left p' => s
                                 | right p' =>
                                   (match m as m' return (m = m' -> Term) with
                                      | 0 => (fun p'' => False_rec _ _)
                                      | S m' => (fun _ => V m')
                                    end) (refl_equal m)
                               end
                   | right p => V m
                 end
        | Abs ty r => Abs ty (sub r (S n) (shift 0 s))
        | Lam r => Lam (sub r n (tyshift_term 0 s))
        | App f g => App (sub f n s) (sub g n s)
        | TApp r ty => TApp (sub r n s) ty
      end). destruct m. apply le_n_O_eq in p. apply p'. auto. inversion p''.
Defined.

Lemma nth_sameL : forall A a (l:list A) G d i,
  i < length G ->
  nth i (G++(a::l)) d = nth i (G++l) d.
Proof.
  induction G. intros. inversion H0.
  intros. destruct i.
  simpl. auto. simpl. apply IHG. simpl in H0.
  apply lt_S_n. auto.
Defined.

Lemma nth_sameR : forall A i a (l:list A) G d,
  length G < S i ->
  nth (S i) (G++(a::l)) d = nth i (G++l) d.
Proof.
  refine
    (fix nth_sameR A i a (l G:list A) d (H: length G < S i) {struct G} : nth (S i) (G++(a::l)) d = nth i (G++l) d :=
      (match G as G' return (G = G' -> nth (S i) (G++(a::l)) d = nth i (G++l) d) with
         | nil => _
         | cons a g => _
       end) (refl_equal G)).
  intros. rewrite H1 in *. simpl. auto.
  intros. rewrite H1 in *. simpl.
  destruct i. simpl in H0. unfold lt in H0. apply le_S_n in H0.
  apply le_n_O_eq in H0. inversion H0.
  apply nth_sameR.
  simpl in H0. unfold lt in H0. apply le_S_n in H0.
  unfold lt. auto.
Defined.

Lemma one_longer :
  forall A i (G :list A) xty l, (S i) < S (length (G ++ xty :: l)) -> i < S (length (G++l)).
Proof.
  intros. rewrite app_length in H0. simpl in H0.
  rewrite plus_comm in H0. simpl in H0.
  unfold lt in *. apply le_S_n in H0.
  rewrite app_length. rewrite plus_comm. auto.
Defined.

Lemma strengthenG_gt : forall i d n l G xty ty,
  length G < S i ->
  Derivation [d ; n ; G ++ xty::l |= V (S i) @ ty] ->
  Derivation [d ; n ; G ++ l |= V i @ ty].
Proof.
  intros i d n l G xty ty Hlength HD.
  inversion HD.
  rewrite nth_sameR in H7.
  apply VarIntro. auto.
  induction G. simpl in *.
  firstorder. simpl in *.
  apply one_longer in H6. auto. auto. auto.
Defined.

Lemma strengthenG_lt : forall i d n l G xty ty,
  i < length G ->
  Derivation [d ; n ; G ++ xty::l |= V i @ ty] ->
  Derivation [d ; n ; G ++ l |= V i @ ty].
Proof.
  intros. inversion H1. subst.
  apply VarIntro ; auto.
  rewrite app_length.
  unfold lt in *.
  apply le_plus_trans. auto.
  rewrite nth_sameL. auto. auto.
Defined.

Definition weakenG_lt : forall i G d n L ty xty,
  i < length G ->
  Derivation [d ; n; G ++ L |= V i @ ty] ->
  Derivation [d ; n; G ++ xty :: L |= V i @ ty].
Proof.
  intros.
  apply VarIntro ; auto. apply type_valid_at_n in H1. auto.
  rewrite app_length.
  apply lt_plus_trans. auto.
  inversion H1; subst. simpl in *.
  apply nth_sameL. auto.
Defined.

Definition weakenG_gt : forall i G d n L ty xty,
  length G < (S i) ->
  Derivation [d; n; G ++ L |= V i @ ty] ->
  Derivation [d; n; G ++ xty :: L |= V (S i) @ ty].
Proof.
  intros.
  inversion H1 ; subst.
  apply VarIntro ; auto. rewrite app_length in *.
  simpl. rewrite plus_comm. simpl.
  apply lt_n_S. rewrite plus_comm. auto.
  apply nth_sameR. auto.
Defined.

Lemma nth_append : forall G xty l, nth (length G) (G ++ xty :: l) Zero = xty.
Proof.
  induction G. intros. simpl. auto.
  intros. simpl. apply IHG.
Defined.

Lemma hole_at_i : forall i j k,
  shift j (V i) = (V k) -> (~ j = k).
Proof.
  intros. simpl in *.
  case_eq (le_lt_dec j i).
  intros. rewrite H1 in H0. clear H1.
  unfold not. intros.
  rewrite <- H1 in H0. inversion H0.
  rewrite <- H3 in l.
  apply (le_Sn_n i). auto.
  intros. rewrite H1 in H0. clear H1.
  inversion H0. rewrite H2 in *.
  unfold not. intro. rewrite H1 in l.
  apply (lt_irrefl k). auto.
Defined.

Lemma shift_var : forall n i d G L xty ty,
  Derivation [d; n; G ++ L |= V i @ ty] ->
  Derivation [d; n; G ++ xty :: L |= shift (length G) (V i) @ ty].
Proof.
  intros.
  case_eq (shift (length G) (V i)).
  (* F *)
  intros. simpl in H1.
  destruct (le_lt_dec (length G) i) ; auto ; inversion H1.

  (* Var *)
  intros.
  cut (shift (length G) (V i) = V n0). intros Hdup.
  apply hole_at_i in Hdup.
  simpl in H1.
  case_eq (le_lt_dec (length G) i). intros.
  rewrite H2 in H1. inversion H1.
  apply weakenG_gt. rewrite <- H4 in *.
  unfold lt in *. apply le_n_S. auto.
  auto.
  intros. rewrite H2 in H1.
  inversion H1. rewrite H4 in *. clear H2.
  apply weakenG_lt. rewrite <- H4. auto. auto. auto.

  (* App *)
  intros. simpl in H1.
  destruct (le_lt_dec (length G) i) ; auto ; inversion H1.

  (* TApp *)
  intros. simpl in H1.
  destruct (le_lt_dec (length G) i) ; auto ; inversion H1.
  (* Abs *)
  intros. simpl in H1.
  destruct (le_lt_dec (length G) i) ; auto ; inversion H1.
  (* Lam *)
  intros. simpl in H1.
  destruct (le_lt_dec (length G) i) ; auto ; inversion H1.
Defined.

Lemma shift_correct : forall d n s xty ty G L,
  Derivation [d ; n; G ++ L |= s @ ty] ->
  Derivation [d ; n; G ++ (xty :: L) |= shift (length G) s @ ty].
Proof.
    refine
      (fix shift_correct (d : FCtx) (n : nat) (s : Term) (xty ty : Ty) (G L : list Ty)
        (D : Derivation [d; n; G ++ L |= s @ ty]) {struct s}:
        Derivation [d ; n; G ++ (xty :: L) |= shift (length G) s @ ty] :=
        (match s as s'
           return (s = s' -> Derivation [d ; n; G ++ (xty :: L) |= shift (length G) s @ ty])
           with
           | F m => _
           | V i => _
           | Abs ty r => _
           | Lam t => _
           | App r s => _
           | TApp r ty' => _
         end) (refl_equal s)) ; intros ; subst.

    (* F *)
    inversion D.
    simpl ; subst.
    apply FunIntro. auto. auto.

    (* V *)
    inversion D.
    apply shift_var. exact D.

    (* App *)
    simpl.
    inversion D ; subst.
    apply ImpElim with (xty:=xty0).
    apply shift_correct ; clear shift_correct ; auto.
    apply shift_correct ; clear shift_correct ; auto.

    (* TApp *)
    simpl.
    inversion D ; subst.
    apply AllElim. auto.
    apply shift_correct ; clear shift_correct. auto.

    (* Abs *)
    simpl.
    inversion D ; subst.
    apply ImpIntro. auto.
    rewrite plus_comm. simpl.
    cut (length  (ty0 :: G) = (S (length G))).
    intros. rewrite <- H0.
    rewrite app_comm_cons.
    apply shift_correct with (G:=(ty0::G)) (ty:=ty1).
    rewrite <- app_comm_cons.
    auto. simpl. auto.

    (* Lam *)
    simpl.
    inversion D ; subst.
    apply AllIntro.
    cut (length G = length (map tyshift G)).
    intros. rewrite H0.
    rewrite map_app. simpl.
    apply shift_correct.
    rewrite <- map_app. auto.
    rewrite map_length. auto.
Defined.

Theorem tyhole_at_i : forall i j k,
  tyshiftn 1 j (TV i) = (TV k) -> (~ j = k).
Proof.
  intros. unfold tyshiftn in *.
  case_eq (le_lt_dec j i).
  intros. rewrite H1 in H0. inversion H0.
  clear H1.
  apply le_n_S in l.
  unfold not. intros. rewrite H1 in l.
  apply le_S_n in l. apply (le_Sn_n i). auto.
  intros. rewrite H1 in H0. clear H1.
  inversion H0. unfold not. intros.
  subst. apply (lt_irrefl k). auto.
Qed.

Lemma tyshift_natural : forall G n m,
  nth n (map (tyshiftn 1 m) G) Zero = tyshiftn 1 m (nth n G Zero).
Proof.
  induction G. simpl. intros. destruct n ; auto.
  intros. simpl. destruct n ; auto.
Qed.

Lemma tyshift_comm : forall xty m n,
  m <= n ->
  tyshiftn 1 (S n) (tyshiftn 1 m xty) = tyshiftn 1 m (tyshiftn 1 n xty).
Proof.
  induction xty ; intros ; simpl ; numerical.

  destruct n; numerical.

  rewrite IHxty2. rewrite IHxty1. auto. auto. auto.

  rewrite IHxty. auto. firstorder.
Qed.

Lemma tyshift_tyshift_map  : forall m G,
  map (tyshiftn 1 0) (map (tyshiftn 1 m) G) = map (tyshiftn 1 (S m)) (map (tyshiftn 1 0) G).
Proof.
  induction G. simpl. auto. simpl.
  rewrite tyshift_comm. rewrite IHG. auto.
  apply (le_O_n m).
Defined.

Lemma tyshift_tysubL : forall ty m n xty,
  m <= n ->
  tyshiftn 1 m (tysub ty n xty) = tysub (tyshiftn 1 m ty) (S n) (tyshiftn 1 m xty).
Proof.
  induction ty ; intros ; simpl ; numerical.

  destruct n ; unfold tyshift ; simpl ; numerical.
  destruct n ; unfold tyshift ; simpl ; numerical.

  rewrite IHty1. rewrite IHty2. auto. auto. auto.

  rewrite IHty. unfold tyshift.
  rewrite tyshift_comm. auto.
  firstorder. firstorder.
Qed.

Lemma tyshift_tysubR : forall ty m n xty,
  n <= m ->
  tyshiftn 1 m (tysub ty n xty) = tysub (tyshiftn 1 (S m) ty) n (tyshiftn 1 m xty).
Proof.
  induction ty ; intros ; simpl ; numerical.
  destruct n ; unfold tyshift ; simpl ; numerical.
  destruct n ; unfold tyshift ; simpl ; numerical.
  destruct n ; unfold tyshift ; simpl ; numerical.

  rewrite IHty1. rewrite IHty2. auto. auto. auto.

  rewrite IHty. unfold tyshift.
  rewrite tyshift_comm ; auto ; firstorder. firstorder.
Qed.

Lemma tyshiftn_closed_id : forall ty l n m,
  n <= m -> valid ty n -> tyshiftn l m ty = ty.
Proof.
  induction ty.
  (* TV *)
  intros; simpl in * ; numerical.

  (* Imp *)
  intros. simpl in *.
  inversion H1.
  apply (IHty1 l n m H0) in H2.
  apply (IHty2 l n m H0) in H3.
  rewrite H2. rewrite H3. auto.

  (* All *)
  intros. simpl in *.
  apply (IHty l (S n) (S m)) in H1.
  rewrite H1. auto. firstorder.
Defined.

Lemma tysub_closed_id : forall ty xty n m,
  n <= m -> valid ty n -> tysub ty m xty = ty.
Proof.
  induction ty.
  (* TV *)
  intros ; simpl in * ; numerical.
  (* Imp *)
  intros ; simpl in *.
  inversion H1.
  apply (IHty1 xty n m H0) in H2.
  apply (IHty2 xty n m H0) in H3.
  rewrite H2. rewrite H3. auto.

  (* All *)
  intros. simpl in *.
  apply (IHty (tyshift xty) (S n) (S m)) in H1.
  rewrite H1. auto. firstorder.
Defined.

Lemma tyshift_correct : forall s d n m G xty,
  Derivation [d; n+m; G |= s @ xty] ->
  Derivation [d; S (n+m); map (tyshiftn 1 m) G |= tyshift_term m s @ tyshiftn 1 m xty].
Proof.
  induction s ; intros.

  (* F *)
  inversion H0 ; subst. simpl.
  apply FunIntro.
  rewrite tyshiftn_closed_id with (n:=0). auto. firstorder. auto.
  rewrite tyshiftn_closed_id with (n:=0). auto. firstorder. auto.

  (* V *)
  inversion H0. subst. simpl.
  apply VarIntro ; auto.
  apply tyshift_level. auto.
  rewrite map_length. auto.
  apply tyshift_natural.

  (* App *)
  inversion H0. subst. simpl.
  apply ImpElim with (xty:=tyshiftn 1 m xty0).
  apply IHs2. auto.
  cut (Imp (tyshiftn 1 m xty0) (tyshiftn 1 m xty) = tyshiftn 1 m (Imp xty0 xty)).
  intros. rewrite H1. apply IHs1. auto. simpl. auto.

  (* TApp *)
  simpl.
  inversion H0 ; subst.
  rewrite tyshift_tysubR.
  apply AllElim.
  apply tyshift_level. auto.
  change (All (tyshiftn 1 (S m) ty)) with (tyshiftn 1 m (All ty)).
  apply IHs. auto.
  apply (le_O_n m).

  (* Abs *)
  simpl. inversion H0 ; subst.
  simpl. apply ImpIntro.
  apply tyshift_level. auto.
  change (tyshiftn 1 m t :: map (tyshiftn 1 m) G) with (map (tyshiftn 1 m) (t :: G)).
  apply IHs. auto.

  (* Lam *)
  simpl. inversion H0 ; subst.
  simpl. apply AllIntro. intros. unfold tyshift.
  rewrite tyshift_tyshift_map.
  intros.
  change (S (S (n + m))) with (S ((S n) + m)).
  rewrite plus_Snm_nSm.
  apply IHs. auto.
  rewrite <- plus_Snm_nSm. auto.
Qed.

Theorem sub_preservation : forall t s d n xty ty G L,
  Derivation [d; n ; G++xty::L |= t @ ty] ->
  Derivation [d; n ; G++L |= s @ xty] ->
  Derivation [d; n ; G++L |= sub t (length G) s @ ty].
Proof.
  induction t.
  (* FunIntro*)
  intros. simpl.
  inversion H0; subst.
  apply FunIntro ; auto.

  (* VarIntro *)
  intros. unfold sub.
  case_eq (le_lt_dec (length G) n) ; intros.
  case_eq (eq_nat_dec (length G) n). intros. rewrite <- e in H0.
  inversion H0. simpl in H10.
  rewrite nth_append in H11. rewrite <- H11. auto.
  destruct n. simpl in *.
  intros. elimtype False. clear H2. clear H3.
  apply le_n_O_eq in l. unfold not in n. apply n. auto.
  intros.

  apply strengthenG_gt with (xty:=xty). clear H2.
  apply le_lt_or_eq in l. inversion l ; auto. clear H3.
  rewrite H2 in n1. unfold not in n1.
  elimtype False. apply n1. auto.

  exact H0.

  apply strengthenG_lt with (xty:=xty). auto. auto.

  (* ImpElim *)
  intros. simpl.
  inversion H0. subst.
  apply ImpElim with (xty:=xty0). eapply IHt2. eexact H4.
  exact H1. eapply IHt1. eexact H9. auto.

  (* AllElim *)
  intros. simpl.
  inversion H0. subst.
  apply AllElim. auto. auto. apply IHt with (xty:=xty). auto. auto.

  (* ImpIntro *)
  intros. simpl.
  inversion H0. subst.
  apply ImpIntro. auto.
  cut (S (length G) = (length (t::G))).
  intros. rewrite H2.
  rewrite app_comm_cons.
  apply IHt with (G := (t :: G)) (xty:=xty). auto.
  rewrite <- app_comm_cons.
  cut (t::G++L = nil++(t::G++L)).
  intros. rewrite H3.

  apply shift_correct with (G:=(nil (A:=Ty))).
  simpl. auto. auto. auto.

  (* AllIntro *)
  intros. simpl in *.
  inversion H0 ; subst.
  apply AllIntro.
  cut (n+0 = n). intro Hpz. rewrite <- Hpz in H1.
  apply tyshift_correct in H1. simpl in H1.
  cut (length (map (tyshiftn 1 0) G) = length G). intros.
  rewrite <- H2.
  rewrite map_app.
  apply IHt with (xty:=tyshiftn 1 0 xty).
  rewrite map_app in H3. simpl in H3. auto.
  rewrite map_app in H1.
  rewrite <- Hpz. auto.
  apply map_length. simpl. auto.
Defined.

Theorem sub_preservation_basic : forall d n L t s xty ty,
  Derivation [d ; n ; xty::L |= t @ ty] ->
  Derivation [d ; n ; L |= s @ xty] ->
  Derivation [d ; n ; L |= sub t 0 s @ ty].
Proof.
  intros.
  change L with (nil++L).
  change 0 with (length  (A:=Ty) nil).
  apply sub_preservation with (xty:=xty). simpl. auto.
  simpl. auto.
Defined.

Theorem type_unique : forall d n L t ty1 ty2,
  Derivation [d ; n ; L |= t @ ty1] -> Derivation [d ;n ; L |= t @ ty2]
  -> ty1 = ty2.
Proof.
  refine
    (fix type_unique d n l (t : Term) ty1 ty2
      (d1 : Derivation [d; n ; l |= t @ ty1])
      (d2 : Derivation [d; n ; l |= t @ ty2]) {struct t}
      : ty1 = ty2 :=
      (match t as t' return (t = t' -> ty1 = ty2)
         with
         | F n => _
         | V n => _
         | App f g => _
         | Abs ty r => _
         | TApp r ty => _
         | Lam r => _
       end) (refl_equal t)) ; intros ; subst.

  (* F *)
  intros. inversion d1 ; inversion d2 ; subst ; auto.

  (* V *)
  intros. inversion d1 ; inversion d2 ; subst ; auto.

  (* App *)
  intros. inversion d1 ; inversion d2 ; subst ; auto.
  apply type_unique with (ty1:=xty) (ty2:=xty0) in H2 ;
    apply type_unique with (ty1:=Imp xty ty1) (ty2:=Imp xty0 ty2) in H7.
  subst. inversion H7. auto. auto. auto. auto.

  (* TApp *)
  intros. inversion d1 ; inversion d2 ; subst ; auto.
  apply type_unique with (ty1:=All ty0) (ty2:=All ty3) in H7.
  inversion H7. auto. auto.

  (* Abs *)
  intros. inversion d1 ; inversion d2 ; subst ; auto.
  apply type_unique with (ty1:=ty0) (ty2:=ty3) in H7.
  subst ; auto. auto.

  (* Lam *)
  intros. inversion d1 ; inversion d2 ; subst ; auto.
  apply type_unique with (ty1:=ty) (ty2:=ty0) in H7.
  subst ; auto. auto.
Defined.

Theorem tysub_tyshift_id : forall a m ty,
  tysub (tyshiftn 1 m a) m ty = a.
Proof.
  induction a.
  intros. simpl. numerical.

  intros. simpl.
  rewrite (IHa1 m ty).
  rewrite (IHa2 m ty). auto.

  intros. simpl. unfold tyshift.
  rewrite (IHa (S m) (tyshiftn 1 0 ty)).
  auto.
Qed.

Lemma tysub_tyshift_map_id : forall l m ty,  map (fun t => tysub t m ty) (map (tyshiftn 1 m) l) = l.
Proof.
  induction l; intros m ty.
  simpl. auto.
  simpl. rewrite tysub_tyshift_id.
  rewrite IHl. auto.
Defined.

Theorem nth_tysub_tyshift : forall l n m ty ty0,
  nth n (map (tyshiftn 1 m) l) Zero = ty ->
  nth n l Zero = tysub ty m ty0.
Proof.
  induction l.
  intros. simpl in *.
  destruct n ; subst ; simpl ; auto.

  intros.
  destruct n. simpl in H0.
  simpl. subst.
  rewrite (tysub_tyshift_id a m ty0). auto.

  simpl. apply IHl. simpl in H0. auto.
Defined.

Lemma tyshiftn_z_id : forall ty n, tyshiftn 0 n ty = ty.
Proof.
  induction ty.
  intros. simpl. case (le_lt_dec n0 n) ; intros ; auto.

  intros. simpl. rewrite IHty1. rewrite IHty2. auto.

  intros. simpl. rewrite IHty. auto.
Defined.

Lemma tyhole_in : forall n m k ty,
  tyshiftn (S n) m ty = (TV k) -> k > m+n \/ k < m.
Proof.
  intros.
  simpl in H0.
  destruct ty. simpl in *.
  case_eq (le_lt_dec m n0) ; intros HP  HX ; rewrite HX in H0.
  inversion H0. firstorder.
  inversion H0. firstorder.
  inversion H0. inversion H0.
Defined.

Lemma tysub_into_hole : forall ty n m k ty',
  k <= m+n /\ k >= m ->
  tysub (tyshiftn (S n) m ty) k ty' = tyshiftn n m ty.
Proof.
  induction ty.

  intros. simpl. numerical.

  intros. simpl. intros. rewrite IHty1. rewrite IHty2. auto. auto. auto.

  intros. simpl. rewrite IHty. auto.
  firstorder.
Defined.

Lemma nth_tysub_map : forall l n m ty1, nth n (map (fun ty : Ty => tysub ty m ty1) l) Zero =
  tysub (nth n l Zero) m ty1.
Proof.
  induction l ; auto.
  intros. simpl. destruct n ; auto.
  intros. simpl. destruct n. auto.
  apply IHl.
Defined.

Lemma tyshift_sum : forall tyx n m, tyshiftn 1 n (tyshiftn m n tyx) = tyshiftn (S m) n tyx.
Proof.
  induction tyx ; intros n0 m.
  (* TV *)
  simpl. auto. numerical.
  (* Imp *)
  simpl.
  rewrite IHtyx1. rewrite IHtyx2. auto.
  (* All *)
  simpl. rewrite IHtyx. auto.
Defined.

Lemma commute_tysub_tyshift_maps : forall l tyx m, map tyshift (map (fun ty : Ty => tysub ty m tyx) l)  =
  map (fun ty => tysub ty (S m) (tyshift tyx)) (map tyshift l).
Proof.
  induction l ; intros.
  simpl. auto.
  simpl.
  cut (tyshift (tysub a m tyx) = tysub (tyshift a) (S m) (tyshift tyx)).
  intros Heq; rewrite Heq.
  rewrite IHl. auto.
  unfold tyshift.
  rewrite tyshift_tysubL. auto. firstorder.
Defined.

(*
Lemma F_weaken : forall ty d n l tyx,
  Derivation [d; n; l |=F n @ tysub ty 0 tyx] ->
  Derivation [d; n; nil |=F n @ ty].
Proof.
  intros.
  inversion H0. subst.
  apply FunIntro. rewrite H3.
  rewrite tysub_closed_id with (n:=0). auto. auto.

  apply tysub_level_gen.

  rewrite tysub_closed_id with (n:=0) in H7 . auto. firstorder.
*)
Axiom tysub_comm : forall ty0 t0 tyx m,
  tysub (tysub ty0 0 t0) m tyx =
  tysub (tysub ty0 (S m) (tyshift tyx)) 0 (tysub t0 m tyx).

Lemma tysub_all : forall t ty tyx d n m l,
  valid tyx (n+m) ->
  Derivation [d; S (n+m); l |= t @ ty] ->
  Derivation [d; (n+m); map (fun ty => tysub ty m tyx) l |= tysubt t m tyx @ tysub ty m tyx].
Proof.
  induction t; intros ty tyx d n0 m l HV HD.

  (* F *)
  apply FunIntro.  inversion HD. subst.
  rewrite tysub_closed_id with (n:=0). auto. firstorder. auto.
  inversion HD. subst.
  rewrite tysub_closed_id with (n:=0). auto. firstorder. auto.

  (* V *)
  inversion HD. subst.
  apply VarIntro.
  apply tysub_level_gen. firstorder. auto. auto.
  rewrite map_length. auto.
  change (tysub (nth n l Zero) m tyx) with ((fun ty => tysub ty m tyx) (nth n l Zero)).
  rewrite <- map_nth. unfold Zero. simpl. auto.
  (* App *)
  inversion HD. subst.
  apply ImpElim with (xty := (tysub xty m tyx)).
  apply IHt2. auto. auto.
  change (Imp (tysub xty m tyx) (tysub ty m tyx)) with (tysub (Imp xty ty) m tyx).
  apply IHt1. auto. auto.
  (* TApp *)
  inversion HD ; subst.
  rewrite tysub_comm.
  apply AllElim. auto.
  apply tysub_level_gen. firstorder. auto. auto.
  fold tysubt.
  change (All (tysub ty0 (S m) (tyshift tyx))) with (tysub (All ty0) m tyx).
  apply IHt. auto. auto.
  (* Abs *)
  inversion HD ; subst.
  simpl.
  apply ImpIntro.
  apply tysub_level_gen. firstorder. auto. auto.
  change (tysub t m tyx :: map (fun ty : Ty => tysub ty m tyx) l) with
    (map (fun ty : Ty => tysub ty m tyx) (t::l)).
  apply IHt. auto. auto.
  (* Lam *)
  inversion HD. subst.
  simpl.
  apply AllIntro.
  rewrite commute_tysub_tyshift_maps.
  (*  cut (map tyshift (map (fun ty : Ty => tysub ty m tyx) l)  =
     map (fun ty => tysub ty (S m) (tyshift tyx)) (map tyshift l)).
  intros Heq.
  rewrite Heq. *)
  change (S (n0 + m)) with (S n0 + m).
  rewrite plus_Snm_nSm.
  apply IHt. fold tyshift.
  rewrite <- plus_Snm_nSm.
  apply tyshift_level. fold plus. auto.
  rewrite <- plus_Snm_nSm.
  auto.
Defined.

Lemma tysub_derivation : forall t d n m l ty tyx,
  valid tyx (n+m) ->
  Derivation [d; S (n+m); map (tyshiftn 1 m) l |=t @ ty] ->
  Derivation [d; (n+m); l |=tysubt t m tyx @ tysub ty m tyx].
Proof.
  induction t ; intros d n0 m l ty tyx HV HD.
  (* F *)
  inversion HD ; subst ; simpl.
  apply FunIntro.
  rewrite tysub_closed_id with (n:=0) ; firstorder.
  rewrite tysub_closed_id with (n:=0) ; firstorder.

  (* V *)
  inversion HD ; subst ; simpl.
  apply VarIntro.
  apply tysub_level_gen ; firstorder.
  rewrite map_length in H6. auto.
  rewrite <- nth_tysub_map.
  rewrite tysub_tyshift_map_id with (m :=m) (ty:=tyx). auto.
  (* App *)
  inversion HD ; subst ; simpl.
  apply ImpElim with (xty := tysub xty m tyx).
  apply IHt2 ; auto.
  change (Imp (tysub xty m tyx) (tysub ty m tyx)) with (tysub (Imp xty ty) m tyx).
  apply IHt1 ; auto.

  (* TApp *)
  inversion HD. subst.
  simpl.
  rewrite tysub_comm.
  apply AllElim.
  apply tysub_level_gen. firstorder. auto. auto.
  change (All (tysub ty0 (S m) (tyshift tyx))) with (tysub (All ty0) m tyx).
  apply IHt. auto. auto.

  (* Abs *)
  inversion HD ; subst ; simpl.
  apply ImpIntro.
  apply tysub_level_gen ; firstorder.
  cut (l = map (fun t => tysub t m tyx) (map (tyshiftn 1 m) l)).
  intros Heq. rewrite Heq.
  change (tysub t m tyx :: map (fun t1 : Ty => tysub t1 m tyx) (map (tyshiftn 1 m) l)) with
    (map (fun t1 : Ty => tysub t1 m tyx) (t::(map (tyshiftn 1 m) l))).
  apply tysub_all. auto. auto.
  rewrite tysub_tyshift_map_id with (m:=m) (ty:=tyx).
  auto.

  (* Lam *)
  inversion HD ; subst ; simpl.
  apply AllIntro.
  change (S (n0+m)) with (S n0 + m).
  rewrite plus_Snm_nSm.
  apply IHt.
  rewrite <- plus_Snm_nSm. auto.
  apply tyshift_level. fold plus. auto.
  cut (map (tyshiftn 1 (S m)) (map tyshift l) = (map tyshift (map (tyshiftn 1 m) l))).
  intros Heq. rewrite Heq.
  rewrite <- plus_Snm_nSm. auto.
  rewrite tyshift_tyshift_map. auto.
Defined.

Lemma tysub_derivation_simple : forall t d n l ty tyx,
  valid tyx n ->
  Derivation [d; S n; map tyshift l |=t @ ty] ->
  Derivation [d; n; l |=tysubt t 0 tyx @ tysub ty 0 tyx].
Proof.
  intros.
  change n with (0+n).
  rewrite plus_comm.
  apply tysub_derivation ; rewrite <- plus_comm ; firstorder.
Defined.

Axiom Delta : nat -> Term.
Axiom Xi : forall d n l m ty, Derivation [d ; n ; l |= F m @ ty] -> Derivation [d ; n ; l |= Delta m @ ty].

Inductive Ev : Term -> Term -> Set :=
| ev_f : forall n, Ev (F n) (Delta n)
| ev_app : forall t t' s, Ev t t' -> Ev (App t s) (App t' s)
| ev_abs : forall t s ty, Ev (App (Abs ty t) s) (sub t 0 s)
| ev_tapp : forall t t' ty, Ev t t' -> Ev (TApp t ty) (TApp t' ty)
| ev_lam : forall t ty, Ev (TApp (Lam t) ty) (tysubt t 0 ty).

Theorem Ev_preservation : forall t t' d n l ty, Derivation [d; n ; l |= t @ ty] ->  Ev t t' -> Derivation [d; n ; l |= t' @ ty].
Proof.
  refine (fix Ev_preservation t t' d n l ty (D : Derivation [d; n ; l |= t @ ty]) (EvH : Ev t t') : Derivation [d; n ; l |= t' @ ty] := _)
    ; case_eq t ; intros; subst.
  (* F *)
  inversion EvH. subst. apply Xi. auto.
  (* V *)
  inversion EvH.
  (* App *)
  inversion EvH ; subst.
  inversion D ; subst.
  apply ImpElim with (xty:=xty). auto.
  apply Ev_preservation with (t:=t0) ; auto.
  inversion D ; subst.
  inversion H7 ; subst.
  apply sub_preservation_basic with (xty:=xty) ; auto.
  (* TApp *)
  inversion EvH ; subst.
  inversion D ; subst.
  apply AllElim ; auto.
  apply Ev_preservation with (t:=t0) ; auto.
  inversion D ; subst.
  inversion H7 ; subst.
  apply tysub_derivation_simple. auto. auto.
  (* Abs *)
  inversion EvH.
  (* Lam *)
  inversion EvH.
Defined.

Definition Evplus := forall t t', Ev t t' \/ Evstar t t'.

Fixpoint ev_in_n (tick : nat) d n l t ty (D : Derivation [d; 0; nil |= t @ ty]) : { t' | Ev

Inductive trans : Term -> label -> term -> Prop :=
| trans_fst : forall t1 t2 A, (0, [] |= (prod t1 t2) @ A) -> trans (prod t1 t2) t1
| trans_snd : forall t1 t2 A, (0, [] |= (prod t1 t2) @ A) -> trans (prod t1 t2) t2
| trans_inl : forall t A B, (0, [] |= (inl t B) @ A) -> trans (inl t B) t
| trans_inr : forall t A B, (0, [] |= (inr t B) @ A) -> trans (inr t B) t
| trans_app : forall t1 t2, (0, [] |= t2 @ A) -> trans (abs t1) (app (abs t1) t2)
| trans_next : forall t1 t2 t3 l, eval t1 t2 -> trans t2 l t3 -> trans t1 l t3.

CoInductive Simulates : term -> term -> Prop :=
| simulates_base : forall a b,
  (forall a' l,
    trans a l a' ->
    (exists b', trans b l b' /\ simulates a' b')) ->
  simulates a b.


Require Import TLC.LibTactics.
Require Import TLC.LibEqual.
Require Import TLC.LibLogic.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Require Import Filter.
Require Import ZArith.
Require Import Psatz.
Require Import LibZExtra.
Require Import LibRewrite.
Local Open Scope Z_scope.

(* A notion of limit, or convergence, or divergence -- it all depends on which
   filters one uses. The assertion [limit f] states that any property [P] that
   is ultimately true of [y] is ultimately true of [f x]. If [f] is a function
   from [nat] to [nat], equipped with its standard filter, this means that [f x]
   tends to infinity as [x] tends to infinity. *)

(* [limit] could take two arguments of type [filter A] and [filter B]. Instead,
   we take two arguments of type [filterType]. *)

Section Limit.

Variables A B : filterType.

Definition limit f :=
  finer (ultimately (image_filterType A f)) (ultimately B).

Lemma limitP f :
  limit f =
  forall P, ultimately B P -> ultimately A (fun x => P (f x)).
Proof. reflexivity. Qed.

Lemma limit_eq f g :
  limit f ->
  (forall a, f a = g a) ->
  limit g.
Proof.
  rewrite !limitP. intros L E P UP.
  specializes L UP. revert L; filter_closed_under_intersection.
  introv H. rewrite~ E in H.
Qed.

Lemma limit_ultimately_eq f g :
  limit f ->
  ultimately A (fun a => f a = g a) ->
  limit g.
Proof.
  rewrite !limitP. intros L UE P UP.
  specializes L UP. revert L UE; filter_closed_under_intersection.
  introv (H & E). rewrite~ E in H.
Qed.

End Limit.
Arguments limit : clear implicits.

(******************************************************************************)
(* Instance for rewriting under [limit] *)

Program Instance Pw_eq_ultimately_proper (A B : filterType) :
  Proper (pw eq ==> Basics.flip Basics.impl) (limit A B).
Next Obligation.
  intros. unfold respectful, pointwise_relation, Basics.flip, Basics.impl.
  intros P1 P2 H U. eapply limit_eq; eauto.
Qed.

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

Lemma limit_id:
  forall A : filterType,
  limit A A (fun a : A => a).
Proof. intros. rewrite limitP. auto. Qed.

Lemma limit_comp :
  forall (A B C : filterType) (f : A -> B) (g : B -> C),
  limit A B f ->
  limit B C g ->
  limit A C (fun x => g (f x)).
Proof.
  introv LF LG. rewrite limitP in *.
  intros P UP.
  specializes LG UP. specializes LF LG. auto.
Qed.

Lemma limit_comp_eq :
  forall (A B C : filterType) (f : A -> B) (g : B -> C) (h : A -> C),
  limit A B f ->
  limit B C g ->
  (forall a, h a = g (f a)) ->
  limit A C h.
Proof.
  introv LF LG E.
  forwards E': fun_ext_dep E.
  rewrite E'. applys~ limit_comp.
Qed.

Section LimitToZ.

Variable A : filterType.

Lemma limitPZ (f : A -> Z) :
  limit A Z_filterType f <->
  (forall y, ultimately A (fun x => y <= f x)).
Proof.
  rewrite limitP.
   split.
  - introv H. intro y. specializes H (ultimately_ge_Z y). auto.
  - introv H. intros P HP. rewrite ZP in HP. destruct HP as (n0 & Hn0).
    generalize (H n0). filter_closed_under_intersection. auto.
Qed.

Lemma limitPZ_ultimately (cond : Z -> Prop) (f : A -> Z) :
  ultimately Z_filterType cond ->
  limit A Z_filterType f <->
  (forall y, cond y -> ultimately A (fun x => y <= f x)).
Proof.
  intro Hcond.
  rewrite limitP. split.
  - introv H. intros y Cy. specializes H (ultimately_ge_Z y). auto.
  - introv H. intros P HP.
    rewrite~ (@ZP_ultimately cond) in HP. destruct HP as (n0 & Cn0 & Hn0).
    generalize (H n0 Cn0). filter_closed_under_intersection. auto.
Qed.

Lemma limitPZ_ge_0 (f : A -> Z) :
  limit A Z_filterType f <->
  (forall y, 0 <= y -> ultimately A (fun x => y <= f x)).
Proof.
  rewrite~ (@limitPZ_ultimately (fun x => 0 <= x)). reflexivity.
  apply ultimately_ge_Z.
Qed.

Lemma limit_le f g :
  limit A Z_filterType f ->
  (forall a, f a <= g a) ->
  limit A Z_filterType g.
Proof.
  rewrite !limitPZ.
  intros L I y. generalize (L y); filter_closed_under_intersection.
  intros. specializes I a. lia.
Qed.

Lemma limit_ultimately_le f g :
  limit A Z_filterType f ->
  ultimately A (fun a => f a <= g a) ->
  limit A Z_filterType g.
Proof.
  rewrite !limitPZ.
  intros L UI y. generalize (L y) UI; filter_closed_under_intersection.
  intros. lia.
Qed.

Lemma limit_sum f g :
  limit A Z_filterType f ->
  limit A Z_filterType g ->
  limit A Z_filterType (fun x => (f x) + (g x)).
Proof.
  rewrite !limitPZ_ge_0.
  intros LF LG y Y.
  generalize (LF y Y) (LG y Y); filter_closed_under_intersection.
  intros. lia.
Qed.

Lemma limit_sum_cst_l c f :
  limit A Z_filterType f ->
  limit A Z_filterType (fun x => c + (f x)).
Proof.
  rewrite !limitPZ.
  intros L y.
  generalize (L (y - c)); filter_closed_under_intersection.
  intros. lia.
Qed.

Lemma limit_sum_cst_r c f :
  limit A Z_filterType f ->
  limit A Z_filterType (fun x => (f x) + c).
Proof.
  rewrite !limitPZ.
  intros L y.
  generalize (L (y - c)); filter_closed_under_intersection.
  intros. lia.
Qed.

Lemma limit_sum_ultimately_ge_l lo f1 f2 :
  ultimately A (fun x => lo <= f1 x) ->
  limit A Z_filterType f2 ->
  limit A Z_filterType (fun x => f1 x + f2 x).
Proof.
  intros U L. rewrite limitPZ in *. intro y; specialize (L (y-lo)).
  revert U L; filter_closed_under_intersection. intros. lia.
Qed.

Lemma limit_sum_ultimately_ge_r lo f1 f2 :
  ultimately A (fun x => lo <= f2 x) ->
  limit A Z_filterType f1 ->
  limit A Z_filterType (fun x => f1 x + f2 x).
Proof.
  intros U L. rewrite limitPZ in *. intro y; specialize (L (y-lo)).
  revert U L; filter_closed_under_intersection. intros. lia.
Qed.

Lemma limit_mul f g :
  limit A Z_filterType f ->
  limit A Z_filterType g ->
  limit A Z_filterType (fun x => (f x) * (g x)).
Proof.
  rewrite !limitPZ_ge_0.
  intros LF LG y Y.
  generalize (LF y Y) (LG y Y); filter_closed_under_intersection.
  intros. assert (y * y <= f a * g a) by nia. nia.
Qed.

Lemma limit_mul_cst_l c f :
  0 < c ->
  limit A Z_filterType f ->
  limit A Z_filterType (fun x => c * (f x)).
Proof.
  rewrite !limitPZ_ge_0.
  intros C L y Y.
  generalize (L y Y); filter_closed_under_intersection.
  intros; nia.
Qed.

Lemma limit_mul_cst_r c f :
  0 < c ->
  limit A Z_filterType f ->
  limit A Z_filterType (fun x => (f x) * c).
Proof.
  intros. eapply limit_eq. applys~ limit_mul_cst_l c. eassumption.
  intros; lia.
Qed.

Lemma limit_max f g :
  limit A Z_filterType f ->
  limit A Z_filterType g ->
  limit A Z_filterType (fun x => Z.max (f x) (g x)).
Proof.
  intros LF LG. rewrite limitPZ in *.
  intros y. generalize (LF y) (LG y); filter_closed_under_intersection.
  intros. lia.
Qed.

End LimitToZ.

Lemma limit_product :
  forall (A B C : filterType) (f : A -> B) (g : A -> C),
  limit A B f ->
  limit A C g ->
  limit A (product_filterType B C) (fun i => (f i, g i)).
Proof.
  introv Lf Lg. rewrite limitP in *.
  simpl. intros Pp UPp. rewrite productP in UPp.
  destruct UPp as (P1 & P2 & UP1 & UP2 & HPp).
  specializes Lf UP1. specializes Lg UP2.
  revert Lf Lg; filter_closed_under_intersection.
  intros. apply HPp; tauto.
Qed.

Lemma limit_lift1 :
  forall (A B C : filterType) (f : A -> C),
  limit A C f ->
  limit (product_filterType A B) C (fun '(a, _) => f a).
Proof.
  introv L.
  rewrite limitP in *. introv U. rewrite productP.
  forwards~ UA: L U.
  eexists. eexists. splits.
  - apply UA.
  - apply filter_universe.
  - auto.
Qed.

Lemma limit_lift2 :
  forall (A B C : filterType) (f : B -> C),
  limit B C f ->
  limit (product_filterType A B) C (fun '(_, b) => f b).
Proof.
  introv L.
  rewrite limitP in *. introv U. rewrite productP.
  forwards~ UB: L U.
  eexists. eexists. splits.
  - apply filter_universe.
  - apply UB.
  - auto.
Qed.

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

Lemma Zshift_limit (x0 : Z) :
  limit Z_filterType Z_filterType (Zshift x0).
Proof.
  intros. rewrite limitP. introv H.
  rewrite ZP in H. destruct H as [x1 H1].
  rewrite ZP. exists (x1 - x0)%Z. intros. apply H1.
  unfold Zshift. lia.
Qed.

Lemma limit_liftl :
  forall (A1 A2 B : filterType) f,
  limit A1 B f ->
  limit (product_filterType A1 A2) (product_filterType B A2) (liftl f).
Proof.
  unfold limit, finer. introv Lf UP. simpl in *.
  rewrite productP in UP. destruct UP as (P1 & P2 & UP1 & UP2 & HP).
  rewrite imageP. rewrite productP. unfold liftl.
  specializes Lf UP1. rewrite imageP in Lf.
  do 2 eexists. splits~.
  exact Lf. exact UP2.
  simpl. intros. eauto.
Qed.

Lemma limit_liftr :
  forall (A1 A2 B : filterType) f,
  limit A2 B f ->
  limit (product_filterType A1 A2) (product_filterType A1 B) (liftr f).
Proof.
  unfold limit, finer. introv Lf UP. simpl in *.
  rewrite productP in UP. destruct UP as (P1 & P2 & UP1 & UP2 & HP).
  rewrite imageP. rewrite productP. unfold liftr.
  specializes Lf UP2. rewrite imageP in Lf.
  do 2 eexists. splits~.
  exact UP1. exact Lf.
  simpl. intros. eauto.
Qed.

Lemma limit_pow_l : forall p,
  0 < p ->
  limit Z_filterType Z_filterType (fun n => n ^ p).
Proof.
  introv Hp.
  rewrite limitP. intros P UP.
  rewrite ZP_ultimately with (cond := fun n => 1 <= n) in UP
    by (apply ultimately_ge_Z).
  destruct UP as (n0 & N0 & HP). rewrite ZP.
  exists n0. intros n N. apply HP.
  rewrite <-(Z.pow_1_r n0).
  apply Z.pow_le_mono; omega.
Qed.

Lemma limit_pow_r : forall p,
  0 < p ->
  limit Z_filterType Z_filterType (fun n => p ^ n).
Proof.
  introv Hp.
  rewrite limitP. intros P UP.
  rewrite ZP_ultimately with (cond := fun n => 1 <= n) in UP
    by (apply ultimately_ge_Z).
  destruct UP as (n0 & N0 & HP). rewrite ZP.
  exists n0. intros n N. apply HP.
  admit. (* TODO *)
Qed.

(* These variants combine [limit_comp] and [limit_pow_l]/[limit_pow_r]. This is
   useful in particular when added to an auto hint base. *)

Lemma limit_pow_l_comp :
  forall (A : filterType) f p,
  0 < p ->
  limit A Z_filterType f ->
  limit A Z_filterType (fun n => (f n) ^ p).
Proof.
  introv Hp L. apply limit_comp with (g := fun n => n ^ p).
  assumption. apply limit_pow_l. assumption.
Qed.

Lemma limit_pow_r_comp :
  forall (A : filterType) f p,
  0 < p ->
  limit A Z_filterType f ->
  limit A Z_filterType (fun n => p ^ (f n)).
Proof.
  introv Hp L. apply limit_comp with (g := fun n => p ^ n).
  assumption. apply limit_pow_r. assumption.
Qed.

Lemma limit_log2 :
  limit Z_filterType Z_filterType Z.log2.
Proof.
  introv L.
  rewrite ZP_ultimately with (cond := fun n => 1 <= n) in L
    by apply ultimately_ge_Z.
  destruct L as (n0 & N0 & HP).
  rewrite imageP. rewrite ZP. exists (2 ^ n0). intros n N.
  apply HP. rewrite <-Z.log2_le_mono; [| exact N].
  apply Z.log2_le_pow2; auto with zarith.
  forwards: pow_ge_1 2 n0; auto with zarith.
Qed.

(* Similarly, this lemma is mostly useful in combination with auto. *)

Lemma limit_log2_comp :
  forall (A : filterType) f,
  limit A Z_filterType f ->
  limit A Z_filterType (fun n => Z.log2 (f n)).
Proof.
  introv L. apply limit_comp. assumption. apply limit_log2.
Qed.

(******************************************************************************)
(* Exports lemmas in a [limit] hint base. *)

Hint Resolve limit_id : limit.
Hint Resolve limit_sum : limit.
Hint Resolve limit_sum_cst_l : limit.
Hint Resolve limit_sum_cst_r : limit.
Hint Resolve limit_mul : limit.
Hint Resolve limit_mul_cst_l : limit.
Hint Resolve limit_mul_cst_r : limit.
Hint Resolve limit_max : limit.
Hint Resolve Zshift_limit : limit.
Hint Resolve limit_liftl : limit.
Hint Resolve limit_liftr : limit.
Hint Resolve limit_pow_l_comp : limit.
Hint Resolve limit_pow_r_comp : limit.
Hint Resolve limit_log2_comp : limit.
Hint Extern 2 (limit (product_filterType _ _) _ (fun '(a, _) => @?f a)) =>
  apply limit_lift1 : limit.
Hint Extern 2 (limit (product_filterType _ _) _ (fun '(_, b) => @?f b)) =>
  apply limit_lift2 : limit.
(* FIXME? Required because [apply_nary] unfolds product_filterType *)
Hint Extern 2 (limit (FilterType _ (product_filterMixin _ _)) _ (fun '(a, _) => @?f a)) =>
  apply limit_lift1 : limit.
(* FIXME? Required because [apply_nary] unfolds product_filterType *)
Hint Extern 2 (limit (FilterType _ (product_filterMixin _ _)) _ (fun '(_, b) => @?f b)) =>
  apply limit_lift2 : limit.
Hint Extern 2 (limit _ (product_filterType _ _) (fun _ => (_, _))) =>
  apply limit_product : limit.

(* By default [auto] does not do anything if it cannot prove the goal
   completely. Here, if we would like it to still do progress even if it cannot
   solve the goal.

   Therefore this [Hint] should catch the leftover goals, and give them to the
   user.
*)
Hint Extern 999 (limit _ _ _) => shelve : limit_fallback.

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

Ltac limit :=
  unshelve (auto with zarith limit limit_fallback).

Ltac limit_trysolve :=
  auto with zarith limit.


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

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_decidable fin_base.

Set Implicit Arguments.

Theorem finite_t_find_dec X (P : X -> Prop)
           (Pdec : forall x, { P x } + { ~ P x })
           (HQ : finite_t X) :
           { x | P x } + { forall x, ~ P x }.
Proof.
  destruct HQ as (l & Hl).
  destruct list_choose_dep with (P := P) (Q := fun x => ~ P x) (l := l)
    as [ (? & ? & ?) | ]; eauto.
Qed.

Theorem exists_dec_fin_t X (P Q : X -> Prop)
           (Pdec : forall x, { P x } + { ~ P x })
           (HQ : fin_t Q)
           (HPQ : forall x, P x -> Q x) :
           { exists x, P x } + { ~ exists x, P x }.
Proof.
  generalize (fin_t_dec _ Pdec HQ); intros ([ | x l ] & Hl).
  + right; intros (x & Hx); apply (Hl x); split; auto.
  + left; exists x; apply Hl; simpl; auto.
Qed.

(* On discrete and finite types, one can weakly reify weak decidability
    into inhabited strong decidability. But I do not think this could be done with
    weak discreteness, weakly decidable equality *)

Definition list_weak_dec X (l : list X) (Q : X -> Prop) :
             (forall x y, In x l -> In y l -> { x = y } + { x <> y } )
          -> (forall x, In x l -> Q x \/ ~ Q x)
          -> inhabited (forall x, In x l -> { Q x } + { ~ Q x }).
Proof.
  induction l as [ | x l IHl ]; intros D H.
  1: { exists; intros _ []. }
  destruct IHl as [ f ].
  + intros; apply D; simpl; auto.
  + intros; apply H; simpl; auto.
  + destruct (H x) as [ Hx | Hx ]; simpl; auto.
    * exists; intros y Hy.
      destruct (D x y) as [ H1 | H1 ]; simpl; auto.
      - left; subst; auto.
      - apply f; destruct Hy; auto; tauto.
    * exists; intros y Hy.
      destruct (D x y) as [ H1 | H1 ]; simpl; auto.
      - right; subst; auto.
      - apply f; destruct Hy; auto; tauto.
Qed.

Fact fin_weak_dec X (P Q : X -> Prop) :
      (forall x y : X, P x -> P y -> { x = y } + { x <> y } )
   -> fin P
   -> (forall x, P x -> Q x \/ ~ Q x)
   -> inhabited (forall x, P x -> { Q x } + { ~ Q x }).
Proof.
  intros H1 (l & Hl) H2.
  destruct (list_weak_dec l Q) as [ f ].
  + intros; apply H1; apply Hl; auto.
  + intros; apply H2; apply Hl; auto.
  + exists; intros; apply f, Hl; auto.
Qed.

Fact finite_weak_dec X (P : X -> Prop) :
       finite X
    -> (forall x y : X, { x = y } + { x <> y })
    -> (forall x, P x \/ ~ P x)
    -> inhabited (forall x, { P x } + { ~ P x }).
Proof.
  intros H1 H2 H3.
  apply finite_fin_eq in H1.
  destruct fin_weak_dec with (Q := P) (2 := H1); auto.
Qed.


Load PropLogic.
From Coq Require Import Setoids.Setoid.

Reserved Notation "U |- A" (at level 80).
Inductive Nd: list Proposition -> Proposition -> Prop :=
| Assumption U A (H: In A U): U |- A
| NotE U P (H1: U |- ¬ ¬ P) : U |- P
| NotI U P Q (H1: P::U |- Q) (H2: P::U |- ¬ Q): U |- ¬ P
| AndE1 U A B (H: U |- (A ∧ B)): U |- A
| AndE2 U A B (H: U |- (A ∧ B)): U |- B
| AndI U A B (H1: U |- A) (H2: U |- B): U |- (A ∧ B)
| OrE U P Q R (H1: U |- P ∨ Q) (H2: P :: U |- R) (H3: Q :: U |- R): U |- R
| OrI1 U P Q (H1: U |- P): U |- P ∨ Q
| OrI2 U P Q (H1: U |- P): U |- Q ∨ P
| ImpE U P Q (H1: U |- P) (H2: U |- P → Q): U |- Q
| ImpI U P Q (H: (P :: U)%list |- Q): U |- P → Q
where "U |- A" := (Nd U A).

Theorem p_implies_p: forall U p,
  U |- p → p.
Proof.
  intros.
  apply ImpI.
  apply Assumption.
  simpl.
  left.
  reflexivity.
Qed.

Example example_1': forall p q,
  [¬ p; q]|- ¬(p ∧ q).
Proof.
  intros p q.
  apply (NotI _ _ p).
  - apply (AndE1 _ _ q). apply Assumption. simpl. left. reflexivity.
  - apply Assumption. simpl. right. left. reflexivity.
Qed.

Example example_2': forall fire smoke rain,
  [fire → smoke; rain → ¬ smoke] |- rain → ¬ fire.
Proof.
  intros fire smoke rain.
  apply ImpI.
  apply (NotI _ _ smoke).
  - apply (ImpE _ fire _).
    + apply Assumption. simpl. left. reflexivity.
    + apply Assumption. simpl. right. right. left. reflexivity.
  - apply (ImpE _ rain _).
    + apply Assumption. simpl. right. left. reflexivity.
    + apply Assumption. simpl. right. right. right. left. reflexivity.
Qed.

Theorem principle_of_explosion: forall U p q,
  [p ; ¬ p] ++ U |- q.
Proof.
  intros.
  apply NotE.
  apply (NotI _ _ p)
  ;apply Assumption
  ;simpl.
  - right. left. reflexivity.
  - right. right. left. reflexivity.
Qed.

Theorem law_of_excluded_middle: forall p,
  [] |- p ∨ ¬ p.
Proof.
  intros.
  apply NotE.
  apply (NotI _ _ ¬ p).
  - apply (NotI _ _ (p ∨ ¬ p)).
    + apply OrI1.
      apply Assumption.
      left.
      reflexivity.
    + apply Assumption. right. left. reflexivity.
  - apply (NotI _ _ (p ∨ ¬ p)).
    + apply OrI2.
      apply Assumption.
      left.
      reflexivity.
    + apply Assumption. right. left. reflexivity.
Qed.

Theorem double_not_introduction: forall p,
  [p] |- ¬ ¬ p.
Proof.
  intros p.
  apply (NotI _ _ p)
  ; apply Assumption
  ; simpl.
  - right. left. reflexivity.
  - left. reflexivity.
Qed.

Theorem contrapositve: forall p q,
  [p → q; ¬ q] |- ¬ p.
Proof.
  intros.
  apply (NotI _ _ q).
  - apply (ImpE _ p _)
    ; apply Assumption
    ; simpl.
    + left. reflexivity.
    + right. left. reflexivity.
  - apply Assumption.
    simpl.
    right. right. left.
    reflexivity.
Qed.

Theorem material_implication: forall p q,
  [¬ p ∨ q] |- p → q.
Proof.
  intros.
  apply ImpI.
  apply (OrE _ ¬ p q).
  - apply Assumption. simpl. right. left. reflexivity.
  - apply NotE.
    apply (NotI _ _ p)
    ;apply Assumption
    ;simpl.
    + right. right. left. reflexivity.
    + right. left. reflexivity.
  - apply Assumption. simpl. left. reflexivity.
Qed.

Theorem NaturalDeduction_is_sound: forall Γ P,
  Γ |- P -> Γ |= P.
Proof.
  intros.
  induction H.
  - unfold models.
    intros.
    unfold Satisfies in H0.
    apply H0 in H.
    apply H.
  - unfold models in IHNd.
    unfold models.
    intros.
    destruct (valuation v P) eqn:E.
    + reflexivity.
    + apply IHNd in H0.
      simpl in H0.
      rewrite E in H0.
      simpl in H0.
      discriminate.
  - unfold models in IHNd1.
    unfold models in IHNd2.
    unfold models.
    simpl in IHNd2.
    intros v.
    destruct (valuation v P) eqn:E.
    + intros. apply (satisfy_chain _ U _) in E.
      * apply IHNd1 in E as IHNd1'.
        apply IHNd2 in E as IHNd2'.
        rewrite IHNd1' in IHNd2'.
        discriminate.
      * apply H1.
    + intros.
      simpl.
      rewrite E.
      simpl.
      reflexivity.
  - unfold models in IHNd.
    unfold models.
    intros.
    apply IHNd in H0.
    simpl in H0.
    apply and_both_true in H0.
    destruct H0 as [H0 _].
    apply H0.
  - unfold models in IHNd.
    unfold models.
    intros.
    apply IHNd in H0.
    simpl in H0.
    apply and_both_true in H0.
    destruct H0 as [_ H0].
    apply H0.
  - unfold models in IHNd1.
    unfold models in IHNd2.
    unfold models.
    intros.
    apply IHNd1 in H1 as IHNd1'.
    apply IHNd2 in H1 as IHNd2'.
    simpl.
    rewrite IHNd1'.
    rewrite IHNd2'.
    reflexivity.
  - unfold models in IHNd1.
    unfold models in IHNd2.
    unfold models in IHNd3.
    unfold models.
    intros.
    apply IHNd1 in H2 as IHNd1'.
    simpl in IHNd1'.
    apply or_either_true in IHNd1'.
    destruct IHNd1' as [H3 | H3].
    + intros. apply (satisfy_chain _ U _) in H3.
      * apply IHNd2 in H3 as IHNd2'.
        apply IHNd2'.
      * apply H2.
    + intros. apply (satisfy_chain _ U _) in H3.
      * apply IHNd3 in H3 as IHNd3'.
        apply IHNd3'.
      * apply H2.
  - unfold models in IHNd.
    unfold models.
    intros.
    apply IHNd in H0.
    simpl.
    rewrite H0.
    simpl.
    reflexivity.
  - unfold models in IHNd.
    unfold models.
    intros.
    apply IHNd in H0.
    simpl.
    rewrite H0.
    destruct (valuation v Q);
    simpl; reflexivity.
  - unfold models in IHNd1.
    unfold models in IHNd2.
    unfold models.
    intros.
    apply IHNd1 in H1 as IHNd1'.
    apply IHNd2 in H1 as IHNd2'.
    simpl in IHNd2'.
    rewrite IHNd1' in IHNd2'.
    simpl in IHNd2'.
    apply IHNd2'.
  - unfold models in IHNd.
    unfold models.
    intros.
    simpl.
    destruct (valuation v P) eqn:E.
    + apply (satisfy_chain _ U _) in E.
      apply IHNd in E as IHNd'.
      rewrite IHNd'. simpl. reflexivity.
      apply H0.
    + simpl. reflexivity.
Qed.


Require Import Coq.micromega.Lia Coq.ZArith.ZArith.
Require Import bbv.NatLib.

Inductive BitWidth := BW32 | BW64.

Class BitWidths := bitwidth: BitWidth.

Section Widths.

  Context {B: BitWidths}.

  Definition wXLEN: nat :=
    match bitwidth with
    | BW32 => 32
    | BW64 => 64
    end.

  Definition log2wXLEN: nat :=
    match bitwidth with
    | BW32 => 5
    | BW64 => 6
    end.

  Definition wXLEN_in_bytes: nat :=
    match bitwidth with
    | BW32 => 4
    | BW64 => 8
    end.

  Lemma pow2_wXLEN_4: 4 < pow2 wXLEN.
  Proof.
    unfold wXLEN, bitwidth. destruct B;
      do 2 rewrite pow2_S;
      change 4 with (2 * (2 * 1)) at 1;
      (repeat apply mult_lt_compat_l; [ | repeat constructor ..]);
      apply one_lt_pow2.
  Qed.

End Widths.


Require Import ssreflect ssrfun ssrbool eqtype.
Require Import ssrnat seq choice.
Require Import order.

Section Def.
  Variable TK : totalOrderType.
  Variable TV : eqType.
  Inductive tree : Type :=
    | empty : tree
    | node2 of tree & TK * TV & tree
    | node3 of tree & TK * TV & tree & TK * TV & tree.

  Fixpoint eqn t0 t1 { struct t0 } :=
    match t0,t1 with
    | empty, empty => true
    | node2 t0s0 t0e0 t0s1, node2 t1s0 t1e0 t1s1 =>
      [&& eqn t0s0 t1s0, (t0e0 == t1e0) & eqn t0s1 t1s1]
    | node3 t0s0 t0e0 t0s1 t0e1 t0s2,
      node3 t1s0 t1e0 t1s1 t1e1 t1s2 =>
      [&& eqn t0s0 t1s0, (t0e0 == t1e0),
          eqn t0s1 t1s1, (t0e1 == t1e1) & eqn t0s2 t1s2]
    | _,_ => false
    end.

  Lemma eqnP : Equality.axiom eqn.
  Proof.
    move=> t0 t1; apply: (iffP idP)=> [|<- {t1}].
    - elim: t0 t1 => [|t0s0 Hs0 t0e0 t0s1 Hs1
                      |t0s0 Hs0 t0e0 t0s1 Hs1 t0e1 t0s2 Hs2].
      - by case.
      - by case=> // t1s0 t1e0 t1s1 /=
                  /and3P [/Hs0<- /eqP<- /Hs1<-].
      - by case=> // t1s0 t1e0 t1s1 t1e1 t1s2 /=
                  /and5P [/Hs0<- /eqP<- /Hs1<- /eqP<- /Hs2<-].
    - elim: t0 => /= [|t0s0 -> t0e0 t0s1 ->
                      |t0s0 -> t0e0 t0s1 -> t0e1 t0s2 ->].
      - done.
      - by rewrite eq_refl.
      - by rewrite eq_refl eq_refl.
  Qed.

  Canonical tree_eqMixin := EqMixin eqnP.
  Canonical tree_eqType := Eval hnf in EqType tree tree_eqMixin.

  Fixpoint tree_check_ordered(t:tree) (lb ub:option TK) : bool :=
    match t with
    | empty =>
      match lb,ub with
      | Some lbs, Some ubs => lbs < ubs
      | _, _ => true
      end
    | node2 t0 (k0,v0) t1 =>
      tree_check_ordered t0 lb (Some k0) &&
      tree_check_ordered t1 (Some k0) ub
    | node3 t0 (k0,v0) t1 (k1,v1) t2 =>
      [&& tree_check_ordered t0 lb (Some k0),
          tree_check_ordered t1 (Some k0) (Some k1) &
          tree_check_ordered t2 (Some k1) ub]
    end.

  Fixpoint tree_depth(t:tree) : nat :=
    match t with
    | empty => 0
    | node2 t0 _ t1 => (maxn (tree_depth t0) (tree_depth t1)) .+1
    | node3 t0 _ t1 _ t2 =>
      (maxn (tree_depth t0) (maxn (tree_depth t1) (tree_depth t2))) .+1
    end.

  Fixpoint tree_check_depth(t:tree) : bool :=
    match t with
    | empty => true
    | node2 t0 _ t1 =>
      [&& (tree_depth t0 == tree_depth t1),
          tree_check_depth t0 & nosimpl tree_check_depth t1]
    | node3 t0 _ t1 _ t2 =>
      [&& (tree_depth t0 == tree_depth t1), (tree_depth t1 == tree_depth t2),
          tree_check_depth t0, tree_check_depth t1 & tree_check_depth t2]
    end.

  Definition tree_valid(t:tree) : bool :=
    tree_check_ordered t None None && tree_check_depth t.

  Definition T23 := sig tree_valid.

  Definition tree_append(k:TK) (v:TV):tree -> bool*tree :=
    fix recur(t:tree) :=
    match t with
    | empty => (true, node2 empty (k,v) empty)
    | node2 t0 ((k0,_) as e0) t1 =>
      if k < k0 then
        match recur t0 with
        | (true, node2 s0 se0 s1) =>
          (false, node3 s0 se0 s1 e0 t1)
        | (_, s) => (false, node2 s e0 t1)
        end
      else if k == k0 then
        (false, node2 t0 (k,v) t1)
      else
        match recur t1 with
        | (true, node2 s0 se0 s1) =>
          (false, node3 t0 e0 s0 se0 s1)
        | (_, s) => (false, node2 t0 e0 s)
        end
    | node3 t0 ((k0,_) as e0) t1 ((k1,_) as e1) t2 =>
      if k < k0 then
        match recur t0 with
        | (true, s) =>
          (true, node2 s e0 (node2 t1 e1 t2))
        | (_, s) => (false, node3 s e0 t1 e1 t2)
        end
      else if k == k0 then
        (false, node3 t0 (k,v) t1 e1 t2)
      else if k < k1 then
        match recur t1 with
        | (true, node2 s0 se0 s1) =>
          (true, node2 (node2 t0 e0 s0) se0 (node2 s1 e1 t2))
        | (_, s) => (false, node3 t0 e0 s e1 t2)
        end
      else if k == k1 then
        (false, node3 t0 e0 t1 (k,v) t2)
      else
        match recur t2 with
        | (true, s) =>
          (true, node2 (node2 t0 e0 t1) e1 s)
        | (_, s) => (false, node3 t0 e0 t1 e1 s)
        end
    end.

  Lemma tree_append_preserve_depth(t:tree) (k:TK) (v:TV):
    let (r,t') := tree_append k v t in
    (tree_depth t' =
      if r then (tree_depth t) .+1 else tree_depth t) /\
    match r,t' with
    | false,_ => true
    | _,node2 _ _ _ => true
    | _,_ => false
    end.
  Proof.
    elim: t => [|t0 Ht0 [k0 v0] t1 Ht1
                |t0 Ht0 [k0 v0] t1 Ht1 [k1 v1] t2 Ht2] /=.
    - done.
    - case: (compare3P TK k k0) => Hk.
      - case: (tree_append k v t0) Ht0 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Ht0]] // _.
          by rewrite maxnA Ht0.
        - by move=> [<- _].
      - done.
      - case: (tree_append k v t1) Ht1 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Ht1]] // _.
          by rewrite Ht1.
        - by move=> [<- _].
    - case: (compare3P TK k k0) => Hk0;
          [| |case: (compare3P TK k k1) => Hk1].
      - case: (tree_append k v t0) Ht0 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Ht0]] // _.
          by rewrite maxnSS Ht0.
        - by move=> [<- _].
      - done.
      - case: (tree_append k v t1) Ht1 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Ht1]] // _.
          by rewrite maxnSS -maxnA (maxnA (tree_depth s0)) Ht1.
        - by move=> [<- _].
      - done.
      - case: (tree_append k v t2) Ht2 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Ht2]] // _.
          by rewrite maxnSS -maxnA Ht2.
        - by move=> [<- _].
  Qed.

  Lemma maxn_eq m : maxn m m = m.
  Proof.
    by unfold maxn; case (m < m)%N.
  Qed.

  Lemma tree_append_preserves_depth_validity(t:tree) (k:TK) (v:TV):
      tree_check_depth t -> tree_check_depth (tree_append k v t).2.
  Proof.
    elim: t => [|t0 Ht0 [k0 v0] t1 Ht1
                |t0 Ht0 [k0 v0] t1 Ht1 [k1 v1] t2 Ht2] /=.
    - done.
    - case: (compare3P TK k k0) => Hk.
      - case: (tree_append k v t0)
              (tree_append_preserve_depth t0 k v) Ht0 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Hpd]] // _ Ht0A Ht0B.
          move: Ht0B Hpd => /and3P [/eqP<- /Ht0A/and3P[/eqP<- -> ->] ->] <-.
          by rewrite maxn_eq eq_refl.
        - by move=> /= [-> _] Ht0 /and3P [-> /Ht0-> ->].
      - done.
      - case: (tree_append k v t1)
              (tree_append_preserve_depth t1 k v) Ht1 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Hpd]] // _ Ht1A Ht1B.
          move: Ht1B Hpd => /and3P [/eqP<- ->/Ht1A/and3P[/eqP<- -> ->]] <-.
          by rewrite maxn_eq eq_refl.
        - by move=> /= [-> _] Ht1 /and3P [-> -> /Ht1->].
    - case: (compare3P TK k k0) => Hk0;
          [| |case: (compare3P TK k k1) => Hk1].
      - case: (tree_append k v t0)
              (tree_append_preserve_depth t0 k v) Ht0 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Hpd]] // _ Ht0A Ht0B.
          move: Ht0B Hpd =>
              /and5P[/eqP-> /eqP<- /Ht0A/and3P[/eqP<- -> ->] -> ->] ->.
          by rewrite maxn_eq eq_refl eq_refl eq_refl.
        - by move=> /= [-> _] Ht0 /and5P[-> -> /Ht0-> -> ->].
      - done.
      - case: (tree_append k v t1)
              (tree_append_preserve_depth t1 k v) Ht1 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Hpd]] // _ Ht1A Ht1B.
          move: Ht1B Hpd =>
              /and5P[/eqP-> /eqP<- -> /Ht1A/and3P[/eqP<- -> ->] ->].
          rewrite maxn_eq=> <-.
          by rewrite eq_refl eq_refl.
        - by move=> /= [-> _] Ht1 /and5P[-> -> -> /Ht1-> ->].
      - done.
      - case: (tree_append k v t2)
              (tree_append_preserve_depth t2 k v) Ht2 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Hpd]] // _ Ht2A Ht2B.
          move: Ht2B Hpd =>
              /and5P[/eqP-> /eqP<- -> -> /Ht2A/and3P[/eqP<- -> ->]] ->.
          by rewrite maxn_eq eq_refl eq_refl eq_refl.
        - by move=> /= [-> _] Ht2 /and5P[-> -> -> -> /Ht2->].
  Qed.
  Lemma tree_append_preserves_order_validity(t:tree)
      (k:TK) (v:TV) (lb ub:option TK):
      (if lb is Some lbs then lbs < k else true) ->
      (if ub is Some ubs then k < ubs else true) ->
      tree_check_ordered t lb ub -> tree_check_ordered (tree_append k v t).2 lb ub.
  Proof.
    elim: t lb ub => [|t0 Ht0 [k0 v0] t1 Ht1
                |t0 Ht0 [k0 v0] t1 Ht1 [k1 v1] t2 Ht2] /=.
    - by move=> lb ub -> -> _.
    - case: (compare3P TK k k0) => Hk.
      - case: (tree_append k v t0) Ht0
            => [[|] [|s0 [sk0 sv0] s1|s [sk0 sv0] s1 [sk1 sv1] s2]]
               /= Ht0A lb ub Hlb Hub /andP[Ht0B ->];
          try by rewrite (Ht0A lb (Some k0) Hlb Hk Ht0B).
        by rewrite Bool.andb_true_r Ht0A.
      - by move: Hk => /eqP<-.
      - by case: (tree_append k v t1) Ht1
               => [[|] [|s0 [sk0 sv0] s1|s [sk0 sv0] s1 [sk1 sv1] s2]]
                  /= Ht1A lb ub Hlb Hub /andP[-> Ht1B];
           rewrite (Ht1A _ _ _ Hub Ht1B).
    - case: (compare3P TK k k0) => Hk0;
          [| |case: (compare3P TK k k1) => Hk1].
      - by case: (tree_append k v t0) Ht0
               => [[|] [|s0 se0 s1|s se0 s1 se1 s2]]
                  /= Ht0A lb ub Hlb Hub /and3P[Ht0B -> ->];
           rewrite (Ht0A _ _ Hlb _ Ht0B).
      - by move: Hk0 => /eqP<-.
      - case: (tree_append k v t1) Ht1
            => [[|] [|s0 [sk0 sv0] s1|s [sk0 sv0] s1 [sk1 sv1] s2]]
                     /= Ht1A lb ub Hlb Hub /and3P[-> Ht1B ->];
          try by move: (Ht1A (Some k0) (Some k1) Hk0 Hk1 Ht1B)=> /andP [-> ->].
        - by rewrite (lt_trans _ _ _ _ Hk0 Hk1).
        - by rewrite (lt_trans _ _ _ _ Hk0 Hk1).
      - by move: Hk1 => /eqP<-.
      - by case: (tree_append k v t2) Ht2
               => [[|] [|s0 se0 s1|s se0 s1 se1 s2]]
                  /= Ht2A lb ub Hlb Hub /and3P[-> -> Ht2B];
           rewrite (Ht2A _ _ _ Hub Ht2B).
  Qed.

  Lemma tree_append_preserves_validity(t:tree) (k:TK) (v:TV):
      tree_valid t -> tree_valid (tree_append k v t).2.
  Proof.
    move=> /andP[valid_order valid_depth].
    by rewrite /tree_valid
        (tree_append_preserves_order_validity t k v None None isT isT valid_order)
        (tree_append_preserves_depth_validity t k v valid_depth).
  Qed.

  Definition append(t:T23) (k:TK) (v:TV):T23 :=
      exist _ (tree_append k v (proj1_sig t)).2
      (tree_append_preserves_validity (proj1_sig t) k v (proj2_sig t)).
End Def.


(* isomorphism.v *)

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

Require Import Arith.

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

(* Tao's representation: *)

Inductive int : Type :=
| Int : nat -> nat -> int.

Notation "a -- b" := (Int a b) (at level 70, no associativity).

(* Signed integer representation: *)

Inductive sint : Type :=
| P : nat -> sint
| Z : sint
| N : nat -> sint.

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

(* Tao's integer equality: *)

Definition int_eq (x y : int) : Prop :=
  match x, y with
  | (a -- b), (c -- d) =>
    a + d = c + b
  end.

Definition int_eqb (x y : int) : bool :=
  match x, y with
  | (a -- b), (c -- d) =>
    a + d =? c + b
  end.

Definition test_int_of_sint (int_of_sint : sint -> int) : bool :=
  (int_eqb (int_of_sint Z) (0 -- 0))
    && (int_eqb (int_of_sint Z) (3 -- 3))
    && (int_eqb (int_of_sint Z) (9 -- 9))
    && (int_eqb (int_of_sint (P 0)) (1 -- 0))
    && (int_eqb (int_of_sint (P 15)) (16 -- 0))
    && (int_eqb (int_of_sint (P 4)) (7 -- 2))
    && (int_eqb (int_of_sint (P 7)) (20 -- 12))
    && (int_eqb (int_of_sint (N 0)) (0 -- 1))
    && (int_eqb (int_of_sint (N 6)) (0 -- 7))
    && (int_eqb (int_of_sint (N 9)) (6 -- 16))
    && (int_eqb (int_of_sint (N 13)) (14 -- 28)).

Definition int_of_sint (x : sint) :=
  match x with
  | P px =>
    (px + 1 -- 0)
  | Z => (0 -- 0)
  | N nx =>
    (0 -- nx + 1)
  end.

Compute (test_int_of_sint int_of_sint).

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

(* Signed integer equality: *)

Definition sint_eq (i1 i2 : sint) : Prop :=
  match i1 with
  | P n1 =>
    match i2 with
    | P n2 =>
      n1 = n2
    | Z =>
      False
    | N n2 =>
      False
    end
  | Z =>
    match i2 with
    | P n2 =>
      False
    | Z =>
      True
    | N n2 =>
      False
    end
  | N n1 =>
    match i2 with
    | P n2 =>
      False
    | Z =>
      False
    | N n2 =>
      n1 = n2
    end
  end.

Definition sint_eqb (i1 i2 : sint) : bool :=
  match i1 with
  | P n1 =>
    match i2 with
    | P n2 =>
      n1 =? n2
    | Z =>
      false
    | N n2 =>
      false
    end
  | Z =>
    match i2 with
    | P n2 =>
      false
    | Z =>
      true
    | N n2 =>
      false
    end
  | N n1 =>
    match i2 with
    | P n2 =>
      false
    | Z =>
      false
    | N n2 =>
      n1 =? n2
    end
  end.

Definition test_sint_of_int (sint_of_int : int -> sint) : bool :=
  (sint_eqb (sint_of_int (0 -- 0)) Z)
    && (sint_eqb (sint_of_int (7 -- 7)) Z)
    && (sint_eqb (sint_of_int (9 -- 8)) (P 0))
    && (sint_eqb (sint_of_int (8 -- 9)) (N 0))
    && (sint_eqb (sint_of_int (13 -- 2)) (P 10))
    && (sint_eqb (sint_of_int (9 -- 15)) (N 5)).

Definition sint_of_int (x : int) :=
  match x with
  | (a -- b) =>
    if a =? b
    then Z
    else if a <? b
         then N (b - a - 1)
         else P (a - b - 1)
  end.

Compute (test_sint_of_int sint_of_int).

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

Proposition int_of_sint_and_back :
  forall x : sint,
    sint_eq x (sint_of_int (int_of_sint x)).
Proof.
  intros [px |  | nx];
    unfold int_of_sint, sint_of_int, sint_eq.
  - Search (0 < S _).
    assert (H_lt := Nat.lt_0_succ px).
    case (px + 1 =? 0) as [ | ] eqn:H_eqb.
    + assert (H_eq := beq_nat_true (px + 1) 0 H_eqb).
      rewrite -> Nat.add_1_r in H_eq.
      Search (_ < _ -> _ <> _).
      contradiction (lt_0_neq (S px) H_lt (eq_sym H_eq)).
    + case (px + 1 <? 0) as [ | ] eqn:H_ltb.
      -- Search (_ < _ -> _).
         assert (H_nlt := Nat.lt_asymm 0 (S px) H_lt).
         unfold not in H_nlt.
         destruct (Nat.ltb_lt (px + 1) 0) as [H_ltb_lt _].
         assert (H_lt_absurd := H_ltb_lt H_ltb);
           clear H_ltb_lt.
         rewrite -> Nat.add_1_r in H_lt_absurd.
         contradiction (H_nlt H_lt_absurd).
      -- Search (_ - 0).
         rewrite -> Nat.sub_0_r.
         Search (_ + _ - _).
         rewrite -> Nat.add_sub.
         reflexivity.
  - Search (Nat.eqb).
    rewrite -> (Nat.eqb_refl 0).
    exact I.
  - Search (0 < S _).
    assert (H_lt := Nat.lt_0_succ nx).
    case (0 =? nx + 1) as [ | ] eqn:H_eqb.
    + assert (H_eq := beq_nat_true 0 (nx + 1) H_eqb).
      rewrite -> Nat.add_1_r in H_eq.
      contradiction (lt_0_neq (S nx) H_lt H_eq).
    + case (0 <? nx + 1) as [ | ] eqn:H_ltb.
      -- rewrite -> Nat.sub_0_r.
         rewrite -> Nat.add_sub.
         reflexivity.
      -- Search (_ <? _).
         destruct (Nat.ltb_nlt 0 (nx + 1)) as [H_ltb_nlt _].
         assert (H_nlt := H_ltb_nlt H_ltb);
           clear H_ltb_nlt.
         rewrite -> Nat.add_1_r in H_nlt.
         unfold not in H_nlt.
         contradiction (H_nlt H_lt).
Qed.

Proposition sint_of_int_and_back :
  forall x : int,
    int_eq x (int_of_sint (sint_of_int x)).
Proof.
  intros [a b].
  unfold sint_of_int.
  case (a =? b) as [ | ] eqn:H_eqb;
    unfold int_of_sint, int_eq.
  - rewrite -> Nat.add_0_r.
    rewrite -> Nat.add_0_l.
    exact (beq_nat_true a b H_eqb).
  - case (a <? b) as [ | ] eqn:H_ltb.
    + destruct (Nat.ltb_lt a b) as [H_ltb_lt _].
      assert (H_lt := H_ltb_lt H_ltb);
        clear H_ltb_lt; clear H_ltb.
      Search (_ - _ + _).
      Check (Nat.sub_add 1 (b - a)).
      Search (_ < _ - _).
      destruct (Nat.lt_add_lt_sub_r 0 b a) as [H_lt_add_sub _].
      rewrite <- (Nat.add_0_l a) in H_lt.
      assert (H_lt_sub := H_lt_add_sub H_lt);
        clear H_lt_add_sub.
      Search (_ < _ -> _ <= _).
      assert (H_le_S := lt_le_S 0 (b - a) H_lt_sub).
      rewrite -> (Nat.sub_add 1 (b - a) H_le_S).
      Search (_ + _ - _).
      rewrite -> Nat.add_0_l in H_lt.
      rewrite -> (Nat.add_sub_assoc
                    a b a (Nat.lt_le_incl a b H_lt)).
      rewrite -> minus_plus.
      rewrite -> Nat.add_0_l.
      reflexivity.
    + destruct (Nat.ltb_ge a b) as [H_ltb_ge _].
      assert (H_ge := H_ltb_ge H_ltb);
        clear H_ltb_ge.
      assert (H_neq := beq_nat_false a b H_eqb).
      Search ( _ <= _ /\ _ <> _).
      destruct (Nat.le_neq b a) as [_ H_le_neq].
      assert (H_gt := H_le_neq (conj H_ge (Nat.neq_sym a b H_neq)));
        clear H_le_neq.
      destruct (Nat.lt_add_lt_sub_r 0 a b) as [H_lt_add_sub _].
      rewrite <- Nat.add_0_l in H_gt at 1.
      assert (H_gt_sub := H_lt_add_sub H_gt);
        clear H_lt_add_sub.
      assert (H_ge_S := lt_le_S 0 (a - b) H_gt_sub);
        clear H_gt_sub.
      rewrite -> (Nat.sub_add 1 (a - b) H_ge_S).
      rewrite -> Nat.add_0_l in H_gt.
      rewrite -> (Nat.sub_add b a H_ge).
      rewrite -> Nat.add_0_r.
      reflexivity.
Qed.

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

(* end of isomorphism.v *)


Require Import HoTT.
Require Import HoTT.Basics.PathGroupoids.

Theorem fibers_equiv : forall (X : Type) (E : X -> Type) (x y : X)
                              (f : x = y), E(x) <~> E(y).
Proof.
  intros.
  split with (equiv_fun:=(transport E f)).
  simple refine (BuildIsEquiv _ _ _ (transport E (f^)) _ _ _).
  intro. induction f. simpl. reflexivity.
  intro. induction f. simpl. reflexivity.
  intro. simpl. induction f. simpl. reflexivity.
Qed.

Theorem equiv_fibers : forall (X : Type) (E1 E2 : X -> Type),
    ((sig E1) <~> (sig E2)) -> forall x, E1(x) <~> E2(x).
Proof.
  intros X E1 E2 h. intro x.


(*|
A few things to keep in mind as you work through pset 1
=======================================================
|*)

Require Import Frap.

(*|
Coq resources
-------------

- Start by looking for examples in the course textbook, including the tactic appendix at the end of the book.

- For help on standard Coq tactics, consult Coq's reference manual (https://coq.inria.fr/distrib/current/refman/), starting from the indices at https://coq.inria.fr/distrib/current/refman/appendix/indexes/index.html.  The manual can be overwhelming, so it's best used for looking up fine details.

Useful commands
---------------

Coq comes with many predefined types, functions, and theorems (“objects”).  The most important commands to help you discover them are `Check`, `About`, `Print`, `Search`, and `Compute`.  Try the following examples:

`Check` gives the type of any term, even with holes:
|*)

Check (1 + _).
Check (fun b => match b with true => 0 | false => 1 end).

(*|
`About` gives general information about an object:
|*)

About bool.
About nat.

(*|
`Print` displays the definition of an object:
|*)

Print bool.
Print Nat.add.

(*|
`Search` finds objects.  Its syntax is very flexible:
|*)

(* Find functions of type [nat -> nat -> bool]. *)
Search (nat -> nat -> bool).
(* Find theorems about "+". *)
Search "+".
(* Find theorems whose statement mentions S and eq. *)
Search eq S.
(* Search for a lemma proving the symmetry of eq. *)
Search (?x = ?y -> ?y = ?x).

(*|
If you are puzzled by a notation, the `Locate` command can help:
|*)

Locate "*".

(*|
To evaluate an expression, use `Compute`:
|*)

Compute (2 * 3, 4 + 4, 0 - 2 + 2, pred (S (S (S 0)))).

(*|
Syntax recap
------------

To define a function inline, use `fun`:
|*)

Check (fun x => x + 1).
Check (fun x: bool => xorb x x).

(*|
To perform a case analysis on a value, use `match`:
|*)

Check (fun b (x y: nat) =>
         match b with
         | true => x
         | false => y
         end).

Check (fun (n: nat) =>
         match n with
         | 0 => 1
         | S n => n
         end).

(*|
In Coq, `if` is just short for `match`:
|*)

Check (fun (b: bool) (x y: nat) =>
         if b then x else y).

(*|
To define a global object, use `Definition` or `Lemma` (`Theorem` is an alias of `Lemma`):
|*)

Definition choose (b: bool) (x y: nat) :=
  if b then x else y.

Compute (choose true 6 822).

Lemma plus_commutes :
  forall x, x = x + 0 + 0.
Proof.
  intros.
  Search (_ + 0).
  rewrite <- plus_n_O.
  rewrite <- plus_n_O.
  equality.
Qed.

(*|
Recursive functions use the keyword `Fixpoint`:
|*)

Fixpoint do_n_times (ntimes: nat) (step: nat -> nat) (start_from: nat) :=
  match ntimes with
  | 0 => start_from
  | S ntimes' => step (do_n_times ntimes' step start_from)
  end.

Compute (6, do_n_times 12 (fun x => x + 65) 42).

(*|
You can use bullets or braces to structure your proofs:
|*)

Lemma both_zero:
  forall x y z: nat, x + y + z = 0 -> x = 0 /\ y = 0 /\ z = 0.
Proof.
  intros x.
  cases x.
  - intros.
    cases y.
    + propositional.
    + simplify.
      invert H.
  - intros y z Heq.
    simplify.
    invert Heq.
Qed.

(*|
A few gotchas
-------------

Natural numbers saturate at 0:
|*)

Compute (3 - 5 + 3).

(*|
The order in which you perform induction on variables matters: if `x` comes before `y` and you induct on `y`, your induction hypothesis will not be general enough.
|*)

Lemma add_comm:
  forall x y: nat, x + y = y + x.
Proof.
  induct y.
  - induct x; simplify; equality.
  - simplify.
    (* `IHy` is valid only for one specific `y` *)
Abort.

Lemma add_comm:
  forall x y: nat, x + y = y + x.
Proof.
  induct x.
  - induct y; simplify; equality.
  - simplify.
    (* `IHx` starts with `forall y`. *)
Abort.

(*|
Here's an example where this subtlety matters:
|*)

Fixpoint factorial (n: nat) :=
  match n with
  | O => 1
  | S n' => n * factorial n'
  end.

Fixpoint factorial_acc (n: nat) (acc: nat) :=
  match n with
  | O => acc
  | S n' => factorial_acc n' (n * acc)
  end.

(*|
First attempt, but our lemma is too weak.
|*)

Lemma factorial_acc_correct:
  forall n, factorial n = factorial_acc n 1.
Proof.
  induct n.
  - equality.
  - simplify.
    Search (_ * 1).
    rewrite Nat.mul_1_r.

(*|
Stuck!  We have no way to simplify `factorial_acc n (S n)`.
|*)

Abort.

(*|
Second attempt: a generalized lemma, but we put the `acc` first, so induction will not generalize it.
|*)

Lemma factorial_acc_correct:
  forall acc n, factorial n * acc = factorial_acc n acc.
Proof.
  induct n.
  - simplify.
    Search (_ + 0).
    rewrite Nat.add_0_r.
    equality.
  - simplify.
    Fail rewrite <- IHn.

(*|
Stuck!  IHn is too weak.
|*)

Abort.

(*|
Third time's the charm!  Note how we ordered `n` and `acc`.
|*)

Lemma factorial_acc_correct:
  forall n acc, factorial n * acc = factorial_acc n acc.
Proof.
  induct n.
  - simplify.
    linear_arithmetic.
  - simplify.

(*|
IHn is strong enough now!
|*)

    rewrite <- IHn.
    linear_arithmetic.
Qed.


(*########################################################*)
(*#-------3 Main Properties and other related terms------#*)
(*########################################################*)

Require Export Definitions.

Set Implicit Arguments.

Section Properties.

Section competitiveness.

Definition bcompetitive (b b':order):= (Nat.ltb (oprice b') (oprice b)) ||
((Nat.eqb (oprice b') (oprice b)) && (Nat.leb (otime b) (otime b') )).

Definition acompetitive (a a':order):= (Nat.ltb (oprice a) (oprice a')) ||
((Nat.eqb (oprice a) (oprice a')) && (Nat.leb (otime a) (otime a') )).

Definition eqcompetitive (a a':order):= ((Nat.eqb (oprice a) (oprice a')) && (Nat.eqb (otime a) (otime a') )).

Lemma bcompetitive_contadiction (b b':order):
bcompetitive b b'-> bcompetitive b' b -> ~eqcompetitive b b' -> False.
Proof. unfold bcompetitive.  unfold eqcompetitive. intros.
       move /orP in H. move /orP in H0. destruct H0; destruct H.
       {  move /ltP in H. move /ltP in H0. lia. }
       {  destruct H1. move /andP in H. destruct H.
          apply /andP. move /eqP in H.  split. apply /eqP.
          auto. move /ltP in H0. move /leP in H1. lia. }
       {  destruct H1. move /andP in H0. destruct H0.
          apply /andP. move /eqP in H0.  split. apply /eqP.
          auto. move /ltP in H. move /leP in H1. lia. }
       {  destruct H1. move /andP in H0. destruct H0.
          move /andP in H. destruct H. apply /andP. split.
          auto. move /leP in H1. move /leP in H2. apply /eqP. lia. } Qed.

Lemma acompetitive_contadiction (a a':order):
acompetitive a a'-> acompetitive a' a -> ~eqcompetitive a a' -> False.
Proof. unfold acompetitive.  unfold eqcompetitive. intros.
       move /orP in H. move /orP in H0. destruct H0; destruct H.
       {  move /ltP in H. move /ltP in H0. lia. }
       {  destruct H1. move /andP in H. destruct H.
          apply /andP. move /eqP in H.  split. apply /eqP.
          auto. move /ltP in H0. move /leP in H1. lia. }
       {  destruct H1. move /andP in H0. destruct H0.
          apply /andP. move /eqP in H0.  split. apply /eqP.
          auto. move /ltP in H. move /leP in H1. lia. }
       {  destruct H1. move /andP in H0. destruct H0.
          move /andP in H. destruct H. apply /andP. split.
          auto. move /leP in H1. move /leP in H2. apply /eqP. lia. } Qed.

Lemma bcompetitive_P : transitive bcompetitive /\ comparable2 bcompetitive.
Proof.  { split.
          { unfold transitive. unfold bcompetitive.
            intros y x z H H1. move /orP in H1. move /orP in H.
            apply /orP. destruct H1;destruct H.
            { left. move /leP in H0. move /leP in H. apply /leP. lia. }
            { move /andP in H. destruct H. left.
              move /leP in H0. move /eqP in H. apply /leP. lia. }
            { move /andP in H0. destruct H0. left.
              move /leP in H. move /eqP in H0. apply /leP. lia. }
            { move /andP in H0. move /andP in H. destruct H0. destruct H.
              right.
              move /eqP in H. move /eqP in H0. apply /andP.
              split. apply /eqP. lia. apply /leP. move /leP in H1.
              move /leP in H2. lia. } }
            { unfold comparable2.
              unfold bcompetitive. intros. destruct x. destruct y.  simpl.
              assert((oprice0 = oprice)\/(oprice0 < oprice)\/(oprice < oprice0)).
              lia. destruct H.
              subst. assert(Nat.ltb oprice oprice = false).
              apply /ltP. lia. rewrite H. simpl.
              assert(Nat.eqb oprice oprice =true). auto. rewrite H0. simpl.
              assert((otime0 <= otime)\/(otime < otime0)). lia. destruct H1.
              right. apply /leP. auto. left. apply /leP. lia.
              destruct H. left. apply /orP. left. apply /ltP. auto. right.
              apply /orP. left. apply /ltP. auto.
               } } Qed.

Lemma acompetitive_P : transitive acompetitive /\ comparable2 acompetitive.
Proof.  { split.
          { unfold transitive. unfold acompetitive.
            intros y x z H H1. move /orP in H1. move /orP in H.
            apply /orP. destruct H1;destruct H.
            { left. move /leP in H0. move /leP in H. apply /leP. lia. }
            { move /andP in H. destruct H. left.
              move /leP in H0. move /eqP in H. apply /leP. lia. }
            { move /andP in H0. destruct H0. left.
              move /leP in H. move /eqP in H0. apply /leP. lia. }
            { move /andP in H0. move /andP in H. destruct H0. destruct H.
              right.
              move /eqP in H. move /eqP in H0. apply /andP.
              split. apply /eqP. lia. apply /leP. move /leP in H1.
              move /leP in H2. lia. } }
            { unfold comparable2.
              unfold acompetitive. intros. destruct x. destruct y.  simpl.
              assert((oprice0 = oprice)\/(oprice < oprice0)\/(oprice0 < oprice)).
              lia. destruct H.
              subst. assert(Nat.ltb oprice oprice = false).
              apply /ltP. lia. rewrite H. simpl.
              assert(Nat.eqb oprice oprice =true). auto. rewrite H0. simpl.
              assert((otime0 <= otime)\/(otime < otime0)). lia. destruct H1.
              right. apply /leP. auto. left. apply /leP. lia.
              destruct H. left. apply /orP. left. apply /ltP. auto. right.
              apply /orP. left. apply /ltP. auto.
               } } Qed.

Lemma not_acompetitive (a1 a2:order): ~acompetitive a1 a2 -> acompetitive a2 a1.
Proof. unfold acompetitive. intros H. unfold not in H. apply /orP.
       destruct(Nat.ltb (oprice a1) (oprice a2)) eqn:H1.
       { simpl in H. destruct H. auto. }
       { simpl in H.  destruct(Nat.eqb (oprice a1) (oprice a2)) eqn: H2.
          { simpl in H. destruct (Nat.leb (otime a1) (otime a2)) eqn: H3.
           destruct H. auto. right. apply /andP. split. move /eqP in H2.
           rewrite H2. apply /eqP. auto. move /leP in H3. apply /leP. lia. }
          { simpl in H. destruct (Nat.leb (otime a1) (otime a2)) eqn: H3.
            move /ltP in H1. move /eqP in H2. left. apply /ltP. lia.
            move /ltP in H1. move /eqP in H2. move /leP in H3.
            left. apply /ltP. lia.
           }
         }
         Qed.

Lemma not_bcompetitive (b1 b2:order): ~bcompetitive b1 b2 -> bcompetitive b2 b1.
Proof. unfold bcompetitive. intros H. unfold not in H. apply /orP.
       destruct(Nat.ltb (oprice b2) (oprice b1)) eqn:H1.
       { simpl in H. destruct H. auto. }
       { simpl in H.  destruct(Nat.eqb (oprice b2) (oprice b1)) eqn: H2.
          { simpl in H. destruct (Nat.leb (otime b1) (otime b2)) eqn: H3.
           destruct H. auto. right. apply /andP. split. move /eqP in H2.
           rewrite H2. apply /eqP. auto. move /leP in H3. apply /leP. lia. }
          { destruct (Nat.leb (otime b1) (otime b2)) eqn: H3.
            move /ltP in H1. move /eqP in H2. left. apply /ltP. lia.
            move /ltP in H1. move /eqP in H2. move /leP in H3.
            left. apply /ltP. lia.
           }
         }
         Qed.

End competitiveness.

Notation "s === t" := (perm s t) (at level 80, no associativity).

Inductive command:Set:=
|buy
|sell
|del.

Record instruction :Type:= Mk_instruction { cmd : command; ord : order}.
Definition action0:=del.
Definition tau0:={| cmd := action0; ord := w0 |}.

Definition Absorb (B A: list order)(tau: instruction):=
match (cmd tau) with
|buy => ((ord tau)::B, A)
|sell =>(B, (ord tau)::A)
|del =>(delete_order B (id (ord tau)), delete_order A (id (ord tau)))
end.

Lemma Absorb_perm (B1 B2 A1 A2 : list order)(tau: instruction):
perm B1 B2 -> perm A1 A2 ->
perm (fst (Absorb B1 A1 tau)) (fst (Absorb B2 A2 tau))/\
perm (snd (Absorb B1 A1 tau)) (snd (Absorb B2 A2 tau)).
Proof. case (cmd tau) eqn:H. unfold Absorb. replace (cmd tau) with buy. simpl. eauto.
unfold Absorb. replace (cmd tau) with sell. simpl. eauto.
unfold Absorb. replace (cmd tau) with del. simpl. intros. split.
apply delete_order_perm. auto. apply delete_order_perm. auto. Qed.

Lemma Absorb_notIn_nodup_id (B A: list order)(tau: instruction):
NoDup (ids B) ->NoDup (ids A) -> ~In (id (ord tau)) (ids B) -> ~In (id (ord tau)) (ids A) ->
NoDup (ids (fst (Absorb B A tau)))/\NoDup (ids (snd (Absorb B A tau))).
Proof. intros. case (cmd tau) eqn:Ht.
split. unfold Absorb. replace (cmd tau) with buy. simpl. eauto.
unfold Absorb. replace (cmd tau) with buy. simpl. eauto.
unfold Absorb. replace (cmd tau) with sell. simpl. eauto.
unfold Absorb. replace (cmd tau) with del. simpl. split.
apply delete_order_ids_nodup. auto. apply delete_order_ids_nodup. auto.
Qed.

Lemma Absorb_del_nodup_id (B A: list order)(tau: instruction):
NoDup (ids B) ->NoDup (ids A) -> (cmd tau ) = del ->
NoDup (ids (fst (Absorb B A tau)))/\NoDup (ids (snd (Absorb B A tau))).
Proof. intros. unfold Absorb. rewrite H1. simpl. split. apply delete_order_ids_nodup. auto. apply delete_order_ids_nodup. auto. Qed.

Lemma Absorb_notIn_nodup_time (B A: list order)(tau: instruction):
NoDup (timesof B) ->NoDup (timesof A) -> ~In (otime (ord tau)) (timesof B) ->
~In (otime (ord tau)) (timesof A) ->
NoDup (timesof (fst (Absorb B A tau)))/\NoDup (timesof (snd (Absorb B A tau))).
Proof. intros. case (cmd tau) eqn:Ht.
unfold Absorb. replace (cmd tau) with buy. simpl. eauto.
unfold Absorb. replace (cmd tau) with sell. simpl. eauto.
unfold Absorb. replace (cmd tau) with del. simpl.
split. apply delete_order_timesof_nodup. auto. apply delete_order_timesof_nodup. auto.
Qed.

Definition Condition1 (M: list transaction)(B A hat_B hat_A: list order)
(tau: instruction):Prop:=
not (matchable hat_B hat_A).

Definition Condition2a (M: list transaction)(B:list order):Prop:=
forall b b', (In b B)/\(In b' B)/\(bcompetitive b b'/\~eqcompetitive b b')/\(In (id b') (ids_bid_aux M)) ->
(Qty_bid M (id b)) = (oquantity b).

Definition Condition2b (M: list transaction)(A:list order):Prop:=
forall a a', (In a A)/\(In a' A)/\(acompetitive a a'/\~eqcompetitive a a')/\(In (id a') (ids_ask_aux M)) ->
(Qty_ask M (id a)) = (oquantity a).

Definition Condition3a (M: list transaction)(B A: list order)
(tau: instruction):Prop:=
let B' := (fst (Absorb B A tau)) in
let A' := (snd (Absorb B A tau)) in
Matching M B' A'.

Definition Condition3b (M: list transaction)(B A hat_B: list order)
(tau: instruction):Prop:=
let B' := (fst (Absorb B A tau)) in
hat_B === (odiff B' (bids M B')).

Definition Condition3c (M: list transaction)(B A hat_A: list order)
(tau: instruction):Prop:=
let A' := (snd (Absorb B A tau)) in
(hat_A === (odiff A' (asks M A'))).

Definition admissible (B A :list order) :=
(NoDup (ids B))/\(NoDup (ids A))/\
(NoDup (timesof B))/\(NoDup (timesof A)).

Definition Legal_input (B A :list order)(tau: instruction):=
admissible (fst (Absorb B A tau)) (snd (Absorb B A tau))/\
not (matchable B A).

Lemma legal_perm (B1 B2 A1 A2 : list order)(tau: instruction):
perm B1 B2/\ perm A1 A2/\Legal_input B1 A1 tau -> Legal_input B2 A2 tau.
Proof. unfold Legal_input. intros H. destruct H. destruct H0.
destruct H1 as [Hb Ha]. unfold admissible in Hb.
destruct Hb as [Hb Hc]. destruct Hc as [Hc Hd].  destruct Hd as [Hd He].
assert(G1:=H). assert(G2:=H0).
unfold perm in G1. move /andP in G1. destruct G1 as [G1a G1b].
unfold perm in G2. move /andP in G2. destruct G2 as [G2a G2b].
apply Absorb_perm with (B1:=B1)(B2:=B2)(tau:=tau) in H0.
destruct H0. repeat split.
apply ids_perm in H0. eauto.
apply ids_perm in H1. eauto.
apply timesof_perm in H0. eauto.
apply timesof_perm in H1. eauto.
intro. destruct Ha.
unfold matchable in H2. destruct H2. destruct H2.
unfold matchable. exists x. exists x0. destruct H2.
destruct H3.
split. eauto. split. eauto. auto. auto. Qed.

Definition Properties (Process: (list order) ->(list order) ->instruction
-> (list order)*(list order)*(list transaction)):=
forall A B tau,
Legal_input B A tau ->
let B' := (fst (Absorb B A tau)) in
let A' := (snd (Absorb B A tau)) in
let hat_B := (Blist (Process B A tau)) in
let hat_A := (Alist (Process B A tau)) in
let M := (Mlist (Process B A tau)) in

Condition1 M B A hat_B hat_A tau /\
Condition2a M B'/\
Condition2b M A'/\
Condition3a M B A tau /\
Condition3b M B A hat_B tau /\
Condition3c M B A hat_A tau.

(*----------------Term require for Gloal theorem part----------------*)

Fixpoint orders (I:list instruction) :(list order):=
match I with
|nil => nil
|i::I' => (ord i)::orders I'
end.

Fixpoint tilln (l: list order)(k:nat):=
match (l,k) with
|(nil, 0) => nil
|(x::l', 0) => x::nil
|(nil, S k) => nil
|(hd::tail, S k) => hd::(tilln tail k)
end.

Lemma tilln_contains_nth (l: list order)(k:nat):
l<>nil/\|l|>=k+1 -> In (nth k l w0) (tilln l k).
Proof. revert k. induction l. intros. destruct H. destruct H. auto.
       destruct k.  simpl. auto. simpl.
       intros. destruct H. assert(l<>nil). intro.
       subst l. simpl in H0. lia. right. apply IHl. split.
       auto. lia. Qed.

Lemma tilln_Subset_whole (l: list order)(k:nat):
Subset (tilln l k) l.
Proof. revert k. induction l. destruct k eqn: Hk. simpl. auto.
simpl. auto. destruct k eqn: Hk. simpl. auto. simpl.
apply Subset_intro. auto. Qed.

Lemma tilln_Subset_next (I: list order)(k:nat):
Subset (tilln I (k-1)) (tilln I k).
Proof. revert I. induction k. simpl. auto. intros.
replace (S k -1) with k. destruct k. destruct I. simpl. auto.
simpl. auto. destruct I. simpl. auto. simpl.
replace (S k -1) with k in IHk. specialize (IHk I).
eauto. lia. lia. Qed.

Lemma timesof_nodup_notIn (B: list order)(k: nat):
NoDup (timesof B) -> Sorted Nat.ltb (timesof B) ->
S k <= (| B |) -> k>0 ->
~In (otime (nth k B w0)) (timesof (tilln B (k - 1))).
Proof. revert B. induction k. intros. lia.
 destruct B. simpl. intros. lia. replace (S k -1) with k.
destruct k. simpl. intros. destruct B. simpl in H1. lia.
simpl. intro. destruct H3.
apply Sorted_elim4 with (x:= (otime o0)) in H0. move /ltP in H0.  lia.
simpl.  auto.  auto. simpl. intros. assert(In (nth (S k) B w0) B).
assert(In (nth (S k) B w0) (tilln B (S k))).
apply tilln_contains_nth. split. intro.
subst B. simpl in H1. lia. lia. assert(Subset (tilln B (S k)) B).
apply tilln_Subset_whole. auto. intro.
destruct H4. apply timesof_elim in H3.
apply Sorted_elim4 with (x:= (otime (nth (S k) B w0))) in H0.
move /ltP in H0.  lia.  auto. assert(S (S k) <= (| B |)). lia.
apply IHk in H5. replace (S k -1) with k in H5.
destruct (H5 H4). lia. eauto. eauto. lia. lia. Qed.

Lemma ordersI_length (I:list instruction) :
|I| = |orders I|.
Proof. induction I. simpl;auto. simpl;lia. Qed.

Lemma ordersI_nil (I:list instruction) :
I <> nil -> (orders I) <> nil.
Proof. intros. induction I. destruct H. auto. simpl.
       intro. inversion H0. Qed.

Definition structured (I :list instruction):=
(forall t:nat,  (t+1) <= (length I) -> (cmd (nth t I tau0) = del)\/
(~In (id (ord (nth t I tau0))) (ids (tilln (orders I) (t-1))))\/
((id (ord (nth t I tau0))) = (id (ord (nth (t-1) I tau0)))/\
(cmd (nth (t-1) I tau0) = del)))
/\ Sorted (Nat.ltb) (timesof (orders I))/\ NoDup ((timesof (orders I))).

Fixpoint iterate (P: (list order)->(list order) -> instruction -> (list order)*(list order)*(list transaction))
(I : list instruction)(k:nat) :=
match k with
|0 => (nil, nil, nil)
| S k' =>  let it:=(iterate P I k') in P (Blist it) (Alist it)
    (nth k' I tau0)
end.

Definition iterated (P: (list order)->(list order) -> instruction -> (list order)*(list order)*(list transaction))
(I : list instruction)(k:nat) :=
if (Nat.ltb (length I) k) then (nil,nil,nil) else iterate P I k.

End Properties.


Lemma eq_sym : forall (X : Type)(x y : X), x = y -> y = x.
intros X x y A.
rewrite A.
reflexivity.
Qed.

Lemma modus_ponens : forall X Y : Prop, X -> (X -> Y) -> Y.
intros X Y x A.
exact (A x).
Qed.

Lemma barbara : forall X Y Z : Prop, (X -> Y) -> (Y -> Z) -> (X -> Z).
intros X Y Z A B x.
exact (B (A x)).
Qed.

Lemma eq_trans : forall (X : Type)(x y z : X), x = y -> y = z -> x = z.
intros.
transitivity y.
assumption.
apply H0.
Qed.

Lemma const : forall X Y, X -> Y -> X.
intros.
apply X0.
Qed.

Goal forall X Y, (forall Z, (X -> Y -> Z) ->
 Z) -> X.
intros X Y Z0.
apply Z0.
apply const.
Qed.

Lemma const' : forall X Y, X -> Y -> Y.
intros.
apply X1.
Qed.

Goal forall X Y, (forall Z, (X -> Y -> Z) -> Z) -> Y.
intros.
apply X0.
apply const'.
Qed.

Lemma leibniz_equality : forall (X : Type)(x y : X),(forall p : X -> Prop, p x -> p y) -> x = y.
intros.
apply (H (fun z => x = z)).
reflexivity.
Qed.

Goal forall X : Type, (fun x : X => x) = (fun y : X => y).
intros.
reflexivity.
Qed.

Goal forall X : Prop, X -> ~~X.
intros X x A.
exact (A x).
Qed.