(** * TAL-0 Typed Assembly Language *)

(** Based on paper by Greg Morrisett , TAL-0 is the design of a RISC-style typed assembly language which focuses on control-flow safety. This post provides a mechanized metatheory, particularly a machine checked proof of soundness of the TAL-0 type system as proposed by the author in section 4.2.10 of the book Advanced Topics in Types and Programming Languages.  *)

(** The TAL-0 language runs on an abstract machine which is represented by 3 components :

1. A heap H which is a finite, partial map from labels to heap values

2. a register file R which is a total map from registers to values, and

3. a current instruction sequence I.
*)

Require Import Bool Arith Vector.
Require Import LibTactics Maps.

Definition registers := total_map nat.
Definition empty_regs : registers := t_empty 0.

Inductive val : Type :=
 | ANum : nat -> val
 | AReg : nat -> val
 | ALab : nat -> val.

(** We denote addresses of instructions stored in the heap as labels. Unlike a typical machine where labels are resolved to some machine address, which are integers, we maintain a distinction between labels and arbit integers, as this complies with our goal to state and prove the control-flow safety i.e. we can only branch to a valid label, and not to any arbit integer. This will ensure that the machine never gets stuck while trying to do some invalid operation. *)
(*define relations for aeval , ieval*)
Fixpoint aeval (a : val) (R : registers) : nat :=
  match a with
 | ANum n => n
 | AReg d => R (Id d)
 | ALab l => l
  end.

Inductive instr : Type :=
 | IMov : forall d : nat,
    val -> instr
 | IAdd : forall d s : nat,
    instr
 | ISub : forall d v : nat,
    instr
 | IIf : forall d : nat,
    val -> instr.

Inductive instr_seq : Type :=
 | ISeq : instr -> instr_seq -> instr_seq
 | IJmp : val -> instr_seq.

(** Simple Notations are chosen for the sake of clarity while writing programs.*)
Notation "'R(' d ')' ':=' a" :=
  (IMov d (ANum a)) (at level 60).
Notation "'R(' d ')' '+:=' 'R(' s ')'" :=
  (IAdd d s) (at level 60).
Notation "'R(' s ')' '-:=' v" :=
  (ISub s v) (at level 60).
Notation "i1 ;; i2" :=
  (ISeq i1 i2) (at level 80, right associativity).
Notation "'JIF' 'R(' d ')' v" :=
  (IIf d (ANum v)) (at level 70).
Notation "'JMP' v" :=
  (IJmp (ALab v)) (at level 80).
Notation "'JMP' 'R(' r ')'" :=
  (IJmp (AReg r)) (at level 80).

Check JIF R(1) 2.
Check R(1) := 10.
Check R(2) +:= R(1).
Check R(2) -:= 1.
Check R(2) +:= R(1) ;; R(2) -:= 1 ;; JMP 2.
Check JMP 2.
Check JMP R(2).

Definition heaps := partial_map instr_seq.
Definition empty_heap : heaps := empty.

(* Machine State *)
Inductive st : Type :=
 | St : heaps -> registers -> instr_seq -> st.

(** Evaluation of instructions is supposed to change the Machine State and thus some of its components H, R or I. These changes are posed as relations between initial and final state of the machine. *)
Inductive ieval : st -> st -> Prop :=
 | R_IMov : forall H R I d a,
    ieval (St H R (R(d) := a ;; I)) (St H (t_update R (Id d) a) I)
 | R_IAdd : forall H R I d s,
     ieval (St H R (R(d) +:= R(s) ;; I)) (St H (t_update R (Id d) (aeval (AReg d) R + aeval (AReg s) R)) I)
 | R_ISub : forall H R I d v,
     ieval (St H R (R(d) -:= v ;; I)) (St H (t_update R (Id d) (aeval (AReg d) R - aeval (ANum v) R)) I)
 | R_IJmp_Succ : forall H R I' a l,
     l = (aeval a R) -> H (Id l) = Some I' -> ieval (St H R (JMP l)) (St H R I')
 | R_IJmpR_Succ : forall H R I' r,
     H (Id (R (Id r))) = Some I' -> ieval (St H R (JMP R(r))) (St H R I')
 | R_IJmp_Fail : forall H R I a,
     H (Id (aeval a R)) = None -> ieval (St H R I) (St H R I)
 | R_IIf_EQ : forall H R I I2 r v,
     aeval (AReg r) R = 0 -> (H (Id v)) = Some I2 -> ieval (St H R (JIF R(r) v ;; I)) (St H R I2)
 | R_IIf_NEQ : forall H R I r v,
     aeval (AReg r) R <> 0 -> ieval (St H R (JIF R(r) v ;; I)) (St H R I)
 | R_ISeq : forall st st' st'',
     ieval st st' -> ieval st' st'' -> ieval st st''.

(** Example of a program fragment that multiplies 2 numbers stored in registers 1 and 2 and stores their product in register 3, before finally looping in its final state register 4. *)
Definition init_heap := update (update (update empty_heap (Id 1) (R(3) := 0 ;; JMP 2)) (Id 2) (JIF R(1) 3 ;; R(2) +:= R(3) ;; R(1) -:= 1 ;; JMP 2) ) (Id 3) (JMP R(4)).

Definition init_regs : registers :=  (t_update (t_update  (t_update (t_update (t_update empty_regs (Id 5) 1) (Id 6) 2) (Id 7) 3) (Id 1) 1) (Id 2) 2).
Definition final_regs : registers := (t_update (t_update (t_update  (t_update (t_update (t_update empty_regs (Id 5) 1) (Id 6) 2) (Id 4) 1) (Id 1) 0) (Id 2) 2) (Id 3) 2).

Eval compute in init_heap (Id (init_regs (Id 6))).

(* jump to a label proof *)
Example ieval_example1 : ieval (St init_heap init_regs
                          (R(3) := 0 ;; JMP 2))
                               (St init_heap (t_update init_regs (Id 3) 0)
                          (JIF R(1) 3 ;; R(2) +:= R(3) ;; R(1) -:= 1 ;; JMP 2)).
Proof.
  apply R_ISeq with (St init_heap (t_update init_regs (Id 3) 0) (IJmp (ALab 2))).
  apply R_IMov.
  apply R_IJmp_Succ with (a := ALab 2).
  simpl.
  reflexivity.
  unfold init_heap.
  rewrite update_neq.
  rewrite update_eq.
  reflexivity.
  rewrite <- beq_id_false_iff; trivial.
Qed.

(** The types consist of
1. int -> represents arbit integer stored in a register

2. reg -> a type constructor. Takes as input, the type of the register, to which this register is pointing.

3. code -> takes as input a typing context Γ, and gives type (code Γ) which is the type of an instruction sequence that expects type of the Register file to be Γ before it begins execution

4. arrow -> represents type of a single instruction (excluding JMP), which expects register file of type Γ1 before execution, and changes it to Γ2 after it has executed.

5. T -> It is the super type. It is used to represent the type of a register in R, which contains the label of the instruction currently executing. Because in such a case, we have the equation : Γ (r) = code Γ, which in the absence of subtyping or polymorphic types can't be solved. Hence T is assigned the type for such a register as it subsumes all types including itself. When we jump through a register of type T, we forget the type assigned to it, and reassign T to it.
Morrisett's paper uses the polymorphic type for due to some more benefits it affords. However we have used T type for its simplicity.
 *)

Inductive ty : Type :=
 | int : ty
 | reg : ty -> ty
 | code : partial_map ty -> ty
 | arrow : partial_map ty -> partial_map ty -> ty
 | True : ty.

Definition context := partial_map ty.

(* register file types *)
Definition empty_Gamma : context := empty.

(* heap types *)
Definition empty_Psi : context := empty.

(** The Typing Rules *)
(** Ψ is a partial map containing types of instruction sequences. As all instruction sequences end in a JMP statement, all valid values in Ψ are Some (code Γ) where Γ is the initial type state of register expected by that instruction sequence. Now, typing rules may require presence of either both Ψ and Γ, or only Ψ or neither. Hence, we introduce a combined context structure, that handles all the 3 cases. *)
Inductive cmbnd_ctx :=
 | EmptyCtx : cmbnd_ctx
 | PsiCtx : context -> cmbnd_ctx
 | PsiGammaCtx : context -> context -> cmbnd_ctx.

(** Typing rules for arithmetic expressions *)
Inductive ahas_type : cmbnd_ctx -> val -> ty -> Prop :=
 | S_Int : forall Ψ n,
     ahas_type (PsiCtx Ψ) (ANum n) int
 | S_Lab : forall Ψ Γ l v R,
     Ψ (Id l) = Some (code Γ) -> l = aeval (ALab v) R -> ahas_type (PsiCtx Ψ) (ALab v) (code Γ)
 | S_Reg : forall Ψ Γ r,
     Γ (Id r) = Some (reg int) -> ahas_type (PsiGammaCtx Ψ Γ) (AReg r) (reg int)
 | S_RegV : forall Ψ Γ r,
     ahas_type (PsiGammaCtx Ψ Γ) (AReg r) (reg (code Γ))
 | S_RegT : forall Ψ Γ r,
     ahas_type (PsiGammaCtx Ψ Γ) (AReg r) True
 | S_Val : forall Ψ Γ a tau,
     ahas_type (PsiCtx Ψ) a tau -> ahas_type (PsiGammaCtx Ψ Γ) a tau.

Hint Constructors ahas_type.

(** Typing rules for instructions *)
Inductive ihas_type : cmbnd_ctx -> instr -> ty -> Prop :=
 | S_Mov : forall Ψ Γ R d a tau,
    ahas_type (PsiGammaCtx Ψ Γ) a tau -> ahas_type (PsiGammaCtx Ψ Γ) (AReg d) (reg tau) -> (update Γ (Id d) (reg tau)) = Γ -> ihas_type (PsiCtx Ψ) (R(d) := aeval a R) (arrow Γ Γ)
 | S_Add : forall Ψ Γ d s,
    ahas_type (PsiGammaCtx Ψ Γ) (AReg s) (reg int) -> ahas_type (PsiGammaCtx Ψ Γ) (AReg d) (reg int) -> update Γ (Id d) (reg int) = Γ -> ihas_type (PsiCtx Ψ) (R(d) +:= R(s)) (arrow Γ Γ)
 | S_Sub : forall Ψ Γ s a v,
      ahas_type (PsiGammaCtx Ψ Γ) a int -> ahas_type (PsiGammaCtx Ψ Γ) (AReg s) (reg int) -> a = ANum v -> ihas_type (PsiCtx Ψ) (R(s) -:= v) (arrow Γ Γ)
 | S_If :  forall Ψ Γ r v,
     ahas_type (PsiGammaCtx Ψ Γ) (AReg r) (reg int) -> ahas_type (PsiGammaCtx Ψ Γ) (ALab v) (code Γ) -> ihas_type (PsiCtx Ψ) (JIF R(r) v) (arrow Γ Γ).
Hint Constructors ihas_type.

Inductive iseq_has_type : cmbnd_ctx -> instr_seq -> ty -> Prop :=
 | S_Jmp :  forall Ψ Γ v,
     ahas_type (PsiGammaCtx Ψ Γ) (ALab v) (code Γ) -> iseq_has_type (PsiCtx Ψ) (JMP v) (code Γ)
 | S_JmpT :  forall Ψ Γ v,
     ahas_type (PsiGammaCtx Ψ Γ) (AReg v) True -> iseq_has_type (PsiCtx Ψ) (JMP R(v)) (code Γ)
 | S_Seq :  forall Ψ i1 i2 Γ Γ2,
     ihas_type (PsiCtx Ψ) i1 (arrow Γ Γ2) -> iseq_has_type (PsiCtx Ψ) i2 (code Γ2) -> iseq_has_type (PsiCtx Ψ) (ISeq i1 i2) (code Γ).                                           Hint Constructors iseq_has_type.

Definition init_Gamma : context := update (update (update (update empty_Gamma (Id 1) (reg int)) (Id 2) (reg int)) (Id 3) (reg int)) (Id 4) True.
Check init_Gamma.
Hint Unfold init_Gamma.

Definition init_Psi : context := update (update (update empty_Psi (Id 1) (code init_Gamma))(Id 3) (code init_Gamma)) (Id 2) (code init_Gamma).
Hint Unfold init_Psi.

Ltac match_map := repeat (try rewrite update_neq; try rewrite update_eq; try reflexivity).
Ltac inequality := (rewrite <- beq_id_false_iff; trivial).
Ltac crush_map := match_map ; inequality; try reflexivity.

Ltac rewrite_hyp :=
     match goal with
       | [ H : ?n = _ |- context[?n] ] => rewrite H
     end.

Ltac crush_generic :=
  repeat match goal with
         | [ H : ?T |- ?T    ] => exact T
         | [ |- ?T = ?T ] => reflexivity
         | [ |- True         ] => constructor
         | [ |- _ /\ _       ] => constructor
         | [ |- _ /\ _ -> _  ] => intro
         | [ H : _ /\ _ |- _ ] => destruct H
         | [ |- nat -> _     ] => intro
         | _ => rewrite_hyp || eauto || jauto
         end.

Ltac crush :=
  repeat (crush_generic; match goal with
                         | [ |- update _ _ _ _ = _ ] => crush_map
                         | [ |- init_Gamma _ = _ ] => unfold init_Gamma
                         | [ |- init_Psi _ = _ ] => unfold init_Psi
                         | [ |- ieval _ _ ] => constructor; auto
                         | [ |- ihas_type _ _ _] => constructor; auto
                         | [ |- ?T -> False  ]  => assert T
                         | _ => try subst; trivial
                         end).

Example heap_2_type : forall I (R : registers), (init_heap (Id 2)) = Some I -> iseq_has_type (PsiCtx init_Psi) I (code init_Gamma).
Proof.
  intros.
  unfold init_heap in H.
  rewrite update_neq in H.
  rewrite update_eq in H.
  symmetry in H.
  inversion H.
  apply S_Seq with (Γ2 := init_Gamma).
  crush.
  constructor; auto.
  apply S_Lab with (l := 3) (R := R).
  crush.
  trivial.
  apply S_Seq with (Γ2 := init_Gamma).
  constructor; auto.
  crush.
  apply update_same.
  crush.
  apply S_Seq with (Γ2 := init_Gamma).
  unfold init_Psi.
  apply S_Sub with (a := ANum 1).
  unfold init_Psi.
  constructor; auto.
  constructor; auto.
  constructor; auto.
  constructor; auto.
  constructor; auto.
  apply S_Lab with (l := 2) (R := R).
  crush.
  trivial.
  trivial.
  rewrite <- beq_id_false_iff.
  trivial.
Qed.

(** Typing rule for register file *)
Inductive Rhas_type : cmbnd_ctx -> registers -> context -> Prop :=
| S_Regfile : forall Ψ Γ R r tau a,
    (Γ (Id r)) = Some tau -> aeval a R = R (Id r) -> ahas_type (PsiGammaCtx Ψ Γ) a tau -> Rhas_type (PsiCtx Ψ) R Γ.

Hint Constructors Rhas_type.

(** Typing rule for Heap *)
Inductive Hhas_type : cmbnd_ctx -> heaps -> context -> Prop :=
| S_Heap : forall Ψ H,
    (forall l tau, exists is, Ψ (Id l) = Some tau /\ H (Id l) = Some is /\ iseq_has_type (PsiCtx Ψ) is tau) -> Hhas_type EmptyCtx H Ψ.

Hint Constructors Hhas_type.

(** Typing rule for a valid Machine State *)
Inductive M_ok : cmbnd_ctx -> heaps -> registers -> instr_seq -> Prop :=
| S_Mach : forall H R Is Ψ Γ,
    Hhas_type EmptyCtx H Ψ -> Rhas_type (PsiCtx Ψ) R Γ -> iseq_has_type (PsiCtx Ψ) Is (code Γ) -> M_ok EmptyCtx H R Is.

Hint Constructors M_ok.

(** We will require some Canonical Values Lemmas in our proof of Soundness *)
Lemma Canonical_Values_Int : forall H Ψ Γ v tau,
    Hhas_type EmptyCtx H Ψ -> ahas_type (PsiGammaCtx Ψ Γ) v tau -> tau = int -> exists n, v = ANum n.
Proof.
  intros.
  subst.
  inversion H1.
  inversion H6.
  exists n.
  crush.
Qed.

Lemma Canonical_Values_Reg :forall H Ψ Γ r R,
    Hhas_type EmptyCtx H Ψ -> Rhas_type (PsiCtx Ψ) R Γ -> ahas_type (PsiGammaCtx Ψ Γ) (AReg r) (reg int) -> exists (n : nat), R (Id r) = n.
Proof.
  intros.
  exists (R (Id r)).
  crush.
Qed.

Lemma Canonical_Values_label1 : forall H Ψ Γ v,
    Hhas_type EmptyCtx H Ψ -> ahas_type (PsiGammaCtx Ψ Γ) (ALab v) (code Γ) ->  Ψ (Id v) = Some (code Γ) -> exists is, H (Id v) = Some is /\ iseq_has_type (PsiCtx Ψ) is (code Γ).
Proof.
  intros.
  inversion H0.
  inversion H1.
  inversion H7.
  simpl in H5.
  specialize H4 with ( l := v) (tau := code Γ).
  destruct H4 as [i G].
  exists i.
  crush.
Qed.

Lemma Canonical_Values_label2 : forall H Ψ Γ R r,
    Hhas_type EmptyCtx H Ψ -> ahas_type (PsiGammaCtx Ψ Γ) (AReg r) True -> exists is, H (Id (R (Id r))) = Some is /\ iseq_has_type (PsiCtx Ψ) is (code Γ).
Proof.
  intros.
  inversion H0.
  inversion H1.
  specialize H3 with ( l := R (Id r)) (tau := (code Γ)).
  destruct H3 as [i G].
  exists i.
  apply G.
  specialize H3 with ( l := R (Id r)) (tau := (code Γ)).
  destruct H3 as [i G].
  exists i.
  crush.
 Qed.

(** Finally the proof of Soundness *)
Theorem Soundness : forall H R Is,
    M_ok EmptyCtx H R Is -> exists H' R' Is', ieval (St H R Is) (St H' R' Is') /\ M_ok EmptyCtx H' R' Is'.
Proof.
  intros.
  inversion H0 ; induction Is; inverts H4.
  induction i; inversion H12;
   try match goal with
    | [H : Γ = Γ2 |- _ ] => symmetry in H
    end;
    try subst.

  (* ISeq IMov I *)
  exists H (t_update R (Id d) (aeval a R1)) Is.
  crush.
  apply S_Mach with (Ψ := Ψ) (Γ := Γ).
  crush.
  apply S_Regfile with (r := d) (tau := reg tau) (a := AReg d).
  rewrite <- H16.
  rewrite update_eq.
  crush.
  crush.
  crush.
  crush.

  (* ISeq IAdd I *)
  exists H (t_update R (Id d) (aeval (AReg d) R + aeval (AReg s) R)) Is.
  split.
  crush.
  apply S_Mach with (Ψ := Ψ) (Γ := Γ).
  crush.
  apply S_Regfile with (a := AReg d) (r := d) (tau := reg int).
  rewrite <- H16; apply update_eq.
  crush.
  crush.
  crush.

  (* ISeq ISub I *)
  exists H (t_update R (Id d) (aeval (AReg d) R - aeval (ANum v) R)) Is.
  split.
  crush.
  apply S_Mach with (Ψ := Ψ) (Γ := Γ).
  crush.
  apply S_Regfile with (a := AReg d) (r := d) (tau := reg int).
  inversion H15.
  crush.
  crush.
  inversion H15.
  crush.
  inversion H7.
  trivial.
  crush.
  crush.

  (* ISeq IIf I *)
  inversion H12.
  inversion H9.
  inversion H18.
  subst.
  simpl in H22.

  remember (R (Id d)) as rd; destruct rd.
  pose proof Canonical_Values_label1 H Ψ Γ v0 H2 H9 H22 as CVL1.
  destruct CVL1 as [Is' G].
  exists H R Is'.
  crush.

  exists H R Is.

  split.
  apply R_IIf_NEQ.
  simpl.
  symmetry in Heqrd; rewrite Heqrd.
  apply beq_nat_false_iff.
  trivial.
  crush.

  (*IJmp*)
  inversion H11; inversion H12.
  simpl in H17.
  subst.
  pose proof Canonical_Values_label1 H Ψ Γ v0 H2 H11 H16 as CVL1.
  destruct CVL1 as [Is G].

  exists H R Is.
  crush.
  apply R_IJmp_Succ with (a := ALab v0).
  crush.
  crush.

  (*IJmpT*)
  pose proof Canonical_Values_label2 H Ψ Γ R v0 H2 H11 as CVL3.
  destruct CVL3 as [Is G].

  exists H R Is.
  crush.
Qed.


(* Steve Awodey's book on category theory *)
(******************************************************************************)
(* Chapter 1.3: Categories                                                    *)
(******************************************************************************)
(* @suharahiromichi *)

(*
(1) ベースライン
http://www.megacz.com/berkeley/coq-categories/
これをもとに改変。Instance ... Proper を使うようにした。
 *)

(*
(2) Proper関数の定義
A Gentle Introduction to Type Classes and Relations in Coq
*)

(*
(3) Setoid を使うようにし、Setsと(P,<=)のインスタンスをつくる。
http://www.iij-ii.co.jp/lab/techdoc/category/category1.html
 *)

(*
できるだけ Generalizable を使う。
 *)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import finset fintype.

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

Require Import Notations.
Require Import Morphisms.
Require Import Coq.Setoids.Setoid.

(*
Reserved Notation "x ~> y" (at level 51, left associativity).
*)
Reserved Notation "x \\o y" (at level 51, left associativity).
Reserved Notation "x === y" (at level 71, left associativity).

Generalizable Variables a b c d e x.
Generalizable Variables Obj.

(* Calss Setoid (carrier : Type) とするのは難しい。なぜ？ *)
Class Setoid : Type :=
  {
    carrier : Type;
    eqv : carrier -> carrier -> Prop;
    eqv_equivalence : Equivalence eqv
  }.
Coercion carrier : Setoid >-> Sortclass.
Notation "x === y" := (eqv x y).

Class Category `(Hom : Obj -> Obj -> Setoid) : Type :=
  {
    hom := Hom where "a ~> b" := (hom a b);
    obj := Obj;
    id   : forall {a : Obj}, (a ~> a);
    comp : forall {a b c : Obj},
             (b ~> c) -> (a ~> b) -> (a ~> c)
                                       where "f \\o g" := (comp f g);
    comp_respects   : forall {a b c : Obj},
                        Proper (eqv ==> eqv ==> eqv) (@comp a b c);
    left_identity   : forall `{f : a ~> b}, id \\o f === f;
    right_identity  : forall `{f : a ~> b}, f \\o id === f;
    associativity   : forall `{f : c ~> d} `{g : b ~> c} `{h : a ~> b},
                        f \\o g \\o h === f \\o (g \\o h)
}.
Coercion obj : Category >-> Sortclass.

Notation "a ~> b"  := (hom a b).
Notation "f \\o g" := (comp f g).
(* Notation "a ~~{ C }~~> b" := (@hom _ _ C a b). *)

(* eqv が、Reflexive と Symmetric と Transitive とを満たす。 *)
Instance category_eqv_Equiv `(C : Category Obj) (a b : Obj) :
  Equivalence (@eqv (a ~> b)).
Proof.
  by apply eqv_equivalence.
Qed.

(* comp は eqv について固有関数である。 *)
Instance category_comp_Proper `(C : Category Obj) (a b c : Obj) :
  Proper (@eqv (b ~> c) ==> @eqv (a ~> b) ==> @eqv (a ~> c)) comp.
Proof.
  by apply comp_respects.
Qed.

(* 可換性についての定理を証明する。 *)
Lemma juggle1 : forall `{C : Category}
                       `(f : d ~> e) `(g : c ~> d) `(h : b ~> c) `(k : a ~> b),
                  f \\o g \\o h \\o k === f \\o (g \\o h) \\o k.
Proof.
  intros.
  rewrite <- associativity.
  reflexivity.
Defined.

Lemma juggle2 : forall `{C : Category}
                       `(f : d ~> e) `(g : c ~> d) `(h : b ~> c) `(k : a ~> b),
                  f \\o (g \\o (h \\o k)) === f \\o (g \\o h) \\o k.
Proof.
  intros.
  do ! rewrite <- associativity.
  reflexivity.
Defined.

Lemma juggle3 : forall `{C : Category}
                       `(f : d ~> e) `(g : c ~> d) `(h : b ~> c) `(k : a ~> b),
                  f \\o g \\o (h \\o k) === f \\o (g \\o h) \\o k.
Proof.
  intros.
  do ! rewrite <- associativity.
  reflexivity.
Defined.

Reserved Notation "x &&& y" (at level 50, left associativity).

(* 直積 *)
Class Product `{C : Category Obj} (Prod : Obj -> Obj -> Obj) : Type :=
  {
    obj' := Obj;
    proj1 : forall {a b : Obj}, (Prod a b) ~> a;
    proj2 : forall {a b : Obj}, (Prod a b) ~> b;

    (* 仲介射 *)
    mediating : forall {a b x : Obj},
                  (x ~> a) -> (x ~> b) -> (x ~> (Prod a b))
                                            where "f &&& g" := (mediating f g);

    med_commute1 : forall `(f : x ~> a) `(g : x ~> b),
                     proj1 \\o (f &&& g) === f;
    med_commute2 : forall `(f : x ~> a) `(g : x ~> b),
                     proj2 \\o (f &&& g) === g;
    med_unique : forall `(f : x ~> a) `(g : x ~> b) `(h : x ~> (Prod a b)),
                   proj1 \\o h === f ->
                   proj2 \\o h === g ->
                   h === (f &&& g)
  }.
Coercion obj': Product >-> Sortclass.
Notation "x &&& y" := (mediating x y).

Check @proj1 : ∀Obj Hom C Prod _ a b, Prod a b ~> a.
Check @proj2 : ∀Obj Hom C Prod _ a b, Prod a b ~> b.

Set Printing All.
Generalizable Variables Prod.
Definition parallel `{C : Category Obj} {Prod : Obj -> Obj -> Obj} {CP : Product Prod}
           `(f : a ~> b) `(g : c ~> d) : (Prod a c) ~> (Prod b d) :=
  let p1 := @proj1 Obj Hom C Prod CP a c in
  let p2 := @proj2 Obj Hom C Prod CP a c in
  (f \\o p1) &&& (g \\o p2).
Notation "f *** g" := (parallel f g).      (* <f,g> *)

(* **** *)
(* Sets *)
(* **** *)
Instance EquivExt : forall (A B : Set), Equivalence (@eqfun A B) := (* notu *)
  {
    Equivalence_Reflexive := @frefl A B;
    Equivalence_Symmetric := @fsym A B;
    Equivalence_Transitive := @ftrans A B
  }.

Instance EqMor : forall (A B : Set), Setoid :=
  {
    carrier := A -> B;
    eqv := @eqfun B A
  }.

Check @Category Set : (Set → Set → Setoid) → Type.
Check @Category Set EqMor : Type.
Check EqMor : Set -> Set -> Setoid.

Program Instance Sets : @Category Set EqMor.
Obligation 3.
Proof.
  rewrite /Sets_obligation_2.
  move=> homab homab' Hhomab hombc hombc' Hhombc.
  move=> x //=.
  rewrite Hhomab.
  rewrite Hhombc.
    by [].
Qed.

Check prod : (Type → Type → Type).
Check @Product Sets EqMor Sets prod.
Check Product prod : Type.

Program Instance SetsProd : @Product Sets EqMor Sets prod :=
  {
    proj1 A B := @fst A B;
    proj2 A B := @snd A B;
    mediating A B X := fun f g x => (f x, g x)
  }.
Obligation 3.
Proof.
  move: H H0.
  rewrite /Sets_obligation_2 => H1 H2 x'.
  rewrite -(H1 x').
  rewrite -(H2 x').
  by apply surjective_pairing.
Qed.

(* **** *)
(* P,<= *)
(* **** *)
Open Scope coq_nat_scope.
Search "_ <= _".
Check 0 <= 0 : Prop.

Definition eq_le m n (p q : m <= n) := True.

Instance EquivGeq : forall (m n : nat), Equivalence (@eq_le m n). (* notu *)
Proof.
    by [].
Qed.

Instance EqLe : forall (m n : nat), Setoid :=
  {
    carrier := m <= n;
    eqv := @eq_le m n
  }.

Check @Category nat : (nat → nat → Setoid) → Type.
Check EqLe : nat → nat → Setoid.
Check @Category nat EqLe.

Program Instance P_LE : @Category nat EqLe.
Obligation 2.
Proof.
    by apply (@Le.le_trans a b c).
Defined.
Obligation 3.
Proof.
  rewrite /P_LE_obligation_1.
  rewrite /P_LE_obligation_2.
  move=> homab homab' Hhomab hombc hombc' Hhombc.
  by rewrite /eq_le.
Defined.
Obligation 4.
Proof.
  rewrite /P_LE_obligation_1.
  rewrite /P_LE_obligation_2.
  by rewrite /eq_le.
Defined.
Obligation 5.
Proof.
  rewrite /P_LE_obligation_1.
  rewrite /P_LE_obligation_2.
  by rewrite /eq_le.
Defined.
Obligation 6.
Proof.
  rewrite /P_LE_obligation_2.
  by rewrite /eq_le.
Defined.

Check P_LE.

Check min : nat -> nat -> nat.
Check @Product P_LE EqLe P_LE min.

Program Instance P_LE_Prod : @Product P_LE EqLe P_LE min.
Obligation 1.
Proof.
  Search (min _ _ <= _).
  by apply Min.le_min_l.
Defined.
Obligation 2.
  by apply Min.le_min_r.
Defined.
Obligation 3.
Proof.
  Search (_ <= min _ _).
  by apply Min.min_glb.
Defined.
Obligation 4.
  rewrite /P_LE_obligation_1.
  rewrite /P_LE_obligation_2.
  rewrite /P_LE_obligation_3.
  by rewrite /eq_le.
Defined.
Obligation 5.
  rewrite /P_LE_obligation_1.
  rewrite /P_LE_obligation_2.
  rewrite /P_LE_obligation_3.
  by rewrite /eq_le.
Defined.

Check P_LE_Prod.

(* an application of parallel (***) *)
Check @parallel.
Lemma parallel_min : forall (m n p q : nat),
      m <= n -> p <= q -> min m p <= min n q.
Proof.
  move=> m n p q Hmn Hpq.
  Check @parallel nat EqLe P_LE min P_LE_Prod m n Hmn p q Hpq.
    by apply: (@parallel nat EqLe P_LE min P_LE_Prod m n Hmn p q Hpq).
    Undo 1.
  Check Hmn *** Hpq.
    by apply: (Hmn *** Hpq).
Qed.
Print parallel_min.

(* END *)


(*|
##########################
Proving a property on sets
##########################

:Link: https://stackoverflow.com/q/52448832
|*)

(*|
Question
********

As a Coq programming experience and following my question in `here
<https://stackoverflow.com/q/52195198/9335627>`__, I'd like to know if
there is another proof, possibly shorter and without using Lemma
``subset_listpair_conserve``, for proving Lemma
``subset_listpair_consFalse``. I proved it but it is long and uses
Lemma ``subset_listpair_consve``.
|*)

Require Import List.
Require Import Bool.

Definition entity := nat.
Definition entityID := nat.
Definition listPair : Set := list (entity * entityID).

(* check if e is in list l *)
Fixpoint in_listpair e (l : listPair) :=
  match l with
  | nil          => false
  | (x, y) :: l' => Nat.eqb e x || in_listpair e l'
  end.

(* check if list l1 is in list l2: i.e., 11 entities are in l2 *)
Fixpoint subset_listpair (l1 l2 : listPair) :=
  match l1 with
  | nil => true
  | (x1, _) :: l1 => in_listpair x1 l2 && subset_listpair l1 l2
  end.

Lemma subset_listpair_consver l1 l2 l3 e :
  in_listpair e l2 = true ->
  in_listpair e l3 = false ->
  subset_listpair l1 l2 = true ->
  subset_listpair l1 l3 = false.
Proof.
Admitted.

Lemma subset_listpair_consFalse l1 l2 l3 :
  subset_listpair l1 l2 = true ->
  subset_listpair l1 l3 = false -> subset_listpair l2 l3 = false.
Proof.
  induction l1.
  - induction l3.
    + destruct l2.
      * simpl. intros. inversion H0.
      * intros. destruct p. simpl in *. reflexivity.
    + simpl in *. intros. intuition. inversion H0.
  - intros. rewrite IHl1.
    + reflexivity.
    + simpl in H0. destruct a. simpl in H.
      rewrite andb_true_iff in H. rewrite andb_false_iff in H0.
      elim H. intros. assumption.
    + simpl in H0. destruct a. simpl in H.
      rewrite andb_true_iff in H. rewrite andb_false_iff in H0.
      elim H. intros.
      * elim H0.
        -- intros. pose proof subset_listpair_consver as H10.
           assert (subset_listpair l1 l3 = false) as H11.
           ++ rewrite H10 with (l2 := l2) (e := e).
              ** reflexivity.
              ** assumption.
              ** assumption.
              ** assumption.
           ++ assumption.
        -- intro. assumption.
Qed.

(*|
Answer
******

Here is one possible solution. I didn't go for a lemma-less proof or
for the shortest proof. Instead, I tried to break down everything into
a bite-sized chunks that are (relatively) easy to manipulate.

First, here is an auxiliary lemma missing from the standard library.
It simply states the law of contraposition in classical logic (we have
decidable propositions here, so those are kind of classical).
|*)

Reset subset_listpair_consFalse. (* .none *)
From Coq Require Import Arith Bool List.

Lemma contra b1 b2 :
  (b2 = false -> b1 = false) <-> (b1 = true -> b2 = true).
Proof. destruct b1, b2; intuition. Qed.

(*| Now, we will need the following easy property: |*)

Lemma in_subset_listpair {p l1 l2} :
  in_listpair p l1 = true ->
  subset_listpair l1 l2 = true ->
  in_listpair p l2 = true.
Proof.
  induction l1 as [| [x1 y1] l1 IH]; simpl; [easy |].
  rewrite orb_true_iff, andb_true_iff. intros [->%Nat.eqb_eq |] []; trivial.
  now apply IH.
Qed.

(*| Next, we prove that ``subset`` is transitive: |*)

Lemma subset_listpair_transitive l2 l1 l3 :
  subset_listpair l1 l2 = true ->
  subset_listpair l2 l3 = true ->
  subset_listpair l1 l3 = true.
Proof.
  induction l1 as [| [x1 y1] l1 IH]; simpl; trivial.
  intros [I1 S1]%andb_prop S2. rewrite (IH S1 S2), andb_true_r.
  now apply (in_subset_listpair I1).
Qed.

(*|
And now, the target lemma, which is basically a contrapositive
statement of the transitivity property:
|*)

Lemma subset_listpair_consFalse l1 l2 l3 :
  subset_listpair l1 l2 = true ->
  subset_listpair l1 l3 = false ->
  subset_listpair l2 l3 = false.
Proof.
  intros S12. rewrite contra.
  now apply subset_listpair_transitive.
Qed.


(* Software Foundations *)
(* Exercice 3 stars, filter_exercise *)

Require Import Coq.Lists.List.
Import ListNotations.

Fixpoint filter{X: Type}(f: X -> bool)(l: list X):=
match l with
|[]   => []
|h::t => if (f h) then h::(filter f t) else (filter f t)
end.

Theorem filter_exercise : forall (X : Type)(test : X -> bool)(x : X)(l lf : list X),
filter test l = x :: lf -> test x = true.
Proof.
    intros. generalize dependent l. induction l as [|h t].
    simpl. intros. inversion H.
    intros. simpl in H. destruct (test h) eqn: th.
    inversion H. rewrite H1 in th. apply th.
    apply IHt in H. apply H.
Qed.


From Hammer Require Import Hammer.

From compcert Require Import Raux.
From compcert Require Import Defs.
From compcert Require Import Digits.
From compcert Require Import Generic_fmt.
From compcert Require Import Float_prop.
From compcert Require Import Bracket.

Set Implicit Arguments.
Set Strongly Strict Implicit.

Section Fcalc_sqrt.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.

Lemma mag_sqrt_F2R :
forall m1 e1,
(0 < m1)%Z ->
mag beta (sqrt (F2R (Float beta m1 e1))) = Z.div2 (Zdigits beta m1 + e1 + 1) :> Z.
Proof. hammer_hook "Sqrt" "Sqrt.mag_sqrt_F2R".
intros m1 e1 Hm1.
rewrite <- (mag_F2R_Zdigits beta m1 e1) by now apply Zgt_not_eq.
apply mag_sqrt.
now apply F2R_gt_0.
Qed.

Definition Fsqrt_core m1 e1 e :=
let d1 := Zdigits beta m1 in
let m1' := (m1 * Zpower beta (e1 - 2 * e))%Z in
let (q, r) := Z.sqrtrem m1' in
let l :=
if Zeq_bool r 0 then loc_Exact
else loc_Inexact (if Zle_bool r q then Lt else Gt) in
(q, l).

Theorem Fsqrt_core_correct :
forall m1 e1 e,
(0 < m1)%Z ->
(2 * e <= e1)%Z ->
let '(m, l) := Fsqrt_core m1 e1 e in
inbetween_float beta m e (sqrt (F2R (Float beta m1 e1))) l.
Proof. hammer_hook "Sqrt" "Sqrt.Fsqrt_core_correct".
intros m1 e1 e Hm1 He.
unfold Fsqrt_core.
set (m' := Zmult _ _).
assert (0 <= m')%Z as Hm'.
{ apply Z.mul_nonneg_nonneg.
now apply Zlt_le_weak.
apply Zpower_ge_0. }
assert (sqrt (F2R (Float beta m1 e1)) = sqrt (IZR m') * bpow e)%R as Hf.
{ rewrite <- (sqrt_Rsqr (bpow e)) by apply bpow_ge_0.
rewrite <- sqrt_mult.
unfold Rsqr, m'.
rewrite mult_IZR, IZR_Zpower by omega.
rewrite Rmult_assoc, <- 2!bpow_plus.
now replace (_ + _)%Z with e1 by ring.
now apply IZR_le.
apply Rle_0_sqr. }
generalize (Z.sqrtrem_spec m' Hm').
destruct Z.sqrtrem as [q r].
intros [Hq Hr].
rewrite Hf.
unfold inbetween_float, F2R. simpl Fnum.
apply inbetween_mult_compat.
apply bpow_gt_0.
rewrite Hq.
case Zeq_bool_spec ; intros Hr'.

rewrite Hr', Zplus_0_r, mult_IZR.
fold (Rsqr (IZR q)).
rewrite sqrt_Rsqr.
now constructor.
apply IZR_le.
clear -Hr ; omega.

constructor.
split.

apply Rle_lt_trans with (sqrt (IZR (q * q))).
rewrite mult_IZR.
fold (Rsqr (IZR q)).
rewrite sqrt_Rsqr.
apply Rle_refl.
apply IZR_le.
clear -Hr ; omega.
apply sqrt_lt_1.
rewrite mult_IZR.
apply Rle_0_sqr.
rewrite <- Hq.
now apply IZR_le.
apply IZR_lt.
omega.
apply Rlt_le_trans with (sqrt (IZR ((q + 1) * (q + 1)))).
apply sqrt_lt_1.
rewrite <- Hq.
now apply IZR_le.
rewrite mult_IZR.
apply Rle_0_sqr.
apply IZR_lt.
ring_simplify.
omega.
rewrite mult_IZR.
fold (Rsqr (IZR (q + 1))).
rewrite sqrt_Rsqr.
apply Rle_refl.
apply IZR_le.
clear -Hr ; omega.

rewrite Rcompare_half_r.
generalize (Rcompare_sqr (2 * sqrt (IZR (q * q + r))) (IZR q + IZR (q + 1))).
rewrite 2!Rabs_pos_eq.
intros <-.
replace ((2 * sqrt (IZR (q * q + r))) * (2 * sqrt (IZR (q * q + r))))%R
with (4 * Rsqr (sqrt (IZR (q * q + r))))%R by (unfold Rsqr ; ring).
rewrite Rsqr_sqrt.
rewrite <- plus_IZR, <- 2!mult_IZR.
rewrite Rcompare_IZR.
replace ((q + (q + 1)) * (q + (q + 1)))%Z with (4 * (q * q) + 4 * q + 1)%Z by ring.
generalize (Zle_cases r q).
case (Zle_bool r q) ; intros Hr''.
change (4 * (q * q + r) < 4 * (q * q) + 4 * q + 1)%Z.
omega.
change (4 * (q * q + r) > 4 * (q * q) + 4 * q + 1)%Z.
omega.
rewrite <- Hq.
now apply IZR_le.
rewrite <- plus_IZR.
apply IZR_le.
clear -Hr ; omega.
apply Rmult_le_pos.
now apply IZR_le.
apply sqrt_ge_0.
Qed.

Definition Fsqrt (x : float beta) :=
let (m1, e1) := x in
let e' := (Zdigits beta m1 + e1 + 1)%Z in
let e := Z.min (fexp (Z.div2 e')) (Z.div2 e1) in
let '(m, l) := Fsqrt_core m1 e1 e in
(m, e, l).

Theorem Fsqrt_correct :
forall x,
(0 < F2R x)%R ->
let '(m, e, l) := Fsqrt x in
(e <= cexp beta fexp (sqrt (F2R x)))%Z /\
inbetween_float beta m e (sqrt (F2R x)) l.
Proof. hammer_hook "Sqrt" "Sqrt.Fsqrt_correct".
intros [m1 e1] Hm1.
apply gt_0_F2R in Hm1.
unfold Fsqrt.
set (e := Z.min _ _).
assert (2 * e <= e1)%Z as He.
{ assert (e <= Z.div2 e1)%Z by apply Z.le_min_r.
rewrite (Zdiv2_odd_eqn e1).
destruct Z.odd ; omega. }
generalize (Fsqrt_core_correct m1 e1 e Hm1 He).
destruct Fsqrt_core as [m l].
apply conj.
apply Z.le_trans with (1 := Z.le_min_l _ _).
unfold cexp.
rewrite (mag_sqrt_F2R m1 e1 Hm1).
apply Z.le_refl.
Qed.

End Fcalc_sqrt.


Require Import List.
Import ListNotations.

Require Import Logic.Class.Eq.

Require Import Logic.Lam.Syntax.

Fixpoint subst_ (v:Type) (e:Eq v) (f:v -> T v) (xs:list v) (t:T v) : T v :=
    match t with
    | Var x     =>
        match in_dec eqDec x xs with
        | left _    => Var x    (* x is deemed bound    -> Var x                *)
        | right _   => f x      (* x is deemed free     -> f x                  *)
        end
    | App t1 t2 => App (subst_ v e f xs t1) (subst_ v e f xs t2)
    | Lam x t1  => Lam x (subst_ v e f (x :: xs) t1)        (* x now bound      *)
    end.

Arguments subst_ {v} {e}.

Definition subst (v:Type) (e:Eq v) (f:v -> T v) (t:T v) : T v :=
    subst_ f [] t.

Arguments subst {v} {e}.

Lemma substVar : forall (v:Type) (e:Eq v) (f:v -> T v) (t:T v) (x:v),
    t = Var x -> subst f t = f x.
Proof. intros v e f t x H. rewrite H. reflexivity. Qed.

Lemma substApp : forall (v:Type) (e:Eq v) (f:v -> T v) (t1 t2 t:T v),
    t = App t1 t2 -> subst f t = App (subst f t1) (subst f t2).
Proof. intros v e f t1 t2 t H. rewrite H. unfold subst. simpl. reflexivity. Qed.


Inductive equivalent P Q := Equivalent (P_to_Q : P -> Q) (Q_to_P : Q -> P).

Inductive equal T (x : T) : T -> Type := Equal : equal T x x.

(* Arithmetic *)

Inductive natural := Zero | Add_1_to (n : natural).

Fixpoint add (m n : natural) : natural :=
  match m with Zero => n | Add_1_to m_minus_1 => add m_minus_1 (Add_1_to n) end.

Definition double (n : natural) : natural := add n n.

Inductive odd (n : natural) :=
  Odd (half : natural)
    (n_odd : equal natural n (Add_1_to (double half))).

Inductive less_than (m n : natural) :=
  LessThan (diff : natural)
    (m_lt_n : equal natural n (Add_1_to (add m diff))).

(* Finite subsets *)

Definition injective_in T R (D : T -> Type) (f : T -> R) :=
  forall x y, D x -> D y -> equal R (f x) (f y) -> equal T x y.

Inductive in_image T R (D : T -> Type) (f : T -> R) (a : R) :=
  InImage (x : T) (x_in_D : D x) (a_is_fx : equal R a (f x)).

Inductive finite_of_order T (D : T -> Type) (n : natural) :=
  FiniteOfOrder (rank : T -> natural)
    (rank_injective : injective_in T natural D rank)
    (rank_onto :
       forall i, equivalent (less_than i n) (in_image T natural D rank i)).

(* Constraints *)
Universes i j.
Inductive constraint1 : (Type -> Type) -> Type := mk_constraint1 : constraint1 (fun x : Type@{i} => (x : Type@{j})).
Constraint i < j.
Inductive constraint2 : Type@{j} := mkc2 (_ : Type@{i}).
Universes i' j'.
Constraint i' = j'.
Inductive constraint3 : (Type -> Type) -> Type := mk_constraint3 : constraint3 (fun x : Type@{i'} => (x : Type@{j'})).
Inductive constraint4 : (Type -> Type) -> Type
  := mk_constraint4 : let U1 := Type in
                      let U2 := Type in
                      constraint4 (fun x : U1 => (x : U2)).

Module CMP_CON.
  (* Comparison of opaque constants MUST be up to the universe graph.
     See #6798. *)
  Universe big.

  Polymorphic Lemma foo@{u} : Type@{big}.
  Proof. exact Type@{u}. Qed.

  Universes U V.

  Definition yo : foo@{U} = foo@{V} := eq_refl.
End CMP_CON.

Set Universe Polymorphism.

Module POLY_SUBTYP.

  Module Type T.
    Axiom foo : Type.
    Parameter bar@{u v|u = v} : foo@{u}.
  End T.

  Module M.
    Axiom foo : Type.
    Axiom bar@{u v|u = v} : foo@{v}.
  End M.

  Module F (A:T). End F.

  Module X := F M.

End POLY_SUBTYP.

Module POLY_IND.

  Polymorphic Inductive ind@{u v | u < v} : Prop := .

  Polymorphic Definition cst@{u v | v < u} := Prop.

End POLY_IND.


Require Export GeoCoq.Elements.OriginalProofs.lemma_rayimpliescollinear.
Require Export GeoCoq.Elements.OriginalProofs.lemma_ray2.
Require Export GeoCoq.Elements.OriginalProofs.lemma_collinearitypreserved.
Require Export GeoCoq.Elements.OriginalProofs.lemma_raystrict.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_equalanglessymmetric :
   forall A B C a b c,
   CongA A B C a b c ->
   CongA a b c A B C.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists U V u v, (Out B A U /\ Out B C V /\ Out b a u /\ Out b c v /\ Cong B U b u /\ Cong B V b v /\ Cong U V u v /\ nCol A B C)) by (conclude_def CongA );destruct Tf as [U[V[u[v]]]];spliter.
assert (Cong b u B U) by (conclude lemma_congruencesymmetric).
assert (Cong b v B V) by (conclude lemma_congruencesymmetric).
assert (Cong v u V U) by (forward_using lemma_doublereverse).
assert (~ Col a b c).
 {
 intro.
 assert (Col b a u) by (conclude lemma_rayimpliescollinear).
 assert (Col b c v) by (conclude lemma_rayimpliescollinear).
 assert (Col B A U) by (conclude lemma_rayimpliescollinear).
 assert (Col B C V) by (conclude lemma_rayimpliescollinear).
 assert (Col a b u) by (forward_using lemma_collinearorder).
 assert (neq b a) by (conclude lemma_ray2).
 assert (neq a b) by (conclude lemma_inequalitysymmetric).
 assert (Col b u c) by (conclude lemma_collinear4).
 assert (Col c b u) by (forward_using lemma_collinearorder).
 assert (Col c b v) by (forward_using lemma_collinearorder).
 assert (neq b c) by (conclude lemma_ray2).
 assert (neq c b) by (conclude lemma_inequalitysymmetric).
 assert (Col b u v) by (conclude lemma_collinear4).
 assert (Cong u v U V) by (conclude lemma_congruencesymmetric).
 assert (Col B U V) by (conclude lemma_collinearitypreserved).
 assert (Col U B V) by (forward_using lemma_collinearorder).
 assert (Col U B A) by (forward_using lemma_collinearorder).
 assert (neq B U) by (conclude lemma_raystrict).
 assert (neq U B) by (conclude lemma_inequalitysymmetric).
 assert (Col B V A) by (conclude lemma_collinear4).
 assert (Col V B A) by (forward_using lemma_collinearorder).
 assert (Col V B C) by (forward_using lemma_collinearorder).
 assert (neq B V) by (conclude lemma_raystrict).
 assert (neq V B) by (conclude lemma_inequalitysymmetric).
 assert (Col B A C) by (conclude lemma_collinear4).
 assert (Col A B C) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (Cong u v U V) by (conclude lemma_congruencesymmetric).
assert (CongA a b c A B C) by (conclude_def CongA ).
close.
Qed.

End Euclid.


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.