(* Copyright (c) 2014, Robert Dockins *)

Require Import String.
Require Import List.
Require Import Setoid.

Require Import basics.
Require Import preord.
Require Import categories.
Require Import sets.
Require Import finsets.
Require Import esets.
Require Import effective.
Require Import directed.
Require Import plotkin.
Require Import joinable.
Require Import approx_rels.
Require Import cpo.
Require Import profinite.
Require Import profinite_adj.

(** * A fixpoint operator for nonstrict functions in PLT.
  *)

Program Definition precompose hf (A B C:PLT.PLT hf) (f:A → B) :
  (Preord.hom (PLT.hom_ord hf B C) (PLT.hom_ord hf A C)) :=
  Preord.Hom (PLT.hom_ord hf B C) (PLT.hom_ord hf A C)
     (fun g => g ∘ f) _.
Next Obligation.
  intros. apply PLT.compose_mono; auto.
Qed.
Arguments precompose [hf A B] C f.

Program Definition postcompose hf (A B C:PLT.PLT hf) (g:B → C) :
  (Preord.hom (PLT.hom_ord hf A B) (PLT.hom_ord hf A C)) :=
  Preord.Hom (PLT.hom_ord hf A B) (PLT.hom_ord hf A C)
      (fun f => g ∘ f) _.
Next Obligation.
  intros. apply PLT.compose_mono; auto.
Qed.
Arguments postcompose [hf] A [B C] g.

Lemma precompose_continuous hf (A B C:PLT.PLT hf) (f:A → B) :
  continuous (directed_hf_cl hf) (precompose C f).
Proof.
  apply CPO.continuous_sup.
  repeat intro. destruct a as [a c].
  unfold precompose in H.
  apply PLT.compose_hom_rel in H.
  destruct H as [y [??]].
  simpl in H0.
  apply union_axiom in H0. destruct H0 as [q [??]].
  apply image_axiom2 in H0. destruct H0 as [q' [??]].
  simpl in H2.
  apply union_axiom.
  exists (PLT.hom_rel (precompose C f q')).
  split. apply image_axiom1'.
  exists (precompose C f q').
  split; auto.
  apply image_axiom1'.
  exists q'. split; auto.
  unfold precompose.
  apply PLT.compose_hom_rel.
  exists y. split; auto.
  rewrite <- H2; auto.
Qed.

Lemma postcompose_continuous hf (A B C:PLT.PLT hf) (g:B → C) :
  continuous (directed_hf_cl hf) (postcompose A g).
Proof.
  apply CPO.continuous_sup.
  repeat intro. destruct a as [a c].
  unfold postcompose in H.
  apply PLT.compose_hom_rel in H.
  destruct H as [y [??]].
  simpl in H.
  apply union_axiom in H. destruct H as [q [??]].
  apply image_axiom2 in H. destruct H as [q' [??]].
  simpl in H2.
  apply union_axiom.
  exists (PLT.hom_rel (postcompose A g q')).
  split. apply image_axiom1'.
  exists (postcompose A g q').
  split; auto.
  apply image_axiom1'.
  exists q'. split; auto.
  unfold postcompose.
  apply PLT.compose_hom_rel.
  exists y. split; auto.
  rewrite <- H2; auto.
Qed.

Program Definition pair_right hf (A B C:PLT.PLT hf) (f:C → A) :
  (Preord.hom (PLT.hom_ord hf C B) (PLT.hom_ord hf C (PLT.prod A B))) :=
  Preord.Hom (PLT.hom_ord hf C B) (PLT.hom_ord hf C (PLT.prod A B))
  (fun g => PLT.pair f g) _.
Next Obligation.
  intros. apply PLT.pair_mono; auto.
Qed.
Arguments pair_right [hf A] B [C] f.

Program Definition pair_left hf (A B C:PLT.PLT hf) (g:C → B) :
  (Preord.hom (PLT.hom_ord hf C A) (PLT.hom_ord hf C (PLT.prod A B))) :=
  Preord.Hom (PLT.hom_ord hf C A) (PLT.hom_ord hf C (PLT.prod A B))
  (fun f => PLT.pair f g) _.
Next Obligation.
  intros. apply PLT.pair_mono; auto.
Qed.
Arguments pair_left [hf] A [B C] g.

Lemma pair_right_continuous hf (A B C:PLT.PLT hf) (f:C → A) :
  continuous (directed_hf_cl hf) (pair_right B f).
Proof.
  apply CPO.continuous_sup.
  repeat intro. destruct a as [c [a b]].
  unfold pair_right in H.
  simpl in H.
  rewrite (PLT.pair_hom_rel _ _ _ _ _ _ c a b) in H.
  destruct H.
  simpl in H0.
  apply union_axiom in H0. destruct H0 as [q [??]].
  apply image_axiom2 in H0. destruct H0 as [q' [??]].
  simpl in H2.
  apply union_axiom.
  exists (PLT.hom_rel (pair_right B f q')).
  split.
  apply image_axiom1'.
  exists (pair_right B f q'). split; auto.
  apply image_axiom1'.  exists q'. split; auto.
  simpl.
  apply PLT.pair_hom_rel. split; auto.
  rewrite <- H2; auto.
Qed.

Lemma pair_left_continuous hf (A B C:PLT.PLT hf) (g:C → B) :
  continuous (directed_hf_cl hf) (pair_left A g).
Proof.
  apply CPO.continuous_sup.
  repeat intro. destruct a as [c [a b]].
  unfold pair_right in H.
  simpl in H.
  rewrite (PLT.pair_hom_rel _ _ _ _ _ _ c a b) in H.
  destruct H.
  simpl in H.
  apply union_axiom in H. destruct H as [q [??]].
  apply image_axiom2 in H. destruct H as [q' [??]].
  simpl in H2.
  apply union_axiom.
  exists (PLT.hom_rel (pair_left A g q')).
  split.
  apply image_axiom1'.
  exists (pair_left A g q'). split; auto.
  apply image_axiom1'.  exists q'. split; auto.
  simpl.
  apply PLT.pair_hom_rel. split; auto.
  rewrite <- H2; auto.
Qed.

Section fixes.
  Variable Γ:PLT.
  Variable A:∂PLT.
  Variable f:Γ → U A ⇒ U A.

  Definition fixes_step
    (x:Γ → U A) : Γ → U A :=

    apply ∘ 〈f, x〉.

  Program Definition fixes_step' :
    PLT.homset_cpo _ Γ (U A) → PLT.homset_cpo _ Γ (U A) :=

    CPO.Hom _ (PLT.homset_cpo _ Γ (U A)) (PLT.homset_cpo _ Γ (U A))
    fixes_step _ _.
  Next Obligation.
    intros. unfold fixes_step.
    apply PLT.compose_mono; auto.
    apply PLT.pair_mono; auto.
  Qed.
  Next Obligation.
    red; intros.
    unfold fixes_step.
    apply continuous_equiv with
      (postcompose Γ PLT.app ∘ pair_right (U A) f); auto.
    hnf; simpl; intros. split; auto.
    apply continuous_sequence.
    apply postcompose_continuous.
    apply pair_right_continuous.
  Qed.

  Definition fixes : Γ → U A := lfp fixes_step'.

  Lemma fixes_unroll :
    fixes ≈ apply ∘ 〈f, fixes〉.
  Proof.
    unfold fixes at 1.
    rewrite <- lfp_fixpoint. simpl. unfold fixes_step.
    auto.
  Qed.

End fixes.
Arguments fixes [Γ A] f.

Lemma fixes_mono Γ A (f g:Γ → U A ⇒ U A) :
  f ≤ g -> fixes f ≤ fixes g.
Proof.
  intro. unfold fixes at 1.
  apply scott_induction.
  red. split. apply bottom_least.
  intros.
  apply CPO.sup_is_least.
  red; intros. apply H1; auto.
  intros. rewrite <- H0; auto.
  simpl; intros. unfold fixes_step.
  rewrite fixes_unroll.
  apply PLT.compose_mono; auto.
  apply PLT.pair_mono; auto.
Qed.

Lemma fixes_eq Γ A (f g:Γ → U A ⇒ U A) :
  f ≈ g -> fixes f ≈ fixes g.
Proof.
  intros [??]; split; apply fixes_mono; auto.
Qed.

Add Parametric Morphism Γ A :
  (@fixes Γ A)
  with signature (Preord.ord_op _ ==> Preord.ord_op _)
  as fixes_le_morphism.
Proof.
  intros. apply fixes_mono. auto.
Qed.

Add Parametric Morphism Γ A :
  (@fixes Γ A)
  with signature (eq_op _ ==> eq_op _)
  as fixes_morphism.
Proof.
  intros. apply fixes_eq. auto.
Qed.

Lemma plt_bot_None A B x y :
  (x,y) ∈ PLT.hom_rel (⊥ : A → U B) <-> y = None.
Proof.
  split; intros.
  simpl in H.
  unfold plt_hom_adj' in H.
  apply PLT.compose_hom_rel in H.
  destruct H as [?[??]].
  simpl in H.
  apply adj_unit_rel_elem in H.
  apply U_hom_rel in H0.
  destruct H0; auto.
  destruct H0 as [?[?[??]]].
  simpl in H0.
  apply union_axiom in H0.
  destruct H0 as [?[??]].
  apply image_axiom2 in H0.
  destruct H0 as [?[??]].
  apply empty_elem in H0. elim H0.

  subst y.
  simpl.
  unfold plt_hom_adj'.
  apply PLT.compose_hom_rel.
  exists None.
  split. simpl.
  apply adj_unit_rel_elem.
  hnf; auto.
  apply U_hom_rel. auto.
Qed.

Lemma plt_bot_chomp A B C (g:A → B) :
  (⊥ : B → U C) ∘ g ≈ ⊥.
Proof.
  split. 2: apply bottom_least.
  hnf. intros.
  destruct a.
  apply PLT.compose_hom_rel in H.
  destruct H as [?[??]].
  apply plt_bot_None in H0.
  apply plt_bot_None. auto.
Qed.

Lemma fixes_compose_commute Γ Γ' A (f:Γ → U A ⇒ U A) (g:Γ' → Γ) :
  fixes f ∘ g ≈ fixes (f ∘ g).
Proof.
  split; unfold fixes at 1; apply scott_induction.
  red; split.
  rewrite plt_bot_chomp.
  apply bottom_least.
  intros.
  transitivity (∐(image (precompose (U A) g) XS)).
  destruct (CPO.continuous_sup _ _ _ (precompose (U A) g)).
  apply H1.
  apply (precompose_continuous false _ _ (U A) g).
  apply CPO.sup_is_least.
  red; intros.
  apply image_axiom2 in H1.
  destruct H1 as [q [??]].
  rewrite H2. simpl.
  apply H0. auto.
  intros. rewrite <- H. auto.
  simpl; intros.
  unfold fixes_step.
  rewrite fixes_unroll.
  rewrite <- (cat_assoc PLT).
  apply PLT.compose_mono; auto.
  rewrite (PLT.pair_compose_commute false).
  apply PLT.pair_mono; auto.

  red; split.
  apply bottom_least.
  intros.
  apply CPO.sup_is_least.
  red; intros.
  apply H0; auto.
  intros.
  rewrite <- H; auto.
  simpl; intros.
  unfold fixes_step.
  rewrite fixes_unroll.
  rewrite <- (cat_assoc PLT).
  apply PLT.compose_mono; auto.
  rewrite (PLT.pair_compose_commute false).
  apply PLT.pair_mono; auto.
Qed.


Require Import core.Semantics.
Require Import core.Syntax.
Require Import core.Model.
Require Import core.TransformationConfiguration.
Require Import String.
Require Import EqNat.
Require Import List.
Require Import Expressions.
Require Import core.utils.Utils.
Require Import PeanoNat.
Require Import Lia.
Require Import FunctionalExtensionality.

(*************************************************************)
(** * Additivity in OutputPatternElement context             *)
(*************************************************************)

Definition Rule_incl_guard' {tc: TransformationConfiguration} (x y: Rule) : Prop :=
  Rule_getName x = Rule_getName y
  /\ (Rule_getGuardExpr x = Rule_getGuardExpr y  \/
      Rule_getGuardExpr x = (fun _ _ => None))
  /\ (Rule_getIteratorExpr x = Rule_getIteratorExpr y)
  /\ (forall o1, In o1 (Rule_getOutputPatternElements x) -> In o1 (Rule_getOutputPatternElements y)).

Definition Transformation_incl_elements''' {tc: TransformationConfiguration} (t1 t2: Transformation) : Prop :=
  (Transformation_getArity t1 = Transformation_getArity t2) /\
  (forall (r1: Rule), In r1 (Transformation_getRules t1) ->
    (exists r2:Rule, In r2 (Transformation_getRules t2) /\ Rule_incl_guard' r1 r2 )).

Theorem additivity_guard_general :
forall (tc: TransformationConfiguration) (t1 t2: Transformation) (sm: SourceModel),
  (Transformation_incl_elements''' t1 t2 ->
    incl (allModelElements (execute t1 sm)) (allModelElements (execute t2 sm))).
Proof.
simpl.
unfold incl.
intros.
apply in_flat_map in H0. repeat destruct H0.
apply in_flat_map in H1. repeat destruct H1.
apply filter_In in H1. destruct H1.
destruct H.
apply in_flat_map. exists x.
split.
* unfold allTuples.
  unfold maxArity.
  rewrite <- H.
  assumption.
* apply in_flat_map.
  specialize (H4 x0 H1).
  destruct H4.
  exists x1.
  unfold Rule_incl_guard' in H4.
  destruct H4. destruct H5. destruct H6. destruct H7.
  split.
  + destruct H6.
    ++ apply filter_In.
       split; auto.
       unfold matchRuleOnPattern, evalGuardExpr.
       unfold matchRuleOnPattern,evalGuardExpr in H3.
       rewrite <- H6. auto.
    ++ unfold matchRuleOnPattern,evalGuardExpr in H3.
       rewrite H6 in H3. simpl in H3. crush.
  + apply in_flat_map.
    apply in_flat_map in H2.
    destruct H2.
    exists x2.
    destruct H2.
    split.
    ++ unfold evalIteratorExpr; unfold evalIteratorExpr in H2. rewrite <- H7; auto.
    ++ apply in_flat_map; apply in_flat_map in H9.
       destruct H9. destruct H9.
       specialize (H8 x3 H9).
       exists x3.
       split; auto.
Qed.

Definition Rule_incl_guard {tc: TransformationConfiguration} (x y: Rule) : Prop :=
  Rule_getName x = Rule_getName y
  /\ (Rule_getGuardExpr x = Rule_getGuardExpr y  \/
      Rule_getGuardExpr x = (fun _ _ => None))
  /\ Rule_getIteratorExpr x = Rule_getIteratorExpr y
  /\ subseq (Rule_getOutputPatternElements x) (Rule_getOutputPatternElements y).

Inductive Transformation_incl_rules' {tc: TransformationConfiguration}  : list Rule -> list Rule -> Prop :=
  | incl_rules_nil : Transformation_incl_rules' nil nil
  | incl_rules_diff : forall x y xs ys, Transformation_incl_rules' xs ys
    -> Rule_incl_guard x y
    -> Transformation_incl_rules' (x::xs) (y::ys).

Definition Transformation_incl_elements'' {tc: TransformationConfiguration} (t1 t2: Transformation) : Prop :=
  (Transformation_getArity t1 = Transformation_getArity t2) /\
  Transformation_incl_rules' (Transformation_getRules t1) (Transformation_getRules t2).

Lemma tr_incl_equiv:
  forall (tc: TransformationConfiguration) t1 t2,
    Transformation_incl_elements'' t1 t2 -> Transformation_incl_elements''' t1 t2.
Proof.
intros.
destruct  H.
unfold Transformation_incl_elements'''.
split.
* auto.
* intro.
  induction H0.
  **  intros.
      contradiction.
  **  intros.
      simpl in H2.
      destruct H2.
      - exists y.
        split.
        -- crush.
        -- rewrite <- H2.
           unfold Rule_incl_guard in H1.
           unfold Rule_incl_guard'; crush.
           induction H6.
           --- contradiction.
           --- destruct H5; crush.
           --- crush.
           --- induction H6.
                + contradiction.
                + simpl in H1.
                  destruct H1.
                  simpl.
                  ++ left; auto.
                  ++ simpl. right. crush.
                + simpl.
                  specialize (IHsubseq H1). right. auto.
      - specialize (IHTransformation_incl_rules' H2).
        destruct IHTransformation_incl_rules'.
        destruct H3.
        exists x0; crush.
Qed.

Theorem additivity_guard_correct :
forall (tc: TransformationConfiguration) (t1 t2: Transformation) (sm: SourceModel),
  (Transformation_incl_elements'' t1 t2 ->
    incl (allModelElements (execute t1 sm)) (allModelElements (execute t2 sm))).
Proof.
intros.
specialize (tr_incl_equiv tc t1 t2 H).
specialize (additivity_guard_general tc t1 t2).
auto.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q A B C Aprime Cprime : Universe, ((wd_ P Q /\ (wd_ P Aprime /\ (wd_ P Cprime /\ (wd_ A Aprime /\ (wd_ B Aprime /\ (wd_ C Cprime /\ (wd_ A B /\ (wd_ C B /\ (wd_ A C /\ (wd_ Aprime Cprime /\ (wd_ C P /\ (wd_ B P /\ (wd_ A P /\ (col_ P Q Aprime /\ (col_ P Q Cprime /\ (col_ A B C /\ (col_ A B Aprime /\ col_ C A Aprime))))))))))))))))) -> col_ P Aprime Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Coq Require Import
     Fin
     Nat
     List
     Relations.

From ITree Require Import
     Indexed.Sum
     CategoryOps.

From CTree Require Import
     CTree
     Eq.Equ
     Eq.Trans
     Interp.Fold
     Misc.Vectors
     Core.Utils.

Local Open Scope fin_vector_scope.

Set Implicit Arguments.

(*| Unique thread identifiers |*)
Notation id n := (fin (S n)).

(*| Thread IDs are a product of an effect [E] with a [uid] |*)
Variant switchE (n: nat): Type -> Type :=
  | Process (i: id n): switchE n unit.

Arguments Process {n}.

Definition switch {n E C} `{switchE n -< E} (i: id n): ctree E C unit :=
  trigger (Process i).


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
Require Import securite.

Lemma POinvprel6 :
 forall (l l0 : list C) (k k0 k1 k2 : K) (c c0 c1 c2 : C)
   (d d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19
    d20 : D),
 inv0
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 inv1
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 invP
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 rel6
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l)
   (ABSI (MBNaKab d18 d19 d20 k2) (MANbKabCaCb d15 d16 d17 k1 c1 c2)
      (MABNaNbKeyK d10 d11 d12 d13 d14) l0) ->
 invP
   (ABSI (MBNaKab d18 d19 d20 k2) (MANbKabCaCb d15 d16 d17 k1 c1 c2)
      (MABNaNbKeyK d10 d11 d12 d13 d14) l0).

Proof.
do 32 intro.
unfold rel6 in |- *; intros Inv0 Inv1 InvP and1.
elim and1; intros t1 and2; elim and2; intros t2 and3; elim and3;
 intros t3 and4; elim and4; intros eq_l0 t4.
elim eq_l0; assumption.
Qed.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(* begin hide *)
Require Export CoRN.ftc.MoreFunSeries.
Require Export CoRN.ftc.Composition.
Require Export CoRN.tactics.DiffTactics2.

Ltac Deriv_substR :=
  match goal with
  |  |- (Derivative ?X1 _) =>
      let t := derivative_of X1 in
      apply Derivative_wdr with t
  end.

Inductive symbPF : Type :=
  | shyp :
      forall (I : interval) (pI : proper I) (F F' : PartIR),
      Derivative I pI F F' -> symbPF
  | shyp' :
      forall (I : interval) (pI : proper I) (F : PartIR),
      Diffble I pI F -> symbPF
  | sconst : forall c : IR, symbPF
  | sid : symbPF
  | splus : symbPF -> symbPF -> symbPF
  | sinv : symbPF -> symbPF
  | sminus : symbPF -> symbPF -> symbPF
  | smult : symbPF -> symbPF -> symbPF
  | sscalmult : IR -> symbPF -> symbPF
  | snth : symbPF -> nat -> symbPF
  | srecip : symbPF -> symbPF
  | sdiv : symbPF -> symbPF -> symbPF
  | scomp : symbPF -> symbPF -> symbPF.
(*
  | ssum0     : nat->(nat->symbPF)->symbPF
  | ssumx     : (n:nat)((i:nat)(lt i n)->symbPF)->symbPF
  | ssum      : nat->nat->(nat->symbPF)->symbPF
*)

Fixpoint symb_to_PartIR (r : symbPF) : PartIR :=
  match r with
  | shyp _ _ f _ _ => f
  | shyp' _ _ f _ => f
  | sconst c => [-C-]c
  | sid => FId
  | splus f g => symb_to_PartIR f{+}symb_to_PartIR g
  | sinv f => {--}(symb_to_PartIR f)
  | sminus f g => symb_to_PartIR f{-}symb_to_PartIR g
  | smult f g => symb_to_PartIR f{*}symb_to_PartIR g
  | sscalmult c f => c{**}symb_to_PartIR f
  | snth f n => symb_to_PartIR f{^}n
  | srecip f => {1/}(symb_to_PartIR f)
  | sdiv f g => symb_to_PartIR f{/}symb_to_PartIR g
  | scomp f g =>
      symb_to_PartIR f[o]
      symb_to_PartIR g
      (*
        | (ssum0 n f)      => (FSum0 n [i:nat](symb_to_PartIR (f i)))
        | (ssumx n f)      => (FSumx n [i:nat][Hi:(lt i n)](symb_to_PartIR (f i Hi)))
        | (ssum m n f)     => (FSum m n [i:nat](symb_to_PartIR (f i)))
      *)
  end.

Fixpoint symbPF_deriv (r : symbPF) : PartIR :=
  match r with
  | shyp _ _ _ f' _ => f'
  | shyp' J pJ F H => Deriv J pJ F H
  | sconst c => [-C-][0]
  | sid => [-C-][1]
  | splus f g => symbPF_deriv f{+}symbPF_deriv g
  | sinv f => {--}(symbPF_deriv f)
  | sminus f g => symbPF_deriv f{-}symbPF_deriv g
  | smult f g =>
      symb_to_PartIR f{*}symbPF_deriv g{+}symbPF_deriv f{*}symb_to_PartIR g
  | sscalmult c f => c{**}symbPF_deriv f
  | snth f n =>
      match n with
      | O => [-C-][0]
      | S p => nring (S p){**}(symbPF_deriv f{*}symb_to_PartIR (snth f p))
      end
  | srecip f => {--}(symbPF_deriv f{/}symb_to_PartIR f{*}symb_to_PartIR f)
  | sdiv f g =>
      (symbPF_deriv f{*}symb_to_PartIR g{-}symb_to_PartIR f{*}symbPF_deriv g){/}
      symb_to_PartIR g{*}symb_to_PartIR g
  | scomp g f =>
      (symbPF_deriv g[o]symb_to_PartIR f){*}
      symbPF_deriv f
      (*
        | (ssum0 n f)       => (FSum0 n [i:nat](symbPF_deriv (f i)))
        | (ssumx n f)       => (FSumx n [i:nat][Hi:(lt i n)](symbPF_deriv (f i Hi)))
        | (ssum m n f)      => (FSum m n [i:nat](symbPF_deriv (f i)))
      *)
  end.

Ltac PartIR_to_symbPF f :=
  match constr:(f) with
  | ([-C-]?X3) => constr:(sconst X3)
  | FId => constr:(sid)
  | (?X3{+}?X4) =>
      let t1 := PartIR_to_symbPF X3 with t2 := PartIR_to_symbPF X4 in
      constr:(splus t1 t2)
  | ({--}?X3) =>
      let t1 := PartIR_to_symbPF X3 in
      constr:(sinv t1)
  | (?X3{-}?X4) =>
      let t1 := PartIR_to_symbPF X3 with t2 := PartIR_to_symbPF X4 in
      constr:(sminus t1 t2)
  | (?X3{*}?X4) =>
      let t1 := PartIR_to_symbPF X3 with t2 := PartIR_to_symbPF X4 in
      constr:(smult t1 t2)
  | (?X3{**}?X4) =>
      let t := PartIR_to_symbPF X4 in
      constr:(sscalmult X3 t)
  | (?X3{^}?X4) =>
      let t1 := PartIR_to_symbPF X3 in
      constr:(snth t1 X4)
  | ({1/}?X3) =>
      let t1 := PartIR_to_symbPF X3 in
      constr:(srecip t1)
  | (?X3{/}?X4) =>
      let t1 := PartIR_to_symbPF X3 with t2 := PartIR_to_symbPF X4 in
      constr:(sdiv t1 t2)
  | (?X3[o]?X4) =>
      let t1 := PartIR_to_symbPF X3 with t2 := PartIR_to_symbPF X4 in
      constr:(scomp t1 t2)
  | ?X3 =>
      let t := constr:(X3) in
      match goal with
      | H:(Derivative ?X1 ?X2 t ?X4) |- _ =>
          constr:(shyp X1 X2 t X4 H)
      | H:(Diffble ?X1 ?X2 t) |- _ => constr:(shyp' X1 X2 t H)
      end
  end.

Ltac Derivative_Help :=
  match goal with
  |  |- (Derivative ?X1 ?X2 ?X3 ?X4) =>
      let r := PartIR_to_symbPF X3 in
      (apply Derivative_wdr with (symbPF_deriv r);
        [ unfold symbPF_deriv, symb_to_PartIR in |- *
        | simpl in |- *; Deriv ])
  end.
(* end hide *)


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

Require Export Droite_plan_espace.
Set Implicit Arguments.
Unset Strict Implicit.
Parameter para_plan_plan : PL -> PL -> Prop.

Axiom
  def_para_plan_plan :
    forall A B C D E F : PO,
    ~ alignes A B C ->
    ~ alignes D E F ->
    para_plan_dr (plan A B C) (droite D E) ->
    para_plan_dr (plan A B C) (droite D F) ->
    para_plan_plan (plan A B C) (plan D E F).

Axiom
  def_para_plan_plan2 :
    forall A B C D E F : PO,
    ~ alignes A B C ->
    ~ alignes D E F ->
    para_plan_plan (plan A B C) (plan D E F) ->
    para_plan_dr (plan A B C) (droite D E) /\
    para_plan_dr (plan A B C) (droite D F).

Lemma couple_vecteurs_coplanaires :
 forall (A B C D E F : PO) (a b c d : R),
 ~ alignes A B C ->
 ~ alignes D E F ->
 vec D E = add_PP (mult_PP a (vec A B)) (mult_PP b (vec A C)) :>PP ->
 vec D F = add_PP (mult_PP c (vec A B)) (mult_PP d (vec A C)) :>PP ->
 para_plan_plan (plan A B C) (plan D E F).
intros.
deroule_triangle D E F.
apply def_para_plan_plan; auto.
apply vecteurs_para_plan_dr with (k := a) (k' := b); auto.
apply vecteurs_para_plan_dr with (k := c) (k' := d); auto.
Qed.

Lemma plans_paralleles_vecteurs :
 forall A B C D E F : PO,
 ~ alignes A B C ->
 ~ alignes D E F ->
 para_plan_plan (plan A B C) (plan D E F) ->
 (exists a : R,
    (exists b : R,
       vec D E = add_PP (mult_PP a (vec A B)) (mult_PP b (vec A C)) :>PP)) /\
 (exists c : R,
    (exists d : R,
       vec D F = add_PP (mult_PP c (vec A B)) (mult_PP d (vec A C)) :>PP)).
intros.
elim def_para_plan_plan2 with (3 := H1);
 [ try clear def_para_plan_plan2; auto | auto | auto ].
intros.
elim para_plan_dr_vecteur with (A := A) (B := B) (C := C) (D := D) (E := E);
 [ intros k H5; elim H5; intros k' H6; try clear H5 para_plan_dr_vecteur;
    try exact H6
 | auto with geo
 | auto
 | auto ].
elim para_plan_dr_vecteur with (A := A) (B := B) (C := C) (D := D) (E := F);
 [ intros k0 H7; elim H7; intros k'0 H8; try clear H7 para_plan_dr_vecteur;
    try exact H8
 | auto with geo
 | auto
 | auto ].
split; [ exists k | idtac ].
exists k'; auto.
exists k0; exists k'0; auto.
deroule_triangle D E F; auto.
Qed.

Lemma paralleles_droites_plan_trans :
 forall A B C D E F G : PO,
 ~ alignes A B C ->
 D <> E :>PO ->
 F <> G :>PO ->
 para_plan_dr (plan A B C) (droite D E) ->
 paralleles (droite D E) (droite F G) ->
 para_plan_dr (plan A B C) (droite F G).
intros.
elim def_para_plan_dr2 with (A := A) (B := B) (C := C) (F := D) (G := E);
 [ intros D0 H5; elim H5; intros E0 H6; elim H6; intros H7 H8; elim H8;
    intros H9 H10; try clear H8 H6 H5 def_para_plan_dr2;
    try exact H10
 | auto
 | auto
 | auto ].
apply def_para_plan_dr with (D := D0) (E := E0); auto.
elim H6; intros H4 H11; elim H4; intros H12 H13; try clear H4 H6;
 try exact H12.
elim H7; intros H4 H11; try clear H7; try exact H11.
apply paralleles_trans with (4 := H10); auto.
Qed.

Lemma para_plan_refl :
 forall A B C : PO,
 ~ alignes A B C -> para_plan_plan (plan A B C) (plan A B C).
intros.
deroule_triangle A B C.
generalize
 (couple_vecteurs_coplanaires (A:=A) (B:=B) (C:=C) (D:=A) (E:=B) (F:=C)
    (a:=1) (b:=0) (c:=0) (d:=1)); intros H11; apply H11;
 auto.
unfold vec in |- *; RingPP.
unfold vec in |- *; RingPP.
Qed.

Lemma para_plan_sym :
 forall A B C D E F : PO,
 ~ alignes A B C ->
 ~ alignes D E F ->
 para_plan_plan (plan A B C) (plan D E F) ->
 para_plan_plan (plan D E F) (plan A B C).
intros A B C D E F H H0 H1; try assumption.
elim
 def_para_plan_plan2
  with (A := A) (B := B) (C := C) (D := D) (E := E) (F := F);
 [ intros H2 H3; try clear def_para_plan_plan2; try exact H3
 | auto
 | auto
 | auto ].
elim para_plan_dr_vecteur with (A := A) (B := B) (C := C) (D := D) (E := E);
 [ intros k H8; elim H8; intros k' H9; try clear H8 para_plan_dr_vecteur;
    auto
 | auto
 | auto
 | auto ].
elim para_plan_dr_vecteur with (A := A) (B := B) (C := C) (D := D) (E := F);
 [ intros k0 H10; elim H10; intros k'0 H11;
    try clear H10 para_plan_dr_vecteur; try exact H11
 | auto
 | auto
 | auto ].
cut
 (ex
    (fun a : R =>
     ex
       (fun b : R =>
        vec A B = add_PP (mult_PP a (vec D E)) (mult_PP b (vec D F)))) /\
  ex
    (fun c : R =>
     ex
       (fun d : R =>
        vec A C = add_PP (mult_PP c (vec D E)) (mult_PP d (vec D F))))).
intros H12.
elim H12; intros H13 H14; elim H13; intros a H15; elim H15; intros b H16;
 try clear H15 H13 H12; try exact H16.
elim H14; intros c H12; elim H12; intros d H13; try clear H12 H14;
 try exact H13.
apply couple_vecteurs_coplanaires with (a := a) (b := b) (c := c) (d := d);
 auto.
cut
 (mult_PP k (vec D F) =
  add_PP (mult_PP (k * k0) (vec A B)) (mult_PP (k * k'0) (vec A C)));
 intros.
cut
 (mult_PP k' (vec D F) =
  add_PP (mult_PP (k' * k0) (vec A B)) (mult_PP (k' * k'0) (vec A C)));
 intros.
cut
 (mult_PP k0 (vec D E) =
  add_PP (mult_PP (k0 * k) (vec A B)) (mult_PP (k0 * k') (vec A C)));
 intros.
cut
 (mult_PP k'0 (vec D E) =
  add_PP (mult_PP (k'0 * k) (vec A B)) (mult_PP (k'0 * k') (vec A C)));
 intros.
cut
 (add_PP (mult_PP k (vec D F)) (mult_PP (- k0) (vec D E)) =
  mult_PP (k * k'0 + - (k0 * k')) (vec A C)); intros.
cut
 (add_PP (mult_PP k' (vec D F)) (mult_PP (- k'0) (vec D E)) =
  mult_PP (k' * k0 + - (k'0 * k)) (vec A B)); intros.
elim (classic (k * k'0 + - (k0 * k') = 0)); intros.
cut (k' * k0 + - (k'0 * k) = 0); intros.
rewrite H15 in H13.
rewrite H14 in H12.
elim (classic (k = 0)); intros.
rewrite H16 in H15.
rewrite H16 in H9.
elim (classic (k' = 0)); intros.
rewrite H17 in H9.
absurd (D = E); auto with geo.
apply conversion_PP with (a := 1) (b := 1); auto with *.
unfold vec in H9.
RingPP2 H9; RingPP.
cut (k0 = 0); intros.
clear H10; clear H8.
rewrite H18 in H11.
elim (classic (k'0 = 0)); intros.
rewrite H8 in H11.
absurd (D = F).
apply non_alignes_distincts with E; auto.
apply conversion_PP with (a := 1) (b := 1); auto with *.
unfold vec in H11.
RingPP2 H11; RingPP.
absurd (alignes D E F); auto.
apply colineaire_alignes with (k'0 * / k'); auto.
rewrite H11; rewrite H9.
unfold vec in |- *.
FieldPP k'.
cut (k' * k0 = 0); intros.
RReplace k0 (/ k' * (k' * k0)).
rewrite H18; field; auto.
field; auto.
rewrite <- H15; ring.
absurd (alignes D E F); auto.
apply colineaire_alignes with (/ k * k0); auto.
cut (mult_PP k (vec D F) = mult_PP k0 (vec D E)); intros.
apply mult_PP_regulier with k; auto.
rewrite H17.
FieldPP k.
VReplace (mult_PP k0 (vec D E))
 (add_PP (mult_PP k0 (vec D E)) (mult_PP 0 (vec A C))).
rewrite <- H12; RingPP.
RReplace (k' * k0 + - (k'0 * k)) (- (k * k'0 + - (k0 * k'))).
rewrite H14; ring.
cut (k' * k0 + - (k'0 * k) <> 0); intros.
split; [ try assumption | idtac ].
exists (/ (k' * k0 + - (k'0 * k)) * - k'0);
 exists (/ (k' * k0 + - (k'0 * k)) * k').
apply mult_PP_regulier with (k' * k0 + - (k'0 * k)); auto.
rewrite <- H13.
FieldPP (k' * k0 + - (k'0 * k)).
exists (/ (k * k'0 + - (k0 * k')) * - k0);
 exists (/ (k * k'0 + - (k0 * k')) * k).
apply mult_PP_regulier with (k * k'0 + - (k0 * k')); auto with real.
rewrite <- H12.
FieldPP (k * k'0 + - (k0 * k')).
RReplace (k' * k0 + - (k'0 * k)) (- (k * k'0 + - (k0 * k'))).
auto with real.
replace (mult_PP (- k'0) (vec D E)) with
 (add_PP (mult_PP (- k'0 * k) (vec A B)) (mult_PP (- k'0 * k') (vec A C))).
rewrite H11; RingPP.
apply mult_PP_regulier with (-1); auto with real.
VReplace (mult_PP (-1) (mult_PP (- k'0) (vec D E))) (mult_PP k'0 (vec D E)).
rewrite H7; RingPP.
replace (mult_PP (- k0) (vec D E)) with
 (add_PP (mult_PP (- k0 * k) (vec A B)) (mult_PP (- k0 * k') (vec A C))).
rewrite H4; RingPP.
apply mult_PP_regulier with (-1); auto with real.
VReplace (mult_PP (-1) (mult_PP (- k0) (vec D E))) (mult_PP k0 (vec D E)).
rewrite H6; RingPP.
rewrite H9; RingPP.
rewrite H9; RingPP.
rewrite H11; RingPP.
rewrite H11; RingPP.
apply non_alignes_distincts with E; auto.
auto with geo.
Qed.

Lemma para_plan_trans :
 forall A B C D E F G H I : PO,
 ~ alignes A B C ->
 ~ alignes D E F ->
 ~ alignes G H I ->
 para_plan_plan (plan A B C) (plan D E F) ->
 para_plan_plan (plan D E F) (plan G H I) ->
 para_plan_plan (plan A B C) (plan G H I).
intros A B C D E F G H I H0 H1 H2 H3 H4; try assumption.
deroule_triangle A B C.
deroule_triangle D E F.
deroule_triangle G H I.
elim
 def_para_plan_plan2
  with (A := A) (B := B) (C := C) (D := D) (E := E) (F := F);
 [ intros H14 H15; try clear def_para_plan_plan2; auto | auto | auto | auto ].
elim
 def_para_plan_plan2
  with (A := D) (B := E) (C := F) (D := G) (E := H) (F := I);
 [ intros; auto | auto | auto | auto ].
elim
 def_para_plan_plan2
  with (A := D) (B := E) (C := F) (D := G) (E := H) (F := I);
 [ try clear def_para_plan_plan2; auto | auto | auto | auto ].
intros.
elim para_plan_dr_vecteur with (A := A) (B := B) (C := C) (D := D) (E := E);
 [ intros k H20; elim H20; [ intros k' H21; try clear H20; auto ]
 | auto
 | auto
 | auto ].
elim para_plan_dr_vecteur with (A := A) (B := B) (C := C) (D := D) (E := F);
 [ intros k0 H22; elim H22; [ intros k'0 H23; try clear H22; auto ]
 | auto
 | auto
 | auto ].
elim para_plan_dr_vecteur with (A := D) (B := E) (C := F) (D := G) (E := H);
 [ intros k1 H20; elim H20; [ intros k'1 H22; try clear H20; auto ]
 | auto
 | auto
 | auto ].
elim para_plan_dr_vecteur with (A := D) (B := E) (C := F) (D := G) (E := I);
 [ intros k2 H20; elim H20; [ intros k'2 H24; try clear H20; auto ]
 | auto
 | auto
 | auto ].
cut
 (ex
    (fun a : R =>
     ex
       (fun b : R =>
        vec G I = add_PP (mult_PP a (vec A B)) (mult_PP b (vec A C)))) /\
  ex
    (fun c : R =>
     ex
       (fun d : R =>
        vec G H = add_PP (mult_PP c (vec A B)) (mult_PP d (vec A C)))));
 intros.
elim H20;
 [ intros H25 H26; elim H25;
    [ intros a H27; elim H27;
       [ intros b H28; try clear H27 H25 H20; try exact H28 ] ] ].
elim H26;
 [ intros c H20; elim H20; [ intros d H25; try clear H20 H26; try exact H25 ] ].
apply couple_vecteurs_coplanaires with (a := c) (b := d) (c := a) (d := b);
 auto.
split; [ try assumption | idtac ].
cut
 (vec G I =
  add_PP (mult_PP k2 (add_PP (mult_PP k (vec A B)) (mult_PP k' (vec A C))))
    (mult_PP k'2 (add_PP (mult_PP k0 (vec A B)) (mult_PP k'0 (vec A C)))));
 intros.
exists (k2 * k + k'2 * k0).
exists (k2 * k' + k'2 * k'0).
rewrite H20; RingPP.
rewrite <- H21; rewrite <- H23; rewrite H24; auto.
cut
 (vec G H =
  add_PP (mult_PP k1 (add_PP (mult_PP k (vec A B)) (mult_PP k' (vec A C))))
    (mult_PP k'1 (add_PP (mult_PP k0 (vec A B)) (mult_PP k'0 (vec A C)))));
 intros.
exists (k1 * k + k'1 * k0).
exists (k1 * k' + k'1 * k'0).
rewrite H20; RingPP.
rewrite <- H21; rewrite <- H23; rewrite H22; auto.
Qed.

Lemma plans_paralleles_ou_droite_incluse2 :
 forall A B C D E F : PO,
 ~ alignes A B C ->
 ~ alignes D E F ->
 para_plan_plan (plan A B C) (plan D E F) \/
 (exists I : PO,
    (exists J : PO,
       I <> J :>PO /\
       incluse (droite I J) (plan A B C) /\ incluse (droite I J) (plan D E F))).
intros A B C D E F H H0; try assumption.
deroule_triangle D E F.
elim
 position_relative_droite_plan
  with (A := A) (B := B) (C := C) (D := D) (E := E);
 [ intros H4; try clear position_relative_droite_plan
 | intros H4; try clear position_relative_droite_plan; try exact H4
 | try trivial
 | try trivial ].
elim
 position_relative_droite_plan
  with (A := A) (B := B) (C := C) (D := D) (E := F);
 [ intros H5; try clear position_relative_droite_plan
 | intros H5; try clear position_relative_droite_plan; try exact H5
 | try trivial
 | try trivial ].
left; try assumption.
apply def_para_plan_plan; auto.
elim H5; intros.
elim def_contact2 with (A := A) (B := B) (C := C) (D := D) (E := F);
 [ intros J H8; elim H8;
    [ intros H9 H10; try clear H8 def_contact2; try exact H10 ]
 | try trivial
 | try trivial
 | try trivial ].
right; try assumption.
elim existence_representant_vecteur with (A := J) (B := E) (C := D); intros I;
 intros; try clear existence_representant_vecteur.
exists I; exists J.
cut (I <> J).
intros H30.
split; [ trivial | split; [ idtac | try assumption ] ].
cut (para_plan_dr (plan A B C) (droite J I)); intros.
apply droite_incluse_plan2; auto.
apply paralleles_droite_plan_coplanaires_incluse with (3 := H12); auto.
apply paralleles_droites_plan_trans with (4 := H4); auto.
apply def_paralleles with (-1); auto.
unfold vec in H11.
VReplace (cons (-1) I) (mult_PP (-1) (cons 1 I)).
RingPP2 H11.
Ringvec.
cut (coplanaires D E F J).
intros H20.
apply droite_incluse_plan2; auto.
cut (para_plan_dr (plan D E F) (droite J I)); intros.
apply paralleles_droite_plan_coplanaires_incluse with (3 := H12); auto.
apply def_para_plan_dr with (D := D) (E := E); auto with geo.
apply def_paralleles with (-1); auto.
unfold vec in H11.
VReplace (cons (-1) I) (mult_PP (-1) (cons 1 I)).
RingPP2 H11.
Ringvec.
unfold coplanaires in |- *.
hPPalignes H9 k.
right; try assumption.
exists k; exists 0.
rewrite H9; RingPP.
unfold vec in H11.
unfold not in |- *; intros; apply H3.
apply conversion_PP with (a := 1) (b := 1); auto.
cut (add_PP (cons (-1) E) (cons 1 D) = add_PP (cons (-1) J) (cons 1 I));
 intros; auto.
RingPP2 H13.
rewrite H12; RingPP.
auto with *.
elim
 position_relative_droite_plan
  with (A := A) (B := B) (C := C) (D := D) (E := F);
 [ intros H5; try clear position_relative_droite_plan
 | unfold perce in |- *; intros H5; try clear position_relative_droite_plan;
    try exact H5
 | try trivial
 | try trivial ].
elim def_contact2 with (A := A) (B := B) (C := C) (D := D) (E := E);
 [ intros J H6; elim H6;
    [ intros H7 H8; try clear H6 def_contact2; try exact H8 ]
 | try trivial
 | try trivial
 | try trivial ].
right; try assumption.
elim existence_representant_vecteur with (A := J) (B := D) (C := F); intros I;
 intros; try clear existence_representant_vecteur;
 try exact H5.
exists I; exists J.
cut (I <> J).
intros H30.
split; [ trivial | split; [ idtac | try assumption ] ].
cut (para_plan_dr (plan A B C) (droite J I)); intros.
apply droite_incluse_plan2; auto.
apply paralleles_droite_plan_coplanaires_incluse with (3 := H10); auto.
apply paralleles_droites_plan_trans with (4 := H5); auto.
apply def_paralleles with 1; auto.
unfold vec in H9; auto.
RingPP2 H9.
RingPP.
cut (coplanaires D E F J); auto with geo.
intros H20.
apply droite_incluse_plan2; auto.
cut (para_plan_dr (plan D E F) (droite J I)); intros.
apply paralleles_droite_plan_coplanaires_incluse with (3 := H10);
 auto with geo.
apply def_para_plan_dr with (D := D) (E := F); auto with geo.
apply def_paralleles with 1; auto.
unfold vec in H9.
RingPP2 H9.
RingPP.
unfold vec in H9.
unfold not in |- *; intros; apply H1.
apply conversion_PP with (a := 1) (b := 1); auto.
cut (add_PP (cons (-1) F) (cons 1 D) = add_PP (cons 1 J) (cons (-1) I));
 intros; auto.
RingPP2 H11.
rewrite H10; RingPP.
VReplace (cons (-1) I) (mult_PP (-1) (cons 1 I)).
RingPP2 H9.
RingPP.
auto with *.
unfold perce in H4.
elim H4; [ intros H6 H7; try clear H4; try exact H7 ].
elim def_contact2 with (A := A) (B := B) (C := C) (D := D) (E := E);
 [ intros J H6; elim H6; [ intros H7 H8; try clear H6; try exact H8 ]
 | trivial
 | trivial
 | trivial ].
elim def_contact2 with (A := A) (B := B) (C := C) (D := D) (E := F);
 [ intros I H6; elim H6; [ intros H9 H10; try clear H6; try exact H10 ]
 | trivial
 | trivial
 | trivial ].
right.
elim (classic (I = J)); intros.
cut (I = D); intros.
elim
 position_relative_droite_plan
  with (A := A) (B := B) (C := C) (D := E) (E := F);
 [ intros H12; try clear position_relative_droite_plan
 | unfold perce in |- *; intros H12; try clear position_relative_droite_plan;
    trivial
 | trivial
 | trivial ].
elim existence_representant_vecteur with (A := I) (B := E) (C := F);
 intros K H13; try clear existence_representant_vecteur.
cut (E <> F); intros.
cut (I <> K); intros.
exists I; exists K.
split; [ trivial | split; [ idtac | try assumption ] ].
apply droite_incluse_plan2; auto with geo.
cut (para_plan_dr (plan A B C) (droite I K)); intros.
apply paralleles_droite_plan_coplanaires_incluse with (3 := H16);
 auto with geo.
apply paralleles_droites_plan_trans with (4 := H12); auto with geo.
apply def_paralleles with 1; auto.
unfold vec in H13.
RingPP2 H13.
RingPP.
apply droite_incluse_plan2; auto with geo.
apply paralleles_droite_plan_coplanaires_incluse with (D := I) (E := K);
 auto with geo.
apply def_para_plan_dr with (D := E) (E := F); auto with geo.
apply def_paralleles with 1; auto.
unfold vec in H13.
RingPP2 H13.
RingPP.
unfold not in |- *; intros; apply H14.
apply conversion_PP with (a := 1) (b := 1); auto.
unfold vec in H12.
cut (add_PP (cons (-1) E) (cons 1 F) = add_PP (cons (-1) I) (cons 1 K));
 intros; auto.
RingPP2 H16.
rewrite H15; RingPP.
auto with *.
elim H12; [ intros H13 H14; try clear H12; try exact H14 ].
elim def_contact2 with (A := A) (B := B) (C := C) (D := E) (E := F);
 [ intros K H12; try clear def_perce2; try exact H8
 | trivial
 | trivial
 | trivial ].
elim H12; [ intros H15 H16; try clear H12; try exact H16 ].
exists I; exists K.
cut (I <> K); intros.
split; [ trivial | split; [ idtac | try assumption ] ].
apply droite_incluse_plan2; auto.
apply droite_incluse_plan2; auto.
rewrite H11; auto with geo.
auto with geo.
rewrite H11; auto.
unfold not in |- *; intros; apply H0.
rewrite H12; auto with geo.
apply concours_unique with (A := D) (A1 := E) (B := F) (B1 := D);
 auto with geo.
rewrite H6; auto.
exists I; exists J.
split; [ trivial | split; [ idtac | try assumption ] ].
apply droite_incluse_plan2; auto.
apply droite_incluse_plan2; auto.
auto with geo.
auto with geo.
elim H5; [ intros H6 H9; try clear H5; try exact H9 ].
elim H4; auto.
Qed.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

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

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

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

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

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export nuprl_props.
Require Export choice.
Require Export cvterm.

Lemma member_mono_is_axiom {o} :
  forall lib (T a b : @CTerm o),
    equality lib a b (mkc_mono T)
    -> a ===>(lib) mkc_axiom # b ===>(lib) mkc_axiom.
Proof.
  unfold equality, nuprl; introv e; exrepd.
  inversion c; subst; try not_univ.

  allunfold @per_mono; allunfold @per_mono_eq; exrepnd.
  computes_to_value_isvalue.
  match goal with
      [H1 : eq _ _ , H2:eq_term_equals _ _ |- _] => apply H2 in H1
  end. repnd. auto.
Qed.

Lemma equality_in_mkc_mono {o} :
  forall lib (A t1 t2 : @CTerm o),
    equality lib t1 t2 (mkc_mono A)
    <=> {eqa : term_equality , t1 ===>(lib) mkc_axiom # t2 ===>(lib) mkc_axiom
      # close lib (univ lib) A A eqa # mono_equality lib eqa}.
Proof.
  introv; split; intro i.

  - applydup @member_mono_is_axiom in i; repnd;
    allunfold @equality; allunfold @nuprl; exrepnd.
    inversion i3; subst; try not_univ.
    allunfold @per_eq; exrepnd. dands; spcast;
    allunfold @per_mono; exrepnd; exists eqa; dands; computes_to_value_isvalue;
    spcast; auto.
    match goal with
      [H1 : eq _ _ , H2:eq_term_equals _ _ |- _] => apply H2 in H1; clear H2
    end.
      allunfold @per_mono_eq. repnd; auto.

  -   repnd.
      allunfold @type.
      allunfold @tequality. exrepnd.
      allunfold @equality; allunfold @nuprl; exrepnd.
      exists (fun t t' : @CTerm o => ccomputes_to_valc lib t mkc_axiom
              # ccomputes_to_valc lib t' mkc_axiom
              # mono_equality lib eqa); sp.
      apply CL_mono.
      unfold per_mono.
      exists A A eqa; sp; spcast;
      try (apply computes_to_valc_refl);
      try (apply iscvalue_mkc_mono; auto).
Qed.

(*
(* !! MOVE  *)
Lemma equality_in_nodep_fun_implies :
  forall f g A B,
    equality f g (mkc_fun A B)
    ->
    (type A # forall a a' : CTerm, equality a a' A -> type B)
     # (forall a a',
          equality a a' A
          -> equality (mkc_apply f a) (mkc_apply g a') B).
Proof.
  introv. rw <- fold_mkc_fun.
  rw equality_in_function. introv Hyp.
  exrepnd; dands; auto; introv Heq.
  - apply Hyp1 in Heq.
    rw substc_cnewvar in Heq.
    rw substc_cnewvar in Heq.
    auto.
  - apply Hyp in Heq.
    rw substc_cnewvar in Heq. auto.
Qed.
*)

(** The following lemma expresses the key property of Mono types.
    Intuitively a type [T] is mono (i.e. [mkc_mono T] is inhabited) if,  whenever we
    have some [a] in that type, anything above it in the
    [approx] ordering (say [b]) is equal to it.

*)

Ltac equality_unique:= let H := fresh "Huniq" in
allunfold nuprl;
match goal with
| [ H1: close ?lib (univ ?lib) ?T1 ?T1 _ , H2 : close ?lib (univ ?lib) ?T1 ?T1 _ |- _ ] =>
    pose proof (nuprl_uniquely_valued lib _ _ _ H1 H2) as H
end.

Lemma mono_inhabited_implies {o} : forall lib T,
member lib mkc_axiom (mkc_mono T)
-> (forall (a b : @CTerm o),
        member lib a T
        -> approxc lib a b
        -> equality lib a b T).
Proof.
  introv Hm.
  apply equality_in_mkc_mono in Hm.
  exrepnd.
  clear Hm1 Hm2.
  repnud Hm0.
  introv Hm Hap.
  repnud Hm.  repnud Hm.
  exrepnd.
  equality_unique.
  apply Huniq in Hm1.
  eapply Hm0 in Hap; eauto;[].
  exists eqa. dands; auto.
Qed.

Lemma tequality_mono {o} :
  forall lib (A1 A2 : @CTerm o),
    tequality lib (mkc_mono A1) (mkc_mono A2)
    <=> tequality lib A1 A2.
Proof.
  intros.
  sp_iff Case.

  - Case "->".
    intros teq.
    unfold tequality, nuprl in teq; exrepnd.
    inversion teq0; subst; try not_univ.
    allunfold @per_mono; exrepnd.
    computes_to_value_isvalue.
    allfold @nuprl.
    dands.
    exists eqa; auto.

  - Case "<-".
    intro teq.
    unfold tequality in teq; destruct teq as [eqa n].
    exists (per_mono_eq lib eqa).
    apply CL_mono.
    unfold per_mono.
    exists A1 A2 eqa; dands; fold @nuprl; auto;
    try (complete (spcast; apply computes_to_valc_refl; apply_iscvalue)).
Qed.


(* Cyclone Semantics using TLC/LN in Coq Version 4 *)
(* "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".   Daniel Grossman, August 2003 *)
(* Lemmas for WFC  *)
(* Brian Milnes 2016 *)
Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax Cyclone_Static_Semantics_Kinding_And_Context_Well_Formedness.
Require Export Cyclone_Static_Semantics_Typing_Heap_Objects.
Require Export Cyclone_Classes Cyclone_Inductions Cyclone_LN_Tactics Cyclone_LN_Extra_Lemmas_And_Automation.
Close Scope list_scope.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

Lemma WFU_ok_upsilon:
  forall u,
    WFU u ->
    LVPE.okp u.
Proof.
  intros.
  inversion H.
  constructor.
  constructor.
  assumption.
  apply LVPE.get_none_inv.
  assumption.
Qed.

Ltac WFU_ok_upsilon :=
  match goal with
    | H : WFU ?u |- LVPE.okp ?u => apply WFU_ok_upsilon
  end.
Hint Extern 1 (LVPE.okp _) => try WFU_ok_upsilon.

Lemma WFU_K:
  forall u xp tau,
   WFU (u &p xp ~p tau) ->
   K empty tau A.
Proof.
  introv WFUd.
  induction u.
  inversion WFUd.
  apply LVPE.empty_push_inv in H0.
  inversion H0.
  rewrite <- LVPE.V.empty_def in H.
  apply LVPE.eq_push_inv in H.
  inversion H.
  inversion H5.
  subst.
  assumption.
  inversion WFUd.
  apply LVPE.empty_push_inv in H0.
  inversion H0.
  apply LVPE.eq_push_inv in H.
  inversion H.
  inversion H5.
  subst.
  assumption.
Qed.
Ltac WFU_K :=
  match goal with
    | H : WFU (?u' &p ?xp' ~p ?tau') |- K empty ?tau' A =>
    apply WFU_K with (u:= u') (xp:=xp') (tau:=tau')
  end.
Hint Extern 1 (K empty _ A) => WFU_K.

Ltac simpl_lvpe_get ::=
  trace_goal;
  timeout 2
  repeat
    match goal with
    | |- context [LVPE.V.get ?a LVPE.V.empty]    => trace_goal;
      rewrite~ LVPE.get_empty

  | |- context [LVPE.V.get ?a (?a ~p _) ]      => trace_goal;
    rewrite~ LVPE.get_single; try repeat case_var~
  | |- context [get ?a (?a ~ _) ]      => trace_goal;
    rewrite~ get_single; try repeat case_var~

  | |- context [LVPE.V.get ?a (_ &p (?a ~p _)) ]      => trace_goal;
    rewrite~ LVPE.get_push; try repeat case_var~
  | |- context [get ?a (_ & (?a ~ _)) ]      => trace_goal;
    rewrite~ get_push; try repeat case_var~

  | |- context [LVPE.V.get ?a (_ &p (_ ~p _)) ]      => trace_goal;
    rewrite~ LVPE.get_push; try repeat case_var~
  | |- context [LVPE.V.get ?a ((?b ~ _) & _)] => trace_goal;
    rewrite~ LVPE.get_concat; try repeat case_var~

  | H: context[LVPE.V.get _ empty = Some _] |- _ =>
    rewrite LVPE.get_empty in H; inversion H

  | H: context[LVPE.V.get _ LVPE.V.empty = Some _] |- _ =>
    rewrite LVPE.get_empty in H; inversion H
end.

Lemma WFU_upsilon_K:
  forall u,
    WFU u ->
    forall x p tau,
      LVPE.V.get (x,p) u = Some tau ->
      K empty tau A.
Proof.
  introv WFUd.
  induction WFUd.
  intros.
  auto.
  simpl_lvpe_get.
  intros.
  destruct(classicT((x0,p0) = (x,p))).
  rewrite LVPE.get_push in H2.
  rewrite If_l in H2.
  inversion H2.
  subst.
  assumption.
  rewrite If_l in H2; try assumption.
  rewrite LVPE.get_push in H2.
  rewrite If_r in H2; try assumption.
  apply IHWFUd with (x:=x0) (p:=p0); try assumption.
Qed.
Ltac WFU_upsilon_K :=
  match goal with
    | H: WFU ?u',
      I: LVPE.V.get (?x',?p') ?u' = Some ?tau'
      |-  K empty ?tau' A =>
  apply WFU_upsilon_K with (u:=u') (x:= x') (p:=p')
end.
Hint Extern 1 (K empty _ A) => WFU_upsilon_K.


Add LoadPath "../metatheory".
Require Import Coq.Arith.Wf_nat.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Equality.

Require Export Metatheory.
Require Export LibLNgen.

Require Export STLC_ott.

(** NOTE: Auxiliary theorems are hidden in generated documentation.
    In general, there is a [_rec] version of every lemma involving
    [open] and [close]. *)

(* *********************************************************************** *)
(** * Induction principles for nonterminals *)

Scheme typ_ind' := Induction for typ Sort Prop.

Definition typ_mutind :=
  fun H1 H2 H3 =>
  typ_ind' H1 H2 H3.

Scheme typ_rec' := Induction for typ Sort Set.

Definition typ_mutrec :=
  fun H1 H2 H3 =>
  typ_rec' H1 H2 H3.

Scheme term_ind' := Induction for term Sort Prop.

Definition term_mutind :=
  fun H1 H2 H3 H4 H5 =>
  term_ind' H1 H2 H3 H4 H5.

Scheme term_rec' := Induction for term Sort Set.

Definition term_mutrec :=
  fun H1 H2 H3 H4 H5 =>
  term_rec' H1 H2 H3 H4 H5.

(* *********************************************************************** *)
(** * Close *)

Fixpoint close_term_wrt_term_rec (n1 : nat) (x1 : termvar) (e1 : term) {struct e1} : term :=
  match e1 with
    | term_var_f x2 => if (x1 == x2) then (term_var_b n1) else (term_var_f x2)
    | term_var_b n2 => if (lt_ge_dec n2 n1) then (term_var_b n2) else (term_var_b (S n2))
    | term_abs t1 e2 => term_abs t1 (close_term_wrt_term_rec (S n1) x1 e2)
    | term_app e2 e3 => term_app (close_term_wrt_term_rec n1 x1 e2) (close_term_wrt_term_rec n1 x1 e3)
  end.

Definition close_term_wrt_term x1 e1 := close_term_wrt_term_rec 0 x1 e1.

(* *********************************************************************** *)
(** * Size *)

Fixpoint size_typ (t1 : typ) {struct t1} : nat :=
  match t1 with
    | typ_base => 1
    | typ_arrow t2 t3 => 1 + (size_typ t2) + (size_typ t3)
  end.

Fixpoint size_term (e1 : term) {struct e1} : nat :=
  match e1 with
    | term_var_f x1 => 1
    | term_var_b n1 => 1
    | term_abs t1 e2 => 1 + (size_typ t1) + (size_term e2)
    | term_app e2 e3 => 1 + (size_term e2) + (size_term e3)
  end.

(* *********************************************************************** *)
(** * Degree *)

(** These define only an upper bound, not a strict upper bound. *)

Inductive degree_term_wrt_term : nat -> term -> Prop :=
  | degree_wrt_term_term_var_f : forall n1 x1,
    degree_term_wrt_term n1 (term_var_f x1)
  | degree_wrt_term_term_var_b : forall n1 n2,
    lt n2 n1 ->
    degree_term_wrt_term n1 (term_var_b n2)
  | degree_wrt_term_term_abs : forall n1 t1 e1,
    degree_term_wrt_term (S n1) e1 ->
    degree_term_wrt_term n1 (term_abs t1 e1)
  | degree_wrt_term_term_app : forall n1 e1 e2,
    degree_term_wrt_term n1 e1 ->
    degree_term_wrt_term n1 e2 ->
    degree_term_wrt_term n1 (term_app e1 e2).

Scheme degree_term_wrt_term_ind' := Induction for degree_term_wrt_term Sort Prop.

Definition degree_term_wrt_term_mutind :=
  fun H1 H2 H3 H4 H5 =>
  degree_term_wrt_term_ind' H1 H2 H3 H4 H5.

Hint Constructors degree_term_wrt_term : core lngen.

(* *********************************************************************** *)
(** * Local closure (version in [Set], induction principles) *)

Inductive lc_set_term : term -> Set :=
  | lc_set_term_var_f : forall x1,
    lc_set_term (term_var_f x1)
  | lc_set_term_abs : forall t1 e1,
    (forall x1 : termvar, lc_set_term (open_term_wrt_term e1 (term_var_f x1))) ->
    lc_set_term (term_abs t1 e1)
  | lc_set_term_app : forall e1 e2,
    lc_set_term e1 ->
    lc_set_term e2 ->
    lc_set_term (term_app e1 e2).

Scheme lc_term_ind' := Induction for lc_term Sort Prop.

Definition lc_term_mutind :=
  fun H1 H2 H3 H4 =>
  lc_term_ind' H1 H2 H3 H4.

Scheme lc_set_term_ind' := Induction for lc_set_term Sort Prop.

Definition lc_set_term_mutind :=
  fun H1 H2 H3 H4 =>
  lc_set_term_ind' H1 H2 H3 H4.

Scheme lc_set_term_rec' := Induction for lc_set_term Sort Set.

Definition lc_set_term_mutrec :=
  fun H1 H2 H3 H4 =>
  lc_set_term_rec' H1 H2 H3 H4.

Hint Constructors lc_term : core lngen.

Hint Constructors lc_set_term : core lngen.

(* *********************************************************************** *)
(** * Body *)

Definition body_term_wrt_term e1 := forall x1, lc_term (open_term_wrt_term e1 (term_var_f x1)).

Hint Unfold body_term_wrt_term.

(* *********************************************************************** *)
(** * Tactic support *)

(** Additional hint declarations. *)

Hint Resolve @plus_le_compat : lngen.

(** Redefine some tactics. *)

Ltac default_case_split ::=
  first
    [ progress destruct_notin
    | progress destruct_sum
    | progress safe_f_equal
    ].

(* *********************************************************************** *)
(** * Theorems about [size] *)

Ltac default_auto ::= auto with arith lngen; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma size_typ_min_mutual :
(forall t1, 1 <= size_typ t1).
Proof.
apply_mutual_ind typ_mutind;
default_simp.
Qed.

(* end hide *)

Lemma size_typ_min :
forall t1, 1 <= size_typ t1.
Proof.
pose proof size_typ_min_mutual as H; intuition eauto.
Qed.

Hint Resolve size_typ_min : lngen.

(* begin hide *)

Lemma size_term_min_mutual :
(forall e1, 1 <= size_term e1).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma size_term_min :
forall e1, 1 <= size_term e1.
Proof.
pose proof size_term_min_mutual as H; intuition eauto.
Qed.

Hint Resolve size_term_min : lngen.

(* begin hide *)

Lemma size_term_close_term_wrt_term_rec_mutual :
(forall e1 x1 n1,
  size_term (close_term_wrt_term_rec n1 x1 e1) = size_term e1).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma size_term_close_term_wrt_term_rec :
forall e1 x1 n1,
  size_term (close_term_wrt_term_rec n1 x1 e1) = size_term e1.
Proof.
pose proof size_term_close_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve size_term_close_term_wrt_term_rec : lngen.
Hint Rewrite size_term_close_term_wrt_term_rec using solve [auto] : lngen.

(* end hide *)

Lemma size_term_close_term_wrt_term :
forall e1 x1,
  size_term (close_term_wrt_term x1 e1) = size_term e1.
Proof.
unfold close_term_wrt_term; default_simp.
Qed.

Hint Resolve size_term_close_term_wrt_term : lngen.
Hint Rewrite size_term_close_term_wrt_term using solve [auto] : lngen.

(* begin hide *)

Lemma size_term_open_term_wrt_term_rec_mutual :
(forall e1 e2 n1,
  size_term e1 <= size_term (open_term_wrt_term_rec n1 e2 e1)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma size_term_open_term_wrt_term_rec :
forall e1 e2 n1,
  size_term e1 <= size_term (open_term_wrt_term_rec n1 e2 e1).
Proof.
pose proof size_term_open_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve size_term_open_term_wrt_term_rec : lngen.

(* end hide *)

Lemma size_term_open_term_wrt_term :
forall e1 e2,
  size_term e1 <= size_term (open_term_wrt_term e1 e2).
Proof.
unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve size_term_open_term_wrt_term : lngen.

(* begin hide *)

Lemma size_term_open_term_wrt_term_rec_var_mutual :
(forall e1 x1 n1,
  size_term (open_term_wrt_term_rec n1 (term_var_f x1) e1) = size_term e1).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma size_term_open_term_wrt_term_rec_var :
forall e1 x1 n1,
  size_term (open_term_wrt_term_rec n1 (term_var_f x1) e1) = size_term e1.
Proof.
pose proof size_term_open_term_wrt_term_rec_var_mutual as H; intuition eauto.
Qed.

Hint Resolve size_term_open_term_wrt_term_rec_var : lngen.
Hint Rewrite size_term_open_term_wrt_term_rec_var using solve [auto] : lngen.

(* end hide *)

Lemma size_term_open_term_wrt_term_var :
forall e1 x1,
  size_term (open_term_wrt_term e1 (term_var_f x1)) = size_term e1.
Proof.
unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve size_term_open_term_wrt_term_var : lngen.
Hint Rewrite size_term_open_term_wrt_term_var using solve [auto] : lngen.

(* *********************************************************************** *)
(** * Theorems about [degree] *)

Ltac default_auto ::= auto with lngen; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma degree_term_wrt_term_S_mutual :
(forall n1 e1,
  degree_term_wrt_term n1 e1 ->
  degree_term_wrt_term (S n1) e1).
Proof.
apply_mutual_ind degree_term_wrt_term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma degree_term_wrt_term_S :
forall n1 e1,
  degree_term_wrt_term n1 e1 ->
  degree_term_wrt_term (S n1) e1.
Proof.
pose proof degree_term_wrt_term_S_mutual as H; intuition eauto.
Qed.

Hint Resolve degree_term_wrt_term_S : lngen.

Lemma degree_term_wrt_term_O :
forall n1 e1,
  degree_term_wrt_term O e1 ->
  degree_term_wrt_term n1 e1.
Proof.
induction n1; default_simp.
Qed.

Hint Resolve degree_term_wrt_term_O : lngen.

(* begin hide *)

Lemma degree_term_wrt_term_close_term_wrt_term_rec_mutual :
(forall e1 x1 n1,
  degree_term_wrt_term n1 e1 ->
  degree_term_wrt_term (S n1) (close_term_wrt_term_rec n1 x1 e1)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_term_wrt_term_close_term_wrt_term_rec :
forall e1 x1 n1,
  degree_term_wrt_term n1 e1 ->
  degree_term_wrt_term (S n1) (close_term_wrt_term_rec n1 x1 e1).
Proof.
pose proof degree_term_wrt_term_close_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve degree_term_wrt_term_close_term_wrt_term_rec : lngen.

(* end hide *)

Lemma degree_term_wrt_term_close_term_wrt_term :
forall e1 x1,
  degree_term_wrt_term 0 e1 ->
  degree_term_wrt_term 1 (close_term_wrt_term x1 e1).
Proof.
unfold close_term_wrt_term; default_simp.
Qed.

Hint Resolve degree_term_wrt_term_close_term_wrt_term : lngen.

(* begin hide *)

Lemma degree_term_wrt_term_close_term_wrt_term_rec_inv_mutual :
(forall e1 x1 n1,
  degree_term_wrt_term (S n1) (close_term_wrt_term_rec n1 x1 e1) ->
  degree_term_wrt_term n1 e1).
Proof.
apply_mutual_ind term_mutind;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_term_wrt_term_close_term_wrt_term_rec_inv :
forall e1 x1 n1,
  degree_term_wrt_term (S n1) (close_term_wrt_term_rec n1 x1 e1) ->
  degree_term_wrt_term n1 e1.
Proof.
pose proof degree_term_wrt_term_close_term_wrt_term_rec_inv_mutual as H; intuition eauto.
Qed.

Hint Immediate degree_term_wrt_term_close_term_wrt_term_rec_inv : lngen.

(* end hide *)

Lemma degree_term_wrt_term_close_term_wrt_term_inv :
forall e1 x1,
  degree_term_wrt_term 1 (close_term_wrt_term x1 e1) ->
  degree_term_wrt_term 0 e1.
Proof.
unfold close_term_wrt_term; eauto with lngen.
Qed.

Hint Immediate degree_term_wrt_term_close_term_wrt_term_inv : lngen.

(* begin hide *)

Lemma degree_term_wrt_term_open_term_wrt_term_rec_mutual :
(forall e1 e2 n1,
  degree_term_wrt_term (S n1) e1 ->
  degree_term_wrt_term n1 e2 ->
  degree_term_wrt_term n1 (open_term_wrt_term_rec n1 e2 e1)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_term_wrt_term_open_term_wrt_term_rec :
forall e1 e2 n1,
  degree_term_wrt_term (S n1) e1 ->
  degree_term_wrt_term n1 e2 ->
  degree_term_wrt_term n1 (open_term_wrt_term_rec n1 e2 e1).
Proof.
pose proof degree_term_wrt_term_open_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve degree_term_wrt_term_open_term_wrt_term_rec : lngen.

(* end hide *)

Lemma degree_term_wrt_term_open_term_wrt_term :
forall e1 e2,
  degree_term_wrt_term 1 e1 ->
  degree_term_wrt_term 0 e2 ->
  degree_term_wrt_term 0 (open_term_wrt_term e1 e2).
Proof.
unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve degree_term_wrt_term_open_term_wrt_term : lngen.

(* begin hide *)

Lemma degree_term_wrt_term_open_term_wrt_term_rec_inv_mutual :
(forall e1 e2 n1,
  degree_term_wrt_term n1 (open_term_wrt_term_rec n1 e2 e1) ->
  degree_term_wrt_term (S n1) e1).
Proof.
apply_mutual_ind term_mutind;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_term_wrt_term_open_term_wrt_term_rec_inv :
forall e1 e2 n1,
  degree_term_wrt_term n1 (open_term_wrt_term_rec n1 e2 e1) ->
  degree_term_wrt_term (S n1) e1.
Proof.
pose proof degree_term_wrt_term_open_term_wrt_term_rec_inv_mutual as H; intuition eauto.
Qed.

Hint Immediate degree_term_wrt_term_open_term_wrt_term_rec_inv : lngen.

(* end hide *)

Lemma degree_term_wrt_term_open_term_wrt_term_inv :
forall e1 e2,
  degree_term_wrt_term 0 (open_term_wrt_term e1 e2) ->
  degree_term_wrt_term 1 e1.
Proof.
unfold open_term_wrt_term; eauto with lngen.
Qed.

Hint Immediate degree_term_wrt_term_open_term_wrt_term_inv : lngen.

(* *********************************************************************** *)
(** * Theorems about [open] and [close] *)

Ltac default_auto ::= auto with lngen brute_force; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma close_term_wrt_term_rec_inj_mutual :
(forall e1 e2 x1 n1,
  close_term_wrt_term_rec n1 x1 e1 = close_term_wrt_term_rec n1 x1 e2 ->
  e1 = e2).
Proof.
apply_mutual_ind term_mutind;
intros; match goal with
          | |- _ = ?term => destruct term
        end;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma close_term_wrt_term_rec_inj :
forall e1 e2 x1 n1,
  close_term_wrt_term_rec n1 x1 e1 = close_term_wrt_term_rec n1 x1 e2 ->
  e1 = e2.
Proof.
pose proof close_term_wrt_term_rec_inj_mutual as H; intuition eauto.
Qed.

Hint Immediate close_term_wrt_term_rec_inj : lngen.

(* end hide *)

Lemma close_term_wrt_term_inj :
forall e1 e2 x1,
  close_term_wrt_term x1 e1 = close_term_wrt_term x1 e2 ->
  e1 = e2.
Proof.
unfold close_term_wrt_term; eauto with lngen.
Qed.

Hint Immediate close_term_wrt_term_inj : lngen.

(* begin hide *)

Lemma close_term_wrt_term_rec_open_term_wrt_term_rec_mutual :
(forall e1 x1 n1,
  x1 `notin` fv_term e1 ->
  close_term_wrt_term_rec n1 x1 (open_term_wrt_term_rec n1 (term_var_f x1) e1) = e1).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma close_term_wrt_term_rec_open_term_wrt_term_rec :
forall e1 x1 n1,
  x1 `notin` fv_term e1 ->
  close_term_wrt_term_rec n1 x1 (open_term_wrt_term_rec n1 (term_var_f x1) e1) = e1.
Proof.
pose proof close_term_wrt_term_rec_open_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve close_term_wrt_term_rec_open_term_wrt_term_rec : lngen.
Hint Rewrite close_term_wrt_term_rec_open_term_wrt_term_rec using solve [auto] : lngen.

(* end hide *)

Lemma close_term_wrt_term_open_term_wrt_term :
forall e1 x1,
  x1 `notin` fv_term e1 ->
  close_term_wrt_term x1 (open_term_wrt_term e1 (term_var_f x1)) = e1.
Proof.
unfold close_term_wrt_term; unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve close_term_wrt_term_open_term_wrt_term : lngen.
Hint Rewrite close_term_wrt_term_open_term_wrt_term using solve [auto] : lngen.

(* begin hide *)

Lemma open_term_wrt_term_rec_close_term_wrt_term_rec_mutual :
(forall e1 x1 n1,
  open_term_wrt_term_rec n1 (term_var_f x1) (close_term_wrt_term_rec n1 x1 e1) = e1).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma open_term_wrt_term_rec_close_term_wrt_term_rec :
forall e1 x1 n1,
  open_term_wrt_term_rec n1 (term_var_f x1) (close_term_wrt_term_rec n1 x1 e1) = e1.
Proof.
pose proof open_term_wrt_term_rec_close_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve open_term_wrt_term_rec_close_term_wrt_term_rec : lngen.
Hint Rewrite open_term_wrt_term_rec_close_term_wrt_term_rec using solve [auto] : lngen.

(* end hide *)

Lemma open_term_wrt_term_close_term_wrt_term :
forall e1 x1,
  open_term_wrt_term (close_term_wrt_term x1 e1) (term_var_f x1) = e1.
Proof.
unfold close_term_wrt_term; unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve open_term_wrt_term_close_term_wrt_term : lngen.
Hint Rewrite open_term_wrt_term_close_term_wrt_term using solve [auto] : lngen.

(* begin hide *)

Lemma open_term_wrt_term_rec_inj_mutual :
(forall e2 e1 x1 n1,
  x1 `notin` fv_term e2 ->
  x1 `notin` fv_term e1 ->
  open_term_wrt_term_rec n1 (term_var_f x1) e2 = open_term_wrt_term_rec n1 (term_var_f x1) e1 ->
  e2 = e1).
Proof.
apply_mutual_ind term_mutind;
intros; match goal with
          | |- _ = ?term => destruct term
        end;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma open_term_wrt_term_rec_inj :
forall e2 e1 x1 n1,
  x1 `notin` fv_term e2 ->
  x1 `notin` fv_term e1 ->
  open_term_wrt_term_rec n1 (term_var_f x1) e2 = open_term_wrt_term_rec n1 (term_var_f x1) e1 ->
  e2 = e1.
Proof.
pose proof open_term_wrt_term_rec_inj_mutual as H; intuition eauto.
Qed.

Hint Immediate open_term_wrt_term_rec_inj : lngen.

(* end hide *)

Lemma open_term_wrt_term_inj :
forall e2 e1 x1,
  x1 `notin` fv_term e2 ->
  x1 `notin` fv_term e1 ->
  open_term_wrt_term e2 (term_var_f x1) = open_term_wrt_term e1 (term_var_f x1) ->
  e2 = e1.
Proof.
unfold open_term_wrt_term; eauto with lngen.
Qed.

Hint Immediate open_term_wrt_term_inj : lngen.

(* *********************************************************************** *)
(** * Theorems about [lc] *)

Ltac default_auto ::= auto with lngen brute_force; tauto.
Ltac default_autorewrite ::= autorewrite with lngen.

(* begin hide *)

Lemma degree_term_wrt_term_of_lc_term_mutual :
(forall e1,
  lc_term e1 ->
  degree_term_wrt_term 0 e1).
Proof.
apply_mutual_ind lc_term_mutind;
intros;
let x1 := fresh "x1" in pick_fresh x1;
repeat (match goal with
          | H1 : _, H2 : _ |- _ => specialize H1 with H2
        end);
default_simp; eauto with lngen.
Qed.

(* end hide *)

Lemma degree_term_wrt_term_of_lc_term :
forall e1,
  lc_term e1 ->
  degree_term_wrt_term 0 e1.
Proof.
pose proof degree_term_wrt_term_of_lc_term_mutual as H; intuition eauto.
Qed.

Hint Resolve degree_term_wrt_term_of_lc_term : lngen.

(* begin hide *)

Lemma lc_term_of_degree_size_mutual :
forall i1,
(forall e1,
  size_term e1 = i1 ->
  degree_term_wrt_term 0 e1 ->
  lc_term e1).
Proof.
intros i1; pattern i1; apply lt_wf_rec;
clear i1; intros i1 H1;
apply_mutual_ind term_mutind;
default_simp;
(* non-trivial cases *)
constructor; default_simp; eapply_first_hyp;
(* instantiate the size *)
match goal with
  | |- _ = _ => reflexivity
  | _ => idtac
end;
instantiate;
(* everything should be easy now *)
default_simp.
Qed.

(* end hide *)

Lemma lc_term_of_degree :
forall e1,
  degree_term_wrt_term 0 e1 ->
  lc_term e1.
Proof.
intros e1; intros;
pose proof (lc_term_of_degree_size_mutual (size_term e1));
intuition eauto.
Qed.

Hint Resolve lc_term_of_degree : lngen.

Ltac typ_lc_exists_tac :=
  repeat (match goal with
            | H : _ |- _ =>
              fail 1
          end).

Ltac term_lc_exists_tac :=
  repeat (match goal with
            | H : _ |- _ =>
              let J1 := fresh in pose proof H as J1; apply degree_term_wrt_term_of_lc_term in J1; clear H
          end).

Lemma lc_term_abs_exists :
forall x1 t1 e1,
  lc_term (open_term_wrt_term e1 (term_var_f x1)) ->
  lc_term (term_abs t1 e1).
Proof.
intros; term_lc_exists_tac; eauto with lngen.
Qed.

Hint Extern 1 (lc_term (term_abs _ _)) =>
  let x1 := fresh in
  pick_fresh x1;
  apply (lc_term_abs_exists x1).

Lemma lc_body_term_wrt_term :
forall e1 e2,
  body_term_wrt_term e1 ->
  lc_term e2 ->
  lc_term (open_term_wrt_term e1 e2).
Proof.
unfold body_term_wrt_term;
default_simp;
let x1 := fresh "x" in
pick_fresh x1;
specialize_all x1;
term_lc_exists_tac;
eauto with lngen.
Qed.

Hint Resolve lc_body_term_wrt_term : lngen.

Lemma lc_body_term_abs_2 :
forall t1 e1,
  lc_term (term_abs t1 e1) ->
  body_term_wrt_term e1.
Proof.
default_simp.
Qed.

Hint Resolve lc_body_term_abs_2 : lngen.

(* begin hide *)

Lemma lc_term_unique_mutual :
(forall e1 (proof2 proof3 : lc_term e1), proof2 = proof3).
Proof.
apply_mutual_ind lc_term_mutind;
intros;
let proof1 := fresh "proof1" in
rename_last_into proof1; dependent destruction proof1;
f_equal; default_simp; auto using @functional_extensionality_dep with lngen.
Qed.

(* end hide *)

Lemma lc_term_unique :
forall e1 (proof2 proof3 : lc_term e1), proof2 = proof3.
Proof.
pose proof lc_term_unique_mutual as H; intuition eauto.
Qed.

Hint Resolve lc_term_unique : lngen.

(* begin hide *)

Lemma lc_term_of_lc_set_term_mutual :
(forall e1, lc_set_term e1 -> lc_term e1).
Proof.
apply_mutual_ind lc_set_term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma lc_term_of_lc_set_term :
forall e1, lc_set_term e1 -> lc_term e1.
Proof.
pose proof lc_term_of_lc_set_term_mutual as H; intuition eauto.
Qed.

Hint Resolve lc_term_of_lc_set_term : lngen.

(* begin hide *)

Lemma lc_set_term_of_lc_term_size_mutual :
forall i1,
(forall e1,
  size_term e1 = i1 ->
  lc_term e1 ->
  lc_set_term e1).
Proof.
intros i1; pattern i1; apply lt_wf_rec;
clear i1; intros i1 H1;
apply_mutual_ind term_mutrec;
default_simp;
try solve [assert False by default_simp; tauto];
(* non-trivial cases *)
constructor; default_simp;
try first [apply lc_set_term_of_lc_term
 | apply lc_set_typ_of_lc_typ];
default_simp; eapply_first_hyp;
(* instantiate the size *)
match goal with
  | |- _ = _ => reflexivity
  | _ => idtac
end;
instantiate;
(* everything should be easy now *)
default_simp.
Qed.

(* end hide *)

Lemma lc_set_term_of_lc_term :
forall e1,
  lc_term e1 ->
  lc_set_term e1.
Proof.
intros e1; intros;
pose proof (lc_set_term_of_lc_term_size_mutual (size_term e1));
intuition eauto.
Qed.

Hint Resolve lc_set_term_of_lc_term : lngen.

(* *********************************************************************** *)
(** * More theorems about [open] and [close] *)

Ltac default_auto ::= auto with lngen; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma close_term_wrt_term_rec_degree_term_wrt_term_mutual :
(forall e1 x1 n1,
  degree_term_wrt_term n1 e1 ->
  x1 `notin` fv_term e1 ->
  close_term_wrt_term_rec n1 x1 e1 = e1).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma close_term_wrt_term_rec_degree_term_wrt_term :
forall e1 x1 n1,
  degree_term_wrt_term n1 e1 ->
  x1 `notin` fv_term e1 ->
  close_term_wrt_term_rec n1 x1 e1 = e1.
Proof.
pose proof close_term_wrt_term_rec_degree_term_wrt_term_mutual as H; intuition eauto.
Qed.

Hint Resolve close_term_wrt_term_rec_degree_term_wrt_term : lngen.
Hint Rewrite close_term_wrt_term_rec_degree_term_wrt_term using solve [auto] : lngen.

(* end hide *)

Lemma close_term_wrt_term_lc_term :
forall e1 x1,
  lc_term e1 ->
  x1 `notin` fv_term e1 ->
  close_term_wrt_term x1 e1 = e1.
Proof.
unfold close_term_wrt_term; default_simp.
Qed.

Hint Resolve close_term_wrt_term_lc_term : lngen.
Hint Rewrite close_term_wrt_term_lc_term using solve [auto] : lngen.

(* begin hide *)

Lemma open_term_wrt_term_rec_degree_term_wrt_term_mutual :
(forall e2 e1 n1,
  degree_term_wrt_term n1 e2 ->
  open_term_wrt_term_rec n1 e1 e2 = e2).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma open_term_wrt_term_rec_degree_term_wrt_term :
forall e2 e1 n1,
  degree_term_wrt_term n1 e2 ->
  open_term_wrt_term_rec n1 e1 e2 = e2.
Proof.
pose proof open_term_wrt_term_rec_degree_term_wrt_term_mutual as H; intuition eauto.
Qed.

Hint Resolve open_term_wrt_term_rec_degree_term_wrt_term : lngen.
Hint Rewrite open_term_wrt_term_rec_degree_term_wrt_term using solve [auto] : lngen.

(* end hide *)

Lemma open_term_wrt_term_lc_term :
forall e2 e1,
  lc_term e2 ->
  open_term_wrt_term e2 e1 = e2.
Proof.
unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve open_term_wrt_term_lc_term : lngen.
Hint Rewrite open_term_wrt_term_lc_term using solve [auto] : lngen.

(* *********************************************************************** *)
(** * Theorems about [fv] *)

Ltac default_auto ::= auto with set lngen; tauto.
Ltac default_autorewrite ::= autorewrite with lngen.

(* begin hide *)

Lemma fv_term_close_term_wrt_term_rec_mutual :
(forall e1 x1 n1,
  fv_term (close_term_wrt_term_rec n1 x1 e1) [=] remove x1 (fv_term e1)).
Proof.
apply_mutual_ind term_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

(* begin hide *)

Lemma fv_term_close_term_wrt_term_rec :
forall e1 x1 n1,
  fv_term (close_term_wrt_term_rec n1 x1 e1) [=] remove x1 (fv_term e1).
Proof.
pose proof fv_term_close_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_term_close_term_wrt_term_rec : lngen.
Hint Rewrite fv_term_close_term_wrt_term_rec using solve [auto] : lngen.

(* end hide *)

Lemma fv_term_close_term_wrt_term :
forall e1 x1,
  fv_term (close_term_wrt_term x1 e1) [=] remove x1 (fv_term e1).
Proof.
unfold close_term_wrt_term; default_simp.
Qed.

Hint Resolve fv_term_close_term_wrt_term : lngen.
Hint Rewrite fv_term_close_term_wrt_term using solve [auto] : lngen.

(* begin hide *)

Lemma fv_term_open_term_wrt_term_rec_lower_mutual :
(forall e1 e2 n1,
  fv_term e1 [<=] fv_term (open_term_wrt_term_rec n1 e2 e1)).
Proof.
apply_mutual_ind term_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

(* begin hide *)

Lemma fv_term_open_term_wrt_term_rec_lower :
forall e1 e2 n1,
  fv_term e1 [<=] fv_term (open_term_wrt_term_rec n1 e2 e1).
Proof.
pose proof fv_term_open_term_wrt_term_rec_lower_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_term_open_term_wrt_term_rec_lower : lngen.

(* end hide *)

Lemma fv_term_open_term_wrt_term_lower :
forall e1 e2,
  fv_term e1 [<=] fv_term (open_term_wrt_term e1 e2).
Proof.
unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve fv_term_open_term_wrt_term_lower : lngen.

(* begin hide *)

Lemma fv_term_open_term_wrt_term_rec_upper_mutual :
(forall e1 e2 n1,
  fv_term (open_term_wrt_term_rec n1 e2 e1) [<=] fv_term e2 `union` fv_term e1).
Proof.
apply_mutual_ind term_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

(* begin hide *)

Lemma fv_term_open_term_wrt_term_rec_upper :
forall e1 e2 n1,
  fv_term (open_term_wrt_term_rec n1 e2 e1) [<=] fv_term e2 `union` fv_term e1.
Proof.
pose proof fv_term_open_term_wrt_term_rec_upper_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_term_open_term_wrt_term_rec_upper : lngen.

(* end hide *)

Lemma fv_term_open_term_wrt_term_upper :
forall e1 e2,
  fv_term (open_term_wrt_term e1 e2) [<=] fv_term e2 `union` fv_term e1.
Proof.
unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve fv_term_open_term_wrt_term_upper : lngen.

(* begin hide *)

Lemma fv_term_subst_term_fresh_mutual :
(forall e1 e2 x1,
  x1 `notin` fv_term e1 ->
  fv_term (subst_term e2 x1 e1) [=] fv_term e1).
Proof.
apply_mutual_ind term_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_term_subst_term_fresh :
forall e1 e2 x1,
  x1 `notin` fv_term e1 ->
  fv_term (subst_term e2 x1 e1) [=] fv_term e1.
Proof.
pose proof fv_term_subst_term_fresh_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_term_subst_term_fresh : lngen.
Hint Rewrite fv_term_subst_term_fresh using solve [auto] : lngen.

(* begin hide *)

Lemma fv_term_subst_term_lower_mutual :
(forall e1 e2 x1,
  remove x1 (fv_term e1) [<=] fv_term (subst_term e2 x1 e1)).
Proof.
apply_mutual_ind term_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_term_subst_term_lower :
forall e1 e2 x1,
  remove x1 (fv_term e1) [<=] fv_term (subst_term e2 x1 e1).
Proof.
pose proof fv_term_subst_term_lower_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_term_subst_term_lower : lngen.

(* begin hide *)

Lemma fv_term_subst_term_notin_mutual :
(forall e1 e2 x1 x2,
  x2 `notin` fv_term e1 ->
  x2 `notin` fv_term e2 ->
  x2 `notin` fv_term (subst_term e2 x1 e1)).
Proof.
apply_mutual_ind term_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_term_subst_term_notin :
forall e1 e2 x1 x2,
  x2 `notin` fv_term e1 ->
  x2 `notin` fv_term e2 ->
  x2 `notin` fv_term (subst_term e2 x1 e1).
Proof.
pose proof fv_term_subst_term_notin_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_term_subst_term_notin : lngen.

(* begin hide *)

Lemma fv_term_subst_term_upper_mutual :
(forall e1 e2 x1,
  fv_term (subst_term e2 x1 e1) [<=] fv_term e2 `union` remove x1 (fv_term e1)).
Proof.
apply_mutual_ind term_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_term_subst_term_upper :
forall e1 e2 x1,
  fv_term (subst_term e2 x1 e1) [<=] fv_term e2 `union` remove x1 (fv_term e1).
Proof.
pose proof fv_term_subst_term_upper_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_term_subst_term_upper : lngen.

(* *********************************************************************** *)
(** * Theorems about [subst] *)

Ltac default_auto ::= auto with lngen brute_force; tauto.
Ltac default_autorewrite ::= autorewrite with lngen.

(* begin hide *)

Lemma subst_term_close_term_wrt_term_rec_mutual :
(forall e2 e1 x1 x2 n1,
  degree_term_wrt_term n1 e1 ->
  x1 <> x2 ->
  x2 `notin` fv_term e1 ->
  subst_term e1 x1 (close_term_wrt_term_rec n1 x2 e2) = close_term_wrt_term_rec n1 x2 (subst_term e1 x1 e2)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_term_close_term_wrt_term_rec :
forall e2 e1 x1 x2 n1,
  degree_term_wrt_term n1 e1 ->
  x1 <> x2 ->
  x2 `notin` fv_term e1 ->
  subst_term e1 x1 (close_term_wrt_term_rec n1 x2 e2) = close_term_wrt_term_rec n1 x2 (subst_term e1 x1 e2).
Proof.
pose proof subst_term_close_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_close_term_wrt_term_rec : lngen.

Lemma subst_term_close_term_wrt_term :
forall e2 e1 x1 x2,
  lc_term e1 ->  x1 <> x2 ->
  x2 `notin` fv_term e1 ->
  subst_term e1 x1 (close_term_wrt_term x2 e2) = close_term_wrt_term x2 (subst_term e1 x1 e2).
Proof.
unfold close_term_wrt_term; default_simp.
Qed.

Hint Resolve subst_term_close_term_wrt_term : lngen.

(* begin hide *)

Lemma subst_term_degree_term_wrt_term_mutual :
(forall e1 e2 x1 n1,
  degree_term_wrt_term n1 e1 ->
  degree_term_wrt_term n1 e2 ->
  degree_term_wrt_term n1 (subst_term e2 x1 e1)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_term_degree_term_wrt_term :
forall e1 e2 x1 n1,
  degree_term_wrt_term n1 e1 ->
  degree_term_wrt_term n1 e2 ->
  degree_term_wrt_term n1 (subst_term e2 x1 e1).
Proof.
pose proof subst_term_degree_term_wrt_term_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_degree_term_wrt_term : lngen.

(* begin hide *)

Lemma subst_term_fresh_eq_mutual :
(forall e2 e1 x1,
  x1 `notin` fv_term e2 ->
  subst_term e1 x1 e2 = e2).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_term_fresh_eq :
forall e2 e1 x1,
  x1 `notin` fv_term e2 ->
  subst_term e1 x1 e2 = e2.
Proof.
pose proof subst_term_fresh_eq_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_fresh_eq : lngen.
Hint Rewrite subst_term_fresh_eq using solve [auto] : lngen.

(* begin hide *)

Lemma subst_term_fresh_same_mutual :
(forall e2 e1 x1,
  x1 `notin` fv_term e1 ->
  x1 `notin` fv_term (subst_term e1 x1 e2)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_term_fresh_same :
forall e2 e1 x1,
  x1 `notin` fv_term e1 ->
  x1 `notin` fv_term (subst_term e1 x1 e2).
Proof.
pose proof subst_term_fresh_same_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_fresh_same : lngen.
Hint Rewrite subst_term_fresh_same using solve [auto] : lngen.

(* begin hide *)

Lemma subst_term_fresh_mutual :
(forall e2 e1 x1 x2,
  x1 `notin` fv_term e2 ->
  x1 `notin` fv_term e1 ->
  x1 `notin` fv_term (subst_term e1 x2 e2)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_term_fresh :
forall e2 e1 x1 x2,
  x1 `notin` fv_term e2 ->
  x1 `notin` fv_term e1 ->
  x1 `notin` fv_term (subst_term e1 x2 e2).
Proof.
pose proof subst_term_fresh_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_fresh : lngen.
Hint Rewrite subst_term_fresh using solve [auto] : lngen.

Lemma subst_term_lc_term :
forall e1 e2 x1,
  lc_term e1 ->
  lc_term e2 ->
  lc_term (subst_term e2 x1 e1).
Proof.
default_simp.
Qed.

Hint Resolve subst_term_lc_term : lngen.

(* begin hide *)

Lemma subst_term_open_term_wrt_term_rec_mutual :
(forall e3 e1 e2 x1 n1,
  lc_term e1 ->
  subst_term e1 x1 (open_term_wrt_term_rec n1 e2 e3) = open_term_wrt_term_rec n1 (subst_term e1 x1 e2) (subst_term e1 x1 e3)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma subst_term_open_term_wrt_term_rec :
forall e3 e1 e2 x1 n1,
  lc_term e1 ->
  subst_term e1 x1 (open_term_wrt_term_rec n1 e2 e3) = open_term_wrt_term_rec n1 (subst_term e1 x1 e2) (subst_term e1 x1 e3).
Proof.
pose proof subst_term_open_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_open_term_wrt_term_rec : lngen.

(* end hide *)

Lemma subst_term_open_term_wrt_term :
forall e3 e1 e2 x1,
  lc_term e1 ->
  subst_term e1 x1 (open_term_wrt_term e3 e2) = open_term_wrt_term (subst_term e1 x1 e3) (subst_term e1 x1 e2).
Proof.
unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve subst_term_open_term_wrt_term : lngen.

Lemma subst_term_open_term_wrt_term_var :
forall e2 e1 x1 x2,
  x1 <> x2 ->
  lc_term e1 ->
  open_term_wrt_term (subst_term e1 x1 e2) (term_var_f x2) = subst_term e1 x1 (open_term_wrt_term e2 (term_var_f x2)).
Proof.
intros; rewrite subst_term_open_term_wrt_term; default_simp.
Qed.

Hint Resolve subst_term_open_term_wrt_term_var : lngen.

(* begin hide *)

Lemma subst_term_spec_rec_mutual :
(forall e1 e2 x1 n1,
  subst_term e2 x1 e1 = open_term_wrt_term_rec n1 e2 (close_term_wrt_term_rec n1 x1 e1)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma subst_term_spec_rec :
forall e1 e2 x1 n1,
  subst_term e2 x1 e1 = open_term_wrt_term_rec n1 e2 (close_term_wrt_term_rec n1 x1 e1).
Proof.
pose proof subst_term_spec_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_spec_rec : lngen.

(* end hide *)

Lemma subst_term_spec :
forall e1 e2 x1,
  subst_term e2 x1 e1 = open_term_wrt_term (close_term_wrt_term x1 e1) e2.
Proof.
unfold close_term_wrt_term; unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve subst_term_spec : lngen.

(* begin hide *)

Lemma subst_term_subst_term_mutual :
(forall e1 e2 e3 x2 x1,
  x2 `notin` fv_term e2 ->
  x2 <> x1 ->
  subst_term e2 x1 (subst_term e3 x2 e1) = subst_term (subst_term e2 x1 e3) x2 (subst_term e2 x1 e1)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_term_subst_term :
forall e1 e2 e3 x2 x1,
  x2 `notin` fv_term e2 ->
  x2 <> x1 ->
  subst_term e2 x1 (subst_term e3 x2 e1) = subst_term (subst_term e2 x1 e3) x2 (subst_term e2 x1 e1).
Proof.
pose proof subst_term_subst_term_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_subst_term : lngen.

(* begin hide *)

Lemma subst_term_close_term_wrt_term_rec_open_term_wrt_term_rec_mutual :
(forall e2 e1 x1 x2 n1,
  x2 `notin` fv_term e2 ->
  x2 `notin` fv_term e1 ->
  x2 <> x1 ->
  degree_term_wrt_term n1 e1 ->
  subst_term e1 x1 e2 = close_term_wrt_term_rec n1 x2 (subst_term e1 x1 (open_term_wrt_term_rec n1 (term_var_f x2) e2))).
Proof.
apply_mutual_ind term_mutrec;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma subst_term_close_term_wrt_term_rec_open_term_wrt_term_rec :
forall e2 e1 x1 x2 n1,
  x2 `notin` fv_term e2 ->
  x2 `notin` fv_term e1 ->
  x2 <> x1 ->
  degree_term_wrt_term n1 e1 ->
  subst_term e1 x1 e2 = close_term_wrt_term_rec n1 x2 (subst_term e1 x1 (open_term_wrt_term_rec n1 (term_var_f x2) e2)).
Proof.
pose proof subst_term_close_term_wrt_term_rec_open_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_close_term_wrt_term_rec_open_term_wrt_term_rec : lngen.

(* end hide *)

Lemma subst_term_close_term_wrt_term_open_term_wrt_term :
forall e2 e1 x1 x2,
  x2 `notin` fv_term e2 ->
  x2 `notin` fv_term e1 ->
  x2 <> x1 ->
  lc_term e1 ->
  subst_term e1 x1 e2 = close_term_wrt_term x2 (subst_term e1 x1 (open_term_wrt_term e2 (term_var_f x2))).
Proof.
unfold close_term_wrt_term; unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve subst_term_close_term_wrt_term_open_term_wrt_term : lngen.

Lemma subst_term_term_abs :
forall x2 t1 e2 e1 x1,
  lc_term e1 ->
  x2 `notin` fv_term e1 `union` fv_term e2 `union` singleton x1 ->
  subst_term e1 x1 (term_abs t1 e2) = term_abs (t1) (close_term_wrt_term x2 (subst_term e1 x1 (open_term_wrt_term e2 (term_var_f x2)))).
Proof.
default_simp.
Qed.

Hint Resolve subst_term_term_abs : lngen.

(* begin hide *)

Lemma subst_term_intro_rec_mutual :
(forall e1 x1 e2 n1,
  x1 `notin` fv_term e1 ->
  open_term_wrt_term_rec n1 e2 e1 = subst_term e2 x1 (open_term_wrt_term_rec n1 (term_var_f x1) e1)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_term_intro_rec :
forall e1 x1 e2 n1,
  x1 `notin` fv_term e1 ->
  open_term_wrt_term_rec n1 e2 e1 = subst_term e2 x1 (open_term_wrt_term_rec n1 (term_var_f x1) e1).
Proof.
pose proof subst_term_intro_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_intro_rec : lngen.
Hint Rewrite subst_term_intro_rec using solve [auto] : lngen.

Lemma subst_term_intro :
forall x1 e1 e2,
  x1 `notin` fv_term e1 ->
  open_term_wrt_term e1 e2 = subst_term e2 x1 (open_term_wrt_term e1 (term_var_f x1)).
Proof.
unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve subst_term_intro : lngen.

(* *********************************************************************** *)
(** * "Restore" tactics *)

Ltac default_auto ::= auto; tauto.
Ltac default_autorewrite ::= fail.


Require Import Relations.
From mathcomp Require Import
     all_ssreflect.

From PoS_NSB Require Import
     Blocks
     Parameters
     BlockTree
     MemEq
     SsrFacts
.

From mathcomp Require Import
     finmap.

Open Scope fmap.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** *TreeChain
    Basic facts about valid chains and trees.
*)
Axiom GenesisSlot : sl GenesisBlock = 0.
Axiom GenesisWin : Winner (bid GenesisBlock) (sl GenesisBlock).

Lemma lt_slots_irr : irreflexive lt_slots.
Proof. by move=> [] > /=; rewrite ltnn. Qed.

Lemma lt_slots_trans : transitive lt_slots.
Proof. by move=> [] ??? [] ??? [] ??? + H; apply/(ltn_trans H). Qed.

Lemma valid_chain_block_gb b : reflect (b = GenesisBlock) (valid_chain [:: b]).
Proof.
  apply/(iffP idP).
  - by rewrite /valid_chain => //= /andP [] ? /andP [] /eqP -> _.
  - by move->; rewrite /valid_chain /= /correct_block eq_refl GenesisWin.
Qed.

Lemma valid_chain_cons c :  valid_chain c -> exists b c', b :: c' = c.
Proof. by case: c=> //= b c _; exists b; exists c. Qed.

Lemma valid_chain_ext b b' c :
  valid_chain (b :: b' :: c) =
  [&& correct_block b, linked b b', lt_slots b b' & valid_chain (b' :: c)].
Proof.
  rewrite /valid_chain /=.
  by do 2!case: (correct_block _);
    case: (linked _ _);
    case: (properly_linked);
    case: (correct_blocks _);
    case: (lt_slots _ _);
    case: (path _ _ _).
Qed.

Lemma valid_chain_short_l c1 b c2 :
  valid_chain (c1 ++ b :: c2) ->
  valid_chain (b :: c2).
Proof.
  elim: c1 => //= b' [] /= .
  - by rewrite valid_chain_ext => _ /andP [] _ /andP [] _ /andP [] _.
  - move=> b'' c1 IH.
    by rewrite valid_chain_ext => /andP [] _ /andP [] _ /andP [] _ /IH.
Qed.

Lemma uniq_valid_chain c :
  valid_chain c -> uniq c.
Proof.
  rewrite /valid_chain /= => /andP [] _ /andP [] _  /sorted_uniq -> //.
  - by apply/lt_slots_trans.
  - by apply/lt_slots_irr.
Qed.

Lemma sorted_blocks_slots bs :
  sorted lt_slots bs = sorted gtn [seq sl b | b <- bs].
Proof. by case: bs=> //= + bs; elim: bs => //= b' bs -> b. Qed.

Lemma best_chain_time {tT : treeType} (t : tT) s :
  {in bestChain s t, forall b, sl b <= s}.
Proof. by move=> b/best_chain_in_all; rewrite mem_filter=> /andP []. Qed.

Definition build_tree {tT : treeType} (bp : BlockPool ) : tT := foldr (fun b => extendTree^~ b) tree0  bp.

Lemma all_build {tT: treeType} : forall bp, (allBlocks (@build_tree tT bp)) =i GenesisBlock :: bp.
Proof.
  elim => [b |b bp IH b'] /=; first by rewrite /= all_tree0.
  rewrite inE. apply/esym. rewrite all_extend mem_cat IH inE orbC mem_seq1 inE.
  by do 2! case: (_ ==_); case: (_ \in _).
Qed.

Lemma build_tree0 T : @build_tree T [::] = tree0.
Proof. done. Qed.

Lemma extend_build_composition T : forall b bp, extendTree (@build_tree T bp) b = @build_tree T (b :: bp).
Proof. done. Qed.

Lemma valid_chain_starts_gb c :
  valid_chain c -> exists bc, bc ++ [:: GenesisBlock] = c.
Proof.
  move=> /andP [] _ /andP [] + _.
  elim: c=> //= b [_ /eqP ->| ?? IH /andP [] _ /IH [] c H].
  - by (exists [::]; rewrite cat0s).
  - by (exists (b :: c); rewrite -cat1s -catA H cat1s).
Qed.

Lemma best_chain_starts_gb {tT : treeType} (t : tT) sl :
  exists bc, bc ++ [:: GenesisBlock] = bestChain sl t .
 Proof. by move: (best_chain_valid t sl) => /valid_chain_starts_gb. Qed.

Lemma gb_in_all {tT: treeType} (t : tT) : GenesisBlock \in allBlocks t.
Proof.
  move/(_ GenesisBlock): (@best_chain_in_all tT 0 t).
  apply: instant1; last by rewrite mem_filter => /andP [].
  move: (@best_chain_starts_gb tT t 0)=> [] ? <-.
  by rewrite mem_cat orbC inE eq_refl.
Qed.

Lemma allBlocks_build_cat {tT : treeType} bs1 bs2 :
  allBlocks (@build_tree tT (bs1 ++ bs2))
  =i (allBlocks (@build_tree tT bs1)) ++ (allBlocks (@build_tree tT bs2)).
Proof.
  elim: bs1 => //= [| > IH /= b'].
  - move=> ?. rewrite mem_cat all_tree0 mem_seq1. case: (_ ==_)/eqP=> // ->.
    by rewrite gb_in_all /=.
  - rewrite all_extend.
    apply/esym.
    rewrite mem_cat all_extend mem_cat orbA orbC -!orbA orbF orbA [(_ \in _) || _]orbC -mem_cat.
    by rewrite -IH mem_cat mem_seq1.
Qed.


From Undecidability.L.Tactics Require Import LTactics GenEncode.
From Undecidability.L Require Import Datatypes.LNat Functions.EqBool.
From Undecidability.L Require Import UpToC.

Import Nat.
Require Export Undecidability.Shared.Libs.PSL.FiniteTypes.FinTypes.

(* *** Encoding finite types *)
(* This is not an instance because we only want it for very specific types. *)
Definition registered_finType `{X : finType} : registered X.
Proof.
  eapply (registerAs index).
  intros x y H. now apply injective_index.
Defined. (*because registerAs*)

Definition finType_eqb {X:finType} (x y : X) :=
  Nat.eqb (index x) (index y).

Lemma finType_eqb_reflect (X:finType) (x y:X) : reflect (x = y) (finType_eqb x y).
Proof.
  unfold finType_eqb. destruct (Nat.eqb_spec (index x) (index y));constructor.
  -now apply injective_index.
  -congruence.
Qed.

Section finType_eqb.
  Local Existing Instance registered_finType.

  Global Instance term_index (F:finType): computableTime' (@index F) (fun _ _=> (1, tt)).
  Proof.
    apply cast_computableTime.
  Qed.

  Local Instance eqbFinType_inst (X:finType): eqbClass finType_eqb (X:=X).
  Proof.
    intros ? ?. eapply finType_eqb_reflect.
  Qed.
  Import Nat.
  Global Instance eqbFinType (X:finType): eqbCompT X.
  Proof.
    evar (c:nat). exists c. unfold finType_eqb.
    unfold enc;cbn.
    extract. unfold eqbTime.
    solverec.
    [c]:exact (c__eqbComp nat + 8).
    rewrite !size_nat_enc.
    all:unfold c, c__natsizeO;try nia.
  Qed.

(*
  Global Instance term_finType_eqb (X:finType) : computableTime' (finType_eqb (X:=X)) (fun x _ => (1,fun y _ => (17 * Init.Nat.min (index x) (index y) + 17,tt))).
  Proof.
    extract.
    solverec.
  Qed. *)

End finType_eqb.

Lemma enc_finType_eq (X:finType) (x:X):
  enc (registered := registered_finType) x = enc (index x).
Proof.
  reflexivity.
Qed.

Lemma size_finType_le (X:finType) (x:X):
  size (enc (registered := registered_finType) x) <= length (elem X) * 4.
Proof.
  rewrite enc_finType_eq,size_nat_enc. specialize (index_le x).
  unfold c__natsizeS, c__natsizeO. lia.
Qed.

Lemma size_finType_any_le (X:finType) `{registered X} (x:X):
  L_facts.size (enc x) <= maxl (map (fun x => L_facts.size (enc x)) (elem X)).
Proof.
  apply maxl_leq. eapply in_map_iff. eauto.
Qed.

Lemma size_finType_any_le_c (X:finType) `{registered X}:
  (fun (x:X) => L_facts.size (enc x)) <=c (fun _ => 1).
Proof.
  setoid_rewrite size_finType_any_le. smpl_upToC_solve.
Qed.