(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(*********************************************************************)
(** * List permutations as a composition of adjacent transpositions  *)
(*********************************************************************)

(* Adapted in May 2006 by Jean-Marc Notin from initial contents by
   Laurent Théry (Huffmann contribution, October 2003) *)

Require Import List Setoid Compare_dec Morphisms FinFun.
Import ListNotations. (* For notations [] and [a;b;c] *)
Set Implicit Arguments.
(* Set Universe Polymorphism. *)

Section Permutation.

Variable A:Type.

Inductive Permutation : list A -> list A -> Prop :=
| perm_nil: Permutation [] []
| perm_skip x l l' : Permutation l l' -> Permutation (x::l) (x::l')
| perm_swap x y l : Permutation (y::x::l) (x::y::l)
| perm_trans l l' l'' :
    Permutation l l' -> Permutation l' l'' -> Permutation l l''.

Local Hint Constructors Permutation.

(** Some facts about [Permutation] *)

Theorem Permutation_nil : forall (l : list A), Permutation [] l -> l = [].
Proof.
  intros l HF.
  remember (@nil A) as m in HF.
  induction HF; discriminate || auto.
Qed.

Theorem Permutation_nil_cons : forall (l : list A) (x : A),
 ~ Permutation nil (x::l).
Proof.
  intros l x HF.
  apply Permutation_nil in HF; discriminate.
Qed.

(** Permutation over lists is a equivalence relation *)

Theorem Permutation_refl : forall l : list A, Permutation l l.
Proof.
  induction l; constructor. exact IHl.
Qed.

Theorem Permutation_sym : forall l l' : list A,
 Permutation l l' -> Permutation l' l.
Proof.
  intros l l' Hperm; induction Hperm; auto.
  apply perm_trans with (l':=l'); assumption.
Qed.

Theorem Permutation_trans : forall l l' l'' : list A,
 Permutation l l' -> Permutation l' l'' -> Permutation l l''.
Proof.
  exact perm_trans.
Qed.

End Permutation.

Hint Resolve Permutation_refl perm_nil perm_skip.

(* These hints do not reduce the size of the problem to solve and they
   must be used with care to avoid combinatoric explosions *)

Local Hint Resolve perm_swap perm_trans.
Local Hint Resolve Permutation_sym Permutation_trans.

(* This provides reflexivity, symmetry and transitivity and rewriting
   on morphims to come *)

Instance Permutation_Equivalence A : Equivalence (@Permutation A) | 10 := {
  Equivalence_Reflexive := @Permutation_refl A ;
  Equivalence_Symmetric := @Permutation_sym A ;
  Equivalence_Transitive := @Permutation_trans A }.

Instance Permutation_cons A :
 Proper (Logic.eq ==> @Permutation A ==> @Permutation A) (@cons A) | 10.
Proof.
  repeat intro; subst; auto using perm_skip.
Qed.

Section Permutation_properties.

Variable A:Type.

Implicit Types a b : A.
Implicit Types l m : list A.

(** Compatibility with others operations on lists *)

Theorem Permutation_in : forall (l l' : list A) (x : A),
 Permutation l l' -> In x l -> In x l'.
Proof.
  intros l l' x Hperm; induction Hperm; simpl; tauto.
Qed.

Global Instance Permutation_in' :
 Proper (Logic.eq ==> @Permutation A ==> iff) (@In A) | 10.
Proof.
  repeat red; intros; subst; eauto using Permutation_in.
Qed.

Lemma Permutation_app_tail : forall (l l' tl : list A),
 Permutation l l' -> Permutation (l++tl) (l'++tl).
Proof.
  intros l l' tl Hperm; induction Hperm as [|x l l'|x y l|l l' l'']; simpl; auto.
  eapply Permutation_trans with (l':=l'++tl); trivial.
Qed.

Lemma Permutation_app_head : forall (l tl tl' : list A),
 Permutation tl tl' -> Permutation (l++tl) (l++tl').
Proof.
  intros l tl tl' Hperm; induction l;
   [trivial | repeat rewrite <- app_comm_cons; constructor; assumption].
Qed.

Theorem Permutation_app : forall (l m l' m' : list A),
 Permutation l l' -> Permutation m m' -> Permutation (l++m) (l'++m').
Proof.
  intros l m l' m' Hpermll' Hpermmm';
   induction Hpermll' as [|x l l'|x y l|l l' l''];
    repeat rewrite <- app_comm_cons; auto.
  apply Permutation_trans with (l' := (x :: y :: l ++ m));
   [idtac | repeat rewrite app_comm_cons; apply Permutation_app_head]; trivial.
  apply Permutation_trans with (l' := (l' ++ m')); try assumption.
  apply Permutation_app_tail; assumption.
Qed.

Global Instance Permutation_app' :
 Proper (@Permutation A ==> @Permutation A ==> @Permutation A) (@app A) | 10.
Proof.
  repeat intro; now apply Permutation_app.
Qed.

Lemma Permutation_add_inside : forall a (l l' tl tl' : list A),
  Permutation l l' -> Permutation tl tl' ->
  Permutation (l ++ a :: tl) (l' ++ a :: tl').
Proof.
  intros; apply Permutation_app; auto.
Qed.

Lemma Permutation_cons_append : forall (l : list A) x,
  Permutation (x :: l) (l ++ x :: nil).
Proof. induction l; intros; auto. simpl. rewrite <- IHl; auto. Qed.
Local Hint Resolve Permutation_cons_append.

Theorem Permutation_app_comm : forall (l l' : list A),
  Permutation (l ++ l') (l' ++ l).
Proof.
  induction l as [|x l]; simpl; intro l'.
  rewrite app_nil_r; trivial. rewrite IHl.
  rewrite app_comm_cons, Permutation_cons_append.
  now rewrite <- app_assoc.
Qed.
Local Hint Resolve Permutation_app_comm.

Theorem Permutation_cons_app : forall (l l1 l2:list A) a,
  Permutation l (l1 ++ l2) -> Permutation (a :: l) (l1 ++ a :: l2).
Proof.
  intros l l1 l2 a H. rewrite H.
  rewrite app_comm_cons, Permutation_cons_append.
  now rewrite <- app_assoc.
Qed.
Local Hint Resolve Permutation_cons_app.

Lemma Permutation_Add a l l' : Add a l l' -> Permutation (a::l) l'.
Proof.
 induction 1; simpl; trivial.
 rewrite perm_swap. now apply perm_skip.
Qed.

Theorem Permutation_middle : forall (l1 l2:list A) a,
  Permutation (a :: l1 ++ l2) (l1 ++ a :: l2).
Proof.
  auto.
Qed.
Local Hint Resolve Permutation_middle.

Theorem Permutation_rev : forall (l : list A), Permutation l (rev l).
Proof.
  induction l as [| x l]; simpl; trivial. now rewrite IHl at 1.
Qed.

Global Instance Permutation_rev' :
 Proper (@Permutation A ==> @Permutation A) (@rev A) | 10.
Proof.
  repeat intro; now rewrite <- 2 Permutation_rev.
Qed.

Theorem Permutation_length : forall (l l' : list A),
 Permutation l l' -> length l = length l'.
Proof.
  intros l l' Hperm; induction Hperm; simpl; auto. now transitivity (length l').
Qed.

Global Instance Permutation_length' :
 Proper (@Permutation A ==> Logic.eq) (@length A) | 10.
Proof.
  exact Permutation_length.
Qed.

Theorem Permutation_ind_bis :
 forall P : list A -> list A -> Prop,
   P [] [] ->
   (forall x l l', Permutation l l' -> P l l' -> P (x :: l) (x :: l')) ->
   (forall x y l l', Permutation l l' -> P l l' -> P (y :: x :: l) (x :: y :: l')) ->
   (forall l l' l'', Permutation l l' -> P l l' -> Permutation l' l'' -> P l' l'' -> P l l'') ->
   forall l l', Permutation l l' -> P l l'.
Proof.
  intros P Hnil Hskip Hswap Htrans.
  induction 1; auto.
  apply Htrans with (x::y::l); auto.
  apply Hswap; auto.
  induction l; auto.
  apply Hskip; auto.
  apply Hskip; auto.
  induction l; auto.
  eauto.
Qed.

Theorem Permutation_nil_app_cons : forall (l l' : list A) (x : A),
 ~ Permutation nil (l++x::l').
Proof.
  intros l l' x HF.
  apply Permutation_nil in HF. destruct l; discriminate.
Qed.

Ltac InvAdd := repeat (match goal with
 | H: Add ?x _ (_ :: _) |- _ => inversion H; clear H; subst
 end).

Ltac finish_basic_perms H :=
  try constructor; try rewrite perm_swap; try constructor; trivial;
  (rewrite <- H; now apply Permutation_Add) ||
  (rewrite H; symmetry; now apply Permutation_Add).

Theorem Permutation_Add_inv a l1 l2 :
  Permutation l1 l2 -> forall l1' l2', Add a l1' l1 -> Add a l2' l2 ->
   Permutation l1' l2'.
Proof.
 revert l1 l2. refine (Permutation_ind_bis _ _ _ _ _).
 - (* nil *)
   inversion_clear 1.
 - (* skip *)
   intros x l1 l2 PE IH. intros. InvAdd; try finish_basic_perms PE.
   constructor. now apply IH.
 - (* swap *)
   intros x y l1 l2 PE IH. intros. InvAdd; try finish_basic_perms PE.
   rewrite perm_swap; do 2 constructor. now apply IH.
 - (* trans *)
   intros l1 l l2 PE IH PE' IH' l1' l2' AD1 AD2.
   assert (Ha : In a l). { rewrite <- PE. rewrite (Add_in AD1). simpl; auto. }
   destruct (Add_inv _ _ Ha) as (l',AD).
   transitivity l'; auto.
Qed.

Theorem Permutation_app_inv (l1 l2 l3 l4:list A) a :
  Permutation (l1++a::l2) (l3++a::l4) -> Permutation (l1++l2) (l3 ++ l4).
Proof.
 intros. eapply Permutation_Add_inv; eauto using Add_app.
Qed.

Theorem Permutation_cons_inv l l' a :
 Permutation (a::l) (a::l') -> Permutation l l'.
Proof.
  intro. eapply Permutation_Add_inv; eauto using Add_head.
Qed.

Theorem Permutation_cons_app_inv l l1 l2 a :
 Permutation (a :: l) (l1 ++ a :: l2) -> Permutation l (l1 ++ l2).
Proof.
  intro. eapply Permutation_Add_inv; eauto using Add_head, Add_app.
Qed.

Theorem Permutation_app_inv_l : forall l l1 l2,
 Permutation (l ++ l1) (l ++ l2) -> Permutation l1 l2.
Proof.
  induction l; simpl; auto.
  intros.
  apply IHl.
  apply Permutation_cons_inv with a; auto.
Qed.

Theorem Permutation_app_inv_r l l1 l2 :
 Permutation (l1 ++ l) (l2 ++ l) -> Permutation l1 l2.
Proof.
 rewrite 2 (Permutation_app_comm _ l). apply Permutation_app_inv_l.
Qed.

Lemma Permutation_length_1_inv: forall a l, Permutation [a] l -> l = [a].
Proof.
  intros a l H; remember [a] as m in H.
  induction H; try (injection Heqm as -> ->);
    discriminate || auto.
  apply Permutation_nil in H as ->; trivial.
Qed.

Lemma Permutation_length_1: forall a b, Permutation [a] [b] -> a = b.
Proof.
  intros a b H.
  apply Permutation_length_1_inv in H; injection H as ->; trivial.
Qed.

Lemma Permutation_length_2_inv :
  forall a1 a2 l, Permutation [a1;a2] l -> l = [a1;a2] \/ l = [a2;a1].
Proof.
  intros a1 a2 l H; remember [a1;a2] as m in H.
  revert a1 a2 Heqm.
  induction H; intros; try (injection Heqm as ? ?; subst);
    discriminate || (try tauto).
  apply Permutation_length_1_inv in H as ->; left; auto.
  apply IHPermutation1 in Heqm as [H1|H1]; apply IHPermutation2 in H1 as [];
    auto.
Qed.

Lemma Permutation_length_2 :
  forall a1 a2 b1 b2, Permutation [a1;a2] [b1;b2] ->
    a1 = b1 /\ a2 = b2 \/ a1 = b2 /\ a2 = b1.
Proof.
  intros a1 b1 a2 b2 H.
  apply Permutation_length_2_inv in H as [H|H]; injection H as -> ->; auto.
Qed.

Lemma NoDup_Permutation l l' : NoDup l -> NoDup l' ->
  (forall x:A, In x l <-> In x l') -> Permutation l l'.
Proof.
 intros N. revert l'. induction N as [|a l Hal Hl IH].
 - destruct l'; simpl; auto.
   intros Hl' H. exfalso. rewrite (H a); auto.
 - intros l' Hl' H.
   assert (Ha : In a l') by (apply H; simpl; auto).
   destruct (Add_inv _ _ Ha) as (l'' & AD).
   rewrite <- (Permutation_Add AD).
   apply perm_skip.
   apply IH; clear IH.
   * now apply (NoDup_Add AD).
   * split.
     + apply incl_Add_inv with a l'; trivial. intro. apply H.
     + intro Hx.
       assert (Hx' : In x (a::l)).
       { apply H. rewrite (Add_in AD). now right. }
       destruct Hx'; simpl; trivial. subst.
       rewrite (NoDup_Add AD) in Hl'. tauto.
Qed.

Lemma NoDup_Permutation_bis l l' : NoDup l -> NoDup l' ->
  length l' <= length l -> incl l l' -> Permutation l l'.
Proof.
 intros. apply NoDup_Permutation; auto.
 split; auto. apply NoDup_length_incl; trivial.
Qed.

Lemma Permutation_NoDup l l' : Permutation l l' -> NoDup l -> NoDup l'.
Proof.
 induction 1; auto.
 * inversion_clear 1; constructor; eauto using Permutation_in.
 * inversion_clear 1 as [|? ? H1 H2]. inversion_clear H2; simpl in *.
   constructor. simpl; intuition. constructor; intuition.
Qed.

Global Instance Permutation_NoDup' :
 Proper (@Permutation A ==> iff) (@NoDup A) | 10.
Proof.
  repeat red; eauto using Permutation_NoDup.
Qed.

End Permutation_properties.

Section Permutation_map.

Variable A B : Type.
Variable f : A -> B.

Lemma Permutation_map l l' :
  Permutation l l' -> Permutation (map f l) (map f l').
Proof.
 induction 1; simpl; eauto.
Qed.

Global Instance Permutation_map' :
  Proper (@Permutation A ==> @Permutation B) (map f) | 10.
Proof.
  exact Permutation_map.
Qed.

End Permutation_map.

Lemma nat_bijection_Permutation n f :
 bFun n f ->
 Injective f ->
 let l := seq 0 n in Permutation (map f l) l.
Proof.
 intros Hf BD.
 apply NoDup_Permutation_bis; auto using Injective_map_NoDup, seq_NoDup.
 * now rewrite map_length.
 * intros x. rewrite in_map_iff. intros (y & <- & Hy').
   rewrite in_seq in *. simpl in *.
   destruct Hy' as (_,Hy'). auto with arith.
Qed.

Section Permutation_alt.
Variable A:Type.
Implicit Type a : A.
Implicit Type l : list A.

(** Alternative characterization of permutation
    via [nth_error] and [nth] *)

Let adapt f n :=
 let m := f (S n) in if le_lt_dec m (f 0) then m else pred m.

Let adapt_injective f : Injective f -> Injective (adapt f).
Proof.
 unfold adapt. intros Hf x y EQ.
 destruct le_lt_dec as [LE|LT]; destruct le_lt_dec as [LE'|LT'].
 - now apply eq_add_S, Hf.
 - apply Lt.le_lt_or_eq in LE.
   destruct LE as [LT|EQ']; [|now apply Hf in EQ'].
   unfold lt in LT. rewrite EQ in LT.
   rewrite <- (Lt.S_pred _ _ LT') in LT.
   elim (Lt.lt_not_le _ _ LT' LT).
 - apply Lt.le_lt_or_eq in LE'.
   destruct LE' as [LT'|EQ']; [|now apply Hf in EQ'].
   unfold lt in LT'. rewrite <- EQ in LT'.
   rewrite <- (Lt.S_pred _ _ LT) in LT'.
   elim (Lt.lt_not_le _ _ LT LT').
 - apply eq_add_S, Hf.
   now rewrite (Lt.S_pred _ _ LT), (Lt.S_pred _ _ LT'), EQ.
Qed.

Let adapt_ok a l1 l2 f : Injective f -> length l1 = f 0 ->
 forall n, nth_error (l1++a::l2) (f (S n)) = nth_error (l1++l2) (adapt f n).
Proof.
 unfold adapt. intros Hf E n.
 destruct le_lt_dec as [LE|LT].
 - apply Lt.le_lt_or_eq in LE.
   destruct LE as [LT|EQ]; [|now apply Hf in EQ].
   rewrite <- E in LT.
   rewrite 2 nth_error_app1; auto.
 - rewrite (Lt.S_pred _ _ LT) at 1.
   rewrite <- E, (Lt.S_pred _ _ LT) in LT.
   rewrite 2 nth_error_app2; auto with arith.
   rewrite <- Minus.minus_Sn_m; auto with arith.
Qed.

Lemma Permutation_nth_error l l' :
 Permutation l l' <->
  (length l = length l' /\
   exists f:nat->nat,
    Injective f /\ forall n, nth_error l' n = nth_error l (f n)).
Proof.
 split.
 { intros P.
   split; [now apply Permutation_length|].
   induction P.
   - exists (fun n => n).
     split; try red; auto.
   - destruct IHP as (f & Hf & Hf').
     exists (fun n => match n with O => O | S n => S (f n) end).
     split; try red.
     * intros [|y] [|z]; simpl; now auto.
     * intros [|n]; simpl; auto.
   - exists (fun n => match n with 0 => 1 | 1 => 0 | n => n end).
     split; try red.
     * intros [|[|z]] [|[|t]]; simpl; now auto.
     * intros [|[|n]]; simpl; auto.
   - destruct IHP1 as (f & Hf & Hf').
     destruct IHP2 as (g & Hg & Hg').
     exists (fun n => f (g n)).
     split; try red.
     * auto.
     * intros n. rewrite <- Hf'; auto. }
 { revert l. induction l'.
   - intros [|l] (E & _); now auto.
   - intros l (E & f & Hf & Hf').
     simpl in E.
     assert (Ha : nth_error l (f 0) = Some a)
      by (symmetry; apply (Hf' 0)).
     destruct (nth_error_split l (f 0) Ha) as (l1 & l2 & L12 & L1).
     rewrite L12. rewrite <- Permutation_middle. constructor.
     apply IHl'; split; [|exists (adapt f); split].
     * revert E. rewrite L12, !app_length. simpl.
       rewrite <- plus_n_Sm. now injection 1.
     * now apply adapt_injective.
     * intro n. rewrite <- (adapt_ok a), <- L12; auto.
       apply (Hf' (S n)). }
Qed.

Lemma Permutation_nth_error_bis l l' :
 Permutation l l' <->
  exists f:nat->nat,
    Injective f /\
    bFun (length l) f /\
    (forall n, nth_error l' n = nth_error l (f n)).
Proof.
 rewrite Permutation_nth_error; split.
 - intros (E & f & Hf & Hf').
   exists f. do 2 (split; trivial).
   intros n Hn.
   destruct (Lt.le_or_lt (length l) (f n)) as [LE|LT]; trivial.
   rewrite <- nth_error_None, <- Hf', nth_error_None, <- E in LE.
   elim (Lt.lt_not_le _ _ Hn LE).
 - intros (f & Hf & Hf2 & Hf3); split; [|exists f; auto].
   assert (H : length l' <= length l') by auto with arith.
   rewrite <- nth_error_None, Hf3, nth_error_None in H.
   destruct (Lt.le_or_lt (length l) (length l')) as [LE|LT];
    [|apply Hf2 in LT; elim (Lt.lt_not_le _ _ LT H)].
   apply Lt.le_lt_or_eq in LE. destruct LE as [LT|EQ]; trivial.
   rewrite <- nth_error_Some, Hf3, nth_error_Some in LT.
   assert (Hf' : bInjective (length l) f).
   { intros x y _ _ E. now apply Hf. }
   rewrite (bInjective_bSurjective Hf2) in Hf'.
   destruct (Hf' _ LT) as (y & Hy & Hy').
   apply Hf in Hy'. subst y. elim (Lt.lt_irrefl _ Hy).
Qed.

Lemma Permutation_nth l l' d :
 Permutation l l' <->
  (let n := length l in
   length l' = n /\
   exists f:nat->nat,
    bFun n f /\
    bInjective n f /\
    (forall x, x < n -> nth x l' d = nth (f x) l d)).
Proof.
 split.
 - intros H.
   assert (E := Permutation_length H).
   split; auto.
   apply Permutation_nth_error_bis in H.
   destruct H as (f & Hf & Hf2 & Hf3).
   exists f. split; [|split]; auto.
   intros x y _ _ Hxy. now apply Hf.
   intros n Hn. rewrite <- 2 nth_default_eq. unfold nth_default.
    now rewrite Hf3.
 - intros (E & f & Hf1 & Hf2 & Hf3).
   rewrite Permutation_nth_error.
   split; auto.
   exists (fun n => if le_lt_dec (length l) n then n else f n).
   split.
   * intros x y.
     destruct le_lt_dec as [LE|LT];
      destruct le_lt_dec as [LE'|LT']; auto.
     + apply Hf1 in LT'. intros ->.
       elim (Lt.lt_irrefl (f y)). eapply Lt.lt_le_trans; eauto.
     + apply Hf1 in LT. intros <-.
       elim (Lt.lt_irrefl (f x)). eapply Lt.lt_le_trans; eauto.
   * intros n.
     destruct le_lt_dec as [LE|LT].
     + assert (LE' : length l' <= n) by (now rewrite E).
       rewrite <- nth_error_None in LE, LE'. congruence.
     + assert (LT' : n < length l') by (now rewrite E).
       specialize (Hf3 n LT). rewrite <- 2 nth_default_eq in Hf3.
       unfold nth_default in Hf3.
       apply Hf1 in LT.
       rewrite <- nth_error_Some in LT, LT'.
       do 2 destruct nth_error; congruence.
Qed.

End Permutation_alt.

(* begin hide *)
Notation Permutation_app_swap := Permutation_app_comm (only parsing).
(* end hide *)


Require Import Arith.
Require Import Omega.
Require Import List.

Add LoadPath "Listkit" as Listkit.

Require Import Listkit.Foreach.

(** Definitions *)
Inductive Ty : Set := TyBase | TyPair : Ty -> Ty -> Ty | TyArr : Ty -> Ty -> Ty.

(** Terms *)
Inductive Term : Set :=
  TmConst
| TmVar (x : nat) : Term
| TmPair : Term -> Term -> Term
| TmProj : bool -> Term -> Term
| TmAbs : Term -> Term
| TmApp : Term -> Term -> Term.

Notation "L @ M" := (TmApp L M) (at level 500).
Notation "〈 L , M 〉" := (TmPair L M) (at level 400).

(** Typing derivations *)
Inductive Typing env : Term -> Ty -> Set :=
| TBase : Typing env TmConst TyBase
| TVar : forall (x:nat) ty,
    value ty = nth_error env x ->
    Typing env (TmVar x) ty
| TPair : forall l m s t, Typing env l s -> Typing env m t ->
    Typing env (TmPair l m) (TyPair s t)
| TApp : forall l m a b,
    Typing env l (TyArr a b) -> Typing env m a ->
    Typing env (TmApp l m) b
| TAbs : forall n s t,
    Typing (s :: env) n t ->
    Typing env (TmAbs n) (TyArr s t)
| TProj1 : forall m s t,
    Typing env m (TyPair s t) ->
    Typing env (TmProj false m) s
| TProj2 : forall m s t,
    Typing env m (TyPair s t) ->
    Typing env (TmProj true m) t
.

Hint Constructors Typing.

(** [env_typing] relates a value environment to its typing. It asserts
    the types (in a [nil] environment) of each of a series of values. *)
Definition env_typing Vs Ts :=
  ((length Vs = length Ts) *
  foreach2_ty _ _ Vs Ts (fun x y => (Typing nil x y)))%type.

(** [env_typing_env] also relates a value environment to its typing. It asserts
    the types (in a given environment) of each of a series of values. *)
Definition env_typing_env env Vs Ts :=
  ((length Vs = length Ts) *
  foreach2_ty _ _ Vs Ts (fun x y => (Typing env x y)))%type.

Hint Unfold env_typing.

(** [env_typing_env] environments can be extended, one term-type pair at a time. *)
Lemma env_typing_intro:
  forall env V Vs T Ts,
    Typing env V T ->
    env_typing_env env (Vs) (Ts) ->
    env_typing_env env (V::Vs) (T::Ts).
Proof.
 intros.
 unfold env_typing_env in *.
 unfold foreach2_ty in *.
 simpl in *.
 intuition.
Qed.

(** [env_typing_env] environments can be destructed into their first
pair and a remaining [env_typing_env] environment. *)
Lemma env_typing_elim:
  forall env V Vs T Ts,
    env_typing_env env (V::Vs) (T::Ts) ->
    (env_typing_env env Vs Ts
    * Typing env V T).
Proof.
 intros ? ? ? ? ? X.
 unfold env_typing_env in X.
 unfold foreach2_ty in X.
 unfold env_typing_env.
 simpl in *.
 intuition.
Qed.

Lemma env_typing_env_app:
  forall env Vs Ws Ts,
    env_typing_env env (Vs++Ws) Ts ->
    {T1s : list Ty & { T2s : list Ty &
      ((length T1s = length Vs) *
      (length T2s = length Ws) *
      (Ts = T1s ++ T2s) *
      (env_typing_env env (Vs ++ Ws) (T1s ++ T2s)))%type } }.
Proof.
 induction Vs.
  simpl.
  intros Ws Ts H.
  exists nil.
  exists Ts.
  simpl.
  inversion H.
  auto.
 simpl.
 intros Ws Ts H.
 inversion H as [H0 X].
 simpl in H0.
 destruct Ts.
 simpl in H0.
  omega.
 destruct (IHVs Ws Ts) as [T1s' H1].
  apply env_typing_elim in H.
  destruct H; auto.
 destruct H1 as [T2s' H2].
 exists (t::T1s').
 exists (T2s').
 simpl.
 destruct H2 as [[[H3 H4] H5] H6].
 split; [split; [split |]|].
    omega.
   auto.
  congruence.
 apply env_typing_intro.
  intuition.
   simpl in *.
   subst Ts.
  unfold foreach2_ty in X.
  simpl in X.
  intuition.
 auto.
Qed.

Lemma env_typing_cons :
  forall V T Vs env,
    Typing nil V T -> env_typing Vs env -> env_typing (V::Vs) (T::env).
Proof.
 intros.
 simpl;  firstorder.
 unfold foreach2_ty; simpl; intuition.
Qed.

Hint Resolve env_typing_cons.

Require Import Coq.Lists.ListSet.

Require Import Listkit.Sets.

Definition set_remove := Listkit.Sets.set_remove.

(** The free variables of a Term, as a set of nats. *)
Fixpoint freevars (M:Term) : set nat :=
  match M with
  | TmConst => empty_set nat
  | TmVar x => set_add eq_nat_dec x (empty_set nat)
  | TmPair L M => set_union eq_nat_dec (freevars L) (freevars M)
  | TmProj b M => freevars M
  | TmAbs N => set_map eq_nat_dec (fun x => x-1)
                 (set_remove _ eq_nat_dec 0 (freevars N))
  | TmApp L M => set_union eq_nat_dec (freevars L) (freevars M)
  end.

Definition free_in x M := set_In x (freevars M).

Definition in_env_domain (n:nat) (env:list Term) := fun x => n <= x < n+length env.
(* (* Alt definition, reuses outside_range; consider it! *)
   Definition in_env_domain (n:nat) (env:list Term) :=
   fun x => false = outside_range n (n+length env) x. *)

(* TODO: in_env_domain and outside_range are essentially logical inverses,
   but are defined in different sorts. Consolidate them! *)

Lemma in_env_domain_map :
    forall n f env, in_env_domain n (map f env) = in_env_domain n env.
 unfold in_env_domain.
 intros.
 rewrite map_length.
 auto.
Qed.


(*

  Copyright 2016 University of Luxembourg

  This file is part of our formalization of Platzer's
    "A Complete Uniform Substitution Calculus for Differential Dynamic Logic"
  available here: http://arxiv.org/pdf/1601.06183.pdf (July 27, 2016).
  We refer to this formalization as DdlCoq here.

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

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

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

  authors:
    Vincent Rahli
    Marcus Völp
    Ivana Vukotic

 *)

Require Export terms_util2.

Lemma vec_eq_dec_in :
  forall (A : Type) (n : nat) (l l' : Vector.t A n),
    (forall x y : A, Vector.In x l -> {x = y} + {x <> y})
    -> {l = l'} + {l <> l'}.
Proof.
  induction n; introv ih.

  { apply Vector.case0 with (v := l).
    apply Vector.case0 with (v := l').
    prove_dec. }

  { revert dependent l; intro l.
    apply (Vector.caseS' l); clear l.
    apply (Vector.caseS' l'); clear l'.
    introv ih.
    pose proof (IHn t0 t) as q; autodimp q hyp.
    { introv i; apply ih; constructor; auto. }
    pose proof (ih h0 h) as z; autodimp z hyp; tcsp.
    destruct q as [q|q]; subst; destruct z as [z|z]; subst; prove_dec.
    right; intro z.
    apply Vector.cons_inj in z; repnd; tcsp. }
Defined.

(**

  In this file decidability of terms, formulas and programs is implemented.
  Decidability for symbols can be found in symbol_util.v.

*)

Lemma KTnum_dec : forall (t u : KTnum), {t = u} + {t <> u}.
Proof.
  destruct t as [n1|r1], u as [n2|r2]; prove_dec.
  { destruct (deq_nat n1 n2); subst; prove_dec. }
  { destruct (Req_EM_T r1 r2); subst; prove_dec. }
Defined.

(** decidability on Terms *)
Lemma term_dec : forall (t u : Term), {t = u} + {t <> u}.
Proof.
  term_rec t Case; destruct u; prove_dec;
    try (complete (destruct (IHt1 u1) as [d1|d1];
                   destruct (IHt2 u2) as [d2|d2];
                   subst; prove_dec));
    try (complete (destruct (IHt u) as [d3|d3]; subst; prove_dec)).

  { Case "KTdot".
    destruct (deq_nat n n0); prove_dec. }

  { Case "KTfuncOf".
    destruct (FunctionSymbol_dec f f0); subst; prove_dec.
    destruct (deq_nat n n0); subst; prove_dec.

    pose proof (vec_eq_dec_in _ _ args a) as h.
    autodimp h hyp.
    destruct h as [h|h]; subst; tcsp.
    right; intro xx.
    inversion xx; eqDepDec; subst; tcsp. }

  { Case "KTnumber".
    destruct (KTnum_dec r r0); subst; prove_dec. }

  { Case "KTread".
    destruct (KAssignable_dec var var0); subst; prove_dec. }
Defined.

(** decidability on Differential Programs *)
Lemma AtomicODE_dec :
  forall (t u : AtomicODE), {t = u} + {t <> u}.
Proof.
  destruct t, u; prove_dec.

  {
    destruct (ODEConst_dec name name0); subst; prove_dec.
  }

  {
    destruct (KAssignable_dec xp xp0); subst; prove_dec.
    destruct (term_dec e e0); subst; prove_dec.
  }
Defined.

Lemma ODE_dec :
  forall (t u : ODE), {t = u} + {t <> u}.
Proof.
  induction t; destruct u; prove_dec.

  { destruct (AtomicODE_dec child child0); subst; prove_dec. }

  {
    destruct (IHt1 u1); subst; prove_dec.
    destruct (IHt2 u2); subst; prove_dec.
  }
Defined.

(** decidability on Formulas and Programs *)
Lemma formula_program_dec :
  (forall (t u : Formula), {t = u} + {t <> u})
  * (forall (t u : Program), {t = u} + {t <> u}).
Proof.
  apply (Formula_Program_rec_2
           (fun t => forall (u : Formula), {t = u} + {t <> u})
           (fun t => forall (u : Program), {t = u} + {t <> u}));
    introv;
    try (intro imp1; introv);
    try (intro imp2; introv);
    destruct u;
    prove_dec;
    try (complete (destruct (IHt1 u1) as [d1|d1];
                   destruct (IHt2 u2) as [d2|d2];
                   subst; prove_dec));
    try (complete (destruct (IHt u) as [d3|d3]; subst; prove_dec));
    try (complete (destruct (term_dec left left0); subst; prove_dec;
                   destruct (term_dec right right0); subst; prove_dec));
    try (complete (destruct (imp1 u1); subst; prove_dec;
                   destruct (imp2 u2); subst; prove_dec));
    try (complete (destruct (imp1 u); subst; prove_dec)).

    {
      destruct (PredicateSymbol_dec f f0); subst; prove_dec.
      destruct (deq_nat n n0); subst; prove_dec.

      pose proof (vec_eq_dec_in _ _ args a) as h.
      autodimp h hyp;[introv i;apply term_dec|].
      destruct h as [h|h]; subst; tcsp.
      right; introv xx; inversion xx; eqDepDec; subst; tcsp.
    }

    {
      destruct (QuantifierSymbol_dec f f0); subst; prove_dec.
      destruct (imp1 u) as [d3|d3]; subst; prove_dec.
    }

    {
      destruct (list_eq_dec KVariable_dec vars vars0) as [d|d]; subst; prove_dec.
      destruct (imp1 u) as [d3|d3]; subst; prove_dec.
    }

    {
      destruct (list_eq_dec KVariable_dec vars vars0) as [d|d]; subst; prove_dec.
      destruct (imp1 u) as [d3|d3]; subst; prove_dec.
    }

    {
      destruct (imp1 prog0) as [d1|d1]; subst; prove_dec.
      destruct (imp2 u) as [d2|d2]; subst; prove_dec.
    }

    {
      destruct (imp1 prog0) as [d1|d1]; subst; prove_dec.
      destruct (imp2 u) as [d2|d2]; subst; prove_dec.
    }

    {
      destruct (ProgramConstName_dec name name0); subst; prove_dec.
    }

    {
      destruct (term_dec e e0); subst; prove_dec.
      destruct (KAssignable_dec x x0); subst; prove_dec.
    }

    {
      destruct (KAssignable_dec x x0); subst; prove_dec.
    }

    {
      destruct (imp1 cond0); subst; prove_dec.
    }

    {
      destruct (imp1 constraint0); subst; prove_dec.
      destruct (ODE_dec ode ode0); subst; prove_dec.
    }
Defined.

(** decidability on Formulas *)
Lemma formula_dec : forall (t u : Formula), {t = u} + {t <> u}.
Proof.
  pose proof formula_program_dec; sp.
Defined.

(** decidability on Programs *)
Lemma program_dec : forall (t u : Program), {t = u} + {t <> u}.
Proof.
  pose proof formula_program_dec; sp.
Defined.


Require Import Setoid.

Parameter recursion : forall A : Set, A -> (nat -> A -> A) -> nat -> A.

Axiom recursion_S :
  forall (A : Set) (EA : relation A) (a : A) (f : nat -> A -> A) (n : nat),
    EA (recursion A a f (S n)) (f n (recursion A a f n)).

Goal forall n : nat, recursion nat 0 (fun _ _ => 1) (S n) = 1.
intro n.
rewrite recursion_S.
reflexivity.
Qed.

Goal forall n : nat, recursion nat 0 (fun _ _ => 1) (S n) = 1.
intro n.
setoid_rewrite recursion_S.
reflexivity.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Cat.Cat Cat.Terminal.
Require Import Limits.Limit.
Require Import KanExt.LocalFacts.From_Iso_Cat.
Require Import Cat.Cat_Iso.

(** Given I : C ≃ D for C and D categories we have limit of (F ∘ I)
    if we have limit of F. *)
Section Limit_From_Isomorphic_Cat.
Context {C D : Category}
        (I : (C ≃≃ D ::> Cat)%isomorphism)
        {E : Category}
        {F : (D –≻ E)%functor}
        (L : Limit F)
.

Definition Limit_From_Isomorphic_Cat : Limit (F ∘ (iso_morphism I)) :=
  Local_Right_KanExt_Iso_along
    (
      Functor_To_1_Cat_Iso
        (Functor_To_1_Cat C)
        (Functor_To_1_Cat D ∘ (iso_morphism I))
    )
    (KanExt_From_Isomorphic_Cat I (Functor_To_1_Cat D) F L)
.

End Limit_From_Isomorphic_Cat.

(** Given I : C ≃ D for C and D categories we have colimit of (F ∘ I)
    if we have colimit of F. *)
Section CoLimit_From_Isomorphic_Cat.
Context {C D : Category}
        (I : (C ≃≃ D ::> Cat)%isomorphism)
        {E : Category}
        {F : (D –≻ E)%functor}
        (L : CoLimit F)
.

Definition CoLimit_From_Isomorphic_Cat : CoLimit (F ∘ (iso_morphism I)) :=
  Limit_From_Isomorphic_Cat (Opposite_Cat_Iso I) L
.

End CoLimit_From_Isomorphic_Cat.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	   Limits  cones(c,F) iso C(c,limF)                		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export SET.
Require Export Limit.
Require Export Map0_dup1.

Set Implicit Arguments.
Unset Strict Implicit.

(* cones(c,F) iso C(c,limF) *)

Section iso_cone.

Variables (J C : Category) (F : Functor J C) (l : Limit F) (c : C).

(* Map cones(c,F) vers C(c,limF) *)

Definition PhiCone_fun (tau : Cones c F) := Lim_diese l tau.

Lemma PhiCone_map_law : Map_law''0 PhiCone_fun.
Proof.
unfold Map_law''0, PhiCone_fun in |- *; simpl in |- *.
intros T1 T2 H.
apply (Ldiese_map l); trivial.
Qed.

Canonical Structure PhiCone_map := Build_Map''0 PhiCone_map_law.

(* Map C(c,limF) vers cones(c,F) *)

 Section phicone_1_fun_def.

 Variable f : c --> Lim l.

 Definition PhiCone_1_fun_tau (i : J) := f o Limiting_cone l i.

 Lemma PhiCone_1_fun_cone_law : Cone_law PhiCone_1_fun_tau.
 Proof.
 unfold Cone_law, PhiCone_1_fun_tau in |- *; simpl in |- *.
 intros i j g.
 (* *) apply Trans with (f o Limiting_cone l i o FMor F g).
 apply Comp_l; apply (EqC (Limiting_cone l) g).
 apply Ass.
 Qed.

 Canonical Structure PhiCone_1_fun : Cones c F := PhiCone_1_fun_cone_law.

 End phicone_1_fun_def.

Lemma PhiCone_1_map_law : Map_law0'' PhiCone_1_fun.
Proof.
unfold Map_law0'', PhiCone_1_fun in |- *.
intros f g H; simpl in |- *.
unfold Equal_NT in |- *; simpl in |- *.
unfold PhiCone_1_fun_tau in |- *; intro i.
apply Comp_r; trivial.
Qed.

Canonical Structure PhiCone_1_map : Map0'' (c --> Lim l) (Cones c F) :=
  PhiCone_1_map_law.

(* phi et PhiCone_1 sont iso *)

Lemma Lim_areIso : AreBij0'' PhiCone_1_map PhiCone_map.
Proof.
unfold AreBij0'' in |- *; split.
intro f; simpl in |- *; unfold PhiCone_fun in |- *.
apply Sym; apply (Prf_limit2 l).
unfold Limit_eq, PhiCone_1_fun in |- *; simpl in |- *.
intro i; apply Refl.
intro tau; simpl in |- *; unfold Equal_NT in |- *.
unfold PhiCone_1_fun, PhiCone_fun in |- *; simpl in |- *.
intro i; unfold PhiCone_1_fun_tau in |- *.
apply (Prf_limit1 l tau i).
Qed.

End iso_cone.


(* This implementation was a helpful reference
   https://gist.github.com/rntz/aaaaf7a0bdb1cc65c49adb6adde29728
*)
Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.
Require Import Coq.Init.Nat.
Require Import Coq.Arith.PeanoNat.

(* Drop returns the string left after removing the first n characters. *)
Fixpoint drop (n : nat) (s : string) :=
  match n with
  | 0 => s
  | S n => match s with
           | EmptyString => EmptyString
           | String _ s => drop n s
           end
  end.

Theorem drop_spec : forall l r , drop (length l) (l ++r ) = r.
Proof.
  intros.
  induction l.
  reflexivity.
  simpl.
  apply IHl.
Qed.

(* Take returns the first n characters of the string or the string itself *)
Fixpoint take (n : nat) (s : string):=
  match n with
  | 0 => EmptyString
  | S n => match s with
           | EmptyString => EmptyString
           | String c s => String c (take n s)
           end
  end.

Theorem take_spec : forall l r , take (length l) (l ++r ) = l.
Proof.
  intros.
  induction l.
  reflexivity.
  simpl.
  rewrite -> IHl.
  reflexivity.
Qed.

(* replicate returns a string of length n comprised of character a.  *)
Fixpoint replicate (a : ascii) (n : nat) :=
  match n with
  | 0 => EmptyString
  | S n' => String a (replicate a n')
  end.

(* string_uniform is a proposition testing if a string is comprised only of a given character *)
Fixpoint string_uniform (a : ascii) (s : string) : Prop :=
  match s with
  | EmptyString => True
  | String h t => (h = a) /\ string_uniform a t
  end.

Theorem replicate_uniform : forall a n , string_uniform a (replicate a n).
Proof.
  intros.
  induction n.
  simpl.
  auto.
  simpl.
  split.
  reflexivity.
  assumption.
Qed.

Theorem replicate_length : forall a n , length (replicate a n) = n.
Proof.
  induction n.
  reflexivity.
  simpl.
  rewrite -> IHn.
  reflexivity.
Qed.

(* left justify *)

Definition left_justify_string
           (a : ascii )
           (n : nat)
           (s : string) : string := s ++ (replicate a (n - (length s))).

Theorem length_sn : forall s a , S(length s) = length (String a s).
Proof.
  reflexivity.
Qed.

Theorem left_justify_padding' : forall (a : ascii) (n : nat) (s : string) ,
    drop (length s) (left_justify_string a n s) = replicate a (n - (length s)).
Proof.
  intros.
  induction s.
  simpl.
  rewrite <- Minus.minus_n_O.
  unfold left_justify_string.
  simpl.
  rewrite <- Minus.minus_n_O.
  reflexivity.
  simpl.
  unfold left_justify_string.
  simpl.
  simpl.
  assert (Ha' := drop_spec s (replicate a (n - S (length s)))).
  apply Ha'.
Qed.

Theorem left_justify_padding : forall (a : ascii) (n : nat) (s : string) ,
    string_uniform a (drop (length s) (left_justify_string a n s)).
Proof.
  intros.
  rewrite -> left_justify_padding'.
  apply replicate_uniform.
Qed.

Theorem distribute_length : forall l r , length (l ++ r ) = length l + (length r).
Proof.
  intros.
  induction l.
  simpl.
  reflexivity.
  simpl.
  rewrite IHl.
  reflexivity.
Qed.

Theorem alternate_max : forall n m , max n m = n + (m - n).
Proof.
  intros n.
  induction n as [| n IHn] ; intros m.
  simpl. apply Minus.minus_n_O.
  destruct m.
  simpl.
  rewrite <- plus_n_O.
  reflexivity.
  simpl.
  assert(forall n m, n = m -> S n = S m).
  intros.
  rewrite H.
  reflexivity.
  apply H.
  apply IHn.
Qed.

Theorem left_justify_length :
        forall (a : ascii) (n : nat) (s : string) ,
          length (left_justify_string a n s) = max (length s) n.
Proof.
  intros.
  rewrite -> alternate_max.
  intros.
  induction s.
  simpl.
  unfold left_justify_string.
  simpl.
  rewrite -> replicate_length.
  reflexivity.
  simpl.
  rewrite -> distribute_length.
  rewrite -> replicate_length.
  reflexivity.
Qed.

Theorem lemma_replicate : forall a n s ,
    take (S n) (String a s) = String a (take n s).
Proof.
  intros.
  reflexivity.
Qed.

Theorem string_associative : forall a s t ,
    append (String a s) t = String a (append s t).
Proof.
  reflexivity.
  Qed.

Theorem take_replicate : forall a n s ,
    take (length s) (s ++ (replicate a n)) = s.
Proof.
  intros.
  induction s.
  reflexivity.
  rewrite <- length_sn.
  rewrite -> string_associative.
  rewrite -> lemma_replicate .
  rewrite -> IHs.
  reflexivity.
Qed.

Theorem left_padding :
  forall (n : nat) (a : ascii) (s : string) ,
    take (length s) (left_justify_string a n s) = s.
Proof.
 intros.
 induction s.
 reflexivity.
 simpl.
 rewrite -> take_replicate.
 reflexivity.
Qed.

(* right justify *)
Definition right_justify_string
           (a : ascii )
           (n : nat)
           (s : string) : string := (replicate a (n - (length s))) ++ s.

Theorem drop_replicate : forall a n s , drop n ((replicate a n)  ++ s) = s.
Proof.
  intros.
  induction n.
  reflexivity.
  simpl.
  apply IHn.
Qed.

Theorem right_justify_padding' : forall (a : ascii) (n : nat) (s : string) ,
    take (n - (length s)) (right_justify_string a n s) = replicate a (n - (length s)).
Proof.
  intros.
  assert (Ha' := take_spec (replicate a (n - (length s))) s).
  rewrite  replicate_length in Ha'.
  unfold right_justify_string.
  rewrite -> Ha'.
  reflexivity.
Qed.

Theorem right_justify_padding : forall (a : ascii) (n : nat) (s : string) ,
    string_uniform a (take (n - (length s)) (right_justify_string a n s)).
Proof.
  intros.
  rewrite -> right_justify_padding'.
  apply replicate_uniform.
Qed.

Theorem right_padding :
  forall (n : nat) (a : ascii) (s : string) ,
    drop (n - (length s)) (right_justify_string a n s) = s.
Proof.
 intros.
 induction s.
 simpl.
 rewrite -> Nat.sub_0_r.
 induction n.
 simpl.
 unfold right_justify_string.
 reflexivity.
 apply drop_replicate.
 unfold right_justify_string.
 apply drop_replicate.
Qed.

Theorem right_justify_length :
        forall (a : ascii) (n : nat) (s : string) ,
          length (right_justify_string a n s) = max (length s) n.
Proof.
  intros.
  rewrite -> alternate_max.
  destruct s.
  simpl.
  unfold right_justify_string.
  simpl.
  rewrite -> distribute_length.
  rewrite -> replicate_length.
  simpl.
  rewrite -> Nat.sub_0_r.
  rewrite -> plus_n_O.
  reflexivity.
  unfold right_justify_string.
  simpl.
  rewrite -> distribute_length.
  rewrite -> replicate_length.
  simpl.
  rewrite -> Nat.add_comm.
  rewrite -> plus_Sn_m.
  reflexivity.
Qed.


From Hammer Require Import Hammer.

Require Import BinInt.
Require Import Zeven.
Require Import Zorder.
Require Import Zcompare.
Require Import ZArith_dec.
Require Import Sumbool.

Local Open Scope Z_scope.

Definition Z_lt_ge_bool (x y:Z) := bool_of_sumbool (Z_lt_ge_dec x y).
Definition Z_ge_lt_bool (x y:Z) := bool_of_sumbool (Z_ge_lt_dec x y).

Definition Z_le_gt_bool (x y:Z) := bool_of_sumbool (Z_le_gt_dec x y).
Definition Z_gt_le_bool (x y:Z) := bool_of_sumbool (Z_gt_le_dec x y).

Definition Z_eq_bool (x y:Z) := bool_of_sumbool (Z.eq_dec x y).
Definition Z_noteq_bool (x y:Z) := bool_of_sumbool (Z_noteq_dec x y).

Definition Zeven_odd_bool (x:Z) := bool_of_sumbool (Zeven_odd_dec x).

Notation Zle_bool := Z.leb (compat "8.3").
Notation Zge_bool := Z.geb (compat "8.3").
Notation Zlt_bool := Z.ltb (compat "8.3").
Notation Zgt_bool := Z.gtb (compat "8.3").

Definition Zeq_bool (x y:Z) :=
match x ?= y with
| Eq => true
| _ => false
end.

Definition Zneq_bool (x y:Z) :=
match x ?= y with
| Eq => false
| _ => true
end.

Lemma Zle_cases n m : if n <=? m then n <= m else n > m.
Proof. hammer_hook "Zbool" "Zbool.Zle_cases".
case Z.leb_spec; now Z.swap_greater.
Qed.

Lemma Zlt_cases n m : if n <? m then n < m else n >= m.
Proof. hammer_hook "Zbool" "Zbool.Zlt_cases".
case Z.ltb_spec; now Z.swap_greater.
Qed.

Lemma Zge_cases n m : if n >=? m then n >= m else n < m.
Proof. hammer_hook "Zbool" "Zbool.Zge_cases".
rewrite Z.geb_leb. case Z.leb_spec; now Z.swap_greater.
Qed.

Lemma Zgt_cases n m : if n >? m then n > m else n <= m.
Proof. hammer_hook "Zbool" "Zbool.Zgt_cases".
rewrite Z.gtb_ltb. case Z.ltb_spec; now Z.swap_greater.
Qed.

Lemma Zle_bool_imp_le n m : (n <=? m) = true -> (n <= m).
Proof. hammer_hook "Zbool" "Zbool.Zle_bool_imp_le".
apply Z.leb_le.
Qed.

Lemma Zle_imp_le_bool n m : (n <= m) -> (n <=? m) = true.
Proof. hammer_hook "Zbool" "Zbool.Zle_imp_le_bool".
apply Z.leb_le.
Qed.

Notation Zle_bool_refl := Z.leb_refl (compat "8.3").

Lemma Zle_bool_antisym n m :
(n <=? m) = true -> (m <=? n) = true -> n = m.
Proof. hammer_hook "Zbool" "Zbool.Zle_bool_antisym".
rewrite !Z.leb_le. apply Z.le_antisymm.
Qed.

Lemma Zle_bool_trans n m p :
(n <=? m) = true -> (m <=? p) = true -> (n <=? p) = true.
Proof. hammer_hook "Zbool" "Zbool.Zle_bool_trans".
rewrite !Z.leb_le. apply Z.le_trans.
Qed.

Definition Zle_bool_total x y :
{ x <=? y = true } + { y <=? x = true }.
Proof. hammer_hook "Zbool" "Zbool.Zle_bool_total".
case_eq (x <=? y); intros H.
- left; trivial.
- right. apply Z.leb_gt in H. now apply Z.leb_le, Z.lt_le_incl.
Defined.

Lemma Zle_bool_plus_mono n m p q :
(n <=? m) = true ->
(p <=? q) = true ->
(n + p <=? m + q) = true.
Proof. hammer_hook "Zbool" "Zbool.Zle_bool_plus_mono".
rewrite !Z.leb_le. apply Z.add_le_mono.
Qed.

Lemma Zone_pos : 1 <=? 0 = false.
Proof. hammer_hook "Zbool" "Zbool.Zone_pos".
reflexivity.
Qed.

Lemma Zone_min_pos n : (n <=? 0) = false -> (1 <=? n) = true.
Proof. hammer_hook "Zbool" "Zbool.Zone_min_pos".
rewrite Z.leb_le, Z.leb_gt. apply Z.le_succ_l.
Qed.

Lemma Zle_is_le_bool n m : (n <= m) <-> (n <=? m) = true.
Proof. hammer_hook "Zbool" "Zbool.Zle_is_le_bool".
symmetry. apply Z.leb_le.
Qed.

Lemma Zge_is_le_bool n m : (n >= m) <-> (m <=? n) = true.
Proof. hammer_hook "Zbool" "Zbool.Zge_is_le_bool".
Z.swap_greater. symmetry. apply Z.leb_le.
Qed.

Lemma Zlt_is_lt_bool n m : (n < m) <-> (n <? m) = true.
Proof. hammer_hook "Zbool" "Zbool.Zlt_is_lt_bool".
symmetry. apply Z.ltb_lt.
Qed.

Lemma Zgt_is_gt_bool n m : (n > m) <-> (n >? m) = true.
Proof. hammer_hook "Zbool" "Zbool.Zgt_is_gt_bool".
Z.swap_greater. rewrite Z.gtb_ltb. symmetry. apply Z.ltb_lt.
Qed.

Lemma Zlt_is_le_bool n m : (n < m) <-> (n <=? m - 1) = true.
Proof. hammer_hook "Zbool" "Zbool.Zlt_is_le_bool".
rewrite Z.leb_le. apply Z.lt_le_pred.
Qed.

Lemma Zgt_is_le_bool n m : (n > m) <-> (m <=? n - 1) = true.
Proof. hammer_hook "Zbool" "Zbool.Zgt_is_le_bool".
Z.swap_greater. rewrite Z.leb_le. apply Z.lt_le_pred.
Qed.

Lemma Zeq_is_eq_bool x y : x = y <-> Zeq_bool x y = true.
Proof. hammer_hook "Zbool" "Zbool.Zeq_is_eq_bool".
unfold Zeq_bool.
rewrite <- Z.compare_eq_iff. destruct Z.compare; now split.
Qed.

Lemma Zeq_bool_eq x y : Zeq_bool x y = true -> x = y.
Proof. hammer_hook "Zbool" "Zbool.Zeq_bool_eq".
apply Zeq_is_eq_bool.
Qed.

Lemma Zeq_bool_neq x y : Zeq_bool x y = false -> x <> y.
Proof. hammer_hook "Zbool" "Zbool.Zeq_bool_neq".
rewrite Zeq_is_eq_bool; now destruct Zeq_bool.
Qed.

Lemma Zeq_bool_if x y : if Zeq_bool x y then x=y else x<>y.
Proof. hammer_hook "Zbool" "Zbool.Zeq_bool_if".
generalize (Zeq_bool_eq x y) (Zeq_bool_neq x y).
destruct Zeq_bool; auto.
Qed.


(**
----
_This file is part of_

----
*** A Formal Definition of JML in Coq #
# and its Application to Runtime Assertion Checking
Ph.D. Thesis by Hermann Lehner
----
Online available at #jmlcoq.info#

Authors:
  - Hermann Lehner
  - David Pichardie (Bicolano)
  - Andreas Kaegi (Syntax Rewritings, Implementation of ADTs)

Copyright 2011 Hermann Lehner

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

----
*)

From Coq Require Import List.
From Coq Require Import Arith.

(**
  Usefull TheoryList extensions:
  - AllS_x_P
  - Last and corresponding lemmas
  - Suffix and corresponding lemmas
 *)

Section TheoryList.

  (*
  Inductive AllS (A : Type) (P : A -> Prop) : list A -> Prop :=
    | allS_nil  : AllS P nil
    | allS_cons : forall (a : A) (l : list A),
                   P a -> AllS P l -> AllS P (a :: l)
  *)

  (** If AllS P l holds, predicate P holds for every element x in l. *)
  Lemma AllS_x_P : forall A P l (x:A), AllS P l -> In x l -> P x.
    Proof.
      intros.
      induction H.
      (* 1 *)
      simpl in H0.
      elim H0.
      (* 2 *)
      elim H0.
      (* 2.1 *)
      intro eq_a_x.
      rewrite <- eq_a_x; exact H.
      (* 2.2 *)
      assumption.
    Qed.
End TheoryList.

Section In.
  Variable A : Type.

  (** If head l = Some x, x is element of l. *)
  Lemma In_head : forall (x:A) l, head l = Some x -> In x l.
    Proof.
      intros.
      induction l.
      discriminate H.
      simpl in H.
      unfold In.
      left.
      inversion H.
      reflexivity.
    Qed.

  (** If l=y::nil, In x l -> x=y. *)
  Lemma In_singleton : forall (x y:A),
    In x (y::nil) -> x = y.
  Proof.
    intros.
    case H; intuition.
    inversion H0.
  Qed.

Lemma in_nth:
forall e (l : list A),
In e l -> forall d, exists n, nth n l d = e /\ (n < length l)%nat.
Proof.
induction l; intros.
 inversion H.

 simpl in H.
 destruct H.
  subst.
  exists O.
  simpl.
  auto with arith.

  elim IHl with d.
  intros.
  exists (S x).
  simpl.
  intuition auto with arith.

  trivial.
Qed.

End In.

Section Last.
  Variable A : Type.

  (** Last x l <-> x is the last element of list l. *)
  Inductive Last (x:A) : list A -> Prop :=
    | Last_base : Last x (x::nil)
    | Last_step : forall (y:A) (l:list A), Last x l -> Last x (y::l).

  (** The empty list nil has no last element. *)
  Lemma Last_nil : forall x:A, Last x nil -> False.
  Proof.
    intros.
    inversion H.
  Qed.

  (** If l is non-empty, the last element x of (y::l) is also the last element of l. *)
  Lemma Last_step_inv : forall (x:A) (l:list A),
    l <> nil -> forall y, Last x (y::l) -> Last x l.
  Proof.
    intros.
    inversion H0.
    rewrite H3 in H; elim H; reflexivity.
    assumption.
  Qed.

  (** The last element x of l2 is also the last element of (l1 ++ l2). *)
  Lemma Last_app : forall (x:A) (l1 l2:list A), Last x l2 -> Last x (l1 ++ l2).
  Proof.
    intros.
    induction l1.
    simpl; assumption.
    change ((a :: l1) ++ l2) with (a :: (l1 ++ l2)).
    apply Last_step; assumption.
  Qed.

  (** If l is non-empty, the last element x of (l1 ++ l2) is also the last element of l2. *)
  Lemma Last_app_inv : forall (x:A) (l1 l2:list A),
    l2 <> nil -> Last x (l1 ++ l2) -> Last x l2.
  Proof.
    intros.
    induction l1.
    simpl; assumption.
    apply IHl1.
    apply Last_step_inv with (y := a).
    destruct l1; [assumption | intuition; discriminate H1].
    assumption.
  Qed.

  (** The last element Last x l of list l is element of the list l. *)
  Theorem Last_In : forall (x:A) (l:list A),
    Last x l -> In x l.
  Proof.
    intros.
    elim H.
    unfold In.
    left; reflexivity.

    intros y l0 L_x_l0 In_x_l0.
    unfold In.
    auto.
  Qed.

  (**
    Retrieve the last element x of l.
    The result is either x together with a proof that x is the last element of l,
    or l is the empty list.
   *)
  Definition lastS (l:list A) : {x:A | Last x l}+{l=nil}.
  Proof.
    induction l.
    (* case l = nil *)
    right; reflexivity.

    (* inductive case *)
    case_eq l.
    left.
    exists a.
    apply Last_base.

    left.
    inversion IHl.
    destruct X.
    exists x.
    rewrite <- H.
    apply Last_step; assumption.

    rewrite H in H0.
    discriminate H0.
  Defined.

End Last.
Arguments Last [A].
Arguments lastS [A].

Section Suffix.
  Variable A : Type.

  (** Suffix s l <-> the list s is a suffix of the list l. *)
  Definition Suffix (s l:list A) : Prop :=
    exists p, p++s = l.

  (** nil is a suffix of every list l. *)
  Lemma Suffix_nil_l : forall l:list A, Suffix nil l.
  Proof.
    intro l.
    exists l; intuition auto with datatypes.
  Qed.

  (** l is a suffix of itself. *)
  Lemma Suffix_l_l : forall l:list A, Suffix l l.
  Proof.
    intro l.
    exists (nil (A:=A)); intuition.
  Qed.

  (** If s is a suffix of l, s is also a suffix of every list (x::l). *)
  Lemma Suffix_step : forall (x:A) (s l:list A), Suffix s l -> Suffix s (x::l).
  Proof.
    intros x s l Hsuff.
    unfold Suffix in * |- *.
    elim Hsuff.
    intros p Heq.
    exists (x::p).
    rewrite <- Heq.
    reflexivity.
  Qed.

  (**
    If s is a suffix of a list l,
    every element x that is an element of s is also an element of l.
   *)
  Lemma Suffix_In : forall s l:list A, Suffix s l -> (forall x:A, In x s -> In x l).
  Proof.
    intros s l Hsuff x Hs.
    elim Hsuff.
    intros p Heq.
    rewrite <- Heq.
    intuition auto with datatypes.
  Qed.

  (**
    For any two elements x and y in a list l,
    it holds that either y is in a suffix (x::s) or
    x is in a suffix (y::s).
   *)
  Lemma Suffix_x_y_or_y_x : forall (l:list A) (x y:A),
      In x l -> In y l ->
      (exists s, Suffix (x::s) l /\ In y (x::s)) \/
      (exists s, Suffix (y::s) l /\ In x (y::s)).
    Proof.
      intros.
      induction l.
      (* case l=nil *)
      inversion H.

      (* case a::l *)

      (* 1st case: a = x *)
      case H; intro Hax.
      left.
      exists l.
      split.
      rewrite Hax.
      apply Suffix_l_l.
      rewrite <- Hax; assumption.

      (* 2nd case: a = y *)
      case H0; intro Hay.
      right.
      exists l.
      split.
      rewrite Hay.
      apply Suffix_l_l.
      rewrite <- Hay; assumption.

      (* 3rd case: a <> x, a <> x *)
      change (In x l) in Hax.
      change (In y l) in Hay.
      generalize (IHl Hax Hay); intro H1.

      case H1; intro.
      left.
      elim H2; intros.
      exists x0.
      destruct H3.
      split.
      apply Suffix_step; assumption.
      assumption.

      right.
      elim H2; intros.
      exists x0.
      destruct H3.
      split.
      apply Suffix_step; assumption.
      assumption.
    Qed.

End Suffix.
Arguments Suffix [A].


(** printing now %\coqdockw{now}% *)
(** printing simp %\coqdoctac{simp}% *)
(** printing by %\coqdockw{by}% *)
(** printing rec %\coqdockw{rec}% *)
(* begin hide *)
From Equations Require Import Equations.
Require Import Lia Utf8 List.
Import ListNotations.
Set Keyed Unification.

Section list_size.
  Context {A : Type} (f : A -> nat).
  Equations list_size (l : list A) : nat :=
  list_size nil := 0;
  list_size (cons x xs) := S (f x + list_size xs).
  Global Transparent list_size.

  Context {B : Type}.
  Equations? list_map_size (l : list A)
           (g : forall (x : A), f x < list_size l -> B) : list B :=
  list_map_size nil _ := nil;
  list_map_size (cons x xs) g := cons (g x _) (list_map_size xs (fun x H => g x _)).

  Proof. auto with arith. lia. Defined.

  Lemma list_map_size_spec (g : A -> B) (l : list A) :
    list_map_size l (fun x _ => g x) = List.map g l.
  Proof.
    funelim (list_map_size l (λ (x : A) (_ : f x < list_size l), g x)); simpl; trivial.
    now rewrite H.
  Qed.
End list_size.

Require Import List.
(* end hide *)
(** To demonstrate nested well-founded recursive definitions, we take a
  well-known example from the literature: rose trees.  We will define a
  recursive function gathering the elements in a [rose] tree in an efficient
  way, using nested well-founded recursion instead of the guardedness check of %\Coq%.
  The [rose] trees are defined as trees whose nodes contain lists of trees,
  i.e. forests. *)

(** To solve measure subgoals *)
#[local] Hint Extern 4 (_ < _) => simpl; lia : rec_decision.
#[local]
Obligation Tactic := CoreTactics.equations_simpl; try (simpl; lia); try typeclasses eauto with rec_decision.

(* begin hide *)
Section RoseTree.
(* end hide *)
  Context {A : Type}.

  Inductive rose : Type :=
    | leaf (a : A) : rose
    | node (l : list rose) : rose.

  (** This is a nested inductive type we can measure assuming a
      [list_size] function for measuring lists. Here we use the usual
      guardedness check of %\Coq% that is able to unfold the
      definition of [list_size] to check that this definition is terminating. *)

  Equations size (r : rose) : nat := size (leaf _) := 0; size (node l) := S (list_size size l).

  (* begin hide *)
  Transparent size.
  Derive NoConfusion for rose.

  (* end hide *)
  (** As explained at the beginning of this section, however, if we want
      to program more complex recursions, or rearrange our terms
      slightly and freely perform dependent pattern-matching, the
      limited syntactic guardness check will quickly get in our way.

      Using a _nested_ [where] clause and the support of %\Equations% for
      well-founded recursion, we can define the following function
      gathering the elements in a rose tree efficiently: *)

  Equations elements (r : rose) (acc : list A) : list A by wf (size r) lt :=
  elements (leaf a) acc := a :: acc;
  elements (node l) acc := aux l _
    where aux x (H : list_size size x < size (node l)) : list A by wf (list_size size x) lt :=
    aux nil _ := acc;
    aux (cons x xs) H := elements x (aux xs _).

  Definition elems r := elements r nil.

  (**
    The function is nesting a well-founded recursion inside
    another one, based on the measure of [rose] trees and lists ([MR R
    f] is a combinator for [λ x y, R (f x) (f y)]).  The termination
    of this definition is ensured solely by logical means, it does not
    require any syntactic check. Note that the auxiliary definition's
    type mentions the variable [l] bound by the enclosing
    pattern-matching, to pass around information on the size of
    arguments. Local [where] clauses allow just that.
    This kind of nested pattern-matching and well-founded recursion was not
    supported by previous definition packages for %\Coq% like
    %\textsc{Function}% or %\textsc{Program}%, and due to the required
    dependencies it is not supported by %\textsc{Isabelle}%'s
    %\texttt{Function}% package either (see %\cite{BoveKraussSozeau2011}% for
    a survey of the treatment of recursion in type-theory based tools). *)

  (** We can show that [elems] is actually computing the same thing as
      the naïve algorithm concatenating elements of each tree in each forest. *)

  Equations elements_spec (r : rose) : list A :=
    elements_spec (leaf a) := [a];
    elements_spec (node l) := concat (List.map elements_spec l).

  (** As [elements] takes an accumulator, we first have to prove a generalized
      lemma, typical of tail-recursive functions: *)

  Lemma elements_correct (r : rose) acc : elements r acc = elements_spec r ++ acc.
  Proof.
    apply (elements_elim (fun r acc f => f = elements_spec r ++ acc)
             (fun l acc x H r => r = concat (List.map elements_spec x) ++ acc));
      intros; simp elements_spec; simpl; trivial. now rewrite H1, H0, app_assoc. Qed.

  (** We apply the eliminator providing the predicate for the nested
      recursive call and simplify using the [simp elements_spec] tactic
      which is rewriting with the defining equations of [elements_spec].
      The induction hypotheses and associativity of concatenation are
      enough to solve the remaining goal which involves the two
      recursive calls to [elements] and [aux]. The above proof is very
      quick as the eliminator frees us from redoing all the nested
      recursive reasoning and the proofs that the induction hypotheses
      can be applied. It is now trivial to prove the correctness of our
      fast implementation: *)

  Lemma elems_correct (r : rose) : elems r = elements_spec r.
  (* begin hide *)
  Proof. now unfold elems; rewrite elements_correct, app_nil_r. Qed.
  (* end hide *)
(* begin hide *)
End RoseTree.
(* end hide *)
Arguments rose A : clear implicits.

Module FullStruct.
  Parameter (A : Type).

  Equations elements (r : rose A) (acc : list A) : list A :=
  elements (leaf a) acc := a :: acc;
  elements (node l) acc := aux l
    where aux (x : list (rose A)) : list A :=
    aux nil := acc;
    aux (cons x xs) := elements x (aux xs).
End FullStruct.

Module WfAndStruct.
  Parameter (A : Type).

  Equations elements (r : rose A) (acc : list A) : list A by wf (size r) lt :=
  elements (leaf a) acc := a :: acc;
  elements (node l) acc := aux l _
    where aux (x : list (rose A)) (H : list_size size x < size (node l)) : list A by struct x :=
    aux nil H := acc;
    aux (cons x xs) H := elements x (aux xs _).

End WfAndStruct.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
Add LoadPath "/Users/jikl/demos/coq/software-foundation-exercise/logic_foundation" as LF.
From LF Require Import Maps.
From PLF Require Import Types.
From PLF Require Import Stlc.
From PLF Require Import SmallStep.

Module STLCProp.

  Import STLC.

  Lemma canonical_forms_bool : forall t,
      empty |- t ? Bool ->
      value t ->
      (t = tru) \/ (t = fls).
  Proof.
    intros t H1 Hv.
    inversion H1; subst; inversion Hv.
    - left. reflexivity.
    - right. reflexivity.
  Qed.

  Lemma canonical_forms_fun : forall t T1 T2,
      empty |- t ? (Arrow T1 T2) ->
      value t ->
      exists x u, t = abs x T1 u.
  Proof.
    intros t T1 T2 H1 Hv.
    inversion H1; subst; inversion Hv.
    eexists. eexists. reflexivity.
  Qed.

  Theorem progress : forall t T,
      empty |- t ? T ->
      value t \/ exists t', t --> t'.
  Proof.
    intros t T H.
    remember (@empty ty) as Gamma.
    induction H.
    - subst. inversion H.
    - left. apply v_abs.
    - right. destruct IHhas_type1.
      + apply HeqGamma.
      + destruct IHhas_type2.
        * apply HeqGamma.
        * subst. apply (canonical_forms_fun t1 T11 T12 H) in H1.
          destruct H1. destruct H1. subst.
          eexists. apply ST_AppAbs. apply H2.
        * subst. destruct H2.  eexists. apply ST_App2. apply H1.
          apply H2.
      + subst. destruct H1. eexists. apply ST_App1. apply H1.
    - subst. left. apply v_tru.
    - subst. left. apply v_fls.
    - subst.
      assert (Heq1 : value t1 \/ (exists t' : tm, t1 --> t')).
      { apply IHhas_type1. reflexivity. }
      assert (Heq2 : value t2 \/ (exists t' : tm, t2 --> t')).
      { apply IHhas_type2. auto. }
      assert (Heq3 : value t3 \/ (exists t' : tm, t3 --> t')).
      { auto. }
      destruct Heq1.
      + inversion H.
        * inversion H3.
        * subst. inversion H2.
        * subst. right. eexists. apply ST_TestTru.
        * subst. right. eexists. apply ST_TestFls.
        * subst. inversion H2.
      + destruct H2. right.
        eexists. apply ST_Test. apply H2.
  Qed.

  (* Show that progress can also be proved by induction on terms
  instead of induction on typing derivations. *)
  Theorem progress' : forall t T,
      empty |- t ? T ->
      value t \/ exists t', t --> t'.
  Proof.
    intro t. induction t; intros T H.
    - inversion H. inversion H2.
    - right. inversion H. subst. apply IHt1 in H3.
      destruct H3.
      + apply IHt2 in H5. destruct H5.
        * inversion H0.
          { eexists. apply ST_AppAbs. apply H1. }
          { subst. inversion H. subst. inversion H5. }
          { subst. inversion H. subst. inversion H5. }
        * destruct H1. eexists. apply ST_App2. apply H0. apply H1.
      + destruct H0. eexists. apply ST_App1. apply H0.
    - left. apply v_abs.
    - left. apply v_tru.
    - left. apply v_fls.
    - right. inversion H; subst. inversion H4; subst.
      + inversion H0.
      + apply IHt1 in H4. destruct H4.
        * inversion H2.
        * destruct H2. eexists. apply ST_Test. apply H2.
      + eexists. apply ST_TestTru.
      + eexists. apply ST_TestFls.
      + apply IHt1 in H4. destruct H4.
        * inversion H3.
        * destruct H3. eexists. apply ST_Test. apply H3.
  Qed.

  Inductive appears_free_in : string -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (var x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (app t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (app t1 t2)
  | afi_abs : forall x y T11 t12,
      y <> x ->
      appears_free_in x t12 ->
      appears_free_in x (abs y T11 t12)
  | afi_test1 : forall x t1 t2 t3 ,
      appears_free_in x t1 ->
      appears_free_in x (test t1 t2 t3)
  | afi_test2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (test t1 t2 t3)
  | afi_test3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (test t1 t2 t3).

  Hint Constructors appears_free_in : db.

  Definition closed (t : tm) :=
    forall x, ~ appears_free_in x t.

  Lemma free_in_context : forall x t T Gamma,
      appears_free_in x t ->
      Gamma |- t ? T ->
      exists T', Gamma x = Some T'.
  Proof.
    intros x t T Gamma Hafi.
    generalize dependent Gamma. generalize dependent T.
    induction Hafi.
    - intros T Gamma H. inversion H; subst. eapply ex_intro. apply H2.
    - intros T Gamma H. inversion H; subst.
      eapply IHHafi. apply H3.
    - intros T Gamma H. inversion H; subst. eapply IHHafi. apply H5.
    - intros T Gamma H1. inversion H1; subst.
      apply (IHHafi T12 (y0 |-> T11; Gamma)) in H6.
      destruct H6. rewrite update_neq in H0.
      + eexists. apply H0.
      + apply H.
    - intros T Gamma H. inversion H; subst.
      eapply IHHafi. apply H4.
    - intros T Gamma H. inversion H; subst.
      eapply IHHafi. apply H6.
    - intros T Gamma H. inversion H; subst.
      eapply IHHafi. apply H7.
  Qed.

  Corollary typable_empty__closed : forall t T,
      empty |- t ? T ->
      closed t.
  Proof.
    unfold closed. intros t T H x0 H1.
    apply (free_in_context x0 t T empty H1) in H.
    inversion H. inversion H0.
  Qed.

  Lemma context_invariance : forall Gamma Gamma' t T,
      Gamma |- t ? T ->
      (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
      Gamma' |- t ? T.
  Proof.
    intros Gamma Gamma' t T H1 H2.
    generalize dependent Gamma'.
    induction H1; intros Gamma' H2.
    - apply T_Var. rewrite <- H. symmetry.
      eapply H2. apply afi_var.
    - apply T_Abs. apply IHhas_type.
      intros x1 Hafi. destruct (string_dec x0 x1).
      + rewrite e. rewrite update_eq. rewrite update_eq.
        reflexivity.
      + rewrite update_neq.
        * rewrite update_neq.
          { apply H2. apply afi_abs. apply n. apply Hafi. }
          { apply n. }
        * apply n.
    - eapply T_App.
      + apply IHhas_type1. intros x0 H3.
        apply H2. apply afi_app1. apply H3.
      + apply IHhas_type2. intros x0 H3.
        apply H2. apply afi_app2. apply H3.
    - apply T_Tru.
    - apply T_Fls.
    - apply T_Test.
      + apply IHhas_type1. intros x0 H3.
        apply H2. apply afi_test1. apply H3.
      + apply IHhas_type2. intros x0 H3.
        apply H2. apply afi_test2. apply H3.
      + apply IHhas_type3. intros x0 H3.
        apply H2. apply afi_test3. apply H3.
  Qed.

  Lemma substitution_preserves_typing : forall Gamma x U t v T,
      (x |-> U; Gamma) |- t ? T ->
      empty |- v ? U ->
      Gamma |- [x:=v]t ? T.
  Proof with eauto.
    intros Gamma x U t v T Ht Ht'.
    generalize dependent Gamma. generalize dependent T.
    induction t; intros T Gamma H; inversion H; subst; simpl...
    - rename s into y. destruct (eqb_stringP x y) as [Hxy|Hxy].
      + subst. rewrite update_eq in H2. inversion H2; subst.
        eapply context_invariance. eassumption.
        apply typable_empty__closed in Ht'. unfold closed in Ht'.
        intros. apply (Ht' x0) in H0. inversion H0.
      + apply T_Var. rewrite update_neq in H2...
    - eapply T_App.
      + apply IHt1. apply H3.
      + apply IHt2. apply H5.
    - rename s into y. rename t into T. apply T_Abs.
      destruct (eqb_stringP x y) as [Hxy | Hxy].
      + subst. rewrite update_shadow in H5. apply H5.
      + apply IHt. eapply context_invariance...
        intros z Hafi.
        destruct (string_dec y z).
        * subst. rewrite update_eq.
          destruct (string_dec x z).
          { subst. rewrite update_eq. exfalso.
            apply Hxy. reflexivity. }
          { rewrite update_neq. rewrite update_eq.
            reflexivity. apply n.
          }
        * rewrite update_neq. destruct (string_dec x z).
          { subst. rewrite update_eq. rewrite update_eq. reflexivity. }
          { rewrite update_neq. rewrite update_neq. rewrite update_neq.
            reflexivity. apply n. apply n0. apply n0.
          }
          { apply n. }
    - apply T_Tru.
    - apply T_Fls.
    - apply T_Test.
      + apply IHt1. apply H4.
      + apply IHt2. apply H6.
      + apply IHt3. apply H7.
  Qed.

  Theorem preservation : forall t t' T,
      empty |- t ? T ->
      t --> t' ->
      empty |- t' ? T.
  Proof with eauto.
    remember (@empty ty) as Gamma.
    intros t t' T HT. generalize dependent t'.
    induction HT; intros t' HE.
    - subst Gamma. subst. solve [inversion HE; subst; auto].
    - subst Gamma. subst. solve [inversion HE; subst; auto].
    - subst. inversion HE; subst...
      + apply substitution_preserves_typing with T11...
        inversion HT1...
      + eapply T_App.
        * apply IHHT1. reflexivity. apply H2.
        * apply HT2.
      + eapply T_App.
        * apply HT1.
        * apply IHHT2. reflexivity. apply H3.
    - inversion HE.
    - inversion HE.
    - inversion HE; subst.
      + apply HT2.
      + apply HT3.
      + apply T_Test.
        * apply IHHT1. reflexivity. apply H3.
        * apply HT2.
        * apply HT3.
  Qed.

  Definition stuck (t : tm) : Prop :=
    (normal_form step) t /\ ~ value t.

  Corollary soundness : forall t t' T,
      empty |- t ? T ->
      t -->* t' ->
      ~ (stuck t').
  Proof.
    intros t t' T Hhas_type Hmulti. unfold stuck.
    intros [Hnf Hnot_val]. unfold normal_form in Hnf.
    induction Hmulti.
    - inversion Hhas_type; subst.
      + inversion H.
      + apply Hnot_val. apply v_abs.
      + apply progress in Hhas_type. destruct Hhas_type; contradiction.
      + apply Hnot_val. apply v_tru.
      + apply Hnot_val. apply v_fls.
      + apply progress in Hhas_type. destruct Hhas_type; contradiction.
    - inversion Hhas_type; subst.
      + inversion H0.
      + apply IHHmulti.
        * eapply preservation.
          apply Hhas_type.
          apply H.
        * apply Hnf.
        * apply Hnot_val.
      + apply IHHmulti.
        * eapply preservation.
          apply Hhas_type.
          apply H.
        * apply Hnf.
        * apply Hnot_val.
      + inversion H.
      + inversion H.
      + apply IHHmulti.
        * eapply preservation.
          apply Hhas_type.
          apply H.
        * apply Hnf.
        * apply Hnot_val.
  Qed.

  Theorem unique_types : forall Gamma e T T',
      Gamma |- e ? T ->
      Gamma |- e ? T' ->
      T = T'.
  Proof.
    intros Gamma e T T' HT HT'.
    generalize dependent T'.
    induction HT; intros T' HT'; inversion HT'; subst.
    - rewrite H in H2. inversion H2. reflexivity.
    - apply IHHT in H4. subst. reflexivity.
    - apply IHHT1 in H2.
      apply IHHT2 in H4. subst. inversion H2. reflexivity.
    - reflexivity.
    - reflexivity.
    - apply IHHT3 in H6. apply H6.
  Qed.

  End STLCProp.

Module STLCArith.
  Import STLC.

  Inductive ty : Type :=
  | Arrow : ty -> ty -> ty
  | Nat : ty.

  Inductive tm : Type :=
  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> ty -> tm -> tm
  | const : nat -> tm
  | scc : tm -> tm
  | prd : tm -> tm
  | mlt : tm -> tm -> tm
  | test0 : tm -> tm -> tm -> tm.

  Reserved Notation "'[' x ':=' s ']' t" (at level 20).

  Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
    match t with
    | var x' =>
      if eqb_string x x' then s else t
    | abs x' T t1 =>
      abs x' T (if eqb_string x x' then t1 else ([x:=s] t1))
    | app t1 t2 =>
      app ([x:=s] t1) ([x:=s] t2)
    | const n => const n
    | scc t' => scc ([x:=s] t')
    | prd t' => prd ([x:=s] t')
    | mlt t1 t2 => mlt ([x:=s] t1) ([x:=s] t2)
    | test0 t1 t2 t3 =>
      test0 ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
    end
  where "'[' x ':=' s ']' t" := (subst x s t).

  Inductive value : tm -> Prop :=
  | v_abs : forall x T t, value (abs x T t)
  | v_const : forall n, value (const n).

  Hint Constructors value : db.

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

  Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
      value v2 ->
      (app (abs x T t12) v2) --> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
      t1 --> t1' ->
      app t1 t2 --> app t1' t2
  | ST_App2 : forall v1 t2 t2',
      value v1 ->
      t2 --> t2' ->
      app v1 t2 --> app v1 t2'
  | ST_Scc1 : forall t1 t1',
      t1 --> t1' ->
      scc t1 --> scc t1'
  | ST_Scc2 : forall n,
      scc (const n) --> const (n+1)
  | ST_Prd1 : forall t1 t1',
      t1 --> t1' ->
      prd t1 --> prd t1'
  | ST_Prd2 : forall n,
      prd (const n) --> const (n - 1)
  | ST_Mlt1 : forall t1 t1' t2,
      t1 --> t1' ->
      mlt t1 t2 --> mlt t1' t2
  | ST_Mlt2 : forall n1 t2 t2',
      value (const n1) ->
      t2 --> t2' ->
      mlt (const n1) t2 --> mlt (const n1) t2'
  | ST_Mlt3 : forall n1 n2,
      value (const n1) ->
      value (const n2) ->
      mlt (const n1) (const n2) --> const (n1 * n2)
  | ST_TestZero : forall t1 t2,
      (test0 (const 0) t1 t2) --> t2
  | ST_TestNonZero : forall v1 t1 t2,
      v1 > 0 ->
      (test0 (const v1) t1 t2) --> t1
  | ST_Test : forall t1 t1' t2 t3,
      t1 --> t1' ->
      (test0 t1 t2 t3) --> (test0 t1' t2 t3)
  where "t1 '-->' t2" := (step t1 t2).

  Hint Constructors step : db.

  Definition context := partial_map ty.

  Reserved Notation "Gamma '|-' t '?' T" (at level 40).
  Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- var x ? T
  | T_Abs : forall Gamma x T11 T12 t12,
      (x |-> T11; Gamma) |- t12 ? T12 ->
      Gamma |- abs x T11 t12 ? Arrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 ? Arrow T11 T12 ->
      Gamma |- t2 ? T11 ->
      Gamma |- app t1 t2 ? T12
  | T_Const : forall Gamma n,
      Gamma |- const n ? Nat
  | T_Scc : forall Gamma t,
      Gamma |- t ? Nat ->
      Gamma |- scc t ? Nat
  | T_Prd : forall Gamma t,
      Gamma |- t ? Nat ->
      Gamma |- prd t ? Nat
  | T_Mlt : forall Gamma t1 t2,
      Gamma |- t1 ? Nat ->
      Gamma |- t2 ? Nat ->
      Gamma |- mlt t1 t2 ? Nat
  | T_Test0 : forall t1 t2 t3 T Gamma,
      Gamma |- t1 ? Nat ->
      Gamma |- t2 ? T ->
      Gamma |- t3 ? T ->
      Gamma |- test0 t1 t2 t3 ? T
  where "Gamma '|-' t '?' T" := (has_type Gamma t T).

  Hint Constructors has_type : db.

  Inductive appears_free_in : string -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (var x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (app t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (app t1 t2)
  | afi_abs : forall x y T11 t12,
      y <> x ->
      appears_free_in x t12 ->
      appears_free_in x (abs y T11 t12)
  | afi_scc : forall x t1,
      appears_free_in x t1 ->
      appears_free_in x (scc t1)
  | afi_prd : forall x t1,
      appears_free_in x t1 ->
      appears_free_in x (prd t1)
  | afi_mlt1 : forall x t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (mlt t1 t2)
  | afi_mlt2 : forall x t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (mlt t1 t2)
  | afi_test1 : forall x t1 t2 t3 ,
      appears_free_in x t1 ->
      appears_free_in x (test0 t1 t2 t3)
  | afi_test2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (test0 t1 t2 t3)
  | afi_test3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (test0 t1 t2 t3).

  Hint Constructors appears_free_in : db.

  Lemma context_invariance : forall Gamma Gamma' t T,
      Gamma |- t ? T ->
      (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
      Gamma' |- t ? T.
  Proof.
    intros Gamma Gamma' t T H1 H2.
    generalize dependent Gamma'.
    induction H1; intros Gamma' H2.
    - apply T_Var. rewrite <- H. symmetry.
      eapply H2. apply afi_var.
    - apply T_Abs. apply IHhas_type.
      intros x1 Hafi. destruct (string_dec x0 x1).
      + rewrite e. rewrite update_eq. rewrite update_eq.
        reflexivity.
      + rewrite update_neq.
        * rewrite update_neq.
          { apply H2. apply afi_abs. apply n. apply Hafi. }
          { apply n. }
        * apply n.
    - eapply T_App.
      + apply IHhas_type1. intros x0 H3.
        apply H2. apply afi_app1. apply H3.
      + apply IHhas_type2. intros x0 H3.
        apply H2. apply afi_app2. apply H3.
    - apply T_Const.
    - apply T_Scc. apply IHhas_type. intros x0 H3.
      apply H2. apply afi_scc. apply H3.
    - apply T_Prd. apply IHhas_type. intros x0 H3.
      apply H2. apply afi_prd. apply H3.
    - apply T_Mlt.
      + apply IHhas_type1. intros x0 H3.
        apply H2. apply afi_mlt1. apply H3.
      + apply IHhas_type2. intros x0 H3.
        apply H2. apply afi_mlt2. apply H3.
    - apply T_Test0.
      + apply IHhas_type1. intros x0 H3.
        apply H2. apply afi_test1. apply H3.
      + apply IHhas_type2. intros x0 H3.
        apply H2. apply afi_test2. apply H3.
      + apply IHhas_type3. intros x0 H3.
        apply H2. apply afi_test3. apply H3.
  Qed.

  Lemma free_in_context : forall x t T Gamma,
      appears_free_in x t ->
      Gamma |- t ? T ->
      exists T', Gamma x = Some T'.
  Proof.
    intros x t T Gamma Hafi.
    generalize dependent Gamma. generalize dependent T.
    induction Hafi.
    - intros T Gamma H. inversion H; subst. eapply ex_intro. apply H2.
    - intros T Gamma H. inversion H; subst.
      eapply IHHafi. apply H3.
    - intros T Gamma H. inversion H; subst. eapply IHHafi. apply H5.
    - intros T Gamma H1. inversion H1; subst.
      apply (IHHafi T12 (y0 |-> T11; Gamma)) in H6.
      destruct H6. rewrite update_neq in H0.
      + eexists. apply H0.
      + apply H.
    - intros T Gamma H. inversion H; subst.
      eapply IHHafi. apply H2.
    - intros T Gamma H. inversion H; subst.
      eapply IHHafi. apply H2.
    - intros T Gamma H. inversion H; subst.
      eapply IHHafi. apply H3.
    - intros T Gamma H. inversion H; subst.
      eapply IHHafi. apply H5.
    - intros T Gamma H. inversion H; subst.
      eapply IHHafi. apply H4.
    - intros T Gamma H. inversion H; subst.
      eapply IHHafi. apply H6.
    - intros T Gamma H. inversion H; subst.
      eapply IHHafi. apply H7.
  Qed.

  Definition closed (t : tm) :=
    forall x, ~ appears_free_in x t.

  Corollary typable_empty__closed : forall t T,
      empty |- t ? T ->
      closed t.
  Proof.
    unfold closed. intros t T H x0 H1.
    apply (free_in_context x0 t T empty H1) in H.
    inversion H. inversion H0.
  Qed.

  Lemma substitution_preserves_typing : forall Gamma x U t v T,
      (x |-> U; Gamma) |- t ? T ->
      empty |- v ? U ->
      Gamma |- [x:=v]t ? T.
  Proof with eauto.
    intros Gamma x U t v T Ht Ht'.
    generalize dependent Gamma. generalize dependent T.
    induction t; intros T Gamma H; inversion H; subst; simpl...
    - rename s into y. destruct (eqb_stringP x y) as [Hxy|Hxy].
      + subst. rewrite update_eq in H2. inversion H2; subst.
        eapply context_invariance. eassumption.
        apply typable_empty__closed in Ht'. unfold closed in Ht'.
        intros. apply (Ht' x0) in H0. inversion H0.
      + apply T_Var. rewrite update_neq in H2...
    - eapply T_App.
      + apply IHt1. apply H3.
      + apply IHt2. apply H5.
    - rename s into y. rename t into T. apply T_Abs.
      destruct (eqb_stringP x y) as [Hxy | Hxy].
      + subst. rewrite update_shadow in H5. apply H5.
      + apply IHt. eapply context_invariance...
        intros z Hafi.
        destruct (string_dec y z).
        * subst. rewrite update_eq.
          destruct (string_dec x z).
          { subst. rewrite update_eq. exfalso.
            apply Hxy. reflexivity. }
          { rewrite update_neq. rewrite update_eq.
            reflexivity. apply n.
          }
        * rewrite update_neq. destruct (string_dec x z).
          { subst. rewrite update_eq. rewrite update_eq. reflexivity. }
          { rewrite update_neq. rewrite update_neq. rewrite update_neq.
            reflexivity. apply n. apply n0. apply n0.
          }
          { apply n. }
    - apply T_Const.
    - apply T_Scc. apply IHt. apply H2.
    - apply T_Prd. apply IHt. apply H2.
    - apply T_Mlt.
      + apply IHt1. apply H3.
      + apply IHt2. apply H5.
    - apply T_Test0.
      + apply IHt1. apply H4.
      + apply IHt2. apply H6.
      + apply IHt3. apply H7.
  Qed.

  Theorem preservation : forall t t' T,
      empty |- t ? T ->
      t --> t' ->
      empty |- t' ? T.
  Proof with eauto.
    remember (@empty ty) as Gamma.
    intros t t' T HT. generalize dependent t'.
    induction HT; intros t' HE.
    - subst Gamma. subst. solve [inversion HE; subst; auto].
    - subst Gamma. subst. solve [inversion HE; subst; auto].
    - subst. inversion HE; subst...
      + apply substitution_preserves_typing with T11...
        inversion HT1...
      + eapply T_App.
        * apply IHHT1. reflexivity. apply H2.
        * apply HT2.
      + eapply T_App.
        * apply HT1.
        * apply IHHT2. reflexivity. apply H3.
    - inversion HE.
    - inversion HE; subst.
      + apply T_Scc. apply IHHT.
        * reflexivity.
        * apply H0.
      + apply T_Const.
    - inversion HE; subst.
      + apply T_Prd. apply IHHT.
        * reflexivity.
        * apply H0.
      + apply T_Const.
    - inversion HE; subst.
      + apply T_Mlt.
        * apply IHHT1.
          reflexivity.
          apply H2.
        * apply HT2.
      + apply T_Mlt.
        * apply HT1.
        * apply IHHT2.
          reflexivity.
          apply H3.
      + apply T_Const.
    - inversion HE; subst.
      + apply HT3.
      + apply HT2.
      + apply T_Test0.
        * apply IHHT1. reflexivity. apply H3.
        * apply HT2.
        * apply HT3.
  Qed.

  Lemma canonical_forms_fun : forall t T1 T2,
      empty |- t ? (Arrow T1 T2) ->
      value t ->
      exists x u, t = abs x T1 u.
  Proof.
    intros t T1 T2 H1 Hv.
    inversion H1; subst; inversion Hv.
    eexists. eexists. reflexivity.
  Qed.

  Theorem progress : forall t T,
      empty |- t ? T ->
      value t \/ exists t', t --> t'.
  Proof.
    intros t T H.
    remember (@empty ty) as Gamma.
    induction H.
    - subst. inversion H.
    - left. apply v_abs.
    - right. destruct IHhas_type1; subst.
      + reflexivity.
      + destruct IHhas_type2; subst.
        * reflexivity.
        * apply (canonical_forms_fun t1 T11 T12 H) in H1.
          destruct H1. destruct H1. subst.
          eexists. apply ST_AppAbs. apply H2.
        * subst. destruct H2.  eexists. apply ST_App2. apply H1.
          apply H2.
      + subst. destruct H1. eexists. apply ST_App1. apply H1.
    - subst. left. apply v_const.
    - subst. destruct IHhas_type.
      + reflexivity.
      + right. inversion H0; subst.
        * inversion H.
        * eexists. apply ST_Scc2.
      + right. inversion H0. eexists. apply ST_Scc1. apply H1.
    - subst. destruct IHhas_type.
      + reflexivity.
      + right. inversion H0; subst.
        * inversion H.
        * eexists. apply ST_Prd2.
      + right. inversion H0. eexists. apply ST_Prd1. apply H1.
    - subst. destruct IHhas_type1.
      + reflexivity.
      + destruct IHhas_type2.
        * reflexivity.
        * inversion H1; subst.
          { inversion H. }
          { inversion H2; subst.
            { inversion H0. }
            { right. eexists. apply ST_Mlt3; assumption. }
          }
        * right. inversion H1; subst.
          { inversion H. }
          { destruct H2. eexists. apply ST_Mlt2. apply H1. apply H2. }
      + right. destruct H1. eexists. apply ST_Mlt1. apply H1.
    - subst.
      assert (Heq1 : value t1 \/ (exists t' : tm, t1 --> t')).
      { apply IHhas_type1. reflexivity. }
      assert (Heq2 : value t2 \/ (exists t' : tm, t2 --> t')).
      { apply IHhas_type2. auto. }
      assert (Heq3 : value t3 \/ (exists t' : tm, t3 --> t')).
      { auto. }
      destruct Heq1.
      + inversion H2; subst.
        * inversion H.
        * destruct n.
          { right. eexists. apply ST_TestZero. }
          { right. eexists. apply ST_TestNonZero. apply Gt.gt_Sn_O. }
      + destruct H2; subst. right.
        eexists. apply ST_Test. apply H2.
  Qed.

End STLCArith.


(* Make [lia] work for [N] *)

Require Import Coq.Arith.Arith Coq.micromega.Lia Coq.NArith.NArith.
Require Import Coq.ZArith.ZArith.

Local Open Scope N_scope.

Hint Rewrite Nplus_0_r nat_of_Nsucc nat_of_Nplus nat_of_Nminus
  N_of_nat_of_N nat_of_N_of_nat
  nat_of_P_o_P_of_succ_nat_eq_succ nat_of_P_succ_morphism : N.

Theorem nat_of_N_eq : forall n m,
  nat_of_N n = nat_of_N m
  -> n = m.
  intros ? ? H; apply (f_equal N_of_nat) in H;
    autorewrite with N in *; assumption.
Qed.

Theorem Nneq_in : forall n m,
  nat_of_N n <> nat_of_N m
  -> n <> m.
  congruence.
Qed.

Section omega_compat.

Local Ltac omega ::= lia.

Theorem Nneq_out : forall n m,
  n <> m
  -> nat_of_N n <> nat_of_N m.
  intuition.
Qed.

End omega_compat.

Theorem Nlt_out : forall n m, n < m
  -> (nat_of_N n < nat_of_N m)%nat.
  unfold N.lt; intros ?? H.
  rewrite nat_of_Ncompare in H.
  apply nat_compare_Lt_lt; assumption.
Qed.

Theorem Nlt_in : forall n m, (nat_of_N n < nat_of_N m)%nat
  -> n < m.
  unfold N.lt; intros.
  rewrite nat_of_Ncompare.
  apply (proj1 (nat_compare_lt _ _)); assumption.
Qed.

Theorem Nge_out : forall n m, n >= m
  -> (nat_of_N n >= nat_of_N m)%nat.
  unfold N.ge; intros ?? H.
  rewrite nat_of_Ncompare in H.
  apply nat_compare_ge; assumption.
Qed.

Theorem Nge_in : forall n m, (nat_of_N n >= nat_of_N m)%nat
  -> n >= m.
  unfold N.ge; intros.
  rewrite nat_of_Ncompare.
  apply nat_compare_ge; assumption.
Qed.

Ltac nsimp H := simpl in H; repeat progress (autorewrite with N in H; simpl in H).

Ltac pre_nomega :=
  try (apply nat_of_N_eq || apply Nneq_in || apply Nlt_in || apply Nge_in); simpl;
    repeat (progress autorewrite with N; simpl);
    repeat match goal with
             | [ H : _ <> _ |- _ ] => apply Nneq_out in H; nsimp H
             | [ H : _ = _ -> False |- _ ] => apply Nneq_out in H; nsimp H
             | [ H : _ |- _ ] => (apply (f_equal nat_of_N) in H
               || apply Nlt_out in H || apply Nge_out in H); nsimp H
           end.

Ltac nomega := pre_nomega; omega || (unfold nat_of_P in *; simpl in *; omega).


(** * prop: Propositions ([Prop]) as a bounded distributive lattice *)

Require Import lattice.

(** lattice operations *)

Canonical Structure Prop_lattice_ops: lattice.ops := {|
  leq := impl;
  weq := iff;
  cup := or;
  cap := and;
  neg := not;
  bot := False;
  top := True
|}.

(** bounded distributive lattice laws
   (we could get a Boolean lattice by assuming excluded middle) *)

#[export] Instance Prop_lattice_laws: lattice.laws (BDL+STR+CNV+DIV) Prop_lattice_ops.
Proof.
  constructor; (try apply Build_PreOrder); simpl;
    repeat intro; try discriminate; tauto.
Qed.

(** we could also equip Prop with a flat monoid structure, but this is
   not useful in practice *)
(*
Require Import monoid.

CoInductive Prop_unit := Prop_tt.

Canonical Structure Prop_ops: monoid.ops := {|
  ob := Prop_unit;
  mor n m := Prop_lattice_ops;
  dot n m p := and;
  one n := True;
  str n x := True;
  cnv n m x := x;
  ldv n m p := impl;
  rdv n m p := impl
|}.

Notation Prop' := (Prop_ops Prop_tt Prop_tt).

Instance Prop_laws: laws (BDL+STR+CNV+DIV) Prop_ops.
Proof.
  constructor; [intros; apply Prop_lattice_laws |..];
    (try now left); repeat right; simpl; try tauto.
Qed.
*)


Set Implicit Arguments.
Unset Strict Implicit.

Require Export nnum_base.
Require Import aac.
Require Export quotient.

Module CAxioms.
Export Ordered_ring.

Parameter cNum :  E.
Parameter rNum : E.

Axiom rNum_sub_cNum : sub rNum cNum.
Axiom nNum_sub_rNum : sub nNum rNum.

Definition nNum_sub_cNum := sub_trans nNum_sub_rNum rNum_sub_cNum.

Notation ℕ := nNum.
Notation ℝ := rNum.
Notation ℂ := cNum.

Lemma r0_inc : inc n0 rNum.
Proof.
ap nNum_sub_rNum. nSolveS.
Qed.

Lemma c0_inc : inc n0 cNum.
Proof.
ap nNum_sub_cNum. nSolveS.
Qed.

Lemma r1_inc : inc n1 rNum.
Proof.
ap nNum_sub_rNum. nSolveS.
Qed.

Lemma c1_inc : inc n1 cNum.
Proof.
ap nNum_sub_cNum. nSolveS.
Qed.

Parameters (cPlus cMult : E2).
Parameter (I : E).

Axiom I_inc : inc I cNum.

Axiom cNum_field : is_field cPlus cMult cNum n0 n1.

Axiom rNum_field : is_field cPlus cMult rNum n0 n1.

Axiom cMult_comm : commutative cMult cNum.

Axiom cPlus_nPlus : forall x, inc x nNum -> forall y, inc y nNum -> cPlus x y = nPlus x y.
Axiom cMult_nMult : forall x, inc x nNum -> forall y, inc y nNum -> cMult x y = nMult x y.

Parameter rLeq : E2P.

Axiom rLeq_to : is_total_order rLeq rNum.

Axiom rNum_ordered_field : is_ordered_field cPlus cMult rLeq rNum n0 n1.

Axiom rLeq_nLeq : forall x, inc x nNum -> forall y, inc y nNum -> rLeq x y = nLeq x y.

Axiom rNum_ex_sup : forall a, sub a rNum -> nonempty a -> ex (is_upper_bound rNum rLeq a) ->
ex (is_super rNum rLeq a).

Definition cOpp := Lci.inverse_of cPlus cNum n0.

Axiom I_2 : cMult I I = cOpp n1.

Axiom complex_parts_unicity : forall a, inc a rNum -> forall b, inc b rNum ->
forall a', inc a' rNum -> forall b', inc b' rNum -> cPlus a (cMult I b) = cPlus a' (cMult I b') ->
(a=a' & b=b').

End CAxioms.
Export CAxioms.


Require Import Ensembles List Coq.Lists.SetoidList Tuple QueryStructure.

Definition EnsembleListEquivalence {A: Type} (ensemble: A -> Prop) (seq: list A) :=
  NoDup seq /\
  forall x, Ensembles.In _ ensemble x <-> List.In x seq.

Definition UnIndexedEnsembleListEquivalence
           {heading} R (l : list (@Tuple heading))  :=
  exists l', (map indexedTuple l') = l /\
  EnsembleListEquivalence R l'.

Definition UnConstrFreshIdx {heading} (R : Ensemble (@IndexedTuple heading)) (bound : nat) :=
  forall tup, R tup -> lt (tupleIndex tup) bound.

Definition EnsembleIndexedListEquivalence {heading}
           (R : Ensemble (@IndexedTuple heading))
           (l : list (@Tuple heading)) :=
  (exists bound, UnConstrFreshIdx R bound)
  /\ UnIndexedEnsembleListEquivalence R l.

Instance EnsembleListEquivalence_AbsR {heading}:
  @UnConstrRelationAbsRClass (@IndexedTuple heading)
                             (list (@Tuple heading)) :=
  {| UnConstrRelationAbsR := @EnsembleIndexedListEquivalence heading|}.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path.

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

Lemma nilp_rev (T : Type) (s : seq T) : nilp (rev s) = nilp s.
Proof. by move: s (rev s) (size_rev s) => [|? ?] []. Qed.

Lemma ifnilE (T A : Type) (s : seq T) (a b : A) :
  (if s is [::] then a else b) = if nilp s then a else b.
Proof. by case: s. Qed.

Lemma relpre_trans {T' T : Type} {leT : rel T} {f : T' -> T} :
  transitive leT -> transitive (relpre f leT).
Proof. by move=> + y x z; apply. Qed.

Lemma allrel_revl {T S : Type} (r : T -> S -> bool) (s1 : seq T) (s2 : seq S) :
  allrel r (rev s1) s2 = allrel r s1 s2.
Proof. exact: all_rev. Qed.

Lemma allrel_revr {T S : Type} (r : T -> S -> bool) (s1 : seq T) (s2 : seq S) :
  allrel r s1 (rev s2) = allrel r s1 s2.
Proof. by rewrite allrelC allrel_revl allrelC. Qed.

Lemma allrel_rev2 {T S : Type} (r : T -> S -> bool) (s1 : seq T) (s2 : seq S) :
  allrel r (rev s1) (rev s2) = allrel r s1 s2.
Proof. by rewrite allrel_revr allrel_revl. Qed.

Lemma eq_allrel_l {T : eqType} {S} (r : T -> S -> bool) (s1 s1' : seq T) s2 :
  s1 =i s1' -> allrel r s1 s2 = allrel r s1' s2.
Proof. by move=> eqs1; apply: eq_all_r. Qed.

Lemma eq_allrel_r {T} {S : eqType} (r : T -> S -> bool) s1 (s2 s2' : seq S) :
  s2 =i s2' -> allrel r s1 s2 = allrel r s1 s2'.
Proof. by rewrite ![allrel _ s1 _]allrelC; apply: eq_allrel_l. Qed.

Lemma eq_allrel2 {T S : eqType} (r : T -> S -> bool)
    (s1 s1' : seq T) (s2 s2' : seq S) :
  s1 =i s1' -> s2 =i s2' -> allrel r s1 s2 = allrel r s1' s2'.
Proof. by move=> /eq_allrel_l -> /eq_allrel_r ->. Qed.