Require Import ZArith.
Require Import FunInd.

Inductive lambda_term : Set :=
| variable : nat -> lambda_term  (* variables libres *)
| reference : nat -> lambda_term (* variables liées *)
| abstraction : lambda_term -> lambda_term
| application : lambda_term -> lambda_term -> lambda_term.

Notation "'var' t" := (variable t) (at level 80, right associativity).
Notation "'ref' t" := (reference t) (at level 85, right associativity).
Notation "'λ' t" := (abstraction t) (at level 99, right associativity).
Notation "'lapp'" := application (at level 79).

(**** Well-formedness ****)

Inductive well_formed_count : nat -> lambda_term -> Prop :=
| reference_wf : forall (n m : nat), m < n -> well_formed_count n (reference m)
| abstraction_wf : forall (n : nat) (t : lambda_term), well_formed_count (S n) t -> well_formed_count n (λ t)
| application_wf : forall (n : nat) (t1 t2 : lambda_term), well_formed_count n t1 -> well_formed_count n t2 ->
  well_formed_count n (lapp t1 t2).

Definition well_formed (t : lambda_term) := well_formed_count 0 t.

Axiom well_formed_app : forall (t1 t2 : lambda_term),
  well_formed (lapp t1 t2) -> well_formed t1 /\ well_formed t2.

Fixpoint br_fix (n : nat) (t u : lambda_term) : lambda_term :=
  match t with
  (* variable libre *)
  | var x => var x
  (* on remplace si c'est le bon indice *)
  | ref m =>
       match (eq_nat_dec n m) with
       | left _ => u
       | _ => ref m
       end
  (* on passe un lambda donc on incrémente l'indice *)
  | λ x => λ (br_fix (n + 1) x u)
  (* on passe au contexte *)
  | lapp t1 t2 => lapp (br_fix n t1 u) (br_fix n t2 u)
  end.

Fixpoint beta_reduction_fix (t u : lambda_term) : option lambda_term :=
    match t with
    | var _ => None
    | ref _ => None
    | λ x => Some (br_fix 0 x u)
    | lapp _ _ => None
    end.

Fixpoint get_redex (t u : lambda_term) : lambda_term :=
    match (beta_reduction_fix t u) with
    | Some t' => t'
    | None => (lapp t u)
  end.

Inductive br : nat -> lambda_term -> lambda_term -> lambda_term -> Prop :=
| br_variable : forall (n x : nat) (u : lambda_term),
	br n (var x) u (var x)
| br_reference : forall (n : nat) (t : lambda_term),
	br n (ref n) t t
| br_reference_2 : forall (n m : nat) (u : lambda_term),
	n <> m -> br n (ref m) u (ref m)
| br_abstraction : forall (n : nat) (t t' u : lambda_term),
	br (n + 1) t u t' -> br n (λ t) u (λ t')
| br_application : forall (n : nat) (t1 t2 t1' t2' u : lambda_term),
	br n t1 u t1' -> br n t2 u t2' -> br n (lapp t1 t2) u (lapp t1' t2').

Inductive beta_reduction : lambda_term -> lambda_term -> Prop :=
| Beta_redex : forall (t t' u : lambda_term),
  br 0 t u t' -> beta_reduction (lapp (λ t) u) t'.

Ltac remove_br :=
  repeat
  match goal with
  | |- context[br _ (var ?x) _ (var ?x)] => apply br_variable
  | |- context[br ?n (ref ?n) ?u ?u] => apply br_reference
  | |- context[br ?n (ref ?m) _ (ref ?m)] => apply br_reference_2; auto
  | |- context[br _ (λ ?t) _ (λ ?t')] => apply br_abstraction; simpl
  | |- context[br _ (lapp ?t1 ?t2) _ (lapp ?t1' ?t2')] => apply br_application
  end.

Functional Scheme br_fix_ind := Induction for br_fix Sort Prop.

Lemma correction_br : forall (n : nat) (l u : lambda_term), br n l u (br_fix n l u).
Proof.
intros.
functional induction (br_fix n l u).
remove_br.
remove_br.
remove_br.
remove_br. apply IHl0.
remove_br. apply IHl0. apply IHl1.
Qed.

Lemma correction_beta_reduction : forall t u t' : lambda_term,  Some t' = (beta_reduction_fix (λ t) u) -> beta_reduction (lapp (λ t) u) t'.
Proof.
intros.
inversion H.
apply Beta_redex. apply correction_br.
Qed.

Inductive beta_ref_trans : lambda_term -> lambda_term -> Prop :=
| Beta_redex_ref_trans : forall (t u : lambda_term),
	beta_reduction t u -> beta_ref_trans t u
| Beta_ref : forall (t : lambda_term),
	beta_ref_trans t t
| Beta_trans : forall (u t v : lambda_term),
	beta_ref_trans t u -> beta_ref_trans u v -> beta_ref_trans t v
| Beta_cong_lambda : forall (t t': lambda_term), beta_ref_trans t t' ->
  beta_ref_trans (λ t) (λ t')
| Beta_cong_app : forall (t u t' u': lambda_term), beta_ref_trans t t' ->
  beta_ref_trans u u' -> beta_ref_trans (lapp t u) (lapp t' u').

Inductive beta_sym : lambda_term -> lambda_term -> Prop :=
| Beta_redex_sym : forall (t u : lambda_term),
	beta_ref_trans t u -> beta_sym t u
| Beta_sym : forall (v t u : lambda_term),
	beta_sym t v -> beta_sym u v -> beta_sym t u.

Notation "t '->β' u" := (beta_reduction t u) (at level 86, no associativity).
Notation "t '->*β' u" := (beta_ref_trans t u) (at level 87, no associativity).
Notation "t '=β' u" := (beta_sym t u) (at level 88, no associativity).

(**** Examples ****)

Definition id := (λ (ref 0)). (* x -> x *)
Definition vrai := (λ (λ (ref 1))). (* x,y -> x *)
Definition faux := (λ (λ (ref 0))). (* x,y -> y *)
Definition ifthenelse := (λ (λ (λ (lapp (lapp (ref 2) (ref 1))) (ref 0)))).
(* b,x,y -> b(x,y) *)
Definition x := (var 0).
Definition y := (var 1).

Lemma vrai_wf : well_formed vrai.
Proof.
  unfold well_formed, vrai.
  apply abstraction_wf.
  apply abstraction_wf.
  apply reference_wf.
  auto.
Qed.

Lemma identity : forall t : lambda_term, lapp id t ->β t.
Proof.
intros.
apply Beta_redex.
apply correction_br.
Qed.

Lemma if_vrai : forall t t' : lambda_term, br 0 t t' t -> lapp (lapp (lapp ifthenelse vrai) t) t' ->*β t.
Proof.
intros.
apply (Beta_trans (lapp (λ t) t')).
apply (Beta_trans (lapp (lapp vrai t) t')).
apply Beta_cong_app.
apply (Beta_trans (lapp (λ (λ (lapp (lapp vrai (ref 1)) (ref 0)))) t)).
apply Beta_cong_app.
apply Beta_redex_ref_trans; apply Beta_redex; apply correction_br.
apply Beta_ref.
apply Beta_cong_app.
apply Beta_cong_lambda.
apply Beta_cong_lambda.
apply (Beta_trans (lapp (λ (ref 1)) (ref 0))).
apply Beta_cong_app.
apply Beta_redex_ref_trans; apply Beta_redex; apply correction_br.
apply Beta_ref.
apply Beta_redex_ref_trans; apply Beta_redex; apply correction_br.
apply Beta_ref.
apply Beta_ref.
apply Beta_cong_app.
apply Beta_redex_ref_trans; apply Beta_redex; apply correction_br.
apply Beta_ref.
apply Beta_redex_ref_trans; apply Beta_redex.
apply H.
Qed.

Definition Y := λ (lapp (λ (lapp (ref 1) (lapp (ref 0) (ref 0)))) (λ (lapp (ref 1) (lapp (ref 0) (ref 0))))).

Lemma point_fixe_Y : forall (g:lambda_term) (x:nat), g = (var x) -> (lapp Y g) =β (lapp g (lapp Y g)).
Proof.
intros.
apply (Beta_sym (lapp g (lapp (λ (lapp g (lapp (ref 0) (ref 0)))) (λ (lapp g (lapp (ref 0) (ref 0))))))).
apply (Beta_sym  (lapp (λ (lapp g (lapp (ref 0) (ref 0)))) (λ (lapp g (lapp (ref 0) (ref 0)))))).
apply Beta_redex_sym; apply Beta_redex_ref_trans; apply Beta_redex; apply correction_br.
apply (Beta_sym (lapp g (lapp (λ (lapp g (lapp (ref 0) (ref 0)))) (λ (lapp g (lapp (ref 0) (ref 0))))))); apply Beta_redex_sym.
apply Beta_ref.
apply Beta_redex_ref_trans; apply Beta_redex.
rewrite H; apply correction_br.
apply Beta_redex_sym; apply Beta_cong_app.
apply Beta_ref. apply Beta_redex_ref_trans; apply Beta_redex; apply correction_br.
Qed.

Definition Θ := (lapp (λ (λ (lapp (ref 0) (lapp (lapp (ref 1) (ref 1)) (ref 0))))) (λ (λ (lapp (ref 0) (lapp (lapp (ref 1) (ref 1)) (ref 0)))))).

Lemma point_fixe_Θ : forall (g : lambda_term) (x : nat), g = (var x) -> (lapp Θ g) ->*β (lapp g (lapp Θ g)).
Proof.
intros.
apply (Beta_trans (lapp (λ (lapp (ref 0) (lapp (lapp ((λ (λ (lapp (ref 0) (lapp (lapp (ref 1) (ref 1)) (ref 0)))))) ((λ (λ (lapp (ref 0) (lapp (lapp (ref 1) (ref 1)) (ref 0))))))) (ref 0)))) g)).
apply Beta_cong_app.
apply Beta_redex_ref_trans; apply Beta_redex; apply correction_br.
apply Beta_ref.
apply Beta_redex_ref_trans; apply Beta_redex; apply correction_br.
Qed.

Definition itere := λ (λ (λ (lapp (lapp (ref 2) (ref 1)) (ref 0)))).
Definition l_0 := λ (λ (ref 0)).
Definition l_1 := λ (λ (lapp (ref 1) (ref 0))).
Definition l_2 := λ (λ (lapp (ref 1) (lapp (ref 1) (ref 0)))).
Definition l_3 := λ (λ (lapp (ref 1) (lapp (ref 1) (lapp (ref 1) (ref 0))))).
Definition l_4 := λ (λ (lapp (ref 1) (lapp (ref 1) (lapp (ref 1) (lapp (ref 1) (ref 0)))))).
Definition l_5 := λ (λ (lapp (ref 1) (lapp (ref 1) (lapp (ref 1) (lapp (ref 1) (lapp (ref 1) (ref 0))))))).
Definition l_6 := λ (λ (lapp (ref 1) (lapp (ref 1) (lapp (ref 1) (lapp (ref 1) (lapp (ref 1) (lapp (ref 1) (ref 0)))))))).
Definition succ := λ (λ (λ (lapp (ref 1) (lapp (lapp (ref 2) (ref 1)) (ref 0))))).
Definition add := λ (λ (lapp itere (lapp (ref 1) (lapp succ (ref 0))))).
Definition fact := λ (lapp (ref 0) (λ λ λ (lapp (lapp (ref 0) (λ λ (lapp (ref 1) (lapp (lapp (ref 3) (ref 1)) (ref 0))))) (λ (lapp (ref 3) (lapp (ref 2) (ref 0))))))).

Goal (lapp succ l_0) ->*β l_1.
Proof.
apply (Beta_trans (λ (λ (lapp (ref 1) (lapp (lapp l_0 (ref 1)) (ref 0)))))).
apply Beta_redex_ref_trans; apply Beta_redex; apply correction_br.
apply Beta_cong_lambda; apply Beta_cong_lambda; apply Beta_cong_app.
apply Beta_ref.
apply (Beta_trans (lapp (λ (ref 0)) (ref 0))).
apply Beta_cong_app. apply Beta_redex_ref_trans; apply Beta_redex; apply correction_br.
apply Beta_ref.
apply Beta_redex_ref_trans; apply Beta_redex; apply correction_br.
Qed.

(**** Innermost strategy ****)

(*Inductive innermost_strategy : lambda_term -> lambda_term -> Prop :=
| in_lambda : forall t : lambda_term, innermost_strategy (λ t) (λ t)
| in_variable : forall n : nat, innermost_strategy (var n) (var n)
| in_app1 : forall t1 t2 t1' t3 : lambda_term, innermost_strategy t1 t1' -> t1' <> (λ t3) -> innermost_strategy (lapp t1 t2) (lapp t1' t2)
| in_app2 : forall t1 t2 t1' t2' t3 t4 t4': lambda_term, innermost_strategy t1 t1' ->
  innermost_strategy t2 t2' -> t1' = (λ t3) -> (beta_reduction (lapp t1' t2') t4) ->
  innermost_strategy t4 t4' ->
  innermost_strategy (lapp t1 t2) t4'.*)

Inductive innermost_strategy : lambda_term -> lambda_term -> Prop :=
| in_lambda : forall t : lambda_term, innermost_strategy (λ t) (λ t)
| in_app2 : forall t1 t2 t1' t2' t3 t4 t4': lambda_term, innermost_strategy t1 t1' ->
  innermost_strategy t2 t2' -> t1' = (λ t3) -> ((lapp t1' t2') ->β t4) -> innermost_strategy t4 t4' ->
  innermost_strategy (lapp t1 t2) t4'.

Lemma test0 : innermost_strategy (lapp id id) id.
Proof.
  unfold id.
  eapply in_app2.
  apply in_lambda.
  apply in_lambda.
  auto.
  apply Beta_redex.
  apply br_reference.
  apply in_lambda.
Qed.

(*Lemma test0 : innermost_strategy (lapp id x) x.
Proof.
  unfold id, x.
  eapply in_app2.
  apply in_lambda.
  apply in_variable.
  auto.
  apply Beta_redex.
  apply br_reference.
  apply in_variable.
Qed.*)

Axiom wf_abstraction : forall (t : lambda_term) (n : nat), well_formed_count n t -> well_formed_count n (λ t).
(*	Proof.
	intros.
	apply abstraction_wf.
	induction t.
	apply variable_wf.
	inversion H. apply reference_wf. apply le_S. apply H2.
	inversion H. apply abstraction_wf.
	admit.
	inversion H.
	apply application_wf.
	apply IHt1. apply H3.
	apply IHt2. apply H4.
	Admitted.*)

Lemma wf_succ : forall (t1 : lambda_term) (n : nat), well_formed_count n t1 -> well_formed_count (S n) t1.
	Proof.
	induction t1; intros.
	inversion H.
	apply reference_wf.
	inversion H; auto.
	apply abstraction_wf.
	apply (IHt1 (S n)).
	inversion H; auto.
  apply application_wf; inversion H.
  apply (IHt1_1 n); auto.
  apply (IHt1_2 n); auto.
Qed.

Axiom redex_well_formed : forall (t1 t2 : lambda_term), well_formed t1 -> t1 ->*β t2 -> well_formed t2.
(*Proof.
Admitted.*)

Axiom innermost_strategy_well_formed : forall (t1 t2 : lambda_term),
  well_formed t1 -> innermost_strategy t1 t2 -> well_formed t2.
(*  Proof.
  unfold well_formed.
  intros.
  induction t1.
  inversion H0. apply variable_wf.
  inversion H. inversion H3.
  inversion H0. apply H.
  inversion H0.
  inversion H.
  Admitted.*)


(** This file is part of CoqEAL, the Coq Effective Algebra Library.
(c) Copyright INRIA and University of Gothenburg, see LICENSE *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq.
From mathcomp Require Import zmodp path choice fintype tuple finset ssralg.
From mathcomp Require Import bigop poly polydiv.

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

Local Open Scope ring_scope.

Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic.

Section karatsuba.

Variable R : ringType.
Definition split_poly n (p : {poly R}) := (rdivp p 'X^n, rmodp p 'X^n).
Definition shift_poly n : {poly R} -> {poly R} := *%R^~ 'X^n.
Definition normalize (p : {poly R}) := p.

Fixpoint karatsuba_rec (n : nat) (p q : {poly R}) :=
  if n is n'.+1 then
    let np := normalize p in  let nq := normalize q in
    let sp := size p in let sq := size q in
    if (sp <= 2) || (sq <= 2) then p * q else
      let m       := minn sp./2 sq./2 in
      let (p1,p2) := split_poly m p in
      let (q1,q2) := split_poly m q in
      let p1q1    := karatsuba_rec n' p1 q1 in
      let p2q2    := karatsuba_rec n' p2 q2 in
      let p12     := p1 + p2 in
      let q12     := q1 + q2 in
      let p12q12  := karatsuba_rec n' p12 q12 in
      shift_poly (2 * m)%N p1q1 +
       shift_poly m (p12q12 - p1q1 - p2q2) +
       p2q2
  else p * q.

Definition karatsuba (p q : {poly R}) :=
  karatsuba_rec (maxn (size p) (size q)) p q.

Lemma karatsuba_recE n (p q : {poly R}) : karatsuba_rec n p q = p * q.
Proof.
elim: n=> //= n ih in p q *; case: ifP=> // _; set m := minn _ _.
rewrite [p in RHS](rdivp_eq (monicXn _ m)) [q in RHS](rdivp_eq (monicXn _ m)).
set dp := rdivp p _; set dq := rdivp q _; set rp := rmodp p _; set rq := rmodp q _.
rewrite /shift_poly /split_poly !ih !(mulrDr, mulrDl, mulNr) mulnC exprM.
rewrite -[_ - _ - _]addrA [_ + _ + (- _ - _)]addrACA [_ + _ - _]addrAC.
by rewrite subrr add0r addrK !(commr_polyXn, mulrA, addrA).
Qed.

Lemma karatsubaE (p q : {poly R}) : karatsuba p q = p * q.
Proof. exact: karatsuba_recE. Qed.

End karatsuba.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.FixedWordSizes.

Definition BoundedWord n (bitwidth : nat)
           (bounds : tuple zrange n) : Type :=
  { x : tuple (wordT (Nat.log2 bitwidth)) n
  | is_bounded_by None bounds
                  (map wordToZ x)}.

Definition BoundedWordToZ n w b (BW :BoundedWord n w b)
  : tuple Z n :=  map wordToZ (proj1_sig BW).


Inductive List (A : Set) : Set :=
  | Nil : List A
  | Cons : A -> List A -> List A.

Inductive eqlong : List nat -> List nat -> Prop :=
  | eql_cons :
      forall (n m : nat) (x y : List nat),
      eqlong x y -> eqlong (Cons nat n x) (Cons nat m y)
  | eql_nil : eqlong (Nil nat) (Nil nat).

Parameter V1 : eqlong (Nil nat) (Nil nat) \/ ~ eqlong (Nil nat) (Nil nat).
Parameter
  V2 :
    forall (a : nat) (x : List nat),
    eqlong (Nil nat) (Cons nat a x) \/ ~ eqlong (Nil nat) (Cons nat a x).
Parameter
  V3 :
    forall (a : nat) (x : List nat),
    eqlong (Cons nat a x) (Nil nat) \/ ~ eqlong (Cons nat a x) (Nil nat).
Parameter
  V4 :
    forall (a : nat) (x : List nat) (b : nat) (y : List nat),
    eqlong (Cons nat a x) (Cons nat b y) \/
    ~ eqlong (Cons nat a x) (Cons nat b y).

Parameter
  nff :
    forall (n m : nat) (x y : List nat),
    ~ eqlong x y -> ~ eqlong (Cons nat n x) (Cons nat m y).
Parameter
  inv_r : forall (n : nat) (x : List nat), ~ eqlong (Nil nat) (Cons nat n x).
Parameter
  inv_l : forall (n : nat) (x : List nat), ~ eqlong (Cons nat n x) (Nil nat).

Fixpoint eqlongdec (x y : List nat) {struct x} :
 eqlong x y \/ ~ eqlong x y :=
  match x, y return (eqlong x y \/ ~ eqlong x y) with
  | Nil _, Nil _ => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil
  | Nil _, Cons _ a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x)
  | Cons _ a x as L, Nil _ => or_intror (eqlong L (Nil nat)) (inv_l a x)
  | Cons _ a x as L1, Cons _ b y as L2 =>
      match eqlongdec x y return (eqlong L1 L2 \/ ~ eqlong L1 L2) with
      | or_introl h => or_introl (~ eqlong L1 L2) (eql_cons a b x y h)
      | or_intror h => or_intror (eqlong L1 L2) (nff a b x y h)
      end
  end.

Type
  match Nil nat as x, Nil nat as y return (eqlong x y \/ ~ eqlong x y) with
  | Nil _, Nil _ => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil
  | Nil _, Cons _ a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x)
  | Cons _ a x as L, Nil _ => or_intror (eqlong L (Nil nat)) (inv_l a x)
  | Cons _ a x as L1, Cons _ b y as L2 =>
      match eqlongdec x y return (eqlong L1 L2 \/ ~ eqlong L1 L2) with
      | or_introl h => or_introl (~ eqlong L1 L2) (eql_cons a b x y h)
      | or_intror h => or_intror (eqlong L1 L2) (nff a b x y h)
      end
  end.


From QuickChick Require Import QuickChick Generators.
Require Import NPeano Lia.

From mathcomp Require Import ssreflect ssrnat ssrbool eqtype.

From QuickChick.RedBlack Require Import redblack.

Require Import List String.
Import ListNotations.

Open Scope string.

Open Scope Checker_scope.

(* Red-Black Tree invariant: executable definition *)

Fixpoint black_height_bool (t: tree) : option nat :=
  match t with
    | Leaf => Some 0
    | Node c tl _ tr =>
      let h1 := black_height_bool tl in
      let h2 := black_height_bool tr in
      match h1, h2 with
        | Some n1, Some n2 =>
          if n1 == n2 then
            match c with
              | Black => Some (S n1)
              | Red => Some n1
            end
          else None
        | _, _ => None
      end
  end.

Definition is_black_balanced (t : tree) : bool :=
  isSome (black_height_bool t).

Fixpoint has_no_red_red (c : color) (t : tree) : bool :=
  match t with
    | Leaf => true
    | Node Red t1 _ t2 =>
      match c with
        | Red => false
        | Black => has_no_red_red Red t1 && has_no_red_red Red t2
      end
    | Node Black t1 _ t2 =>
      has_no_red_red Black t1 && has_no_red_red Black t2
  end.

(* begin is_redblack_bool *)
Definition is_redblack_bool (t : tree) : bool :=
  is_black_balanced t && has_no_red_red Red t.
(* end is_redblack_bool *)

Fixpoint showColor (c : color) :=
  match c with
    | Red => "Red"
    | Black => "Black"
  end.

Fixpoint tree_to_string (t : tree) :=
  match t with
    | Leaf => "Leaf"
    | Node c l x r => "Node " ++ showColor c ++ " "
                            ++ "(" ++ tree_to_string l ++ ") "
                            ++ show x ++ " "
                            ++ "(" ++ tree_to_string r ++ ")"
  end.

Instance showTree {A : Type} `{_ : Show A} : Show tree :=
  {|
    show t := "" (* CH: tree_to_string t causes a 9x increase in runtime *)
  |}.

(* begin insert_preserves_redblack_checker *)
Definition insert_preserves_redblack_checker (genTree : G tree) : Checker :=
  forAll arbitrary (fun n => forAll genTree (fun t =>
    is_redblack_bool t ==> is_redblack_bool (insert n t))).
(* end insert_preserves_redblack_checker *)

Import QcDefaultNotation. Open Scope qc_scope.

(* begin genAnyTree *)
Definition genColor := elems [Red; Black].
Fixpoint genAnyTree_depth (d : nat) : G tree :=
  match d with
    | 0 => returnGen Leaf
    | S d' => freq [(1, returnGen Leaf);
                    (9, liftGen4 Node genColor (genAnyTree_depth d')
                                     arbitrary (genAnyTree_depth d'))]
  end.
Definition genAnyTree : G tree := sized genAnyTree_depth.
(* end genAnyTree *)

Extract Constant defSize => "10".

Definition test_naive :=
  insert_preserves_redblack_checker genAnyTree.
(* begin QC_naive *)
(*! QuickChick test_naive. *)
(* end QC_naive *)

(* gathering some size statistics *)
Fixpoint tree_size (t : tree) : nat :=
  match t with
    | Leaf => 1
    | Node c tl _ tr => 1 + (tree_size tl) + (tree_size tr)
  end.

Definition insert_preserves_redblack_checker_size (genTree : G tree) : Checker :=
  forAll arbitrary (fun n => forAll genTree (fun t =>
    collect (append "size " (show (tree_size t)))
    (is_redblack_bool t ==> is_redblack_bool (insert n t)))).

(*
Extract Constant Test.defNumTests => "100000".
QuickChick (insert_preserves_redblack_checker_size genAnyTree).
*)

Module DoNotation.
Import ssrfun.
Notation "'do!' X <- A ; B" :=
  (bindGen A (fun X => B))
  (at level 200, X ident, A at level 100, B at level 200).
End DoNotation.
Import DoNotation.

Require Import Relations Wellfounded Lexicographic_Product.

Definition ltColor (c1 c2: color) : Prop :=
  match c1, c2 with
    | Red, Black => True
    | _, _ => False
  end.

Lemma well_foulded_ltColor : well_founded ltColor.
Proof.
  unfold well_founded.
  intros c; destruct c;
  repeat (constructor; intros c ?; destruct c; try now (exfalso; auto)).
Qed.

Definition sigT_of_prod {A B : Type} (p : A * B) : {_ : A & B} :=
  let (a, b) := p in existT (fun _ : A => B) a b.

Definition prod_of_sigT {A B : Type} (p : {_ : A & B}) : A * B :=
  let (a, b) := p in (a, b).

Definition wf_hc (c1 c2 : (nat * color)) : Prop :=
  lexprod nat (fun _ => color) lt (fun _ => ltColor) (sigT_of_prod c1) (sigT_of_prod c2).

Lemma well_founded_hc : well_founded wf_hc.
Proof.
  unfold wf_hc. apply wf_inverse_image.
  apply wf_lexprod. now apply Wf_nat.lt_wf. intros _; now apply well_foulded_ltColor.
Qed.

Require Import Program.Wf. Import WfExtensionality.
Require Import FunctionalExtensionality.

(* begin genRBTree_height *)
Program Fixpoint genRBTree_height (hc : nat*color) {wf wf_hc hc} : G tree :=
  match hc with
  | (0, Red) => returnGen Leaf
  | (0, Black) => oneOf [returnGen Leaf;
                    (do! n <- arbitrary; returnGen (Node Red Leaf n Leaf))]
  | (S h, Red) => liftGen4 Node (returnGen Black) (genRBTree_height (h, Black))
                                        arbitrary (genRBTree_height (h, Black))
  | (S h, Black) => do! c' <- genColor;
                    let h' := match c' with Red => S h | Black => h end in
                    liftGen4 Node (returnGen c') (genRBTree_height (h', c'))
                                       arbitrary (genRBTree_height (h', c')) end.
(* end genRBTree_height *)
Next Obligation.
  unfold wf_hc; simpl; left; lia.
Qed.
Next Obligation.
  unfold wf_hc; simpl; left; lia.
Qed.
Next Obligation.
  unfold wf_hc; simpl; destruct c'; [right; apply I | left; lia].
Qed.
Next Obligation.
  unfold wf_hc; simpl; destruct c'; [right; apply I | left; lia].
Qed.
Next Obligation.
  abstract (apply well_founded_hc).
Defined.

Lemma genRBTree_height_eq (hc : nat*color) :
  genRBTree_height hc =
  match hc with
  | (0, Red) => returnGen Leaf
  | (0, Black) => oneOf [returnGen Leaf;
                    (do! n <- arbitrary; returnGen (Node Red Leaf n Leaf))]
  | (S h, Red) => liftGen4 Node (returnGen Black) (genRBTree_height (h, Black))
                                        arbitrary (genRBTree_height (h, Black))
  | (S h, Black) => do! c' <- genColor;
                    let h' := match c' with Red => S h | Black => h end in
                    liftGen4 Node (returnGen c') (genRBTree_height (h', c'))
                                       arbitrary (genRBTree_height (h', c')) end.
Proof.
  unfold_sub genRBTree_height (genRBTree_height hc).
  f_equal. destruct hc as [[|h] [|]]; try reflexivity.
  f_equal. apply functional_extensionality => [[|]]; reflexivity.
Qed.

(* Hope that this is enough for preventing unfolding genRBTree_height *)
Global Opaque genRBTree_height.

(* begin genRBTree *)
Definition genRBTree := bindGen arbitrary (fun h => genRBTree_height (h, Red)).
(* end genRBTree *)

Definition showDiscards (r : Result) :=
  match r with
  | Success ns nd _ _ => "Success: number of successes " ++ show (ns-1) ++ newline ++
                         "         number of discards "  ++ show nd ++ newline
  | _ => show r
  end.

Definition testInsert :=
  showDiscards (quickCheck (insert_preserves_redblack_checker genRBTree)).

Extract Constant defSize => "10".
Definition test_smart :=
  (insert_preserves_redblack_checker genRBTree).
(* begin QC_good *)
(*! QuickChick test_smart. *)
(* end QC_good *)

(* gathering some size statistics
Extract Constant Test.defNumTests => "100000".
QuickChick (insert_preserves_redblack_checker_size genRBTree).
*)


Set Automatic Introduction.

Inductive even : nat -> Prop :=
| even_0 : even 0
| even_odd : forall n, odd n -> even (S n)
with odd : nat -> Prop :=
| odd_1 : odd 1
| odd_even : forall n, even n -> odd (S n).

Lemma foo {n : nat} (E : even n) : even (S (S n))
with bar {n : nat} (O : odd n) : odd (S (S n)).
Proof. destruct E. constructor. constructor. apply even_odd. apply (bar _ H).
  destruct O. repeat constructor. apply odd_even. apply (foo _ H).
Defined.


Require Import Arith.

Structure poset := {
poset_carrier:> Set;
poset_relation:> poset_carrier -> poset_carrier -> Prop;
refl: forall x , poset_relation x x ;
transivity: forall x  y z , poset_relation x y /\ poset_relation y z
 -> poset_relation x z;
anti_symmetry: forall x y, poset_relation x y /\ poset_relation y x -> x = y;
}.

Notation "x <= y" := (poset_relation x y) (at level 70, no associativity).

Inductive two := a | b.

Definition ftwo(x y:two):Prop:=
match x with
    |a => True
    | b => (match y with
 | b => True
| a => False
end
)
end.
Eval compute in (ftwo b a).

Definition two_poset : poset.
Proof.
refine {| poset_carrier := two; poset_relation := ftwo |}.
-intros. induction x.
   +  simpl. trivial.
   +  simpl. trivial.
- intros. rename H into Hypoth. induction x.
   ++ simpl. trivial.
   ++ destruct Hypoth.
     *** induction y.
         -- elim H.
         -- apply H0.
- intros. destruct H. induction x.
   + induction y.
     --- trivial.
    --- elim H0.
   + induction y. elim H. trivial.
Qed.

Inductive LiftedBool := T | F | B.

Defnition LiftedBoolRel (x y : LiftedBool): Prop :=
match x with
    |T => ( match y with
          |T => True
          |F => False
          |B => False
           end)
    |F => ( match y with
          |T => False
          |F => True
          |B => False
           end)
    |B => True
end

Eval compute in LiftedBoolRel T F
Definition


Theorem Ex041 (A B C : Prop) :  B /\ B -> A -> ((C \/ ~B) \/ A <-> A /\ ~(B -> ~A)).
Proof.
  intro.
  destruct H.
  split.
  + intro.
    split.
    - exact H1.
    - intro. apply H3.
      * exact H.
      * exact H1.
  + intro.
    right.
    exact H1.
Qed.


Require Import Coq.Classes.Morphisms.
Require Import Relation_Definitions.
Require Import Wellfounded.
Import Basics.
Import Relation_Operators.

Require Import compcert.lib.Coqlib.

     (*  The order on the lists is not lexicographic!
         It's Every element is smaller or equal.
         ALSO : surprisingly, we don't need transitivity.

       *)
      Inductive list_ord {A} (ord: A -> A -> Prop): list A -> list A -> Prop:=
      | lt_head: forall x y ls, ord x y -> list_ord ord (x::ls) (y::ls)
      | lt_tail: forall x ls ls', list_ord ord ls ls' ->
                             list_ord ord (x::ls) (x::ls').
      Inductive list_ord_part {A}
                (list_ord: list A -> list A -> Prop)
                (ord: A -> A -> Prop): list A -> list A -> Prop:=
      | lt_head_part: forall x y ls, ord x y ->
                                list_ord_part list_ord ord (x::ls) (y::ls)
      | lt_tail_part: forall x ls ls', list_ord ls ls' ->
                                  list_ord_part list_ord ord (x::ls) (x::ls').

      Inductive list_ord_trans {A} (ord: A -> A -> Prop): list A -> list A -> Prop:=
      | lt_head_trans: forall x y ls, ord x y -> list_ord_trans ord (x::ls) (y::ls)
      | lt_tail_trans: forall x ls ls', list_ord_trans ord ls ls' ->
                             list_ord_trans ord (x::ls) (x::ls')
      | lt_all: forall x y ls ls', ord x y ->
                              list_ord_trans ord ls ls' ->
                              list_ord_trans ord (x::ls) (y::ls').
      Instance list_ord_is_trans {A} (ord: relation A):
        Transitive ord -> Transitive (list_ord_trans ord).
      Proof.
        intros Trans ?? z H1; revert z.
        induction H1; intros z Hz; inv Hz;
          first [constructor 1|
                 constructor 2|
                 constructor 3]; eauto.
      Qed.

      Definition trans_symprod {A B} ltA ltB : relation (A * B):=
        Relation_Operators.clos_trans _ (@Relation_Operators.symprod A B ltA ltB).
      Lemma trans_symprod_wf:
         forall {A B} (leA : relation A) (leB : relation B),
       well_founded leA -> well_founded leB ->
       well_founded (trans_symprod leA leB).
      Proof. intros; apply wf_clos_trans, wf_symprod; eauto. Qed.

      Definition ord_union_intersection {A B} ltA ltB : relation (A * B):=
        Relation_Operators.clos_trans _ (@Relation_Operators.symprod A B ltA ltB).

      Lemma list_order_as_pair:
        forall {A} ord (a b:A) lsa lsb,
          list_ord ord (a::lsa) (b::lsb) <->
          symprod _ _ ord (list_ord ord) (a,lsa) (b,lsb).
      Proof.
        split; intros **.
        - inv H.
          + left; assumption.
          + right; assumption.
        - remember (a,lsa) as alsa.
          remember (b,lsb) as blsb.
          set (listify:= fun a_lsa: (A * list A)=> (fst a_lsa) :: (snd a_lsa)).
          replace (a::lsa) with (listify alsa) by
           (unfold listify; subst; reflexivity).
          replace (b::lsb) with (listify blsb) by
              (unfold listify; subst; reflexivity).
          clear Heqalsa Heqblsb.
          induction H.
          + apply lt_head; assumption.
          + apply lt_tail; assumption.
      Qed.
      Lemma list_order_part_as_pair:
        forall {A} list_ord ord (a b:A) lsa lsb,
          list_ord_part list_ord ord (a::lsa) (b::lsb) <->
          symprod _ _ ord list_ord (a,lsa) (b,lsb).
      Proof.
        split; intros **.
        - inv H.
          + left; assumption.
          + right; assumption.
        - remember (a,lsa) as alsa.
          remember (b,lsb) as blsb.
          set (listify:= fun a_lsa: (A * list A)=> (fst a_lsa) :: (snd a_lsa)).
          replace (a::lsa) with (listify alsa) by
           (unfold listify; subst; reflexivity).
          replace (b::lsb) with (listify blsb) by
              (unfold listify; subst; reflexivity).
          clear Heqalsa Heqblsb.
          induction H.
          + apply lt_head_part; assumption.
          + apply lt_tail_part; assumption.
      Qed.

      Lemma list_order_trans_as_pair:
        forall {A} ord (a b:A) lsa lsb,
          Transitive ord ->
          list_ord_trans ord (a::lsa) (b::lsb) <->
          trans_symprod ord (list_ord_trans ord) (a,lsa) (b,lsb).
      Proof.
        split; intros **.
        - inv H0.
          + eapply t_step; left; assumption.
          + eapply t_step; right; assumption.
          + eapply Relation_Operators.t_trans.
            * eapply Relation_Operators.t_step.
              left; eassumption.
            * eapply Relation_Operators.t_step.
              right; eassumption.
        - remember (a,lsa) as alsa.
          remember (b,lsb) as blsb.
          set (listify:= fun a_lsa: (A * list A)=> (fst a_lsa) :: (snd a_lsa)).
          replace (a::lsa) with (listify alsa) by
           (unfold listify; subst; reflexivity).
          replace (b::lsb) with (listify blsb) by
              (unfold listify; subst; reflexivity).
          clear Heqalsa Heqblsb.
          induction H0. inv H0.
          + apply lt_head_trans; assumption.
          + apply lt_tail_trans; assumption.
          + eapply list_ord_is_trans; eauto.
      Qed.

      (* List order annotated with length. *)
      Definition ln_ord {A} (ord: (list A) -> (list A) -> Prop) n:=
        fun ls1 ls2 =>
          length ls1 = n /\ length ls2 = n /\ ord ls1 ls2.

      Lemma well_founded_by_length:
        forall {A} (ord: relation A) ,
        (forall n, forall x, length x = n ->
              Acc (list_ord ord) x) ->
        well_founded (list_ord ord).
      Proof. intros ** ?; eapply H; reflexivity. Qed.

      Lemma list_ord_length:
        forall {A} (ord: relation A) y x,
          list_ord ord y x ->
          length y = length x.
      Proof.
        intros. revert y H.
        induction x; intros; inv H.
        all: simpl; f_equal; eauto.
      Qed.

      Lemma ln_ord_inversion:
        forall {A} (ord: relation A) n y x,
          length x = n ->
          list_ord ord y x ->
          ln_ord (list_ord ord) n y x.
      Proof.
        repeat split; auto.
        - erewrite list_ord_length; eauto.
      Qed.

      Lemma wf_list_helper:
        forall {A} (ord: relation A) n,
          (forall x : list A, Acc (ln_ord (list_ord ord) n) x) ->
          forall x : list A,
            Datatypes.length x = n -> Acc (list_ord ord) x.
      Proof.
        intros ? ? ? ? x.
        eapply (@Acc_ind _ (ln_ord (list_ord ord) n)
                         (fun x => length x = n -> Acc (list_ord ord) x)

               ); eauto.
        clear x; intros.
        econstructor; intros.
        eapply H1.
        - apply ln_ord_inversion; eauto.
        - erewrite list_ord_length; eauto.
      Qed.

      Lemma wf_list_ord_n:
        forall {A} (ord:A -> A -> Prop),
        (forall n, well_founded (ln_ord (list_ord ord) n)) ->
        well_founded (list_ord ord).
      Proof.
        intros ** ?.
        eapply wf_list_helper; try reflexivity. eapply H.
      Qed.

      Local Instance well_founded_subrelation {A}
        : Proper (flip subrelation ==> impl) (@well_founded A).
      Proof.
        intros R R' HR Rwf a.
        induction (Rwf a) as [a Ra R'a].
        constructor; intros y Hy.
        apply R'a, HR, Hy.
      Qed.

      Definition pair_to_list {A} (als: A *list A ): list A :=
        match als with | (a, ls) => a:: ls end.
      Definition comp_ord {A B} (ord:relation A) (f: B -> A): relation B:=
        fun b1 b2 => ord (f b1) (f b2).
      Lemma trans_symprod_length:
        forall {A} (ord: relation A) x y,
          trans_symprod ord (list_ord ord) x y ->
          length (pair_to_list y) = length (pair_to_list x).
      Proof.
        intros.
        induction H. inv H.
        - reflexivity.
        - simpl. eapply list_ord_length in H0; eauto.
        - etransitivity; eauto.
      Qed.
      Lemma comp_ord_subrelation:
        forall {A} ls_ord (ord: relation A),
          (relation_equivalence)
            (symprod _ _ ord (ls_ord))
            (comp_ord (list_ord_part ls_ord ord) pair_to_list).
      Proof.
        intros ** [] []; split; intros H.
        - inv H; constructor; auto.
        - inv H; constructor; auto.
      Qed.

      Lemma rel_equiv:
        forall {A} (ord: relation A) n,
          (flip subrelation)
            (symprod _ _ ord (ln_ord (list_ord ord) n))
            (comp_ord (ln_ord (list_ord ord) (S n)) pair_to_list).
      Proof.
        intros ** [] []; simpl.
        - intros (?&?&?).
          eapply list_order_as_pair in H1.
          induction H1.
          + constructor; auto.
          + constructor.
            repeat (split; eauto).
      Qed.
      Lemma wf_comp_ord_filter:
        forall {A B} (ord:relation A) (f: B -> A) (P: A -> Prop),
          (forall a, P a -> exists b, f b = a) ->
          well_founded (comp_ord ord f) ->
          (forall a b, ord a b -> P a) ->
          (forall a b, ord a b -> P b) ->
          well_founded ord.
      Proof.
        intros ?? ord f P H Hwf ? ? a.
        econstructor; intros.
        pose proof (H0 _ _ H2) as Py.
        destruct (H y Py) as (b & fb); rewrite <- fb.
        clear Py fb a y H2.
        eapply (@Acc_ind _ (comp_ord ord f)
                         (fun b => Acc ord (f b))); eauto.
        - intros.
          econstructor; intros.
          pose proof (H0 _ _ H4) as Py.
          destruct (H y Py) as (b' & fb'); rewrite <- fb' in *.
          eapply H3; eauto.
      Qed.

      Lemma pair_to_list_pimg:
          forall A (a : list A), a <> nil ->
                        exists b : A * list A, pair_to_list b = a.
      Proof.
        intros. destruct a; try (contradict H; reflexivity).
        exists (a,a0); reflexivity.
      Qed.
      Lemma list_ord_wf:
        forall {A} (ord:A->A->Prop),
          well_founded ord ->
          well_founded (list_ord ord).
      Proof.
        intros.
        eapply wf_list_ord_n.
        induction n.
        - intros ** a. destruct a.
          + constructor; intros ? (?&?&?). inv H2.
          + constructor; intros ? (?&?&?). inv H1.
        - eapply wf_comp_ord_filter;
            try apply pair_to_list_pimg.

          + erewrite <- rel_equiv; eapply wf_symprod; auto.
          + intros ?? (?&?&?) ?; subst; simpl in *;congruence.
          + intros ?? (?&?&?) ?; subst; simpl in *;congruence.
      Qed.

      Lemma list_ord_part_wf:
        forall {A} list_ord (ord:A->A->Prop),
          well_founded ord ->
          well_founded list_ord ->
          well_founded (list_ord_part list_ord ord).
      Proof.
        intros.
        eapply wf_comp_ord_filter;
          try apply pair_to_list_pimg.
        - erewrite <- comp_ord_subrelation; apply wf_symprod; assumption.
        - intros ** Heq; subst; simpl in *. inv H1.
        - intros ** Heq; subst; simpl in *. inv H1.
      Qed.


Require Import Arith.
Require Import List.
Require Import Lang.

Lemma idx_length : forall (s : Set) (A : s) G n, idx n G = Some A -> length G > n.
Proof.
  induction G ; intros ; simpl.
  destruct n.
  (* zero *)
  simpl in H.  inversion H.
  simpl in H. inversion H.
  (* succ *)
  intros. simpl.
  case_eq n. intros. subst. auto with arith.
  intros. apply gt_n_S. apply IHG. subst. simpl in H. auto.
Defined.

Lemma idx_at : forall (S : Set) (Ξ Γ : list S) (A : S), idx (length Ξ) (Ξ++A::Γ) = Some A.
Proof.
  induction Ξ. simpl. intros. auto.
  intros. simpl. apply IHΞ.
Defined.

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

Lemma idx_shift_le : forall (s : Set)
  Ξ Γ i (A : s) B,  length Ξ <= i ->
  idx i (Ξ ++ Γ) = Some B ->
  idx (S i) (Ξ ++ A :: Γ) = Some B.
Proof.
  induction Ξ ; intros.
  simpl in * ; auto.
  simpl ; destruct i.
   (* 0 *) simpl in H ; inversion H.
   (* S i *) apply IHΞ ; eauto with arith.
Defined.

Lemma idx_shift_lt : forall (s : Set)
  Ξ Γ i (A : s) B,  i < length Ξ ->
  idx i (Ξ ++ Γ) = Some B ->
  idx i (Ξ ++ A :: Γ) = Some B.
Proof.
  induction Ξ ; intros.
  simpl in *. inversion H.
  simpl ; destruct i.
   (* 0 *) simpl in * ; auto.
   (* S i *) simpl in *. apply IHΞ ; eauto with arith.
Defined.

Definition weaken_var_lt : forall Ξ Γ i A B,
  i < length Ξ ->
  (Ξ ++ Γ ⊢ v i @ B) ->
  (Ξ ++ A :: Γ ⊢ v i @ B).
Proof.
  intros.
  apply VarIntro.
  inversion H0. subst. apply idx_shift_lt ; auto.
Defined.

Definition weaken_var_gt : forall Ξ Γ i A B,
  length Ξ < (S i) ->
  (Ξ ++ Γ ⊢ v i @ B) ->
  (Ξ ++ A :: Γ ⊢ v (S i) @ B).
Proof.
  intros.
  apply VarIntro.
  inversion H0. subst.
  apply idx_shift_le; auto with arith.
Defined.

Lemma weaken_var : forall Ξ Γ i A B,
  (Ξ ++ Γ ⊢ v i @ B) ->
  (Ξ ++ A :: Γ ⊢ shiftat (length Ξ) (v i) @ B).
Proof.
  intros.
  simpl.
  case (le_lt_dec (length Ξ) i). intros.
  apply weaken_var_gt; auto with arith.
  intros.
  apply weaken_var_lt; auto with arith.
Defined.

Lemma weaken : forall Ξ Γ t A B,
  (Ξ ++ Γ ⊢ t @ B) ->
  (Ξ ++ A :: Γ ⊢ shiftat (length Ξ) t @ B).
Proof.
  refine
    (fix weaken (Ξ Γ : Ctx) (t : Term) (A B : Ty)
      (d : (Ξ ++ Γ ⊢ t @ B)) {struct t} : (Ξ ++ A :: Γ ⊢ shiftat (length Ξ) t @ B) :=
      (match t as t'
         return (t = t' -> (Ξ ++ A :: Γ ⊢ shiftat (length Ξ) t @ B))
        with
         | v i => _
         | ƛ ty r => _
         | r · s => _
       end) (refl_equal t))  ; intros ; subst.

  (* var *)
  intros. apply weaken_var. auto.
  (* lam *)
  simpl.
  inversion d. subst.
  apply ImpIntro.
  change (S (length Ξ)) with (length (ty::Ξ)).
  change (ty :: Ξ ++ A :: Γ) with ((ty :: Ξ) ++ A :: Γ).
  apply weaken. auto.

  (* app *)
  simpl.
  inversion d. subst.
  apply ImpElim with (A:=A0).
  apply weaken. auto.
  apply weaken. auto.
Defined.

Require Import Omega.

Lemma shift_invariance : forall t Γ i A, i >= length Γ -> (Γ ⊢ t @ A) -> shiftat i t = t.
Proof.
  induction t ; intros ; simpl ; auto.

  (* v *)
  inversion H0. subst. apply idx_length in H3.
  simpl. case (le_lt_dec i n) ; intros. apply False_rec. omega. auto.

  (* lam *)
  inversion H0 ; subst.
  rewrite IHt with (Γ:=t::Γ) (A:=B). auto. simpl. auto with arith.
  inversion H0 ; subst.  auto.

  (* app *)
  inversion H0. subst.
  rewrite IHt1 with (Γ:=Γ) (A:=A0 ⇒ A).
  rewrite IHt2 with (Γ:=Γ) (A:=A0).
  auto. auto. auto. auto. auto.
Defined.

Lemma closed_shift_invariant : forall t A i, ([] ⊢ t @ A) -> shiftat i t = t.
Proof.
  intros.
  apply shift_invariance with (Γ:=[]) (A :=A). simpl. auto with arith. auto.
Defined.

Lemma weaken_closed_one : forall Γ t A B, ([] ⊢ t @ A) -> (Γ ⊢ t @ A) -> (B::Γ ⊢ t @ A).
Proof.
  induction Γ ; intros.

  (* [] *)
  apply closed_shift_invariant with (i:=0) in H.
  rewrite <- H.
  change [B] with ([]++B::[]).
  apply weaken. simpl. auto.
  intros.

  (* a::Γ *)
  apply closed_shift_invariant with (i:=0) in H.
  rewrite <- H.
  change (B::a::Γ) with ([]++B::(a::Γ)).
  apply weaken. simpl.  auto.
Defined.

Lemma weaken_closed : forall Γ t A, ([] ⊢ t @ A) -> (Γ ⊢ t @ A).
Proof.
  induction Γ.
  intros. auto. intros. apply weaken_closed_one. auto. apply IHΓ. auto.
Defined.

Lemma idx_sameR : forall (A : Set) i a (Γ Ξ:list A),
  length Ξ < S i ->
  idx (S i) (Ξ++a::Γ) = idx i (Ξ++Γ).
Proof.
  refine
    (fix idx_sameR (A : Set) i a (Γ Ξ:list A) (H: length Ξ < S i) {struct Ξ} : idx (S i) (Ξ++(a::Γ)) = idx i (Ξ++Γ) :=
      (match Ξ as Ξ' return (Ξ = Ξ' -> idx (S i) (Ξ++(a::Γ)) = idx i (Ξ++Γ)) with
         | nil => _
         | cons a g => _
       end) (refl_equal Ξ)).
  intros. subst. simpl. auto.
  intros ; subst. simpl. simpl in H.
  destruct i.  apply le_S_n in H. apply le_n_O_eq in H.
  inversion H.
  apply idx_sameR. auto with arith.
Defined.

Lemma idx_sameL : forall (s : Set) (Γ Ξ:list s) i A,
  i < length Ξ ->
  idx i (Ξ++A::Γ) = idx i (Ξ++Γ).
Proof.
  induction Ξ ; intros ; simpl in *.
  unfold lt in H. apply le_n_O_eq in H. inversion H.
  destruct i. simpl. auto.
  simpl. apply IHΞ. eauto with arith.
Defined.

Lemma strengthen_gt : forall Ξ Γ i A B,
  length Ξ < S i ->
  (Ξ ++ A :: Γ ⊢ v (S i) @ B) ->
  (Ξ ++ Γ ⊢ v i @ B).
Proof.
  intros.
  inversion H0 ; subst ; auto.
  apply VarIntro.
  rewrite <- idx_sameR with (a:=A) ; auto.
Defined.

Lemma strengthen_lt : forall Ξ Γ i A B,
  i < length Ξ ->
  (Ξ ++ A :: Γ ⊢ v i @ B) ->
  (Ξ ++ Γ ⊢ v i @ B).
Proof.
  intros. inversion H0. subst.
  apply VarIntro.
  rewrite <- idx_sameL with (A:=A) ; auto.
Defined.


Definition tautology : forall P : Prop, P -> P
:= (fun (P : Prop) (H : P)=> H).

Definition Modus_tollens : forall P Q : Prop, ~Q /\ (P -> Q) -> ~P :=
  (fun (P Q : Prop) (H : ~Q /\ (P -> Q)) =>
     match H with
       | conj H0 H1 => (fun (H2 : P) => H0 (H1 H2))
     end).

Definition Diojunctive_syllogism : forall P Q : Prop, (P \/ Q) -> ~P -> Q
  :=(fun (P Q : Prop) (H0 : P \/ Q) (H1 : ~P) =>
       match H0 with
         | or_introl H2 => match H1 H2 return Q with end
         | or_intror H2 => H2
       end
    )
.

Definition tautology_on_Set : forall A : Set, A -> A
  := (fun (A : Set) (B : A) => B)
.

Definition Modus_tollens_on_Set : forall A B : Set, (B -> Empty_set) * (A -> B) -> (A -> Empty_set)
  := (fun (A B : Set) (H : (B -> Empty_set) * (A -> B)) (H0 : A) =>
        let (a, b) := H in
        a (b H0)
     )
.

Definition Diojunctive_syllogism_on_Set : forall A B : Set, (A + B) -> (A -> Empty_set) -> B
  := (fun (A B : Set) (C : A + B) (H : A -> Empty_set) =>
        match C with
          | inr b => b
          | inl a => match H a return B with
                     end
        end
     )
.


(**************************************************************)
(*   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 Bool Lia Eqdep_dec.

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

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

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

Import fol_notations.

Set Implicit Arguments.

(* * From binary singleton to n-ary singleton with n >= 2 *)

Local Notation ø := vec_nil.

(* The reduction could be made to work for (infinite) SAT only *)

Section Sig2_Sig_n_encoding.

  Variable (n : nat).

  Notation Σ2 := (Σrel 2).
  Notation Σn := (Σrel (S (S n))).

  (* The encoding is trivial here : replace R2(x,y) with Rn(x,y,...,y) *)

  Fixpoint Σ2_Σn (A : fol_form Σ2) : fol_form Σn :=
    match A with
      | ⊥              => ⊥
      | fol_atom   _ v => let x := Σrel_var (vec_head v)            in
                          let y := Σrel_var (vec_head (vec_tail v))
                          in  @fol_atom Σn tt (£x##vec_set_pos (fun _ => £y))
      | fol_bin b A B  => fol_bin b (Σ2_Σn A) (Σ2_Σn B)
      | fol_quant q A  => fol_quant q (Σ2_Σn A)
     end.

  Section correctness.

    Variable (X : Type) (M2 : fo_model Σ2 X) (Mn : fo_model Σn X).

    Notation "⟪ A ⟫" := (fun ψ => fol_sem M2 ψ A).
    Notation "⟪ A ⟫'" := (fun φ => fol_sem Mn φ A) (at level 1, format "⟪ A ⟫'").

    Let P2 a b := fom_rels M2 tt (a##b##ø).
    Let Pn a b := fom_rels Mn tt (a##vec_set_pos (fun _ => b)).

    Hypothesis HP : forall x y, P2 x y <-> Pn x y.

    Lemma Σ2_Σn_correct (A : fol_form Σ2) φ : ⟪ A ⟫ φ <-> ⟪Σ2_Σn A⟫' φ.
    Proof using HP.
      revert φ.
      induction A as [ | [] v | b A HA B HB | q A HA ]; intros phi.
      + simpl; tauto.
      + vec split v with a; vec split v with b; vec nil v; clear v; revert a b.
        intros [ a | [] ] [ b | [] ]; unfold Σ2_Σn; simpl; rew fot.
        rewrite vec_map_set_pos; apply HP.
      + simpl; apply fol_bin_sem_ext; auto.
      + simpl; apply fol_quant_sem_ext; intro; auto.
    Qed.

  End correctness.

  Variable (A : fol_form Σ2).

  Section soundness.

    Variables (X : Type)
              (M2 : fo_model Σ2 X)
              (H1 : finite_t X)
              (H2 : fo_model_dec M2)
              (phi : nat -> X)
              (H3 : fol_sem M2 phi A).

    Let Mn : fo_model Σn X.
    Proof.
      exists.
      + intros [].
      + intros []; simpl.
        intros v.
        exact (fom_rels M2 tt (vec_head v##vec_head (vec_tail v)##ø)).
    Defined.

    Local Lemma Σ2_Σn_sound_loc : fo_form_fin_dec_SAT (Σ2_Σn A).
    Proof using All.
      exists X, Mn, H1.
      exists. { intros [] ?; apply H2. }
      exists phi.
      revert H3.
      apply Σ2_Σn_correct; simpl; tauto.
    Qed.

  End soundness.

  Lemma Σ2_Σn_soundness :
        fo_form_fin_dec_SAT A
     -> fo_form_fin_dec_SAT (Σ2_Σn A).
  Proof.
    intros (X & M2 & H1 & H2 & phi & H3).
    apply Σ2_Σn_sound_loc with (M2 := M2) (phi := phi); auto.
  Qed.

  Section completeness.

    Variables (X : Type)
              (Mn : fo_model Σn X)
              (H1 : finite_t X)
              (H2 : fo_model_dec Mn)
              (phi : nat -> X)
              (H3 : fol_sem Mn phi (Σ2_Σn A)).

    Let M2 : fo_model Σ2 X.
    Proof.
      exists.
      + intros [].
      + intros []; simpl.
        intros v.
        exact (fom_rels Mn tt (vec_head v##vec_set_pos (fun _ => vec_head (vec_tail v)))).
    Defined.

    Local Lemma Σ2_Σn_complete_loc : fo_form_fin_dec_SAT A.
    Proof using All.
      exists X, M2, H1.
      exists. { intros [] ?; apply H2. }
      exists phi.
      revert H3.
      apply Σ2_Σn_correct; simpl; tauto.
    Qed.

  End completeness.

  Lemma Σ2_Σn_completeness :
        fo_form_fin_dec_SAT (Σ2_Σn A)
     -> fo_form_fin_dec_SAT A.
  Proof.
    intros (X & Mn & H1 & H2 & phi & H3).
    apply Σ2_Σn_complete_loc with (Mn := Mn) (phi := phi); auto.
  Qed.

End Sig2_Sig_n_encoding.


(* Calculation for a language with interrupts (using the same compiler
and VM as Hutton and Wright). *)

Require Import List.
Require Import Tactics.

Require Import ZArith.
Local Open Scope Z_scope.

Inductive Expr : Set := Val (n : Z) | Add (e1 e2 : Expr) | Throw | Catch (e h : Expr)
                      | Seqn (e1 e2 : Expr) | Block (e : Expr) | Unblock (e : Expr).

Reserved Notation "x ⇓[ i ] y" (at level 70, no associativity).
Inductive Status : Set := B | U.

Inductive eval : Expr -> Status -> option Z -> Prop :=
| eval_val n i : Val n ⇓[i] Some n
| eval_throw i : Throw ⇓[i] None
| eval_add1 x y n m i : x ⇓[i] Some n -> y ⇓[i] Some m -> Add x y ⇓[i] Some (n + m)
| eval_add2 x y i : x ⇓[i] None -> Add x y ⇓[i] None
| eval_add3 x y n i : x ⇓[i] Some n -> y ⇓[i] None -> Add x y ⇓[i] None
| eval_seq1 x y n v i : x ⇓[i] Some n -> y ⇓[i] v -> Seqn x y ⇓[i] v
| eval_seq2  x y i : x ⇓[i] None -> Seqn x y ⇓[i] None
| eval_catch1 x y n i : x ⇓[i] Some n -> Catch x y ⇓[i] Some n
| eval_catch2 x y v i : x ⇓[i] None -> y ⇓[i] v -> Catch x y ⇓[i] v
| eval_block x v i : x ⇓[B] v -> Block x ⇓[i] v
| eval_unblock x v i : x ⇓[U] v -> Unblock x ⇓[i] v
| eval_int x : x ⇓[U] None
where "x ⇓[ i ] y" := (eval x i y).

Hint Constructors eval.

Inductive Instr : Set := PUSH (n : Z) | ADD | THROW | UNMARK | MARK (h : list Instr)
                       | POP | RESET | SET (i : Status).

Definition Code := list Instr.

Import ListNotations.

Fixpoint comp' (e : Expr) (c : Code) : Code :=
  match e with
    | Val n => PUSH n :: c
    | Add x y => comp' x (comp' y (ADD :: c))
    | Throw => THROW :: c
    | Catch e1 e2 => MARK (comp' e2 c) :: comp' e1 (UNMARK :: c)
    | Seqn e1 e2 => comp' e1 (POP :: comp' e2 c)
    | Block e => SET B :: comp' e (RESET :: c)
    | Unblock e => SET U :: comp' e (RESET :: c)
  end.

Definition comp (e : Expr) : Code := comp' e nil.

Inductive Elem : Set := VAL (n : Z) | HAN (c : Code) | INT (s  : Status).

Definition Stack : Set := list Elem.

Inductive Conf : Set := conf (c : Code) (s : Stack) (i : Status)
                      | fail (s : Stack) (i : Status).

Notation "⟨ c , s , i ⟩" := (conf c s i).
Notation "⟪ s , i ⟫" := (fail s i ).

Reserved Notation "x ==> y" (at level 80, no associativity).
Inductive VM : Conf -> Conf -> Prop :=
 | vm_push n c s i : ⟨PUSH n :: c, s, i⟩ ==> ⟨ c , VAL n :: s, i ⟩
 | vm_throw c s i : ⟨ THROW :: c, s, i⟩ ==> ⟪s, i⟫
 | vm_add c s m n i : ⟨ADD :: c, VAL m :: VAL n :: s, i⟩ ==> ⟨c, VAL (n + m) :: s, i⟩
 | vm_pop c n s i : ⟨POP :: c, VAL n :: s, i⟩ ==> ⟨c, s, i⟩
 | vm_mark h c s i : ⟨MARK h :: c, s, i⟩ ==> ⟨c, HAN h :: s, i⟩
 | vm_unmark c n h s i : ⟨UNMARK :: c, VAL n :: HAN h :: s, i⟩ ==> ⟨c, VAL n :: s, i⟩
 | vm_set c s i j : ⟨SET j :: c, s, i⟩ ==> ⟨c, INT i :: s, j⟩
 | vm_reset c s n i j : ⟨RESET :: c, VAL n :: INT i :: s, j⟩ ==> ⟨c, VAL n :: s, i⟩

 | vm_fail_val  m s i : ⟪VAL m :: s, i⟫ ==> ⟪s, i⟫
 | vm_fail_han s h i : ⟪HAN h :: s, i⟫ ==> ⟨h,s,i⟩
 | vm_fail_int i j s : ⟪INT i :: s, j⟫ ==> ⟪s,i⟫

 | vm_int c op s : ⟨op :: c, s, U⟩ ==> ⟪s, U⟫
where "x ==> y" := (VM x y).

Hint Constructors VM.

(* Boilerplate to import calculation tactics *)
Module VM <: Machine.
Definition Conf := Conf.
Definition Rel := VM.
End VM.
Module VMCalc := Calculation VM.
Import VMCalc.

Ltac by_eval := eval_inv (eval).

Theorem spec e P c :  { s i, ⟨comp' e c , s, i⟩ | P s i} =|>
                        { s i n, ⟨c , VAL n :: s, i⟩ | e ⇓[i] Some n /\ P s i}
                        ∪ { s i, ⟪s, i⟫ | e ⇓[i] None /\ P s i}.
Proof.
  intros.
  generalize dependent c.
  generalize dependent P.
  induction e;intros.

   begin
    ({ s i n', ⟨c, VAL n' :: s, i⟩ | Val n ⇓[i] Some n' /\ P s i} ∪
     { s i, ⟪s, i⟫ | Val n ⇓[i] None /\ P s i }).
   = {by_eval}
    ({ s i , ⟨c, VAL n :: s, i⟩ |  P s i} ∪
     { s , ⟪s, U⟫ | P s U }).
  <== {apply vm_push}
    ({ s i, ⟨ PUSH n :: c, s, i⟩ | P s i } ∪
     { s , ⟪s, U⟫ | P s U }).
  <== {apply vm_int}
    ({ s i, ⟨ PUSH n :: c, s, i⟩ | P s i } ∪
     { s, ⟨ PUSH n :: c, s, U⟩ | P s U }).
  = {auto}
    ({ s i, ⟨ PUSH n :: c, s, i⟩ | P s i }).
  [].

  begin
    ({s i n, ⟨c, VAL n :: s, i⟩ | Add e1 e2 ⇓[i] Some n /\ P s i } ∪
       { s i , ⟪s, i⟫ | Add e1 e2 ⇓[i] None /\ P s i }) .
  = {by_eval}
  ({s i n m, ⟨c, VAL (n + m) :: s, i⟩ | e1 ⇓[i] Some n /\ e2 ⇓[i] Some m /\ P s i} ∪
   { s i n , ⟪s, i⟫ | e1 ⇓[i] Some n /\ e2 ⇓[i] None /\ P s i } ∪
   { s i , ⟪s, i⟫ | e1 ⇓[i] None /\ P s i }).
  <== {apply vm_add}
  ({ s i n m, ⟨ADD :: c, VAL m :: VAL n :: s, i⟩ | e1 ⇓[i] Some n /\ e2 ⇓[i] Some m /\ P s i} ∪
   { s i n , ⟪ s, i ⟫ | e1 ⇓[i] Some n /\ e2 ⇓[i] None /\ P s i }
   ∪ { s i, ⟪s, i⟫ | e1 ⇓[i] None /\ P s i }).
  <== {apply vm_fail_val}
  ({ s i n m, ⟨ADD :: c, VAL m :: VAL n :: s, i⟩ | e1 ⇓[i] Some n /\ e2 ⇓[i] Some m /\ P s i} ∪
   { s i n , ⟪ VAL n :: s, i ⟫ | e1 ⇓[i] Some n /\ e2 ⇓[i] None /\ P s i }
   ∪ { s i, ⟪s, i⟫ | e1 ⇓[i] None /\ P s i }).
  = { auto }
  ({ s' i m, ⟨ADD :: c, VAL m :: s', i⟩ | e2 ⇓[i] Some m /\ (exists n s, s' = VAL n :: s
                                                        /\ e1 ⇓[i] Some n /\ P s i)} ∪
   { s' i, ⟪s', i⟫ | e2 ⇓[i] None /\ (exists n s, s' = VAL n :: s /\ e1 ⇓[i] Some n /\ P s i) } ∪
   { s i, ⟪s, i⟫ | e1 ⇓[i] None /\ P s i }).
  <|= {apply IHe2}
  ({ s' i, ⟨comp' e2 (ADD :: c), s', i⟩ | (exists n s, s' = VAL n :: s /\ e1 ⇓[i] Some n /\ P s i)}
     ∪ { s i, ⟪s, i⟫ | e1 ⇓[i] None /\ P s i }).
  = { auto }
  ({ s i n, ⟨comp' e2 (ADD :: c), VAL n :: s, i⟩ | e1 ⇓[i] Some n /\ P s i}
     ∪ { s i , ⟪s, i⟫ | e1 ⇓[i] None /\ P s i }).
  <|= { apply IHe1 }
  ({ s i, ⟨comp' e1 (comp' e2 (ADD :: c)), s, i⟩ | P s i}).
  [].

  begin
    ({s i n, ⟨c, VAL n :: s, i⟩ | Throw ⇓[i] Some n /\ P s i} ∪
    { s i , ⟪s, i⟫ | Throw ⇓[i] None /\ P s i}).
  = {by_eval}
    ({ s i , ⟪s, i⟫ | P s i}).
  <== {apply vm_throw}
    ({ s i , ⟨THROW :: c, s, i⟩ | P s i}).
  [].

  begin
    ({s i n, ⟨c, VAL n :: s, i⟩ | Catch e1 e2 ⇓[i] Some n /\ P s i } ∪
    { s i , ⟪s, i⟫ | Catch e1 e2 ⇓[i] None /\ P s i }).
  = {by_eval}
    ({s i n, ⟨c, VAL n :: s, i⟩ | e1 ⇓[i] Some n /\ P s i } ∪
    {s i n, ⟨c, VAL n :: s, i⟩ | e1 ⇓[i] None /\ e2 ⇓[i] Some n /\ P s i } ∪
    { s i , ⟪s, i⟫ | e1 ⇓[i] None /\ e2 ⇓[i] None /\ P s i } ∪
    { s , ⟪s, U⟫ | P s U }).
  = {auto}
    ({s i n, ⟨c, VAL n :: s, i⟩ | e1 ⇓[i] Some n /\ P s i } ∪
    ({s i n, ⟨c, VAL n :: s, i⟩ | e2 ⇓[i] Some n /\ (e1 ⇓[i] None /\ P s i) } ∪
     { s i , ⟪s, i⟫ | e2 ⇓[i] None /\ (e1 ⇓[i] None /\ P s i) }) ∪
    { s , ⟪s, U⟫ | P s U }).
  <|= { apply IHe2 }
    ({s i n, ⟨c, VAL n :: s, i⟩ | e1 ⇓[i] Some n /\ P s i } ∪
    {s i, ⟨comp' e2 c, s, i⟩ | e1 ⇓[i] None /\ P s i } ∪
    { s , ⟪s, U⟫ | P s U }).
  <== { apply vm_fail_han }
    ({s i n, ⟨c, VAL n :: s, i⟩ | e1 ⇓[i] Some n /\ P s i } ∪
    {s i, ⟪HAN (comp' e2 c) :: s, i⟫ | e1 ⇓[i] None /\ P s i } ∪
    { s , ⟪s, U⟫ | P s U }).
  <== { apply vm_unmark }
    ({s i n, ⟨UNMARK :: c, VAL n :: HAN (comp' e2 c) :: s, i⟩ | e1 ⇓[i] Some n /\ P s i } ∪
    {s i, ⟪HAN (comp' e2 c) :: s, i⟫ | e1 ⇓[i] None /\ P s i } ∪
    { s , ⟪s, U⟫ | P s U }).
  = { auto }
    ({s' i n, ⟨UNMARK :: c, VAL n :: s', i⟩ | e1 ⇓[i] Some n /\ (exists s, s' = HAN (comp' e2 c) :: s /\ P s i )} ∪
    {s' i, ⟪s', i⟫ | e1 ⇓[i] None /\ (exists s, s' = HAN (comp' e2 c) :: s /\ P s i ) } ∪
    { s , ⟪s, U⟫ | P s U }).
  <|= {apply IHe1}
    ({s' i, ⟨comp' e1 (UNMARK :: c), s', i⟩ | (exists s, s' = HAN (comp' e2 c) :: s /\ P s i ) } ∪
    { s , ⟪s, U⟫ | P s U }).
  = {auto}
    ({s i, ⟨comp' e1 (UNMARK :: c), HAN (comp' e2 c) :: s, i⟩ | P s i } ∪
    { s , ⟪s, U⟫ | P s U }).
  <== {apply vm_mark}
    ({s i, ⟨MARK (comp' e2 c) :: comp' e1 (UNMARK :: c), s, i⟩ | P s i } ∪
    { s , ⟪s, U⟫ | P s U }).
  <== {apply vm_int}
    ({s i, ⟨MARK (comp' e2 c) :: comp' e1 (UNMARK :: c), s, i⟩ | P s i } ∪
    { s , ⟨MARK (comp' e2 c) :: comp' e1 (UNMARK :: c), s, U⟩ | P s U }).
  = {auto}
    ({s i, ⟨MARK (comp' e2 c) :: comp' e1 (UNMARK :: c), s, i⟩ | P s i }).
  [].

  begin
    ({s i n, ⟨c, VAL n :: s, i⟩ | Seqn e1 e2 ⇓[i] Some n /\ P s i } ∪
    { s i , ⟪s, i⟫ | Seqn e1 e2 ⇓[i] None /\ P s i }).
  = {by_eval}
    ({s i n, ⟨c, VAL n :: s, i⟩ | e2 ⇓[i] Some n /\ (exists m, e1 ⇓[i] Some m) /\ P s i } ∪
    {s i, ⟪s, i⟫ | e2 ⇓[i] None /\ (exists m, e1 ⇓[i] Some m) /\ P s i } ∪
    { s i , ⟪s, i⟫ | e1 ⇓[i] None /\ P s i }).
  <|= {apply IHe2}
    ({s i, ⟨comp' e2 c, s, i⟩ | (exists m, e1 ⇓[i] Some m) /\ P s i } ∪
    { s i , ⟪s, i⟫ | e1 ⇓[i] None /\ P s i }).
  = {eauto}
    ({s i m, ⟨comp' e2 c, s, i⟩ | e1 ⇓[i] Some m /\ P s i } ∪
    { s i , ⟪s, i⟫ | e1 ⇓[i] None /\ P s i }).
  <== {apply vm_pop}
    ({s i m, ⟨POP :: comp' e2 c, VAL m :: s, i⟩ | e1 ⇓[i] Some m /\ P s i } ∪
    { s i , ⟪s, i⟫ | e1 ⇓[i] None /\ P s i }).
  <|= {apply IHe1}
    ({s i, ⟨comp' e1 (POP :: comp' e2 c), s, i⟩ | P s i }).
  [].

  begin
    ({s i n, ⟨c, VAL n :: s, i⟩ | Block e ⇓[i] Some n /\ P s i } ∪
    { s i, ⟪s, i⟫ | Block e ⇓[i] None /\ P s i }).
  = {by_eval}
    ({s i n, ⟨c, VAL n :: s, i⟩ | e ⇓[B] Some n /\ P s i } ∪
    { s i, ⟪s, i⟫ | e ⇓[B] None /\ P s i } ∪
    { s , ⟪s, U⟫ | P s U }).
  <== {apply vm_reset}
    ({s i n, ⟨RESET :: c, VAL n :: INT i :: s, B⟩ | e ⇓[B] Some n /\ P s i } ∪
    { s i, ⟪s, i⟫ | e ⇓[B] None /\ P s i } ∪
    { s , ⟪s, U⟫ | P s U }).
  <== {apply vm_fail_int}
    ({s i n, ⟨RESET :: c, VAL n :: INT i :: s, B⟩ | e ⇓[B] Some n /\ P s i } ∪
    { s i, ⟪INT i :: s, B⟫ | e ⇓[B] None /\ P s i } ∪
    { s , ⟪s, U⟫ | P s U }).
  = {auto}
    ({s' i' n, ⟨RESET :: c, VAL n :: s', i'⟩ | e ⇓[i'] Some n /\
                                             (i' = B /\ exists s i, s' = INT i :: s /\ P s i) } ∪
    { s' i', ⟪s', i'⟫ | e ⇓[i'] None /\ (i' = B /\ exists s i, s' = INT i :: s /\ P s i) } ∪
    { s , ⟪s, U⟫ | P s U }).
  <|= {apply IHe}
    ({s' i', ⟨comp' e (RESET :: c), s', i'⟩ | i' = B /\ exists s i, s' = INT i :: s /\ P s i } ∪
    { s , ⟪s, U⟫ | P s U }).
  = {auto}
    ({s i, ⟨comp' e (RESET :: c), INT i :: s, B⟩ | P s i } ∪
    { s , ⟪s, U⟫ | P s U }).
  <== {apply vm_set}
    ({s i, ⟨SET B :: comp' e (RESET :: c), s, i⟩ | P s i } ∪
    { s , ⟪s, U⟫ | P s U }).
  <== {apply vm_int}
    ({s i, ⟨SET B :: comp' e (RESET :: c), s, i⟩ | P s i } ∪
    {s, ⟨SET B :: comp' e (RESET :: c), s, U⟩ | P s U }).
  = {auto}
    ({s i, ⟨SET B :: comp' e (RESET :: c), s, i⟩ | P s i }).
  [].

  begin
    ({s i n, ⟨c, VAL n :: s, i⟩ | Unblock e ⇓[i] Some n /\ P s i } ∪
    { s i, ⟪s, i⟫ | Unblock e ⇓[i] None /\ P s i }).
  = {by_eval}
    ({s i n, ⟨c, VAL n :: s, i⟩ | e ⇓[U] Some n /\ P s i } ∪
    { s i, ⟪s, i⟫ | e ⇓[U] None /\ P s i } ∪
    { s , ⟪s, U⟫ | P s U }).
  <== {apply vm_reset}
    ({s i n, ⟨RESET :: c, VAL n :: INT i :: s, U⟩ | e ⇓[U] Some n /\ P s i } ∪
    { s i, ⟪s, i⟫ | e ⇓[U] None /\ P s i } ∪
    { s , ⟪s, U⟫ | P s U }).
  <== {apply vm_fail_int}
    ({s i n, ⟨RESET :: c, VAL n :: INT i :: s, U⟩ | e ⇓[U] Some n /\ P s i } ∪
    { s i, ⟪INT i :: s, U⟫ | e ⇓[U] None /\ P s i } ∪
    { s , ⟪s, U⟫ | P s U }).
  = {auto}
    ({s' i' n, ⟨RESET :: c, VAL n :: s', i'⟩ | e ⇓[i'] Some n /\
                                             (i' = U /\ exists s i, s' = INT i :: s /\ P s i) } ∪
    { s' i', ⟪s', i'⟫ | e ⇓[i'] None /\ (i' = U /\ exists s i, s' = INT i :: s /\ P s i) } ∪
    { s , ⟪s, U⟫ | P s U }).
  <|= {apply IHe}
    ({s' i', ⟨comp' e (RESET :: c), s', i'⟩ | i' = U /\ exists s i, s' = INT i :: s /\ P s i } ∪
    { s , ⟪s, U⟫ | P s U }).
  = {auto}
    ({s i, ⟨comp' e (RESET :: c), INT i :: s, U⟩ | P s i } ∪
    { s , ⟪s, U⟫ | P s U }).
  <== {apply vm_set}
    ({s i, ⟨SET U :: comp' e (RESET :: c), s, i⟩ | P s i } ∪
    { s , ⟪s, U⟫ | P s U }).
  <== {apply vm_int}
    ({s i, ⟨SET U :: comp' e (RESET :: c), s, i⟩ | P s i } ∪
    { s , ⟨SET U :: comp' e (RESET :: c), s, U⟩ | P s U }).
  = {auto}
    ({s i, ⟨SET U :: comp' e (RESET :: c), s, i⟩ | P s i }).
  [].
Qed.


Require Import Rbase Ranalysis.
Require Import Rinterval Rfunctions Rfunction_def Rfunction_facts.
Require Import Ranalysis_def Ranalysis_def_simpl.
Require Import MyRIneq MyR_dist Lra.

Require Import Ass_handling.

Local Open Scope R_scope.

(** stricly_whatever implies whatever *)

Lemma strictly_increasing_in_increasing_in : forall D f,
  strictly_increasing_in D f -> increasing_in D f.
Proof.
intros D f f_incr x y Dx Dy [Hlt | Heq].
 left ; apply f_incr ; assumption.
 subst ; reflexivity.
Qed.

Lemma strictly_decreasing_in_decreasing_in : forall D f,
  strictly_decreasing_in D f -> decreasing_in D f.
Proof.
intros D f f_decr x y Dx Dy [Hlt | Heq].
 left ; apply f_decr ; assumption.
 subst ; reflexivity.
Qed.

Lemma strictly_monotonous_in_monotonous_in : forall D f,
 strictly_monotonous_in D f -> monotonous_in D f.
Proof.
intros D f [Hd | Hi] ;
 [left ; apply strictly_decreasing_in_decreasing_in |
 right ; apply strictly_increasing_in_increasing_in] ; assumption.
Qed.

Lemma strictly_increasing_increasing f : strictly_increasing f -> increasing f.
Proof.
  apply strictly_increasing_in_increasing_in.
Qed.

Lemma strictly_decreasing_decreasing f : strictly_decreasing f -> decreasing f.
Proof.
  apply strictly_decreasing_in_decreasing_in.
Qed.

Lemma strictly_monotonous_monotonous f : strictly_monotonous f -> monotonous f.
Proof.
  apply strictly_monotonous_in_monotonous_in.
Qed.

(** Strict monotonicity implies injectivity *)

Lemma strictly_increasing_in_injective_in : forall D f,
  strictly_increasing_in D f -> injective_in D f.
Proof.
intros D f f_inc x y x_in y_in feq ; destruct (Rtotal_order x y) as [Hlt | [Heq | Hgt]].
 destruct (Rlt_irrefl (f y)) ; apply Rle_lt_trans with (f x).
  rewrite feq ; reflexivity.
  apply f_inc ; assumption.
 assumption.
 destruct (Rlt_irrefl (f x)) ; apply Rle_lt_trans with (f y).
  rewrite feq ; reflexivity.
  apply f_inc ; assumption.
Qed.

Lemma strictly_decreasing_in_injective_in : forall D f,
  strictly_decreasing_in D f -> injective_in D f.
Proof.
intros D f f_dec x y x_in y_in feq ; destruct (Rtotal_order x y) as [Hlt | [Heq | Hgt]].
 destruct (Rlt_irrefl (f x)) ; apply Rle_lt_trans with (f y).
  rewrite feq ; reflexivity.
  apply f_dec ; assumption.
 assumption.
 destruct (Rlt_irrefl (f y)) ; apply Rle_lt_trans with (f x).
  rewrite feq ; reflexivity.
  apply f_dec ; assumption.
Qed.

Lemma strictly_monotonous_in_injective_in : forall D f,
  strictly_monotonous_in D f -> injective_in D f.
Proof.
intros D f [f_dec | f_inc] ;
 [apply strictly_decreasing_in_injective_in |
  apply strictly_increasing_in_injective_in] ; assumption.
Qed.

Lemma strictly_increasing_injective f : strictly_increasing f -> injective f.
Proof.
  apply strictly_increasing_in_injective_in.
Qed.

Lemma strictly_decreasing_injective f : strictly_decreasing f -> injective f.
Proof.
  apply strictly_decreasing_in_injective_in.
Qed.

Lemma strictly_monotonous_injective f : strictly_monotonous f -> injective f.
Proof.
  apply strictly_monotonous_in_injective_in.
Qed.

(** It also helps simplify Rmin / Rmax statements *)

Lemma increasing_in_Rmin_simpl :
  forall D f, increasing_in D f ->
  forall x y, D x -> D y -> x <= y -> Rmin (f x) (f y) = f x.
Proof.
intros D f f_inc x y Dx Dy Hxy ;
 assert (flb_lt_fub : f x <= f y) by (apply f_inc ; assumption) ;
 unfold Rmin ; destruct (Rle_dec (f x) (f y)) ; intuition.
Qed.

Lemma increasing_in_Rmax_simpl :
  forall D f, increasing_in D f ->
  forall x y, D x -> D y -> x <= y -> Rmax (f x) (f y) = f y.
Proof.
intros D f f_inc x y Dx Dy Hxy ;
 assert (flb_lt_fub : f x <= f y) by (apply f_inc ; assumption) ;
 unfold Rmax ; destruct (Rle_dec (f x) (f y)) ; intuition.
Qed.

Lemma decreasing_in_Rmin_simpl :
  forall D f, decreasing_in D f ->
  forall x y, D x -> D y -> x <= y -> Rmin (f x) (f y) = f y.
Proof.
intros D f f_dec x y Dx Dy Hxy ;
 assert (flb_lt_fub : f y <= f x) by (apply f_dec ; assumption) ;
 unfold Rmin ; destruct (Rle_dec (f x) (f y)) ; intuition.
Qed.

Lemma decreasing_in_Rmax_simpl :
  forall D f, decreasing_in D f ->
  forall x y, D x -> D y -> x <= y -> Rmax (f x) (f y) = f x.
Proof.
intros D f f_dec x y Dx Dy Hxy ;
 assert (flb_lt_fub : f y <= f x) by (apply f_dec ; assumption) ;
 unfold Rmax ; destruct (Rle_dec (f x) (f y)) ; intuition.
Qed.

(** Image of an interval throught a monotonous function *)

Lemma increasing_interval_image : forall f lb ub x,
  increasing_interval lb ub f -> interval lb ub x ->
  interval (f lb) (f ub) (f x).
Proof.
intros f lb ub x Hf x_in ; assert (lb_le_ub : lb <= ub) by
 (eapply interval_inhabited ; eassumption) ; split ; apply Hf.
 apply interval_l ; assumption.
 assumption.
 apply x_in.
 assumption.
 apply interval_r ; assumption.
 apply x_in.
Qed.

Lemma decreasing_interval_image : forall f lb ub x,
  decreasing_interval lb ub f -> interval lb ub x ->
  interval (f ub) (f lb) (f x).
Proof.
intros f lb ub x Hf x_in ; assert (lb_le_ub : lb <= ub) by
 (eapply interval_inhabited ; eassumption) ; split ; apply Hf.
 assumption.
 apply interval_r ; assumption.
 apply x_in.
 apply interval_l ; assumption.
 assumption.
 apply x_in.
Qed.

Lemma monotonous_interval_image : forall f lb ub x,
  monotonous_interval lb ub f -> interval lb ub x ->
  interval (Rmin (f lb) (f ub)) (Rmax (f lb) (f ub)) (f x).
Proof.
intros f lb ub x [f_dec | f_inc] x_in ;
 assert (lbub : lb <= ub) by (eapply interval_inhabited, x_in).
 erewrite decreasing_in_Rmax_simpl, decreasing_in_Rmin_simpl ; try eassumption.
  apply decreasing_interval_image ; assumption.
  apply interval_l ; assumption.
  apply interval_r ; assumption.
  apply interval_l ; assumption.
  apply interval_r ; assumption.
 erewrite increasing_in_Rmax_simpl, increasing_in_Rmin_simpl ; try eassumption.
  apply increasing_interval_image ; assumption.
  apply interval_l ; assumption.
  apply interval_r ; assumption.
  apply interval_l ; assumption.
  apply interval_r ; assumption.
Qed.

Lemma strictly_increasing_interval_image : forall f lb ub x,
  strictly_increasing_interval lb ub f -> open_interval lb ub x ->
  open_interval (f lb) (f ub) (f x).
Proof.
intros f lb ub x Hf x_in ; assert (lb_le_ub : lb <= ub) by
 (left ; eapply open_interval_inhabited ; eassumption) ; split ; apply Hf.
 apply interval_l ; assumption.
 apply open_interval_interval ; assumption.
 apply x_in.
 apply open_interval_interval ; assumption.
 apply interval_r ; assumption.
 apply x_in.
Qed.

Lemma strictly_decreasing_interval_image : forall f lb ub x,
  strictly_decreasing_interval lb ub f -> open_interval lb ub x ->
  open_interval (f ub) (f lb) (f x).
Proof.
intros f lb ub x Hf x_in ; assert (lb_le_ub : lb <= ub) by
 (left ; eapply open_interval_inhabited ; eassumption) ; split ; apply Hf.
 apply open_interval_interval ; assumption.
 apply interval_r ; assumption.
 apply x_in.
 apply interval_l ; assumption.
 apply open_interval_interval ; assumption.
 apply x_in.
Qed.

Lemma strictly_monotonous_interval_image : forall f lb ub x,
  strictly_monotonous_interval lb ub f -> open_interval lb ub x ->
  open_interval (Rmin (f lb) (f ub)) (Rmax (f lb) (f ub)) (f x).
Proof.
intros f lb ub x [f_dec | f_inc] x_in ;
 assert (lbub : lb <= ub) by (left ; eapply open_interval_inhabited, x_in).
 erewrite decreasing_in_Rmax_simpl, decreasing_in_Rmin_simpl.
  apply strictly_decreasing_interval_image ; assumption.
  apply strictly_decreasing_in_decreasing_in ; eassumption.
  apply interval_l ; assumption.
  apply interval_r ; assumption.
  assumption.
  apply strictly_decreasing_in_decreasing_in ; eassumption.
  apply interval_l ; assumption.
  apply interval_r ; assumption.
  assumption.
 erewrite increasing_in_Rmax_simpl, increasing_in_Rmin_simpl.
  apply strictly_increasing_interval_image ; assumption.
  apply strictly_increasing_in_increasing_in ; eassumption.
  apply interval_l ; assumption.
  apply interval_r ; assumption.
  assumption.
  apply strictly_increasing_in_increasing_in ; eassumption.
  apply interval_l ; assumption.
  apply interval_r ; assumption.
  assumption.
Qed.

(** Compatibility of variations with operations *)

Lemma increasing_in_opp : forall D f,
  increasing_in D f -> decreasing_in D (-f)%F.
Proof.
intros D f Hf x y Dx Dy Hxy ; unfold opp_fct ;
 apply Ropp_le_contravar, Hf ; assumption.
Qed.

Lemma increasing_in_opp_rev : forall D f,
  increasing_in D (- f)%F -> decreasing_in D f.
Proof.
intros D f Hf x y Dx Dy Hxy ; unfold opp_fct ;
 apply Ropp_le_cancel, Hf ; assumption.
Qed.

Lemma strictly_increasing_in_opp : forall D f,
  strictly_increasing_in D f -> strictly_decreasing_in D (-f)%F.
Proof.
intros D f Hf x y Dx Dy Hxy ; unfold opp_fct ;
 apply Ropp_lt_contravar, Hf ; assumption.
Qed.

Lemma strictly_increasing_in_opp_rev : forall D f,
  strictly_increasing_in D (- f)%F -> strictly_decreasing_in D f.
Proof.
intros D f Hf x y Dx Dy Hxy ; unfold opp_fct ;
 apply Ropp_lt_cancel, Hf ; assumption.
Qed.

Lemma decreasing_in_opp : forall D f,
  decreasing_in D f -> increasing_in D (-f)%F.
Proof.
intros D f Hf x y Dx Dy Hxy ; unfold opp_fct ;
 apply Ropp_le_contravar, Hf ; assumption.
Qed.

Lemma decreasing_in_opp_rev : forall D f,
  decreasing_in D (- f)%F -> increasing_in D f.
Proof.
intros D f Hf x y Dx Dy Hxy ; unfold opp_fct ;
 apply Ropp_le_cancel, Hf ; assumption.
Qed.

Lemma strictly_decreasing_in_opp : forall D f,
  strictly_decreasing_in D f -> strictly_increasing_in D (-f)%F.
Proof.
intros D f Hf x y Dx Dy Hxy ; unfold opp_fct ;
 apply Ropp_lt_contravar, Hf ; assumption.
Qed.

Lemma strictly_decreasing_in_opp_rev : forall D f,
  strictly_decreasing_in D (- f)%F -> strictly_increasing_in D f.
Proof.
intros D f Hf x y Dx Dy Hxy ; unfold opp_fct ;
 apply Ropp_lt_cancel, Hf ; assumption.
Qed.

(* TODO: more generic lemmas like these ones *)

Lemma increasing_in_plus : forall D f g,
  increasing_in D f -> increasing_in D g -> increasing_in D (f + g)%F.
Proof.
intros D f g Hf Hg x y Dx Dy Hxy ; unfold plus_fct ;
 apply Rplus_le_compat ; [apply Hf | apply Hg] ; assumption.
Qed.

Lemma increasing_in_minus : forall D f g,
  increasing_in D f -> decreasing_in D g -> increasing_in D (f - g)%F.
Proof.
intros D f g Hf Hg x y Dx Dy Hxy ; unfold plus_fct ;
 apply Rplus_le_compat ; [apply Hf | apply Ropp_le_contravar, Hg] ; assumption.
Qed.

Lemma strictly_increasing_strictly_decreasing_interval2 : forall f lb ub,
  strictly_increasing_interval lb ub f ->
  strictly_decreasing_interval (- ub) (- lb) (fun x => f(-x)).
Proof.
intros f c r f_incr ; intros x y x_in_B y_in_B x_lt_y.
 apply f_incr ; unfold interval in * ; try split ; intuition ; lra.
Qed.

Lemma strictly_decreasing_strictly_increasing_interval2 : forall f lb ub,
  strictly_decreasing_interval lb ub f ->
  strictly_increasing_interval (-ub) (-lb) (fun x => f(-x)).
Proof.
intros f c r f_decr ; intros x y x_in_B y_in_B x_lt_y.
 apply f_decr ; unfold interval in * ; try split ; intuition ; lra.
Qed.

Lemma strictly_increasing_reciprocal_interval_compat : forall f g lb ub,
  strictly_increasing_interval lb ub f ->
  reciprocal_interval (f lb) (f ub) f g ->
  (forall x, interval (f lb) (f ub) x -> interval lb ub (g x)) ->
  strictly_increasing_interval (f lb) (f ub) g.
Proof.
intros f g lb ub f_incr f_recip_g g_ok x y x_in_I y_in_I x_lt_y.
 destruct (Rlt_le_dec (g x) (g y)) as [T | F].
  assumption.
  destruct F as [F | F].
   assert (Hf : y < x).
    unfold reciprocal_interval, id in f_recip_g ; rewrite <- f_recip_g.
    apply Rgt_lt ; rewrite <- f_recip_g.
    unfold comp ; apply f_incr ; [apply g_ok | apply g_ok |] ; assumption.
    assumption.
    assumption.
   apply False_ind ; apply Rlt_irrefl with x ; apply Rlt_trans with y ; assumption.
   assert (Hf : x = y).
    unfold reciprocal_interval, id in f_recip_g ; rewrite <- f_recip_g.
    symmetry ; rewrite <- f_recip_g.
    unfold comp ; rewrite F ; reflexivity.
    assumption.
    assumption.
   rewrite Hf in x_lt_y ; elim (Rlt_irrefl _ x_lt_y).
Qed.

Lemma strictly_increasing_reciprocal_interval_comm: forall f g lb ub,
  (forall x, interval (f lb) (f ub) x -> interval lb ub (g x)) ->
  strictly_increasing_interval lb ub f ->
  reciprocal_interval (f lb) (f ub) f g ->
  reciprocal_interval lb ub g f.
Proof.
intros f g lb ub g_ok f_sinc Hfg x x_in ;
 assert (f_inc : increasing_interval lb ub f).
  apply strictly_increasing_in_increasing_in ; assumption.
 destruct (Req_dec (g (f x)) x) as [Heq | Hneq].
  assumption.
  destruct (Rlt_irrefl (f x)).
  destruct (Rdichotomy _ _ Hneq) as [Hlt | Hlt].
  apply Rle_lt_trans with (f (g (f x))).
   right ; rewrite Hfg.
    reflexivity.
    apply increasing_interval_image ; [apply strictly_increasing_in_increasing_in |] ; assumption.
   apply f_sinc ; [apply g_ok, increasing_interval_image | |] ; assumption.
  apply Rlt_le_trans with (f (g (f x))).
   apply f_sinc ; [| apply g_ok, increasing_interval_image |] ; assumption.
  right ; rewrite Hfg.
   reflexivity.
   apply increasing_interval_image ; assumption.
Qed.

Lemma strictly_decreasing_reciprocal_interval_comm: forall f g lb ub,
  (forall x, interval (f ub) (f lb) x -> interval lb ub (g x)) ->
  strictly_decreasing_interval lb ub f ->
  reciprocal_interval (f ub) (f lb) f g ->
  reciprocal_interval lb ub g f.
Proof.
intros f g lb ub g_ok f_sdec Hfg x x_in ;
 assert (f_dec : decreasing_interval lb ub f).
  apply strictly_decreasing_in_decreasing_in ; assumption.
 destruct (Req_dec (g (f x)) x) as [Heq | Hneq].
  assumption.
  destruct (Rlt_irrefl (f x)).
  destruct (Rdichotomy _ _ Hneq) as [Hlt | Hlt].
  apply Rlt_le_trans with (f (g (f x))).
   apply f_sdec ; [apply g_ok, decreasing_interval_image | |] ; assumption.
  right ; rewrite Hfg.
   reflexivity.
   apply decreasing_interval_image ; assumption.
  apply Rle_lt_trans with (f (g (f x))).
   right ; rewrite Hfg.
    reflexivity.
    apply decreasing_interval_image ; assumption.
   apply f_sdec ; [| apply g_ok, decreasing_interval_image |] ; assumption.
Qed.

(** Knowing f's variations and the ordering of f a and f b we can deduce a and b's ordering *)

Lemma strictly_increasing_open_interval_order : forall f lb ub a b,
  open_interval lb ub a -> open_interval lb ub b ->
  strictly_increasing_open_interval lb ub f ->
  f a < f b -> a < b.
Proof.
intros f lb ub a b a_in b_in Hf Hfafb ; destruct (Rlt_le_dec a b) as [altb | blea].
 assumption.
 destruct blea as [blta | beqa].
  destruct (Rlt_irrefl (f a)) ; transitivity (f b).
   assumption.
   apply Hf ; assumption.
  rewrite beqa in Hfafb ; destruct (Rlt_irrefl _ Hfafb).
Qed.

Lemma strictly_increasing_interval_order : forall f lb ub a b,
  open_interval lb ub a -> open_interval lb ub b ->
  strictly_increasing_open_interval lb ub f ->
  f a <= f b -> a <= b.
Proof.
intros f lb ub a b a_in b_in Hf Hfafb ; destruct (Rle_lt_dec a b) as [aleb | blta].
 assumption.
 destruct (Rlt_irrefl (f a)) ; apply Rle_lt_trans with (f b).
  assumption.
  apply Hf ; assumption.
Qed.


Require Import Arith.
Require Export Compare_dec.
Require Export Relations.

Hint Resolve t_step rt_step rt_refl: core.
Hint Unfold transp: core.

Section Termes.

  Inductive sort : Set :=
    | kind : sort
    | prop : sort.

  Inductive term : Set :=
    | Srt : sort -> term
    | Ref : nat -> term
    | Abs : term -> term -> term
    | App : term -> term -> term
    | Prod : term -> term -> term.

  Fixpoint lift_rec (n : nat) (t : term) (k : nat) {struct t} : term :=
    match t with
    | Srt s => Srt s
    | Ref i =>
        match le_gt_dec k i with
        | left _ => Ref (n + i)
        | right _ => Ref i
        end
    | Abs T M => Abs (lift_rec n T k) (lift_rec n M (S k))
    | App u v => App (lift_rec n u k) (lift_rec n v k)
    | Prod A B => Prod (lift_rec n A k) (lift_rec n B (S k))
    end.

  Definition lift n t := lift_rec n t 0.

  Fixpoint subst_rec (N M : term) (k : nat) {struct M} : term :=
    match M with
    | Srt s => Srt s
    | Ref i =>
        match lt_eq_lt_dec k i with
        | inleft (left _) => Ref (pred i)
        | inleft (right _) => lift k N
        | inright _ => Ref i
        end
    | Abs A B => Abs (subst_rec N A k) (subst_rec N B (S k))
    | App u v => App (subst_rec N u k) (subst_rec N v k)
    | Prod T U => Prod (subst_rec N T k) (subst_rec N U (S k))
    end.

  Definition subst N M := subst_rec N M 0.

  Inductive subterm : term -> term -> Prop :=
    | sbtrm_abs_l : forall A B, subterm A (Abs A B)
    | sbtrm_abs_r : forall A B, subterm B (Abs A B)
    | sbtrm_app_l : forall A B, subterm A (App A B)
    | sbtrm_app_r : forall A B, subterm B (App A B)
    | sbtrm_prod_l : forall A B, subterm A (Prod A B)
    | sbtrm_prod_r : forall A B, subterm B (Prod A B).

  Inductive mem_sort (s : sort) : term -> Prop :=
    | mem_eq : mem_sort s (Srt s)
    | mem_prod_l : forall u v, mem_sort s u -> mem_sort s (Prod u v)
    | mem_prod_r : forall u v, mem_sort s v -> mem_sort s (Prod u v)
    | mem_abs_l : forall u v, mem_sort s u -> mem_sort s (Abs u v)
    | mem_abs_r : forall u v, mem_sort s v -> mem_sort s (Abs u v)
    | mem_app_l : forall u v, mem_sort s u -> mem_sort s (App u v)
    | mem_app_r : forall u v, mem_sort s v -> mem_sort s (App u v).

End Termes.

  Hint Constructors subterm.
  Hint Constructors mem_sort.

Section Beta_Reduction.

  Inductive red1 : term -> term -> Prop :=
    | beta : forall M N T, red1 (App (Abs T M) N) (subst N M)
    | abs_red_l :
        forall M M', red1 M M' -> forall N, red1 (Abs M N) (Abs M' N)
    | abs_red_r :
        forall M M', red1 M M' -> forall N, red1 (Abs N M) (Abs N M')
    | app_red_l :
        forall M1 N1, red1 M1 N1 -> forall M2, red1 (App M1 M2) (App N1 M2)
    | app_red_r :
        forall M2 N2, red1 M2 N2 -> forall M1, red1 (App M1 M2) (App M1 N2)
    | prod_red_l :
        forall M1 N1, red1 M1 N1 -> forall M2, red1 (Prod M1 M2) (Prod N1 M2)
    | prod_red_r :
        forall M2 N2, red1 M2 N2 -> forall M1, red1 (Prod M1 M2) (Prod M1 N2).

  Inductive red (M : term) : term -> Prop :=
    | refl_red : red M M
    | trans_red : forall P N, red M P -> red1 P N -> red M N.

  Inductive conv (M : term) : term -> Prop :=
    | refl_conv : conv M M
    | trans_conv_red : forall P N, conv M P -> red1 P N -> conv M N
    | trans_conv_exp : forall P N, conv M P -> red1 N P -> conv M N.

  Inductive par_red1 : term -> term -> Prop :=
    | par_beta :
        forall M M' N N' T,
        par_red1 M M' ->
        par_red1 N N' -> par_red1 (App (Abs T M) N) (subst N' M')
    | sort_par_red : forall s, par_red1 (Srt s) (Srt s)
    | ref_par_red : forall n, par_red1 (Ref n) (Ref n)
    | abs_par_red :
        forall M M' T T',
        par_red1 M M' -> par_red1 T T' -> par_red1 (Abs T M) (Abs T' M')
    | app_par_red :
        forall M M' N N',
        par_red1 M M' -> par_red1 N N' -> par_red1 (App M N) (App M' N')
    | prod_par_red :
        forall M M' N N',
        par_red1 M M' -> par_red1 N N' -> par_red1 (Prod M N) (Prod M' N').

  Definition par_red := clos_trans term par_red1.

End Beta_Reduction.

  Hint Constructors red1: coc.
  Hint Constructors par_red1: coc.
  Hint Resolve refl_red refl_conv: coc.
  Hint Unfold par_red: coc.

Section Normalisation_Forte.

  Definition normal t := forall u, ~ red1 t u.

  Definition sn := Acc (transp _ red1).

End Normalisation_Forte.

  Hint Unfold sn: coc.

  Lemma eqterm : forall u v : term, {u = v} + {u <> v}.
Proof.
decide equality.
decide equality.

apply eq_nat_dec.
Qed.

  Lemma inv_lift_sort :  forall s n t k, lift_rec n t k = Srt s -> t = Srt s.
intros.
destruct t; try  discriminate H.
 auto.
 unfold lift_rec in H.
   destruct (le_gt_dec k n0);  discriminate H.
Qed.

  Lemma inv_subst_sort :
    forall s x t k, subst_rec x t k = Srt s -> t = Srt s \/ x = Srt s.
intros.
destruct t; try  discriminate H.
 auto.
 unfold subst_rec in H.
   destruct (lt_eq_lt_dec k n) as [[fv| eqv]| bv]; try  discriminate H.
   right.
   unfold lift in H.
   apply inv_lift_sort with (1 := H).
Qed.

  Lemma lift_ref_ge :
   forall k n p, p <= n -> lift_rec k (Ref n) p = Ref (k + n).
intros; simpl in |- *.
elim (le_gt_dec p n); auto with arith.
intro; absurd (p <= n); auto with arith.
Qed.

  Lemma lift_ref_lt : forall k n p, p > n -> lift_rec k (Ref n) p = Ref n.
intros; simpl in |- *.
elim (le_gt_dec p n); auto with arith.
intro; absurd (p <= n); auto with arith.
Qed.

  Lemma subst_ref_lt : forall u n k, k > n -> subst_rec u (Ref n) k = Ref n.
simpl in |- *; intros.
elim (lt_eq_lt_dec k n); intros; auto with arith.
elim a; intros.
absurd (k <= n); auto with arith.

inversion_clear b in H.
elim gt_irrefl with n; auto with arith.
Qed.

  Lemma subst_ref_gt :
   forall u n k, n > k -> subst_rec u (Ref n) k = Ref (pred n).
simpl in |- *; intros.
elim (lt_eq_lt_dec k n); intros.
elim a; intros; auto with arith.
inversion_clear b in H.
elim gt_irrefl with n; auto with arith.

absurd (k <= n); auto with arith.
Qed.

  Lemma subst_ref_eq : forall u n, subst_rec u (Ref n) n = lift n u.
intros; simpl in |- *.
elim (lt_eq_lt_dec n n); intros.
elim a; intros; auto with coc.
elim lt_irrefl with n; auto with coc.

elim gt_irrefl with n; auto with coc.
Qed.

  Lemma lift_rec0 : forall M k, lift_rec 0 M k = M.
simple induction M; simpl in |- *; intros; auto with coc.
elim (le_gt_dec k n); auto with coc.

rewrite H; rewrite H0; auto with coc.

rewrite H; rewrite H0; auto with coc.

rewrite H; rewrite H0; auto with coc.
Qed.

  Lemma lift0 : forall M, lift 0 M = M.
intros; unfold lift in |- *.
apply lift_rec0; auto with coc.
Qed.

  Lemma simpl_lift_rec :
   forall M n k p i,
   i <= k + n ->
   k <= i -> lift_rec p (lift_rec n M k) i = lift_rec (p + n) M k.
simple induction M; simpl in |- *; intros; auto with coc.
elim (le_gt_dec k n); intros.
rewrite lift_ref_ge; auto with coc.
rewrite plus_assoc; auto with coc.

rewrite plus_comm.
apply le_trans with (k + n0); auto with arith.

rewrite lift_ref_lt; auto with arith.
apply le_gt_trans with k; auto with arith.

rewrite H; auto with arith; rewrite H0; simpl in |- *; auto with arith.

rewrite H; auto with arith; rewrite H0; simpl in |- *; auto with arith.

rewrite H; auto with arith; rewrite H0; simpl in |- *; auto with arith.
Qed.

  Lemma simpl_lift : forall M n, lift (S n) M = lift 1 (lift n M).
intros; unfold lift in |- *.
rewrite simpl_lift_rec; auto with arith.
Qed.

  Lemma permute_lift_rec :
   forall M n k p i,
   i <= k ->
   lift_rec p (lift_rec n M k) i = lift_rec n (lift_rec p M i) (p + k).
simple induction M; simpl in |- *; intros; auto with coc.
elim (le_gt_dec k n); elim (le_gt_dec i n); intros.
rewrite lift_ref_ge; auto with arith.
rewrite lift_ref_ge; auto with arith.
elim plus_assoc_reverse with p n0 n.
elim plus_assoc_reverse with n0 p n.
elim plus_comm with p n0; auto with arith.

apply le_trans with n; auto with arith.

absurd (i <= n); auto with arith.
apply le_trans with k; auto with arith.

rewrite lift_ref_ge; auto with arith.
rewrite lift_ref_lt; auto with arith.

rewrite lift_ref_lt; auto with arith.
rewrite lift_ref_lt; auto with arith.
apply le_gt_trans with k; auto with arith.

rewrite H; auto with arith; rewrite H0; auto with arith.
rewrite plus_n_Sm; auto with arith.

rewrite H; auto with arith; rewrite H0; auto with arith.

rewrite H; auto with arith; rewrite H0; auto with arith.
rewrite plus_n_Sm; auto with arith.
Qed.

  Lemma permute_lift :
   forall M k, lift 1 (lift_rec 1 M k) = lift_rec 1 (lift 1 M) (S k).
intros.
change (lift_rec 1 (lift_rec 1 M k) 0 = lift_rec 1 (lift_rec 1 M 0) (1 + k))
 in |- *.
apply permute_lift_rec; auto with arith.
Qed.

  Lemma simpl_subst_rec :
   forall N M n p k,
   p <= n + k ->
   k <= p -> subst_rec N (lift_rec (S n) M k) p = lift_rec n M k.
simple induction M; simpl in |- *; intros; auto with arith.
elim (le_gt_dec k n); intros.
rewrite subst_ref_gt; auto with arith.
red in |- *; red in |- *.
apply le_trans with (S (n0 + k)); auto with arith.

rewrite subst_ref_lt; auto with arith.
apply le_gt_trans with k; auto with arith.

rewrite H; auto with arith; rewrite H0; auto with arith.
elim plus_n_Sm with n k; auto with arith.

rewrite H; auto with arith; rewrite H0; auto with arith.

rewrite H; auto with arith; rewrite H0; auto with arith.
elim plus_n_Sm with n k; auto with arith.
Qed.

  Lemma simpl_subst :
   forall N M n p, p <= n -> subst_rec N (lift (S n) M) p = lift n M.
intros; unfold lift in |- *.
apply simpl_subst_rec; auto with arith.
Qed.

  Lemma commut_lift_subst_rec :
   forall M N n p k,
   k <= p ->
   lift_rec n (subst_rec N M p) k = subst_rec N (lift_rec n M k) (n + p).
simple induction M; intros; auto with arith.
unfold subst_rec at 1, lift_rec at 2 in |- *.
elim (lt_eq_lt_dec p n); elim (le_gt_dec k n); intros.
elim a0.
case n; intros.
inversion_clear a1.

unfold pred in |- *.
rewrite lift_ref_ge; auto with arith.
rewrite subst_ref_gt; auto with arith.
elim plus_n_Sm with n0 n1.
auto with arith.

apply le_trans with p; auto with arith.

simple induction 1.
rewrite subst_ref_eq.
unfold lift in |- *.
rewrite simpl_lift_rec; auto with arith.

absurd (k <= n); auto with arith.
apply le_trans with p; auto with arith.
elim a; auto with arith.
simple induction 1; auto with arith.

rewrite lift_ref_ge; auto with arith.
rewrite subst_ref_lt; auto with arith.

rewrite lift_ref_lt; auto with arith.
rewrite subst_ref_lt; auto with arith.
apply le_gt_trans with p; auto with arith.

simpl in |- *.
rewrite plus_n_Sm.
rewrite H; auto with arith; rewrite H0; auto with arith.

simpl in |- *; rewrite H; auto with arith; rewrite H0; auto with arith.

simpl in |- *; rewrite plus_n_Sm.
rewrite H; auto with arith; rewrite H0; auto with arith.
Qed.

  Lemma commut_lift_subst :
   forall M N k, subst_rec N (lift 1 M) (S k) = lift 1 (subst_rec N M k).
intros; unfold lift in |- *.
rewrite commut_lift_subst_rec; auto with arith.
Qed.

  Lemma distr_lift_subst_rec :
   forall M N n p k,
   lift_rec n (subst_rec N M p) (p + k) =
   subst_rec (lift_rec n N k) (lift_rec n M (S (p + k))) p.
simple induction M; intros; auto with arith.
unfold subst_rec at 1 in |- *.
elim (lt_eq_lt_dec p n); intro.
elim a.
case n; intros.
inversion_clear a0.

unfold pred, lift_rec at 1 in |- *.
elim (le_gt_dec (p + k) n1); intro.
rewrite lift_ref_ge; auto with arith.
elim plus_n_Sm with n0 n1.
rewrite subst_ref_gt; auto with arith.
red in |- *; red in |- *; apply le_n_S.
apply le_trans with (n0 + (p + k)); auto with arith.
apply le_trans with (p + k); auto with arith.

rewrite lift_ref_lt; auto with arith.
rewrite subst_ref_gt; auto with arith.

simple induction 1.
unfold lift in |- *.
rewrite <- permute_lift_rec; auto with arith.
rewrite lift_ref_lt; auto with arith.
rewrite subst_ref_eq; auto with arith.

rewrite lift_ref_lt; auto with arith.
rewrite lift_ref_lt; auto with arith.
rewrite subst_ref_lt; auto with arith.

simpl in |- *; replace (S (p + k)) with (S p + k); auto with arith.
rewrite H; rewrite H0; auto with arith.

simpl in |- *; rewrite H; rewrite H0; auto with arith.

simpl in |- *; replace (S (p + k)) with (S p + k); auto with arith.
rewrite H; rewrite H0; auto with arith.
Qed.

  Lemma distr_lift_subst :
   forall M N n k,
   lift_rec n (subst N M) k = subst (lift_rec n N k) (lift_rec n M (S k)).
intros; unfold subst in |- *.
pattern k at 1 3 in |- *.
replace k with (0 + k); auto with arith.
apply distr_lift_subst_rec.
Qed.

  Lemma distr_subst_rec :
   forall M N P n p,
   subst_rec P (subst_rec N M p) (p + n) =
   subst_rec (subst_rec P N n) (subst_rec P M (S (p + n))) p.
simple induction M; auto with arith; intros.
unfold subst_rec at 2 in |- *.
elim (lt_eq_lt_dec p n); intro.
elim a.
case n; intros.
inversion_clear a0.

unfold pred, subst_rec at 1 in |- *.
elim (lt_eq_lt_dec (p + n0) n1); intro.
elim a1.
case n1; intros.
inversion_clear a2.

rewrite subst_ref_gt; auto with arith.
rewrite subst_ref_gt; auto with arith.
apply gt_le_trans with (p + n0); auto with arith.

simple induction 1.
rewrite subst_ref_eq; auto with arith.
rewrite simpl_subst; auto with arith.

rewrite subst_ref_lt; auto with arith.
rewrite subst_ref_gt; auto with arith.

simple induction 1.
rewrite subst_ref_lt; auto with arith.
rewrite subst_ref_eq.
unfold lift in |- *.
rewrite commut_lift_subst_rec; auto with arith.

do 3 (rewrite subst_ref_lt; auto with arith).

simpl in |- *; replace (S (p + n)) with (S p + n); auto with arith.
rewrite H; auto with arith; rewrite H0; auto with arith.

simpl in |- *; rewrite H; rewrite H0; auto with arith.

simpl in |- *; replace (S (p + n)) with (S p + n); auto with arith.
rewrite H; rewrite H0; auto with arith.
Qed.

  Lemma distr_subst :
   forall P N M k,
   subst_rec P (subst N M) k = subst (subst_rec P N k) (subst_rec P M (S k)).
intros; unfold subst in |- *.
pattern k at 1 3 in |- *.
replace k with (0 + k); auto with arith.
apply distr_subst_rec.
Qed.

  Lemma one_step_red : forall M N, red1 M N -> red M N.
intros.
apply trans_red with M; auto with coc.
Qed.

  Hint Resolve one_step_red: coc.

  Lemma red1_red_ind :
   forall N P,
   (P:term -> Prop) N ->
   (forall M R, red1 M R -> red R N -> P R -> P M) ->
   forall M, red M N -> P M.
cut
 (forall M N,
  red M N ->
  forall P : term -> Prop,
  P N -> (forall M R, red1 M R -> red R N -> P R -> P M) -> P M).
intros.
apply (H M N); auto with coc.

simple induction 1; intros; auto with coc.
apply H1; auto with coc.
apply H4 with N0; auto with coc.

intros.
apply H4 with R; auto with coc.
apply trans_red with P; auto with coc.
Qed.

  Lemma trans_red_red : forall M N P, red M N -> red N P -> red M P.
intros.
generalize H0 M H.
simple induction 1; auto with coc.
intros.
apply trans_red with P0; auto with coc.
Qed.

  Lemma red_red_app :
   forall u u0 v v0, red u u0 -> red v v0 -> red (App u v) (App u0 v0).
simple induction 1.
simple induction 1; intros; auto with coc.
apply trans_red with (App u P); auto with coc.

intros.
apply trans_red with (App P v0); auto with coc.
Qed.

  Lemma red_red_abs :
   forall u u0 v v0, red u u0 -> red v v0 -> red (Abs u v) (Abs u0 v0).
simple induction 1.
simple induction 1; intros; auto with coc.
apply trans_red with (Abs u P); auto with coc.

intros.
apply trans_red with (Abs P v0); auto with coc.
Qed.

  Lemma red_red_prod :
   forall u u0 v v0, red u u0 -> red v v0 -> red (Prod u v) (Prod u0 v0).
simple induction 1.
simple induction 1; intros; auto with coc.
apply trans_red with (Prod u P); auto with coc.

intros.
apply trans_red with (Prod P v0); auto with coc.
Qed.

  Hint Resolve red_red_app red_red_abs red_red_prod: coc.

  Lemma red1_lift :
   forall n u v, red1 u v -> forall k, red1 (lift_rec n u k) (lift_rec n v k).
simple induction 1; simpl in |- *; intros; auto with coc.
rewrite distr_lift_subst; auto with coc.
Qed.

  Hint Resolve red1_lift: coc.

  Lemma red1_subst_r :
   forall a t u,
   red1 t u -> forall k, red1 (subst_rec a t k) (subst_rec a u k).
simple induction 1; simpl in |- *; intros; auto with coc.
rewrite distr_subst; auto with coc.
Qed.

  Lemma red1_subst_l :
   forall t u,
   red1 t u -> forall a k, red (subst_rec t a k) (subst_rec u a k).
simple induction a; simpl in |- *; auto with coc.
intros.
elim (lt_eq_lt_dec k n); intros; auto with coc.
elim a0; auto with coc.
unfold lift in |- *; auto with coc.
Qed.

  Hint Resolve red1_subst_l red1_subst_r: coc.

  Lemma red_prod_prod :
   forall u v t,
   red (Prod u v) t ->
   forall P : Prop,
   (forall a b, t = Prod a b -> red u a -> red v b -> P) -> P.
simple induction 1; intros.
apply H0 with u v; auto with coc.

apply H1; intros.
inversion_clear H4 in H2.
inversion H2.
apply H3 with N1 b; auto with coc.
apply trans_red with a; auto with coc.

apply H3 with a N2; auto with coc.
apply trans_red with b; auto with coc.
Qed.

  Lemma red_sort_sort : forall s t, red (Srt s) t -> t <> Srt s -> False.
simple induction 1; intros; auto with coc.
apply H1.
generalize H2.
case P; intros; try discriminate.
inversion_clear H4.
Qed.

  Lemma one_step_conv_exp : forall M N, red1 M N -> conv N M.
intros.
apply trans_conv_exp with N; auto with coc.
Qed.

  Lemma red_conv : forall M N, red M N -> conv M N.
simple induction 1; auto with coc.
intros; apply trans_conv_red with P; auto with coc.
Qed.

  Hint Resolve one_step_conv_exp red_conv: coc.

  Lemma sym_conv : forall M N, conv M N -> conv N M.
simple induction 1; auto with coc.
simple induction 2; intros; auto with coc.
apply trans_conv_red with P0; auto with coc.

apply trans_conv_exp with P0; auto with coc.

simple induction 2; intros; auto with coc.
apply trans_conv_red with P0; auto with coc.

apply trans_conv_exp with P0; auto with coc.
Qed.

  Hint Immediate sym_conv: coc.

  Lemma trans_conv_conv : forall M N P, conv M N -> conv N P -> conv M P.
intros.
generalize M H; elim H0; intros; auto with coc.
apply trans_conv_red with P0; auto with coc.

apply trans_conv_exp with P0; auto with coc.
Qed.

  Lemma conv_conv_prod :
   forall a b c d, conv a b -> conv c d -> conv (Prod a c) (Prod b d).
intros.
apply trans_conv_conv with (Prod a d).
elim H0; intros; auto with coc.
apply trans_conv_red with (Prod a P); auto with coc.

apply trans_conv_exp with (Prod a P); auto with coc.

elim H; intros; auto with coc.
apply trans_conv_red with (Prod P d); auto with coc.

apply trans_conv_exp with (Prod P d); auto with coc.
Qed.

  Lemma conv_conv_lift :
   forall a b n k, conv a b -> conv (lift_rec n a k) (lift_rec n b k).
intros.
elim H; intros; auto with coc.
apply trans_conv_red with (lift_rec n P k); auto with coc.

apply trans_conv_exp with (lift_rec n P k); auto with coc.
Qed.

  Lemma conv_conv_subst :
   forall a b c d k,
   conv a b -> conv c d -> conv (subst_rec a c k) (subst_rec b d k).
intros.
apply trans_conv_conv with (subst_rec a d k).
elim H0; intros; auto with coc.
apply trans_conv_red with (subst_rec a P k); auto with coc.

apply trans_conv_exp with (subst_rec a P k); auto with coc.

elim H; intros; auto with coc.
apply trans_conv_conv with (subst_rec P d k); auto with coc.

apply trans_conv_conv with (subst_rec P d k); auto with coc.
apply sym_conv; auto with coc.
Qed.

  Hint Resolve conv_conv_prod conv_conv_lift conv_conv_subst: coc.

  Lemma refl_par_red1 : forall M, par_red1 M M.
simple induction M; auto with coc.
Qed.

  Hint Resolve refl_par_red1: coc.

  Lemma red1_par_red1 : forall M N, red1 M N -> par_red1 M N.
simple induction 1; auto with coc; intros.
Qed.

  Hint Resolve red1_par_red1: coc.

  Lemma red_par_red : forall M N, red M N -> par_red M N.
red in |- *; simple induction 1; intros; auto with coc.
apply t_trans with P; auto with coc.
Qed.

  Lemma par_red_red : forall M N, par_red M N -> red M N.
simple induction 1.
simple induction 1; intros; auto with coc.
apply trans_red with (App (Abs T M') N'); auto with coc.

intros.
apply trans_red_red with y; auto with coc.
Qed.

  Hint Resolve red_par_red par_red_red: coc.

  Lemma par_red1_lift :
   forall n a b,
   par_red1 a b -> forall k, par_red1 (lift_rec n a k) (lift_rec n b k).
simple induction 1; simpl in |- *; auto with coc.
intros.
rewrite distr_lift_subst; auto with coc.
Qed.

  Lemma par_red1_subst :
   forall a b c d,
   par_red1 a b ->
   par_red1 c d -> forall k, par_red1 (subst_rec a c k) (subst_rec b d k).
simple induction 2; simpl in |- *; auto with coc; intros.
rewrite distr_subst; auto with coc.

elim (lt_eq_lt_dec k n); auto with coc; intros.
elim a0; intros; auto with coc.
unfold lift in |- *.
apply par_red1_lift; auto with coc.
Qed.

  Lemma inv_par_red_abs :
   forall (P : Prop) T U x,
   par_red1 (Abs T U) x ->
   (forall T' U', x = Abs T' U' -> par_red1 U U' -> P) -> P.
do 5 intro.
inversion_clear H; intros.
apply H with T' M'; auto with coc.
Qed.

  Hint Resolve par_red1_lift par_red1_subst: coc.

  Lemma mem_sort_lift :
   forall t n k s, mem_sort s (lift_rec n t k) -> mem_sort s t.
simple induction t; simpl in |- *; intros; auto with coc.
generalize H; elim (le_gt_dec k n); intros; auto with coc.
inversion_clear H0.

inversion_clear H1.
apply mem_abs_l; apply H with n k; auto with coc.

apply mem_abs_r; apply H0 with n (S k); auto with coc.

inversion_clear H1.
apply mem_app_l; apply H with n k; auto with coc.

apply mem_app_r; apply H0 with n k; auto with coc.

inversion_clear H1.
apply mem_prod_l; apply H with n k; auto with coc.

apply mem_prod_r; apply H0 with n (S k); auto with coc.
Qed.

  Lemma mem_sort_subst :
   forall b a n s,
   mem_sort s (subst_rec a b n) -> mem_sort s a \/ mem_sort s b.
simple induction b; simpl in |- *; intros; auto with coc.
generalize H; elim (lt_eq_lt_dec n0 n); intro.
elim a0; intros.
inversion_clear H0.

left.
apply mem_sort_lift with n0 0; auto with coc.

intros.
inversion_clear H0.

inversion_clear H1.
elim H with a n s; auto with coc.

elim H0 with a (S n) s; auto with coc.

inversion_clear H1.
elim H with a n s; auto with coc.

elim H0 with a n s; auto with coc.

inversion_clear H1.
elim H with a n s; auto with coc.

elim H0 with a (S n) s; intros; auto with coc.
Qed.

  Lemma exp_sort_mem : forall s t u, red1 t u -> mem_sort s u -> mem_sort s t.
induction 1; intros; try inversion_clear H0; auto.
apply mem_sort_subst in H; destruct H; auto.
Qed.

  Lemma red_sort_mem : forall t s, red t (Srt s) -> mem_sort s t.
intros.
pattern t in |- *.
apply red1_red_ind with (Srt s); auto with coc.
do 4 intro.
elim H0; intros.
elim mem_sort_subst with M0 N 0 s; intros; auto with coc.

inversion_clear H4; auto with coc.

inversion_clear H4; auto with coc.

inversion_clear H4; auto with coc.

inversion_clear H4; auto with coc.

inversion_clear H4; auto with coc.

inversion_clear H4; auto with coc.
Qed.

  Lemma red_normal : forall u v, red u v -> normal u -> u = v.
simple induction 1; auto with coc; intros.
absurd (red1 u N); auto with coc.
absurd (red1 P N); auto with coc.
elim (H1 H3).
unfold not in |- *; intro; apply (H3 N); auto with coc.
Qed.

  Lemma sn_red_sn : forall a b, sn a -> red a b -> sn b.
unfold sn in |- *.
simple induction 2; intros; auto with coc.
apply Acc_inv with P; auto with coc.
Qed.

  Lemma commut_red1_subterm : commut _ subterm (transp _ red1).
red in |- *.
simple induction 1; intros.
exists (Abs z B); auto with coc.

exists (Abs A z); auto with coc.

exists (App z B); auto with coc.

exists (App A z); auto with coc.

exists (Prod z B); auto with coc.

exists (Prod A z); auto with coc.
Qed.

  Lemma subterm_sn : forall a, sn a -> forall b, subterm b a -> sn b.
unfold sn in |- *.
simple induction 1; intros.
apply Acc_intro; intros.
elim commut_red1_subterm with x b y; intros; auto with coc.
apply H1 with x0; auto with coc.
Qed.

  Lemma sn_prod : forall A, sn A -> forall B, sn B -> sn (Prod A B).
unfold sn in |- *.
simple induction 1.
simple induction 3; intros.
apply Acc_intro; intros.
inversion_clear H5; auto with coc.
apply H1; auto with coc.
apply Acc_intro; auto with coc.
Qed.

  Lemma sn_subst : forall T M, sn (subst T M) -> sn M.
intros.
cut (forall t, sn t -> forall m, t = subst T m -> sn m).
intros.
apply H0 with (subst T M); auto with coc.

unfold sn in |- *.
simple induction 1; intros.
apply Acc_intro; intros.
apply H2 with (subst T y); auto with coc.
rewrite H3.
unfold subst in |- *; auto with coc.
Qed.