(* -*- mode: coq; mode: visual-line -*- *)
(** * Theorems about the natural numbers, depending on TruncType *)

Require Export Coq.Init.Peano.
Require Import HoTT.Basics.
Require Import HoTT.Types.Bool.
Require Import HoTT.TruncType HoTT.DProp.

(** We reopen these scopes so they take precedence over nat_scope; otherwise, now that we have [Coq.Init.Peano], we'd get [* : nat -> nat -> nat] rather than [* : Type -> Type -> Type]. *)
Global Open Scope type_scope.
Global Open Scope core_scope.

(** But in this file, we want to be able to use the usual symbols for natural number arithmetic. *)
Local Open Scope nat_scope.

Scheme nat_ind := Induction for nat Sort Type.
Scheme nat_rec := Minimality for nat Sort Type.

(** ** Arithmetic *)

Lemma nat_plus_n_O : forall n:nat, n = n + 0.
Proof.
  induction n.
  - reflexivity.
  - simpl; apply ap; assumption.
Qed.

Lemma nat_plus_n_Sm : forall n m:nat, (n + m).+1 = n + m.+1.
Proof.
  intros n m; induction n; simpl.
  - reflexivity.
  - apply ap; assumption.
Qed.

Definition nat_plus_comm (n m : nat) : n + m = m + n.
Proof.
  revert m; induction n as [|n IH]; intros m; simpl.
  - refine (nat_plus_n_O m).
  - transitivity (m + n).+1.
    + apply ap, IH.
    + apply nat_plus_n_Sm.
Qed.

(** ** Exponentiation *)

Fixpoint nat_exp (n m : nat) : nat
  := match m with
       | 0 => 1
       | S m => nat_exp n m * n
     end.

(** ** Factorials *)

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

(* here ends the old Types/Nat.v and starts Spaces.v *)

(** Much of the layout of this file is adapted from ssreflect *)

(** ** Equality *)
(** *** Boolean equality and its properties *)

Fixpoint code_nat (m n : nat) {struct m} : DHProp :=
  match m, n with
    | 0, 0 => True
    | m'.+1, n'.+1 => code_nat m' n'
    | _, _ => False
  end.

Infix "=n" := code_nat : nat_scope.

Fixpoint idcode_nat {n} : (n =n n) :=
  match n as n return (n =n n) with
    | 0 => tt
    | S n' => @idcode_nat n'
  end.

Fixpoint path_nat {n m} : (n =n m) -> (n = m) :=
  match m as m, n as n return (n =n m) -> (n = m) with
    | 0, 0 => fun _ => idpath
    | m'.+1, n'.+1 => fun H : (n' =n m') => ap S (path_nat H)
    | _, _ => fun H => match H with end
  end.

Global Instance isequiv_path_nat {n m} : IsEquiv (@path_nat n m).
Proof.
  refine (isequiv_adjointify
            (@path_nat n m)
            (fun H => transport (fun m' => (n =n m')) H idcode_nat)
            _ _).
  { intros []; simpl.
    induction n; simpl; trivial.
    by destruct (IHn^)%path. }
  { intro. apply path_ishprop. }
Defined.

Definition equiv_path_nat {n m} : (n =n m) <~> (n = m)
  := Build_Equiv _ _ (@path_nat n m) _.

Global Instance decidable_paths_nat : DecidablePaths nat
  := fun n m => decidable_equiv _ (@path_nat n m) _.

Corollary hset_nat : IsHSet nat.
Proof.
  exact _.
Defined.

(** ** Natural number ordering *)

Definition leq m n := ((m - n) =n 0).
Definition lt m n := leq (m.+1) n.

Notation "m <= n" := (leq m n) : nat_scope.
Notation "m < n" := (lt m n) : nat_scope.
Notation "m >= n" := (n <= m) (only parsing) : nat_scope.
Notation "m > n" := (n < m) (only parsing) : nat_scope.

(** ** Theorems about natural number ordering *)

Fixpoint leq0n {n} : 0 <= n :=
  match n as n return 0 <= n with
    | 0 => tt
    | n'.+1 => @leq0n n'
  end.

Fixpoint subnn {n} : n - n =n 0 :=
  match n as n return n - n =n 0 with
    | 0 => tt
    | n'.+1 => @subnn n'
  end.

Global Instance leq_refl : Reflexive leq
  := @subnn.

Fixpoint leqnSn {n} : n <= S n :=
  match n as n return n <= S n with
  | 0 => tt
  | n'.+1 => @leqnSn n'
  end.

Fixpoint leq_transd {x y z} : (x <= y -> y <= z -> x <= z)%dprop :=
  match x as x, y as y, z as z return (x <= y -> y <= z -> x <= z)%dprop with
    | 0, 0, 0 => dprop_istrue
    | x'.+1, 0, 0 => dprop_istrue
    | 0, y'.+1, 0 => dprop_istrue
    | 0, 0, z'.+1 => dprop_istrue
    | x'.+1, y'.+1, 0 => dprop_istrue
    | x'.+1, 0, z'.+1 => dprop_istrue
    | 0, y'.+1, z'.+1 => @leq_transd 0 y' z'
    | x'.+1, y'.+1, z'.+1 => @leq_transd x' y' z'
  end.

Global Instance leq_trans : Transitive (fun n m => leq n m)
  := @leq_transd.

Fixpoint leq_antisymd {x y} : (x <= y -> y <= x -> x =n y)%dprop :=
  match x as x, y as y return (x <= y -> y <= x -> x =n y)%dprop with
    | 0, 0 => dprop_istrue
    | x'.+1, y'.+1 => @leq_antisymd x' y'
    | _, _ => dprop_istrue
  end.

Lemma leq_antisym : forall {x y}, x <= y -> y <= x -> x = y.
Proof.
  intros x y p q.
  apply path_nat.
  apply leq_antisymd; assumption.
Defined.

Definition not_nltn n : ~ (n < n).
Proof.
  induction n as [|n IH]; simpl.
  - auto.
  - apply IH.
Defined.

Definition leq1Sn {n} : 1 <= n.+1 := tt.

Fixpoint leqdichot {m} {n} : ((m <= n) + (m > n))%type.
Proof.
  induction m, n.
  - left; reflexivity.
  - left; apply leq0n.
  - right; unfold lt; apply leq1Sn.
  - assert ((m <= n) + (n < m)) as X by apply leqdichot.
    induction X as [leqmn|ltnm].
    + left; assumption.
    + right; assumption.
Defined.


Add LoadPath "D:\sfsol".
Require Export Stlc.

Module STLCExtended.

Inductive ty : Type :=
  | TArrow : ty -> ty -> ty
  | TNat : ty
  | TUnit : ty
  | TProd : ty -> ty -> ty
  | TSum : ty -> ty -> ty
  | TList : ty -> ty.

Tactic Notation "T_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "TArrow" | Case_aux c "TNat"
  | Case_aux c "TProd" | Case_aux c "TUnit"
  | Case_aux c "TSum" | Case_aux c "TList" ].

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | tnat : nat -> tm
  | tsucc : tm -> tm
  | tpred : tm -> tm
  | tmult : tm -> tm -> tm
  | tif0 : tm -> tm -> tm -> tm
  | tpair : tm -> tm -> tm
  | tfst : tm -> tm
  | tsnd : tm -> tm
  | tunit : tm
  | tlet : id -> tm -> tm -> tm
  | tinl : ty -> tm -> tm
  | tinr : ty -> tm -> tm
  | tcase : tm -> id -> tm -> id -> tm -> tm
  | tnil : ty -> tm
  | tcons : tm -> tm -> tm
  | tlcase : tm -> tm -> id -> id -> tm -> tm
  | tfix : tm -> tm.

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp" | Case_aux c "tabs"
  | Case_aux c "tnat" | Case_aux c "tsucc" | Case_aux c "tpred"
  | Case_aux c "tmult" | Case_aux c "tif0"
  | Case_aux c "tpair" | Case_aux c "tfst" | Case_aux c "tsnd"
  | Case_aux c "tunit" | Case_aux c "tlet"
  | Case_aux c "tinl" | Case_aux c "tinr" | Case_aux c "tcase"
  | Case_aux c "tnil" | Case_aux c "tcons" | Case_aux c "tlcase"
  | Case_aux c "tfix" ].

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar y =>
      if eq_id_dec x y then s else t
  | tabs y T t1 =>
      tabs y T (if eq_id_dec x y then t1 else (subst x s t1))
  | tapp t1 t2 =>
      tapp (subst x s t1) (subst x s t2)
  | tnat x => tnat x
  | tsucc t => tsucc (subst x s t)
  | tpred t => tpred (subst x s t)
  | tmult t1 t2 => tmult (subst x s t1) (subst x s t2)
  | tif0 t1 t2 t3 => tif0 (subst x s t1) (subst x s t2)(subst x s t3)
  | tpair t1 t2 => tpair (subst x s t1) (subst x s t2)
  | tfst t1 => tfst (subst x s t1)
  | tsnd t1 => tsnd (subst x s t1)
  | tunit => tunit
  | tlet y t1 t2 => if eq_id_dec x y then
      tlet y (subst x s t1) t2 else
      tlet y (subst x s t1) (subst x s t2)
  | tinl T t => tinl T (subst x s t)
  | tinr T t => tinr T (subst x s t)
  | tcase t x1 t1 x2 t2 => if eq_id_dec x x1 then
      if eq_id_dec x x2 then
        tcase (subst x s t) x1 t1 x2 t2 else
        tcase (subst x s t) x1 t1 x2 (subst x s t2)
      else if eq_id_dec x x2 then
        tcase (subst x s t) x1 (subst x s t1) x2 t2 else
        tcase (subst x s t) x1 (subst x s t1) x2 (subst x s t2)
  | tnil T => tnil T
  | tcons t1 t2 => tcons (subst x s t1) (subst x s t2)
  | tlcase t1 t2 x1 x2 t3 => if eq_id_dec x x1 then
      tlcase (subst x s t1) (subst x s t2) x1 x2 t3
      else if eq_id_dec x x2 then
      tlcase (subst x s t1) (subst x s t2) x1 x2 t3
      else tlcase (subst x s t1) (subst x s t2) x1 x2 (subst x s t3)
  | tfix t => tfix (subst x s t)
  end.

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

Inductive value : tm -> Prop :=
  | v_abs : forall x T11 t12,
      value (tabs x T11 t12)
  | v_nat : forall x,
      value (tnat x)
  | v_unit : value tunit
  | v_pair : forall t1 t2,
      value t1 ->
      value t2 ->
      value (tpair t1 t2)
  | v_inl : forall T t,
      value t ->
      value (tinl T t)
  | v_inr : forall T t,
      value t ->
      value (tinr T t)
  | v_nil : forall T,
      value (tnil T)
  | v_cons : forall t1 t2,
      value t1 ->
      value t2 ->
      value (tcons t1 t2).

Hint Constructors value.

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

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T11 t12 v2,
         value v2 ->
         (tapp (tabs x T11 t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         (tapp t1 t2) ==> (tapp t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         (tapp v1 t2) ==> (tapp v1 t2')
  | ST_Succ : forall t t',
         t ==> t' ->
         tsucc t ==> tsucc t'
  | ST_SuccNat : forall x,
         tsucc (tnat x) ==> tnat (S x)
  | ST_Pred : forall t t',
         t ==> t' ->
         tpred t ==> tpred t'
  | ST_PredNat : forall x,
         tpred (tnat x) ==> tnat (pred x)
  | ST_Mult1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tmult t1 t2 ==> tmult t1' t2
  | ST_Mult2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tmult v1 t2 ==> tmult v1 t2'
  | ST_MultNat : forall x1 x2,
         tmult (tnat x1) (tnat x2) ==> tnat (mult x1 x2)
  | ST_IF0_Cond : forall t1 t1' t2 t3,
         t1 ==> t1' ->
         tif0 t1 t2 t3 ==> tif0 t1' t2 t3
  | ST_If0_If : forall t1 t2,
         tif0 (tnat 0) t1 t2 ==> t1
  | ST_If0_Else : forall x t1 t2,
         x <> 0 ->
         tif0 (tnat x) t1 t2 ==> t2
  | ST_Pair1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tpair t1 t2 ==> tpair t1' t2
  | ST_Pair2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tpair v1 t2 ==> tpair v1 t2'
  | ST_First_Pair : forall t1 t2,
         tfst (tpair t1 t2) ==> t1
  | ST_Second_Pair : forall t1 t2,
         tsnd (tpair t1 t2) ==> t2
  | ST_First : forall t t',
         t ==> t' ->
         tfst t ==> tfst t'
  | ST_Second : forall t t',
         t ==> t' ->
         tsnd t ==> tsnd t'
  | ST_Let1 : forall x t1 t1' t2,
         t1 ==> t1' ->
         tlet x t1 t2 ==> tlet x t1' t2
  | ST_LetValue : forall x v1 t2,
         value v1 ->
         tlet x v1 t2 ==> [x:=v1]t2
  | ST_Inl : forall T t t',
         t ==> t' ->
         tinl T t ==> tinl T t'
  | ST_Inr : forall T t t',
         t ==> t' ->
         tinr T t ==> tinr T t'
  | ST_Case : forall t t' x1 t1 x2 t2,
         t ==> t' ->
         tcase t x1 t1 x2 t2 ==> tcase t' x1 t1 x2 t2
  | ST_CaseInl : forall T t x1 t1 x2 t2,
         tcase (tinl T t) x1 t1 x2 t2 ==> [x1:=t]t1
  | ST_CaseInr : forall T t x1 t1 x2 t2,
         tcase (tinr T t) x1 t1 x2 t2 ==> [x2:=t]t2
  | ST_Cons : forall t t' t2,
         t ==> t' ->
         tcons t t2 ==> tcons t' t2
  | ST_ConsValue : forall v1 t t',
         value v1 ->
         t ==> t' ->
         tcons v1 t ==> tcons v1 t'
  | ST_LCase1 : forall t1 t1' t2 x1 x2 t3,
         t1 ==> t1' ->
         tlcase t1 t2 x1 x2 t3 ==> tlcase t1' t2 x1 x2 t3
  | ST_LCaseNil : forall T t2 x1 x2 t3,
         tlcase (tnil T) t2 x1 x2 t3 ==> t2
  | ST_LCaseCons : forall t2 x1 x2 t3 v1 v2,
         value v1 ->
         value v2 ->
         tlcase (tcons v1 v2) t2 x1 x2 t3 ==>
         [x1:=v1]([x2:=v2]t3)
  | ST_Fix1 : forall t1 t1',
         t1 ==> t1' ->
         tfix t1 ==> tfix t1'
  | ST_FixAbs : forall x T t,
         tfix (tabs x T t) ==> [x:=tfix (tabs x T t)]t

where "t1 '==>' t2" := (step t1 t2).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App1" | Case_aux c "ST_App2"
    | Case_aux c "ST_Succ" | Case_aux c "ST_Pred"
    | Case_aux c "ST_Mult1" | Case_aux c "ST_Mult2"
    | Case_aux c "ST_IF0_Cond" | Case_aux c "ST_IF0_If"
    | Case_aux c "ST_IF0_Else" | Case_aux c "ST_Pair1"
    | Case_aux c "ST_Pair2" | Case_aux c "ST_FirstPair"
    | Case_aux c "ST_SecondPair" | Case_aux c "ST_First"
    | Case_aux c "ST_Second" | Case_aux c "ST_Let1"
    | Case_aux c "ST_LetValue" | Case_aux c "ST_Inl"
    | Case_aux c "ST_Inr" | Case_aux c "ST_Case"
    | Case_aux c "ST_CaseInl" | Case_aux c "ST_CaseInr"
    | Case_aux c "ST_Cons" | Case_aux c "ST_ConsValue"
    | Case_aux c "ST_LCase1" | Case_aux c "ST_LCaseNil"
    | Case_aux c "ST_LCaseCons" | Case_aux c "ST_Fix1"
    | Case_aux c "ST_FixAbs"
  ].

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

Hint Constructors step.

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- (tvar x) \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      (extend Gamma x T11) |- t12 \in T12 ->
      Gamma |- (tabs x T11 t12) \in (TArrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in (TArrow T1 T2) ->
      Gamma |- t2 \in T1 ->
      Gamma |- (tapp t1 t2) \in T2
  | T_Nat : forall Gamma x,
      Gamma |- tnat x \in TNat
  | T_Succ : forall Gamma t,
      Gamma |- t \in TNat ->
      Gamma |- tsucc t \in TNat
  | T_Pred : forall Gamma t,
      Gamma |- t \in TNat ->
      Gamma |- tpred t \in TNat
  | T_Mult : forall Gamma t1 t2,
      Gamma |- t1 \in TNat ->
      Gamma |- t2 \in TNat ->
      Gamma |- tmult t1 t2 \in TNat
  | T_If : forall Gamma t1 t2 t3 T,
      Gamma |- t1 \in TNat ->
      Gamma |- t2 \in T ->
      Gamma |- t3 \in T ->
      Gamma |- tif0 t1 t2 t3 \in T
  | T_Pair : forall Gamma t1 t2 T1 T2,
      Gamma |- t1 \in T1 ->
      Gamma |- t2 \in T2 ->
      Gamma |- (tpair t1 t2) \in (TProd T1 T2)
  | T_First : forall Gamma t T1 T2,
      Gamma |- t \in (TProd T1 T2) ->
      Gamma |- tfst t \in T1
  | T_Second : forall Gamma t T1 T2,
      Gamma |- t \in (TProd T1 T2) ->
      Gamma |- tsnd t \in T2
  | T_Unit : forall Gamma,
      Gamma |- tunit \in TUnit
  | T_Let : forall Gamma x t1 T1 t2 T2,
      Gamma |- t1 \in T1 ->
      extend Gamma x T1 |- t2 \in T2 ->
      Gamma |- tlet x t1 t2 \in T2
  | T_Inl : forall Gamma t T1 T2,
      Gamma |- t \in T1 ->
      Gamma |- tinl T2 t \in TSum T1 T2
  | T_Inr : forall Gamma t T1 T2,
      Gamma |- t \in T2 ->
      Gamma |- tinr T1 t \in TSum T1 T2
  | T_Case : forall Gamma t0 T1 T2 x1 x2 t1 t2 T,
      Gamma |- t0 \in TSum T1 T2 ->
      extend Gamma x1 T1 |- t1 \in T ->
      extend Gamma x2 T2 |- t2 \in T ->
      Gamma |- tcase t0 x1 t1 x2 t2 \in T
  | T_Nil : forall Gamma T,
      Gamma |- tnil T \in TList T
  | T_Cons : forall Gamma t1 t2 T,
      Gamma |- t1 \in T ->
      Gamma |- t2 \in TList T ->
      Gamma |- tcons t1 t2 \in TList T
  | T_LCase : forall Gamma h t t1 t2 t3 T1 T,
      Gamma |- t1 \in TList T1 ->
      Gamma |- t2 \in T ->
      extend (extend Gamma h T1) t (TList T1) |- t3 \in T ->
      Gamma |- tlcase t1 t2 h t t3 \in T
  | T_Fix : forall Gamma t1 T1,
      Gamma |- t1 \in TArrow T1 T1 ->
      Gamma |- tfix t1 \in T1

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs" | Case_aux c "T_App"
    | Case_aux c "T_Nat" | Case_aux c "T_Succ" | Case_aux c "T_Pred"
    | Case_aux c "T_Mult" | Case_aux c "T_If" | Case_aux c "T_Pair"
    | Case_aux c "T_First" | Case_aux c "T_Second" | Case_aux c "T_Unit"
    | Case_aux c "T_Let" | Case_aux c "T_Inl" | Case_aux c "T_Inr"
    | Case_aux c "T_Case" | Case_aux c "T_Nil" | Case_aux c "T_Cons"
    | Case_aux c "T_LCase" | Case_aux c "T_Fix"
].

Module Examples.

Notation a := (Id 0).
Notation f := (Id 1).
Notation g := (Id 2).
Notation l := (Id 3).
Notation k := (Id 6).
Notation i1 := (Id 7).
Notation i2 := (Id 8).
Notation x := (Id 9).
Notation y := (Id 10).
Notation processSum := (Id 11).
Notation n := (Id 12).
Notation eq := (Id 13).
Notation m := (Id 14).
Notation evenodd := (Id 15).
Notation even := (Id 16).
Notation odd := (Id 17).
Notation eo := (Id 18).

Hint Extern 2 (has_type _ (tapp _ _) _) =>
  eapply T_App; auto.

Hint Extern 2 (has_type _ (tlcase _ _ _ _ _) _) =>
  eapply T_LCase; auto.

Hint Extern 2 (_ = _) => compute; reflexivity.

Module Numtest.

Definition test :=
  tif0
    (tpred
      (tsucc
        (tpred
          (tmult
            (tnat 2)
            (tnat 0)))))
    (tnat 5)
    (tnat 6).

Example typechecks :
  (@empty ty) |- test \in TNat.
Proof.
  unfold test.
  auto 10.
Qed.

Example numtest_reduces :
  test ==>* tnat 5.
Proof.
  unfold test. normalize.
Qed.

End Numtest.

Module Prodtest.

Definition test :=
  tsnd
    (tfst
      (tpair
        (tpair
          (tnat 5)
          (tnat 6))
        (tnat 7))).

Example typechecks :
  (@empty ty) |- test \in TNat.
Proof. unfold test. eauto 15. Qed.

Example reduces :
  test ==>* tnat 6.
Proof. unfold test. normalize. Qed.

End Prodtest.

Module LetTest.

Definition test :=
  tlet
    x
    (tpred (tnat 6))
    (tsucc (tvar x)).

Example typechecks :
  (@empty ty) |- test \in TNat.
Proof. unfold test. eauto 15. Qed.

Example reduces :
  test ==>* tnat 6.
Proof. unfold test. normalize. Qed.

End LetTest.

Module Sumtest1.

Definition test :=
  tcase (tinl TNat (tnat 5))
    x (tvar x)
    y (tvar y).

Example typechecks :
  (@empty ty) |- test \in TNat.
Proof. unfold test. eauto 15. Qed.

Example reduces :
  test ==>* (tnat 5).
Proof. unfold test. normalize. Qed.

End Sumtest1.

Module Sumtest2.

Definition test :=
  tlet
    processSum
    (tabs x (TSum TNat TNat)
      (tcase (tvar x)
         n (tvar n)
         n (tif0 (tvar n) (tnat 1) (tnat 0))))
    (tpair
      (tapp (tvar processSum) (tinl TNat (tnat 5)))
      (tapp (tvar processSum) (tinr TNat (tnat 5)))).

Example typechecks :
  (@empty ty) |- test \in (TProd TNat TNat).
Proof. unfold test. eauto 15. Qed.

Example reduces :
  test ==>* (tpair (tnat 5) (tnat 0)).
Proof. unfold test. normalize. Qed.

End Sumtest2.

Module ListTest.

Definition test :=
  tlet l
    (tcons (tnat 5) (tcons (tnat 6) (tnil TNat)))
    (tlcase (tvar l)
       (tnat 0)
       x y (tmult (tvar x) (tvar x))).

Example typechecks :
  (@empty ty) |- test \in TNat.
Proof. unfold test. eauto 20. Qed.

Example reduces :
  test ==>* (tnat 25).
Proof. unfold test. normalize. Qed.

End ListTest.

Module FixTest1.

Definition fact :=
  tfix
    (tabs f (TArrow TNat TNat)
      (tabs a TNat
        (tif0
           (tvar a)
           (tnat 1)
           (tmult
              (tvar a)
              (tapp (tvar f) (tpred (tvar a))))))).

Example fact_typechecks :
  (@empty ty) |- fact \in (TArrow TNat TNat).
Proof. unfold fact. auto 10.
Qed.

Example fact_example:
  (tapp fact (tnat 4)) ==>* (tnat 24).
Proof. unfold fact. normalize. Qed.

End FixTest1.

Module FixTest2.

Definition map :=
  tabs g (TArrow TNat TNat)
    (tfix
      (tabs f (TArrow (TList TNat) (TList TNat))
        (tabs l (TList TNat)
          (tlcase (tvar l)
            (tnil TNat)
            a l (tcons (tapp (tvar g) (tvar a))
                         (tapp (tvar f) (tvar l))))))).

Example map_typechecks :
  empty |- map \in
    (TArrow (TArrow TNat TNat)
      (TArrow (TList TNat)
        (TList TNat))).
Proof. unfold map. auto 10. Qed.

Example map_example :
  tapp (tapp map (tabs a TNat (tsucc (tvar a))))
         (tcons (tnat 1) (tcons (tnat 2) (tnil TNat)))
  ==>* (tcons (tnat 2) (tcons (tnat 3) (tnil TNat))).
Proof. unfold map. normalize. Qed.

End FixTest2.

Module FixTest3.

Definition equal :=
  tfix
    (tabs eq (TArrow TNat (TArrow TNat TNat))
      (tabs m TNat
        (tabs n TNat
          (tif0 (tvar m)
            (tif0 (tvar n) (tnat 1) (tnat 0))
            (tif0 (tvar n)
              (tnat 0)
              (tapp (tapp (tvar eq)
                              (tpred (tvar m)))
                      (tpred (tvar n)))))))).

Example equal_typechecks :
  (@empty ty) |- equal \in (TArrow TNat (TArrow TNat TNat)).
Proof. unfold equal. auto 10.
Qed.

Example equal_example1:
  (tapp (tapp equal (tnat 4)) (tnat 4)) ==>* (tnat 1).
Proof. unfold equal. normalize. Qed.

Example equal_example2:
  (tapp (tapp equal (tnat 4)) (tnat 5)) ==>* (tnat 0).
Proof. unfold equal. normalize. Qed.

End FixTest3.

Module FixTest4.

Definition eotest :=
  tlet evenodd
    (tfix
      (tabs eo (TProd (TArrow TNat TNat) (TArrow TNat TNat))
        (tpair
          (tabs n TNat
            (tif0 (tvar n)
              (tnat 1)
              (tapp (tsnd (tvar eo)) (tpred (tvar n)))))
          (tabs n TNat
            (tif0 (tvar n)
              (tnat 0)
              (tapp (tfst (tvar eo)) (tpred (tvar n))))))))
  (tlet even (tfst (tvar evenodd))
  (tlet odd (tsnd (tvar evenodd))
  (tpair
    (tapp (tvar even) (tnat 3))
    (tapp (tvar even) (tnat 4))))).

Example eotest_typechecks :
  (@empty ty) |- eotest \in (TProd TNat TNat).
Proof. unfold eotest. eauto 30.
Qed.

Example eotest_example1:
  eotest ==>* (tpair (tnat 0) (tnat 1)).
Proof. unfold eotest. normalize. Qed.

End FixTest4.

End Examples.

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.
Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  generalize dependent HeqGamma.
  has_type_cases (induction Ht) Case; intros HeqGamma; subst...
  Case "T_Var".
    inversion H.
  Case "T_App".
    right.
    destruct IHHt1; subst...
      destruct IHHt2; subst...
        inversion H; subst; try (solve by inversion)...
      inversion H0; subst...
      inversion H;subst...
  Case "T_Succ".
    right.
    destruct IHHt; subst...
      inversion H; subst; try (solve by inversion)...
      inversion H...
  Case "T_Pred".
    right.
    destruct IHHt; subst...
      inversion H; subst; try (solve by inversion)...
      inversion H...
  Case "T_Mult".
    right.
    destruct IHHt1; subst...
      inversion H; subst; try (solve by inversion)...
      destruct IHHt2; subst...
        inversion H0; subst; try (solve by inversion)...
        inversion H0...
      inversion H...
  Case "T_If".
    right.
    destruct IHHt1; subst...
      inversion H; subst; try (solve by inversion).
      destruct x...
      inversion H...
  Case "T_Pair".
    destruct IHHt1; subst...
      destruct IHHt2; subst...
        inversion H0...
      inversion H...
  Case "T_First".
    right.
      destruct IHHt; subst...
        inversion H; subst; try (solve by inversion)...
        inversion H...
  Case "T_Second".
    right.
      destruct IHHt; subst...
        inversion H; subst; try (solve by inversion)...
        inversion H...
  Case "T_Let".
    right.
      destruct IHHt1; subst...
        inversion H...
  Case "T_Inl".
    destruct IHHt; subst...
      inversion H; subst; try (solve by inversion)...
  Case "T_Inr".
    destruct IHHt; subst...
      inversion H; subst; try (solve by inversion)...
  Case "T_Case".
    right.
      destruct IHHt1; subst...
        inversion H; subst; try (solve by inversion).
        inversion Ht1...
        inversion Ht1...
        inversion H...
  Case "T_Cons".
    destruct IHHt1; subst...
      destruct IHHt2; subst...
      inversion H0...
      inversion H...
  Case "T_LCase".
    right.
    destruct IHHt1; subst...
      inversion H; subst; try (solve by inversion)...
      inversion H...
  Case "T_Fix".
    right.
      destruct IHHt; subst...
      inversion H; subst; try (solve by inversion)...
      inversion H...
  Qed.

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x ->
        appears_free_in x t12 ->
        appears_free_in x (tabs y T11 t12)
  | afi_succ : forall x t,
        appears_free_in x t ->
        appears_free_in x (tsucc t)
  | afi_pred : forall x t,
        appears_free_in x t ->
        appears_free_in x (tpred t)
  | afi_mult1 : forall x t1 t2,
        appears_free_in x t1 -> appears_free_in x (tmult t1 t2)
  | afi_mult2 : forall x t1 t2,
        appears_free_in x t2 -> appears_free_in x (tmult t1 t2)
  | afi_if0_0 : forall x t1 t2 t3,
        appears_free_in x t1 -> appears_free_in x (tif0 t1 t2 t3)
  | afi_if0_1 : forall x t1 t2 t3,
        appears_free_in x t2 -> appears_free_in x (tif0 t1 t2 t3)
  | afi_if0_2 : forall x t1 t2 t3,
        appears_free_in x t3 -> appears_free_in x (tif0 t1 t2 t3)
  | afi_pair1 : forall x t1 t2,
        appears_free_in x t1 -> appears_free_in x (tpair t1 t2)
  | afi_pair2 : forall x t1 t2,
        appears_free_in x t2 -> appears_free_in x (tpair t1 t2)
  | afi_first : forall x t,
        appears_free_in x t -> appears_free_in x (tfst t)
  | afi_second : forall x t,
        appears_free_in x t -> appears_free_in x (tsnd t)
  | afi_Let1 : forall x y t1 t2,
        appears_free_in x t1 -> appears_free_in x (tlet y t1 t2)
  | afi_Let2 : forall x y t1 t2,
        x<>y ->
        appears_free_in x t2 ->
        appears_free_in x (tlet y t1 t2)
  | afi_inl : forall x T t,
        appears_free_in x t -> appears_free_in x (tinl T t)
  | afi_inr : forall x T t,
        appears_free_in x t -> appears_free_in x (tinr T t)
  | afi_case1 : forall x1 x2 x3 t1 t2 t3,
        appears_free_in x1 t1 ->
        appears_free_in x1 (tcase t1 x2 t2 x3 t3)
  | afi_case2 : forall x1 x2 x3 t1 t2 t3,
        x1<>x2 ->
        appears_free_in x1 t2 ->
        appears_free_in x1 (tcase t1 x2 t2 x3 t3)
  | afi_case3 : forall x1 x2 x3 t1 t2 t3,
        x1<>x3 ->
        appears_free_in x1 t3 ->
        appears_free_in x1 (tcase t1 x2 t2 x3 t3)
  | afi_cons1 : forall x t1 t2,
        appears_free_in x t1 ->
        appears_free_in x (tcons t1 t2)
  | afi_cons2 : forall x t1 t2,
        appears_free_in x t2 ->
        appears_free_in x (tcons t1 t2)
  | afi_tlcase1 : forall x1 x2 x3 t1 t2 t3,
        appears_free_in x1 t1 ->
        appears_free_in x1 (tlcase t1 t2 x2 x3 t3)
  | afi_tlcase2 : forall x1 x2 x3 t1 t2 t3,
        appears_free_in x1 t2 ->
        appears_free_in x1 (tlcase t1 t2 x2 x3 t3)
  | afi_tlcase3 : forall x1 x2 x3 t1 t2 t3,
        x1<>x2 ->
        x1<>x3 ->
        appears_free_in x1 t3 ->
        appears_free_in x1 (tlcase t1 t2 x2 x3 t3)
  | afi_fix : forall x t,
        appears_free_in x t ->
        appears_free_in x (tfix t).

Hint Constructors appears_free_in.

Lemma context_invariance : forall Gamma Gamma' t S,
     Gamma |- t \in S ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     Gamma' |- t \in S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  has_type_cases (induction H) Case;
    intros Gamma' Heqv...
  Case "T_Var".
    apply T_Var... rewrite <- Heqv...
  Case "T_Abs".
    apply T_Abs... apply IHhas_type. intros y Hafi.
    unfold extend.
    destruct (eq_id_dec x y)...
  Case "T_Mult".
    apply T_Mult...
  Case "T_If".
    apply T_If...
  Case "T_Pair".
    apply T_Pair...
  Case "T_Let".
    eapply T_Let...
    apply IHhas_type2. intros. unfold extend.
    destruct (eq_id_dec x x0)...
  Case "T_Case".
    eapply T_Case...
    apply IHhas_type2. intros. unfold extend.
    destruct (eq_id_dec x1 x)...
    apply IHhas_type3. intros. unfold extend.
    destruct (eq_id_dec x2 x)...
  Case "T_Cons".
    apply T_Cons...
  Case "T_LCase".
    eapply T_LCase...
    apply IHhas_type3. intros. unfold extend.
    destruct (eq_id_dec t x)...
    destruct (eq_id_dec h x)...
Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t \in T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  has_type_cases (induction Htyp) Case; inversion Hafi; subst...
  Case "T_Abs".
    destruct IHHtyp as [T' Hctx]... exists T'.
    unfold extend in Hctx.
    rewrite neq_id in Hctx...
  Case "T_Let".
    apply IHHtyp2 in H4. inversion H4; subst.
    unfold extend in H. rewrite neq_id in H...
  Case "T_Case".
    apply IHHtyp2 in H6. inversion H6; subst.
    unfold extend in H6. rewrite neq_id in H6...
    apply IHHtyp3 in H6. inversion H6; subst.
    unfold extend in H6. rewrite neq_id in H6...
  Case "T_LCase".
    apply IHHtyp3 in H7. inversion H7; subst.
    unfold extend in H. rewrite neq_id in H...
    rewrite neq_id in H...
  Qed.

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     (extend Gamma x U) |- t \in S ->
     empty |- v \in U ->
     Gamma |- ([x:=v]t) \in S.
Proof with eauto.
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent Gamma. generalize dependent S.
  t_cases (induction t) Case;
    intros S Gamma Htypt; simpl; inversion Htypt; subst...
  Case "tvar".
    simpl.
    destruct (eq_id_dec x i).
      subst. unfold extend in H1. rewrite eq_id in H1.
      inversion H1; subst. clear H1.
      eapply context_invariance...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
      apply T_Var... unfold extend in H1. rewrite neq_id in H1...
  Case "tabs".
    apply T_Abs...
    destruct (eq_id_dec x i).
      eapply context_invariance...
      subst. intros x Hafi. unfold extend.
      destruct (eq_id_dec i x)...
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold extend.
      destruct (eq_id_dec i z)...
      subst. rewrite neq_id...
  Case "tlet".
    destruct (eq_id_dec x i);
    eapply T_Let; eauto; eapply context_invariance...
    intros. unfold extend. subst. destruct (eq_id_dec i x0)...
    apply IHt2. eapply context_invariance...
    intros. unfold extend. destruct (eq_id_dec i x0); eauto.
    subst. rewrite neq_id...
  Case "tcase".
    destruct (eq_id_dec x i); subst...
      destruct (eq_id_dec i i0); subst; eauto;
        eapply T_Case; eauto; eapply context_invariance; eauto;
        intros; unfold extend.
        destruct (eq_id_dec i0 x)...
        destruct (eq_id_dec i0 x)...
        destruct (eq_id_dec i x)...
      apply IHt3... eapply context_invariance...
      intros. unfold extend. destruct (eq_id_dec i0 x); subst...
      rewrite neq_id...
    destruct (eq_id_dec x i0); subst; eauto;
      eapply T_Case; eauto; eapply context_invariance...
      apply IHt2. eapply context_invariance...
      intros. unfold extend. destruct (eq_id_dec i x); subst...
      rewrite neq_id...
      intros. unfold extend. destruct (eq_id_dec i0 x); subst...
      apply IHt2. eapply context_invariance...
      intros. unfold extend. destruct (eq_id_dec i x0); subst...
      rewrite neq_id...
      apply IHt3. eapply context_invariance...
      intros. unfold extend. destruct (eq_id_dec i0 x0); subst...
      rewrite neq_id...
  Case "tlcase".
    destruct (eq_id_dec x i); subst...
      eapply T_LCase... eapply context_invariance...
      intros. unfold extend. destruct (eq_id_dec i0 x); subst...
      destruct (eq_id_dec i x)...
      destruct (eq_id_dec x i0); subst...
      eapply T_LCase... eapply context_invariance...
      intros; unfold extend. destruct (eq_id_dec i0 x); subst...
      eapply T_LCase... apply IHt3.
      eapply context_invariance... intros.
      unfold extend. destruct(eq_id_dec i0 x0); subst...
      rewrite neq_id...
      destruct (eq_id_dec i x0); subst...
      rewrite neq_id...
  Qed.

Theorem preservation : forall t t' T,
     empty |- t \in T ->
     t ==> t' ->
     empty |- t' \in T.
Proof with eauto.
  intros t t' T HT.
  remember (@empty ty) as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  has_type_cases (induction HT) Case;
  intros t' HeqGamma HE; subst; inversion HE; subst...
  Case "T_App".
    inversion HE; subst...
    apply substitution_preserves_typing with T1...
    inversion HT1...
  Case "T_First".
    inversion HT...
  Case "T_Second".
    inversion HT...
  Case "T_Let".
    eapply substitution_preserves_typing...
  Case "T_Case".
    eapply substitution_preserves_typing...
    inversion HT1...
    eapply substitution_preserves_typing...
    inversion HT1...
  Case "T_LCase".
    eapply substitution_preserves_typing...
    eapply substitution_preserves_typing...
    inversion HT1...
    inversion HT1...
  Case "T_Fix".
    eapply substitution_preserves_typing...
    inversion HT...
  Qed.

End STLCExtended.


From mathcomp Require Import all_ssreflect.
Require Import ZArith.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Check Equality.axiom.
Check Zeq_bool.
Check rel.

Lemma Zeq_boolP : Equality.axiom Zeq_bool.
Proof.
    move => x y.
    by apply: (iffP idP); rewrite Zeq_is_eq_bool.
Qed.

Restart.
Show.
Undo.


Theorem all_perm :
  forall (A : Type) (P : A -> A -> Prop),
    (forall x y : A, P x y) -> forall x y : A, P y x.
Proof. intros A P H x y; apply H. Qed.

Theorem resolution :
  forall (A : Type) (P Q R S : A -> Prop),
    (forall a : A, Q a -> R a -> S a) ->
    (forall b : A, P b -> Q b) ->
    (forall c : A, P c -> R c -> S c).
Proof.
  intros A P Q R S H H' c H0 H1.
  apply H.
  apply H'; assumption.
  assumption.
  Qed.


Require Import Reals.
Require Import Waterproof.AllTactics.
Require Import Waterproof.notations.notations.
Require Import Reals.ROrderedType.
Require Import Waterproof.theory.analysis.reals. (* Req_true is in here *)
Require Import Waterproof.load.
Import databases_RealsAndIntegers.
Require Import micromega.Lra.
Open Scope R_scope.

Section Definitions.
Context (X : Metric_Space).

(* Definition metric_to_base := Base. *)

Coercion Base : Metric_Space >-> Sortclass.

Definition dist_positive :
  ∀ x y : X, dist X x y ≥ 0
  := dist_pos X.

Definition dist_non_degenerate :
  ∀ x y : X, (dist X x y = 0) ⇒ (x = y).
  Take x, y : X.
  By (proj1(_,_,(dist_refl X x y))) we conclude that (dist X x y = 0 ⇨ x = y).
Defined.

Definition dist_symmetric :
  ∀ x y : X, dist X x y = dist X y x
  := dist_sym X.

Definition dist_triangle_inequality :
  ∀ x y z : X, dist X x z ≤ dist X x y + dist X y z.
  Take x, y, z : X.
  By (dist_tri X) we conclude that (dist X x z ≤ dist X x y + dist X y z).
Qed.

Definition dist_reflexive : ∀ x : X, dist X x x = 0.
  Take x : X.
  By (proj2(_,_,(dist_refl X x x))) we conclude that (dist X x x = 0).
Defined.

End Definitions.

(** ** Expample : a discrete metric on the real line *)

Definition d_discrete_R :
  ℝ → ℝ → ℝ := fun (x y : ℝ) => if Reqb x y then 0 else 3.

Lemma d'_eq_0 : forall x y : ℝ,
  d_discrete_R x y = 0 -> (Reqb x y) = true.
Proof.
Take x, y : ℝ.
Assume that (d_discrete_R x y = 0) (i).
Either (x = y) or (x ≠ y).
+ Case (x = y).
  By Req_true we conclude that (Reqb x y = true).

+ Case (x ≠ y).
  Expand the definition of d_discrete_R in (i).
  That is, write (i) as ( (if Reqb x y then 0 else 3) = 0).
  rewrite (Req_false x y n) in i.
  It holds that (3 ≠ 0).
  Contradiction.
Qed.

Lemma d'_eq_3 : forall x y : ℝ, d_discrete_R x y = 3 -> (Reqb x y) = false.
Proof.
Take x, y : ℝ.
Assume that (d_discrete_R x y = 3) (i).
Expand the definition of d_discrete_R in (i).
That is, write (i) as ( (if Reqb x y then 0 else 3) = 3).
Either (x = y) or (x ≠ y).
+ Case (x = y).
  rewrite (Req_true x y e) in i.
  It holds that (0 ≠ 3).
  Contradiction.
+ Case (x ≠ y).
  By Req_false we conclude that (Reqb x y = false).
Qed.

#[export] Hint Resolve d'_eq_0 : reals.
#[export] Hint Resolve d'_eq_3 : reals.
#[export] Hint Extern 0 => unfold d_discrete_R; rewrite Req_true; lra : reals.
#[export] Hint Extern 0 => unfold d_discrete_R; rewrite Req_false; lra : reals.


Set Implicit Arguments.

Require Import List.

Section TopSection.

  Fixpoint app_all A (ls : list (list A)) :=
    match ls with
      | nil => nil
      | x :: xs => x ++ app_all xs
    end.

  Definition Disjoint A (ls1 ls2 : list A) := forall e : A, ~ (In e ls1 /\ In e ls2).

  Definition IsInjection A B (f : A -> B) := forall x y, x <> y -> f x <> f y.

  Variable t : Type.
  Variable B : Type.

  Implicit Types ls : list t.
  Implicit Types f : t -> B.
  Implicit Types x y e a : t.

  Lemma map_app_all : forall f lsls, map f (app_all lsls) = app_all (map (fun ls => map f ls) lsls).
    induction lsls; simpl; intros; eauto.
    rewrite map_app; f_equal; eauto.
  Qed.

  Require Import Sumbool.
  Require Import GeneralTactics.

  Lemma find_spec : forall (f : t -> bool) ls a, find f ls = Some a -> f a = true /\ In a ls.
    induction ls; simpl; intuition; try discriminate;
    (destruct (sumbool_of_bool (f a));
     [rewrite e in H; injection H; intros; subst; eauto |
      rewrite e in H; eapply IHls in H; openhyp; eauto]).
  Qed.

  Lemma find_spec_None : forall (f : t -> bool) ls, List.find f ls = None -> ~ exists a, List.In a ls /\ f a = true.
    induction ls; simpl; intuition.
    openhyp; intuition.
    openhyp.
    subst.
    rewrite H1 in H.
    intuition.
    eapply IHls.
    discriminate.
    discriminate.
    destruct (f a); intuition.
    discriminate.
    eapply H2.
    eexists; split; eauto.
  Qed.

  Lemma In_app_all_intro : forall lsls ls e, In e ls -> In ls lsls -> In e (app_all lsls).
    induction lsls; simpl; intros.
    eauto.
    openhyp.
    subst.
    eapply in_or_app.
    eauto.
    eapply in_or_app.
    right.
    eauto.
  Qed.

  Lemma In_app_all_elim : forall lsls x, In x (app_all lsls) -> exists ls, In x ls /\ In ls lsls.
    induction lsls; simpl; intros.
    intuition.
    eapply in_app_or in H.
    openhyp.
    eexists.
    eauto.
    eapply IHlsls in H.
    openhyp.
    eexists; eauto.
  Qed.

  Lemma Disjoint_symm : forall ls1 ls2, Disjoint ls1 ls2 -> Disjoint ls2 ls1.
    unfold Disjoint; intros; firstorder.
  Qed.

  Lemma Disjoint_incl : forall ls1 ls2 ls1' ls2', Disjoint ls1 ls2 -> incl ls1' ls1 -> incl ls2' ls2 -> Disjoint ls1' ls2'.
    unfold Disjoint, incl; intros; firstorder.
  Qed.

  Lemma incl_map : forall f ls1 ls2, incl ls1 ls2 -> incl (map f ls1) (map f ls2).
    unfold incl.
    intros.
    eapply in_map_iff in H0.
    openhyp.
    subst.
    eapply H in H1.
    eapply in_map_iff.
    eexists.
    eauto.
  Qed.

  Lemma Disjoint_map : forall f ls1 ls2, Disjoint (map f ls1) (map f ls2) -> Disjoint ls1 ls2.
    unfold Disjoint; intros.
    intuition.
    eapply H.
    split; eapply in_map; eauto.
  Qed.

  Lemma Injection_NoDup : forall f ls, IsInjection f -> NoDup ls -> NoDup (map f ls).
    unfold IsInjection.
    induction ls; simpl; intros.
    econstructor.
    inversion H0; subst.
    econstructor.
    intuition.
    contradict H3.
    eapply in_map_iff in H1.
    openhyp.
    eapply H in H1.
    intuition.
    intros.
    subst.
    inversion H0; subst.
    contradiction.
    eapply IHls.
    eauto.
    eauto.
  Qed.

  Lemma NoDup_app : forall ls1 ls2, NoDup ls1 -> NoDup ls2 -> Disjoint ls1 ls2 -> NoDup (ls1 ++ ls2).
    unfold Disjoint.
    induction ls1; simpl; intros.
    eauto.
    econstructor.
    intuition.
    eapply in_app_or in H2.
    openhyp.
    inversion H; subst.
    contradiction.
    eapply H1.
    eauto.
    eapply IHls1.
    inversion H; subst.
    eauto.
    eauto.
    intros.
    firstorder.
  Qed.

End TopSection.


From mathcomp Require Import all_ssreflect all_algebra all_field.
Require Import extra_mathcomp posnum hanson_elem_arith.

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

Import Order.TTheory GRing.Theory Num.Theory.

Local Open Scope ring_scope.

Notation "r '%:C'" := (ratr r : algC) (at level 8). (* random level *)

(* Section presenting the theory of exp_quo, which corresponds to
taking a rational exponent of a complex algebraic number *)
Section RationalPower.

Definition exp_quo r p q := q.-root r%:C ^+ p.

Arguments exp_quo r p%nat q%nat : simpl never.

Lemma exp_quo_0 p q : exp_quo 0 p q = (p == 0%N)%:R.
Proof. by rewrite /exp_quo /ratr mul0r rootC0 expr0n. Qed.

Lemma exp_quo_1 p q : (0 < q)%N -> exp_quo 1 p q = 1.
Proof. by move => Hq; rewrite /exp_quo rmorph1 rootC1 // expr1n. Qed.

Lemma exp_quoMl r1 r2 p1 q1 (Hr1 : 0 <= r1) :
  exp_quo (r1 * r2) p1 q1 = exp_quo r1 p1 q1 * exp_quo r2 p1 q1.
Proof. by rewrite /exp_quo rmorphM /= rootCMl ?exprMn ?ler0q. Qed.

Lemma exp_quoMr r1 r2 p1 q1 (Hr2 : 0 <= r2) :
  exp_quo (r1 * r2) p1 q1 = exp_quo r1 p1 q1 * exp_quo r2 p1 q1.
Proof. by rewrite mulrC exp_quoMl // mulrC. Qed.

Lemma exp_quoV r p q : 0 <= r -> exp_quo r^-1 p q = (exp_quo r p q)^-1.
Proof.
rewrite /exp_quo fmorphV /=; case: q => [|q] r_ge_0.
  by rewrite !root0C expr0n; case: eqP; rewrite (invr0, invr1).
by rewrite rootCV ?ler0q // exprVn.
Qed.

Lemma exp_quo_lessE r1 r2 p1 q1 p2 q2 :
    0 <= r1 -> 0 <= r2 -> (0 < q1)%N -> (0 < q2)%N ->
    (exp_quo r1 p1 q1 <= exp_quo r2 p2 q2) =
    (r1%:C ^+ (p1 * q2) <= r2%:C ^+ (p2 * q1)).
Proof.
move=> Hr1 Hr2 Hq1 Hq2; rewrite /exp_quo -!rootCX ?ler0q //.
rewrite root_le_x // ?rootC_ge0 ?exprn_ge0 ?ler0q //.
by rewrite -rootCX ?root_x_le ?exprn_ge0 ?ler0q // -!exprM.
Qed.

Lemma exp_quo_less r1 r2 p q :
  (0 < q)%N -> 0 <= r1 -> 0 <= r2 -> r1 <= r2 ->
  exp_quo r1 p q <= exp_quo r2 p q.
Proof.
move => Hq H1 H2 Hleq.
by rewrite exp_quo_lessE // ler_expn2r ?ler_rat // nnegrE ler0q.
Qed.

Lemma exp_quo_lessn r1 (p1 q1 p2 q2 : nat) :
  (0 < q1)%N -> (0 < q2)%N -> 1 <= r1 -> (p1 * q2 <= p2 * q1)%N ->
  exp_quo r1 p1 q1 <= exp_quo r1 p2 q2.
Proof.
move => Hq1 Hq2 H1r Hle.
have H0r : 0 <= r1 by apply/le_trans/H1r/ler01.
by rewrite exp_quo_lessE // exp_incr_expp ?ler1q.
Qed.

Lemma exp_quo_r_nat r i : (r ^+ i)%:C = exp_quo r i 1.
Proof. by rewrite /exp_quo root1C CratrE /=. Qed.

Lemma exp_quo_nat_nat i j : (i ^ j)%:R%:C = exp_quo i%:Q j 1.
Proof. by rewrite natrX exp_quo_r_nat. Qed.

Lemma exp_quo_plus r1 p1 q1 p2 q2 :
  (0 < q1)%N -> (0 < q2)%N -> 0 <= r1 ->
  exp_quo r1 (p1 * q2 + p2 * q1) (q1 * q2) =
  exp_quo r1 p1 q1 * exp_quo r1 p2 q2.
Proof.
move => Hq1pos Hq2pos Hr1pos.
rewrite [LHS]exprD [in l in l * _ = _]mulnC !prod_root ?ler0q //.
by rewrite mulnC exprM mulnC exprM !rootCK.
Qed.

Lemma exp_quo_equiv r1 p1 q1 p2 q2 :
  (0 < q1)%N -> (0 < q2)%N -> 0 <= r1 -> (p1 * q2 = p2 * q1)%N ->
  exp_quo r1 p1 q1 = exp_quo r1 p2 q2.
Proof.
move => Hq1pos Hq2pos Hr1pos Heq.
have Hprodpos : (0 < q1 * q2)%N by rewrite muln_gt0 Hq1pos Hq2pos.
suff : q1.-root r1%:C ^+ p1 ^+ (q1 * q2) = q2.-root r1%:C ^+ p2 ^+ (q1 * q2).
  by apply: pexpIrn; rewrite // nnegrE exprn_ge0 ?rootC_ge0 ?ler0q.
rewrite !exprM ![_ ^+ _ ^+ q1]exprAC -exprM ![_ ^+ _ ^+ q2]exprAC !rootCK //.
by rewrite -exprM Heq mulnC.
Qed.

Lemma exp_quo_ge0 r p q : (0 < q)%N -> 0 <= r -> 0 <= exp_quo r p q.
Proof. by move=> Hq Hr; rewrite exprn_gte0 ?rootC_ge0 ?ler0q. Qed.

Lemma exp_quo_gt0 r p q : (0 < q)%N -> (0 < r) ->  0 < exp_quo r p q.
Proof. by move => Hq Hr; rewrite exprn_gte0 ?rootC_gt0 ?ltr0q. Qed.

Lemma exp_quo_ge1 r p q : (0 < q)%N -> (1 <= r) -> 1 <= exp_quo r p q.
Proof. by move => Hq Hr; rewrite exprn_ege1 ?rootC_ge1 ?ler1q. Qed.

Lemma exp_quo_gt1 r p q : (0 < p)%N -> (0 < q)%N -> 1 < r -> 1 < exp_quo r p q.
Proof. by move => Hp Hq Hr; rewrite exprn_egt1 ?rootC_gt1 ?ltr1q -?lt0n. Qed.

Lemma sqrtC_exp_quo (r : rat) : sqrtC r%:C = exp_quo r 1%N 2%N.
Proof. by rewrite /exp_quo expr1. Qed.

Lemma exp_quo_self_grows (p1 q1 p2 q2 : nat) r1 r2 :
  (0 < q1)%N ->
  (0 < q2)%N ->
  r1 = p1%:Q / q1%:Q ->
  r2 = p2%:Q / q2%:Q ->
  0 < r1 ->
  1 <= r2 ->
  r1 <= r2 ->
  exp_quo r1 p1 q1 <= exp_quo r2 p2 q2.
Proof.
move => Hq1 Hq2 Hr1 Hr2 Hr1gt0 Hle1r2 Hle12.
have Hr1pos : 0 <= r1 by apply: ltW.
have Hr2pos : 0 <= r2 by rewrite Hr2 divr_ge0 // ?ler0z.
have: r1%:C ^+ (p1 * q2) <= r2%:C ^+ (p1 * q2).
  by rewrite ler_expn2r ?ler_rat // nnegrE ler0q.
rewrite exp_quo_lessE // => /le_trans -> //; rewrite exp_incr_expp ?ler1q //.
move: Hle12; rewrite Hr1 Hr2 ler_pdivr_mulr ?ltr0n //.
by rewrite mulrAC ler_pdivl_mulr ?ltr0n // -!natrM ler_nat.
Qed.

End RationalPower.

(* This Section contains a collection of four facts used in the proof
of Hanson's lemma: a comparison of factorial to a geometric sequence,
the formula for summing a geometric sequence, and a bound on (1 + 1 /
x) ^ x *)
Section FourFacts.

(* A lemma comparing factorial to a geometric sequence *)
Lemma fact_greater_geom i : i.+1`!%:R >= (3%:Q / 2%:Q) ^+ i.
Proof.
elim: i => // i IHi; rewrite exprS factS natrM; apply: ler_pmul IHi => //.
by rewrite ler_pdivr_mulr ?ltr0n // mulr_natr -mulrnA ler_nat.
Qed.

(* Formula for a geometric sum in a field *)
Lemma geometric_sum (R : numFieldType) n (r : R) (Hr : r != 1) :
  \sum_(i < n) r ^+ i = (1 - r ^+ n) / (1 - r).
Proof.
elim: n => [|n Hn]; first by rewrite big_ord0 expr0 subrr mul0r.
have den_neq0 : 1 - r != 0 by rewrite subr_eq0 eq_sym.
rewrite big_ord_recr /= Hn; apply: canRL (mulfK den_neq0) _.
by rewrite [LHS]mulrDl divfK // mulrBr mulr1 addrA subrK exprSr.
Qed.

(* A bound on (1 + 1 / (n+1)) ^ (n+2) *)
Lemma one_plus_invn_expn (n : nat) : (1 + n%:Q^-1) ^+ n.+1 <= 8%:Q.
Proof.
case: n => // n.
have step: (1 + n.+1%:Q^-1) ^+ n.+1 <= \sum_(i < n.+2) i`!%:Q^-1.
  rewrite exprDn; apply: ler_sum => i _; rewrite expr1n mul1r -mulr_natr exprVn.
  rewrite ler_pdivr_mull ?ler_pdivl_mulr ?ltr0n ?expn_gt0 ?fact_gt0 //.
  by rewrite -natrM bin_ffact -natrX ler_nat ffact_le_expn.
have {step}: (1 + n.+1%:Q^-1) ^+ n.+2 <= 2%:Q * \sum_(i < n.+2) i`!%:Q^-1.
  rewrite exprS; apply: ler_pmul => //.
  by rewrite -[2%:Q]/(1 + 1) ler_add2l invf_le1 // ler1z.
move/le_trans; apply; rewrite -[8%:Q]/(2%:Q * 4%:Q) ler_pmul2l //.
have: 1 + \sum_(i < n.+1) (2%:Q / 3%:Q) ^+ i <= 4%:Q.
  rewrite geometric_sum // -[4%:Q]/(1 + 3%:Q) ler_add2l.
  have -> : 1 - 2%:Q / 3%:Q = 3%:Q^-1 by [].
  by rewrite invrK ler_pimull // ler_subl_addr ler_addl.
apply: le_trans; rewrite big_ord_recl ler_add2l; apply: ler_sum => i _ /=.
by rewrite -invf_div exprVn lef_pinv ?posrE ?ltr0n ?fact_gt0 ?fact_greater_geom.
Qed.

(* TODO : clean up, use more ^-1 *)
(* this proof is very long in big part because of exp_quo *)
Lemma one_plus_invx_expx (p q : nat) :
  0 < p%:Q / q%:Q -> exp_quo (1 + q%:Q / p%:Q) p q <= ratr 9%:Q.
Proof.
move=> /ltr_neq.
rewrite eq_sym mulf_eq0 invr_eq0 negb_or !intr_eq0 -!lt0n => /andP[Hp Hq].
have [leqp|ltpq] := leqP q p.

(* First part : q <= p *)
pose f := (p %/ q)%N.
apply: (@le_trans _ _ (ratr 8%:Q)); last by rewrite ler_rat.
suff: exp_quo (1 + q%:~R / p%:~R) p q <= exp_quo (1 + f%:Q^-1) f.+1 1.
  by move=> /le_trans -> //; rewrite -exp_quo_r_nat ler_rat one_plus_invn_expn.
rewrite exp_quo_lessE ?addr_ge0 ?mulr_ge0 ?invr_ge0 ?ler0n // muln1.
have: (1 + f%:~R^-1)%:C ^+ p <= (1 + f%:~R^-1)%:C ^+ (f.+1 * q).
  by rewrite exp_incr_expp ?ler1q ?ler_addl ?invr_ge0 ?ler0n 1?ltnW ?ltn_ceil.
apply: le_trans.
rewrite ler_expn2r ?nnegrE ?ler0q ?addr_ge0 ?mulr_ge0 ?invr_ge0 ?ler0n //.
rewrite ler_rat ler_add2l ler_pdivr_mulr ?ltr0n // mulrC.
rewrite ler_pdivl_mulr ?ltr0n ?divn_gt0 //.
by rewrite -intrM ler_nat mulnC leq_trunc_div.

(* Second part : p < q *)
pose f := (q %/ p)%N.
have Helper0 : (0 < f)%N.
  by rewrite divn_gt0 // ltnW.
have Helper1 : 0 <= 1 + q%:Q / p%:Q.
  by rewrite addr_ge0 ?divr_ge0 ?ler0n.
have Helper2 : 1 + q%:Q / p%:Q <= 1 + (1 + f%:~R).
  rewrite ler_add2l -mulrS ler_pdivr_mulr ?ltr0n // -natrM ler_nat.
  by rewrite ltnW ?ltn_ceil.
have Helper3 : (p * f <= q)%N.
  by rewrite mulnC leq_trunc_div.
apply: (@le_trans _ _ (exp_quo (1 + (1 + f%:Q)) p q)).
  by apply: exp_quo_less; rewrite // !addr_ge0 ?ler0n.
apply: (@le_trans _ _ (exp_quo (1 + (1 + f%:Q)) 1 f)).
  by apply: exp_quo_lessn; rewrite //= ?ler_addl ?addr_ge0 ?ler0n // mul1n.
apply: (@le_trans _ _ (exp_quo ((3 ^ f.+1)%N%:Q) 1 f)).
  rewrite exp_quo_less // ?addr_ge0 ?ler0n //.
  by rewrite -rat1 -!natrD ler_nat !add1n replace_exponential.
rewrite /exp_quo expr1 !CratrE expnS natrM rootCMr ?ler0n //.
have -> : 9%:R = 3%:R * 3%:R :> algC by rewrite -natrM.
by rewrite ler_pmul ?root_le_x ?rootC_ge0 ?ler0n ?natrX // ler_eexpr ?ler1n.
Qed.

End FourFacts.


Require Import CSet Var.

Definition vars_up_to (n:var) :=
  Pos.peano_rect (fun _ => set var)
                 {}
                 (fun x X => {x; X})
                 n.

Lemma inj_lt x y
  : (x < y)%positive
    <-> Pos.to_nat x < Pos.to_nat y.
Proof.
  rewrite <- (Pos2Nat.id y) at 1.
  rewrite <- (Pos2Nat.id x) at 1.
  unfold Pos.lt.
  rewrite <- Nat2Pos.inj_compare; eauto.
  - rewrite Nat.compare_lt_iff. reflexivity.
  - exploit (Pos2Nat.is_pos x). simpl in *. omega.
  - exploit (Pos2Nat.is_pos y). simpl in *. omega.
Qed.

Lemma inj_le x y
  : (x <= y)%positive
    <-> Pos.to_nat x <= Pos.to_nat y.
Proof.
  rewrite <- (Pos2Nat.id y) at 1.
  rewrite <- (Pos2Nat.id x) at 1.
  unfold Pos.le.
  rewrite <- Nat2Pos.inj_compare; eauto.
  - rewrite Nat.compare_le_iff. reflexivity.
  - exploit (Pos2Nat.is_pos x). simpl in *. omega.
  - exploit (Pos2Nat.is_pos y). simpl in *. omega.
Qed.

Lemma vars_up_to_in (x i:var)
  : (x < i)%positive <-> x ∈ vars_up_to i.
Proof.
  unfold vars_up_to.
  revert x.
  induction i using Pos.peano_ind; intros.
  - rewrite Pos.peano_rect_base.
    split; intros.
    + exfalso.
      eapply inj_lt in H.
      rewrite Pos2Nat.inj_1 in H.
      exploit (Pos2Nat.is_pos x). simpl in *. omega.
    + cset_tac.
  - rewrite Pos.peano_rect_succ.
    cset_tac'.
    + eapply IHi.
      eapply inj_lt.
      eapply inj_lt in H.
      rewrite Pos2Nat.inj_succ in *.
      decide (Pos.to_nat i = Pos.to_nat x).
      * simpl in *. exfalso. eapply n. hnf.
        eapply Pos2Nat.inj in e. eauto.
      * omega.
    + eapply inj_lt.
      rewrite Pos2Nat.inj_succ. omega.
    + eapply IHi in H0.
      eapply inj_lt in H0.
      eapply inj_lt.
      rewrite Pos2Nat.inj_succ. omega.
Qed.

Lemma in_vars_up_to (n m:var)
: (n < m)%positive -> n ∈ vars_up_to m.
Proof.
  intros. eapply vars_up_to_in. eauto.
Qed.

Lemma in_vars_up_to' n m
: (n <= m)%positive -> n ∈ vars_up_to (m + 1)%positive.
Proof.
  intros. eapply vars_up_to_in.
  eapply inj_lt. eapply inj_le in H.
  rewrite Pos.add_1_r. rewrite Pos2Nat.inj_succ. omega.
Qed.

Lemma vars_up_to_incl n m
: (n <= m)%positive -> vars_up_to n ⊆ vars_up_to m.
Proof.
  intros H x IN. eapply vars_up_to_in; eapply vars_up_to_in in IN.
  eapply inj_lt; eapply inj_lt in IN. eapply inj_le in H. omega.
Qed.

Lemma vars_up_to_max n m
: vars_up_to (Pos.max n m) [=] vars_up_to n ∪ vars_up_to m.
Proof.
  hnf. intros.
  rewrite <- !vars_up_to_in.
  cset_tac'.
  - rewrite <- !vars_up_to_in in *.
    rewrite inj_lt in *.
    rewrite Pos2Nat.inj_max in *.
    decide ((Pos.to_nat n) <= (Pos.to_nat m)).
    + rewrite Max.max_r in H; eauto.
    + rewrite Max.max_l in H; omega.
  - rewrite <- !vars_up_to_in in *.
    rewrite inj_lt in *.
    rewrite Pos2Nat.inj_max in *.
    decide ((Pos.to_nat n) <= (Pos.to_nat m)).
    + rewrite Max.max_r; omega.
    + rewrite Max.max_l; omega.
  - rewrite <- !vars_up_to_in in *.
    rewrite inj_lt in *.
    rewrite Pos2Nat.inj_max in *.
    decide ((Pos.to_nat n) <= (Pos.to_nat m)).
    + rewrite Max.max_r; omega.
    + rewrite Max.max_l; omega.
Qed.


Require Import List.
Set Implicit Arguments.

Inductive lfactor (A:Set) : list A -> list A -> Prop :=
  | lf1 : forall u:list A, lfactor nil u
  | lf2 : forall (a:A) (u v:list A), lfactor u v ->
                                     lfactor (a :: u) (a :: v).

Definition lfactor_suffix :
  forall (A:Set) (u v:list A), lfactor u v -> {w : list A | v = u ++ w}.
 intros A u; elim u.
 intros v; exists v; auto.
 intros a u' Hrec v; case v.
 intros Hf; cut False.
 contradiction.
 inversion Hf.
 intros b v' Hf.
 elim (Hrec v').
 intros r Heq; exists r.
 inversion Hf.
 simpl in |- *; rewrite <- Heq.
 trivial.
 inversion Hf; assumption.
Defined.


Require Import Specif.
Require Import Orders.
Require Import OrdersEx.
Require Import MSets.
Require Import Arith.
Require Import Omega.

Module NatSet := Make Nat_as_OT.
Module NatSetFacts := Facts NatSet.

Section MSet_set.

  Import NatSet.

  Definition has_upper_bound n
    := For_all (gt n).

  Definition MFinNatSet (n:nat) : Type
    := {s: t | has_upper_bound n s}.

  Definition MsingleS (n:nat) (i:nat): MFinNatSet n.
  Proof.
    unfold MFinNatSet.
    case (lt_dec i n); intros H.
    -
      exists (singleton i).
      unfold has_upper_bound, For_all.
      intros x I.
      apply singleton_spec in I.
      omega.
    -
      exists empty.
      unfold has_upper_bound, For_all.
      intros x I.
      apply empty_spec in I.
      contradiction.
  Defined.

  Example MFoo: Empty (inter
                         (proj1_sig (MsingleS 5 2))
                         (proj1_sig (MsingleS 5 1))).
  Proof.
    simpl.
    unfold Empty.
    intros a H.
    apply inter_spec in H.
    destruct H as [H1 H2].
    apply singleton_spec in H1.
    apply singleton_spec in H2.
    congruence.
  Qed.

  (* Unbounded version *)
  Fixpoint NatSet_indexf (n:nat) (f: nat -> bool): NatSet.t :=
    match n with
    | O => empty
    | S j => union
              (if f j then singleton j else empty)
              (NatSet_indexf j f)
    end.

  Lemma empty_upper_bound:
    has_upper_bound 0 empty.
  Proof.
    unfold has_upper_bound.
    unfold For_all.
    intros x H.
    apply empty_spec in H.
    contradiction.
  Qed.

  Lemma lt_gt:
    forall m n, m < n <-> n > m.
  Proof.
    intros m n.
    split; intros;omega.
  Qed.

  Lemma max_lb_l: forall n m p : nat, n > p -> max n m > p.
  Proof.
    intros n m p H.
    assert (D: n < m /\ Nat.max n m = m \/ m <= n /\ Nat.max n m = n) by apply Max.max_spec.
    destruct D; omega.
  Qed.

  Lemma max_lb_r: forall n m p : nat, m > p -> max n m > p.
  Proof.
    intros n m p H.
    assert (D: n < m /\ Nat.max n m = m \/ m <= n /\ Nat.max n m = n) by apply Max.max_spec.
    destruct D; omega.
  Qed.

  Lemma union_upper_bound
        (ba bb:nat)
        (a b: t):
    has_upper_bound ba a -> has_upper_bound bb b ->
    has_upper_bound (max ba bb) (union a b).
  Proof.
    intros A B.
    unfold has_upper_bound, For_all in *.
    intros x I.
    specialize (A x).
    specialize (B x).
    rewrite union_spec in *.
    destruct I as [IA | IB].
    -
      apply A in IA.
      apply max_lb_l, IA.
    -
      apply B in IB.
      apply max_lb_r, IB.
  Qed.

  Lemma singleton_upper_bound:
    forall n, has_upper_bound (S n) (singleton n).
  Proof.
    intros n.
    unfold has_upper_bound, For_all.
    intros x H.
    apply singleton_spec in H.
    omega.
  Qed.

  Lemma weaken_upper_bound:
    forall s n m, m>=n -> has_upper_bound n s -> has_upper_bound m s.
  Proof.
    intros s n m D U.
    unfold has_upper_bound, For_all in *.
    intros x H.
    specialize (U x H).
    omega.
  Qed.

  Lemma max_sn_n:
    forall n : nat, Init.Nat.max (S n) n = S n.
  Proof.
    intros n.
    induction n.
    reflexivity.
    rewrite <- IHn at 3.
    rewrite Max.succ_max_distr.
    reflexivity.
  Qed.

  Definition build_FinNatSet (n:nat) (f: nat -> bool): MFinNatSet n.
  Proof.
    exists (NatSet_indexf n f).
    induction n.
    -
      apply empty_upper_bound.
    -
      simpl.
      replace (S n) with (max (S n) n).
      apply union_upper_bound.
      case (f n).
      + apply singleton_upper_bound.
      + assert (E: has_upper_bound 0 empty) by apply empty_upper_bound.
        apply weaken_upper_bound with (m:=S n) in E.
        apply E.
        omega.
      + apply IHn.
      + apply max_sn_n.
  Defined.

  Definition full_set (n:nat) (m b:nat): MFinNatSet n :=
    build_FinNatSet n (fun _ => true).

End MSet_set.


Require Import Classes.RelationClasses.
Require Import Permutation.

From CoqAlgs Require Export Base.
From CoqAlgs Require Export Ord.
From CoqAlgs Require Export Data.ListLemmas.

(*Set Universe Polymorphism.*)

Fixpoint count {A : Type} (p : A -> bool) (l : list A) : nat :=
match l with
    | [] => 0
    | h :: t => (if p h then 1 else 0) + count p t
end.

Definition perm {A : Type} (l1 l2 : list A) : Prop :=
  forall p : A -> bool, count p l1 = count p l2.

(* Lemmas about [count]. *)

Lemma count_app :
  forall (A : Type) (p : A -> bool) (l1 l2 : list A),
    count p (l1 ++ l2) = count p l1 + count p l2.
Proof.
  induction l1; cbn; intros.
    reflexivity.
    rewrite IHl1. destruct (p a); cbn; reflexivity.
Qed.

Lemma count_app_comm :
  forall (A : Type) (p : A -> bool) (l1 l2 : list A),
    count p (l1 ++ l2) = count p (l2 ++ l1).
Proof.
  induction l1 as [| h1 t1]; cbn; intros.
    rewrite app_nil_r. reflexivity.
    rewrite !count_app. cbn. destruct (p h1); lia.
Qed.

Lemma count_last :
  forall (A : Type) (p : A -> bool) (l : list A) (x : A),
    count p (l ++ [x]) = count p l + count p [x].
Proof.
  intros. rewrite count_app. reflexivity.
Qed.

Lemma count_reverse :
  forall (A : Type) (p : A -> bool) (l : list A),
    count p (rev l) = count p l.
Proof.
  induction l as [| h t]; cbn; intros.
    reflexivity.
    rewrite count_app, IHt. cbn. destruct (p h); lia.
Qed.

Lemma count_cons :
  forall (A : Type) (p : A -> bool) (h : A) (t : list A),
    p h = true -> count p (h :: t) = 1 + count p t.
Proof.
  intros. cbn. rewrite H. reflexivity.
Qed.

Lemma count_filter :
  forall (A : Type) (p1 p2 : A -> bool) (t : list A),
    count p1 t = count p1 (filter p2 t) +
                 count p1 (filter (fun x : A => negb (p2 x)) t).
Proof.
  induction t as [| h' t']; cbn.
    reflexivity.
    destruct (p1 h') eqn: H, (p2 h'); cbn; rewrite ?H, ?IHt'; try
      lia.
Qed.

Lemma count_In :
  forall (A : Type) (p : A -> bool) (l : list A),
    Exists (fun x => p x = true) l <-> count p l <> 0.
Proof.
  split.
    induction 1; cbn.
      rewrite H. inv 1.
      destruct (p x).
        inv 1.
        assumption.
    induction l as [| h t]; cbn; intros.
      contradiction.
      destruct (p h) eqn: Hph.
        left. assumption.
        right. apply IHt, H.
Qed.

Lemma count_0_nil :
  forall (A : Type) (l : list A),
    (forall p : A -> bool, count p l = 0) -> l = [].
Proof.
  induction l as [| h t]; cbn; intros.
    reflexivity.
    specialize (H (fun _ => true)). cbn in H. congruence.
Qed.

(* Lemmas about [perm]. *)
Lemma perm_refl :
  forall (A : Type) (l : list A), perm l l.
Proof. unfold perm; auto. Defined.

Lemma perm_symm :
  forall (A : Type) (l1 l2 : list A),
    perm l1 l2 -> perm l2 l1.
Proof. unfold perm; auto. Defined.

Lemma perm_trans :
  forall (A : Type) (l1 l2 l3 : list A),
    perm l1 l2 -> perm l2 l3 -> perm l1 l3.
Proof.
  unfold perm; intros. eapply eq_trans; auto.
Defined.

Lemma perm_cons :
  forall (A : Type) (x : A) (l1 l2 : list A),
    perm l1 l2 -> perm (x :: l1) (x :: l2).
Proof.
  unfold perm. intros. simpl. rewrite H. reflexivity.
Defined.

Lemma perm_nil_cons :
  forall (A : Type) (h : A) (t : list A),
    ~ perm (h :: t) [].
Proof.
  unfold not; intros.
  red in H. specialize (H (fun _ => true)).
  cbn in H. inversion H.
Qed.

Lemma perm_swap :
  forall (A : Type) (x y : A) (l1 l2 : list A),
    perm l1 l2 -> perm (x :: y :: l1) (y :: x :: l2).
Proof.
  unfold perm; cbn; intros.
  destruct (p x), (p y); rewrite ?H; reflexivity.
Defined.

Theorem perm_front :
  forall (A : Type) (x : A) (l1 l2 : list A),
    perm (l1 ++ x :: l2) (x :: l1 ++ l2).
Proof.
  induction l1 as [| h1 t1]; simpl; intros.
    apply perm_refl.
    eapply perm_trans with (h1 :: x :: t1 ++ l2).
      apply perm_cons. apply IHt1.
      apply perm_swap. apply perm_refl.
Qed.

#[global] Hint Resolve perm_refl perm_symm perm_cons perm_swap perm_front : core.

Lemma perm_app_comm :
  forall (A : Type) (l1 l2 : list A),
    perm (l1 ++ l2) (l2 ++ l1).
Proof.
  unfold perm. intros. apply count_app_comm.
Qed.

Lemma perm_app :
  forall (A : Type) (l1 l1' l2 l2' : list A),
    perm l1 l1' -> perm l2 l2' -> perm (l1 ++ l2) (l1' ++ l2').
Proof.
  unfold perm; intros. rewrite 2 count_app, H, H0. auto.
Qed.

Lemma Exists_dec :
  forall (A : Ord) (x : A) (l : list A),
    Exists (fun y => y = x) l <->
    Exists (fun y => y =? x = true) l.
Proof.
  split; induction 1; subst; auto.
    left. trich.
    trich.
Qed.

Lemma perm_In :
  forall (A : Ord) (x : A) (l l' : list A),
    In x l -> perm l l' -> In x l'.
Proof.
  intros. rewrite In_Exists, Exists_dec in *.
  rewrite count_In. red in H0. rewrite <- H0, <- count_In.
  assumption.
Qed.

#[export]
Instance Equiv_perm (A : Type) : Equivalence (@perm A).
Proof.
  split; red; intros; eauto. eapply perm_trans; eauto.
Defined.

Lemma perm_singl :
  forall (A : Ord) (x : A) (l : list A),
    perm [x] l -> l = [x].
Proof.
  unfold perm; destruct l as [| h1 [| h2 t]]; cbn; intros.
    specialize (H (fun _ => true)). cbn in H. inv H.
    specialize (H (fun y => y =? h1)). cbn in H. trich.
    {
      assert (H1 := H (fun y => y =? h1)).
      assert (H2 := H (fun y => y =? h2)).
      cbn in *. trich.
    }
Qed.

Lemma perm_cons_inv :
  forall (A : Type) (h : A) (t1 t2 : list A),
    perm (h :: t1) (h :: t2) -> perm t1 t2.
Proof.
  unfold perm; intros.
  specialize (H p). cbn in H.
  destruct (p h).
    inv H.
    assumption.
Qed.

Lemma removeFirst_In_perm :
  forall (A : Ord) (p : A -> bool) (x : A) (l : list A),
    In x l -> p x = true ->
      perm l (x :: removeFirst (fun y => y =? x) l).
Proof.
  induction l as [| h t]; cbn; inv 1; trich.
  intro. rewrite perm_swap.
    apply perm_cons, IHt; assumption.
    reflexivity.
Qed.

Function removeFirst' {A : Type} (p : A -> bool) (l : list A) : option (A * list A) :=
match l with
    | [] => None
    | h :: t =>
        if p h
        then Some (h, t)
        else
          match removeFirst' p t with
              | None => None
              | Some (x, l') => Some (x, h :: l')
          end
end.

Lemma removeFirst'_perm :
  forall {A : Type} {p : A -> bool} {l l' : list A} {x : A},
    removeFirst' p l = Some (x, l') ->
      perm l (x :: l').
Proof.
  intros until l.
  functional induction removeFirst' p l;
  inv 1.
  rewrite perm_swap.
    apply perm_cons, IHo. eassumption.
    reflexivity.
Qed.

Lemma perm_In' :
  forall (A : Ord) (h : A) (t l : list A),
    perm (h :: t) l -> In h l.
Proof.
  intros. rewrite In_Exists, Exists_dec, count_In, <- H. cbn. trich.
Qed.

Lemma count_removeFirst_neq :
  forall (A : Ord) (x y : A) (l : list A),
    x <> y -> count (fun z => z =? x) (removeFirst (fun z => z =? y) l) =
              count (fun z => z =? x) l.
Proof.
  induction l as [| h t]; cbn; intros; trich; trich.
Qed.

Lemma count_removeFirst_In :
  forall (A : Type) (p : A -> bool) (l : list A),
    Exists (fun x => p x = true) l ->
      count p (removeFirst p l) = count p l - 1.
Proof.
  induction l as [| h t]; cbn; intros.
    reflexivity.
    destruct (p h) eqn: Hph; cbn.
      lia.
      rewrite Hph. inv H.
Qed.

Fixpoint removeFirst'' {A : Type} (p : A -> bool) (l : list A) : option (list A * A * list A) :=
match l with
    | [] => None
    | h :: t =>
        if p h
        then Some ([], h, t)
        else
          match removeFirst'' p t with
              | None => None
              | Some (start, x, rest) => Some (h :: start, x, rest)
          end
end.

Functional Scheme removeFirst''_ind := Induction for removeFirst'' Sort Prop.

Lemma perm_removeFirst'' :
  forall {A : Type} {p : A -> bool} {l s e : list A} {x : A},
    removeFirst'' p l = Some (s, x, e) ->
      perm l (s ++ x :: e).
Proof.
  intros until l.
  functional induction removeFirst'' p l;
  inv 1.
    cbn. apply perm_cons, IHo. assumption.
Qed.

Lemma removeFirst''_Exists_Some :
  forall {A : Type} {p : A -> bool} {l : list A},
    Exists (fun x : A => p x = true) l ->
      exists (s e : list A) (x : A),
        removeFirst'' p l = Some (s, x, e).
Proof.
  intros until l.
  functional induction removeFirst'' p l;
  inv 1.
    do 3 eexists. reflexivity.
    do 3 eexists. reflexivity.
    do 3 eexists. reflexivity.
    destruct (IHo H1) as (s & e & x & IH). congruence.
Qed.

Lemma removeFirst''_spec :
  forall {A : Type} {p : A -> bool} {l s e : list A} {x : A},
    removeFirst'' p l = Some (s, x, e) ->
      l = s ++ x :: e.
Proof.
  intros until l.
  functional induction removeFirst'' p l;
  inv 1.
    rewrite (IHo _ _ _ e1). reflexivity.
Qed.

Lemma removeFirst''_spec' :
  forall {A : Type} {p : A -> bool} {l s e : list A} {x : A},
    removeFirst'' p l = Some (s, x, e) ->
      p x = true.
Proof.
  intros until l.
  functional induction removeFirst'' p l;
  inv 1.
    eapply IHo. eassumption.
Qed.

Lemma removeFirst''_spec'' :
  forall {A : Type} {p : A -> bool} {l : list A},
    removeFirst'' p l = None ->
      Forall (fun x : A => p x = false) l.
Proof.
  intros until l.
  functional induction removeFirst'' p l;
  inv 1.
Qed.

Lemma count_removeFirst''_None :
  forall {A : Type} {p : A -> bool} {l : list A},
    removeFirst'' p l = None ->
      count p l = 0.
Proof.
  intros until l.
  functional induction removeFirst'' p l;
  inv 1.
  cbn. destruct (p h).
    congruence.
    auto.
Qed.

Lemma perm_front_ex' :
  forall (A : Ord) (h : A) (t l : list A),
    perm (h :: t) l -> exists l1 l2 : list A,
      l = l1 ++ h :: l2 /\ perm (l1 ++ l2) t.
Proof.
  intros.
  destruct (removeFirst'' (fun x : A => x =? h) l) eqn: Hrf.
    destruct p as [[s x] e]. rewrite (removeFirst''_spec Hrf).
      exists s, e. split.
        do 2 f_equal. apply removeFirst''_spec' in Hrf. cbn in Hrf. trich.
        apply (perm_cons_inv _ h). rewrite H, (perm_removeFirst'' Hrf), perm_front.
          apply removeFirst''_spec' in Hrf. cbn in Hrf. trich.
    apply count_removeFirst''_None in Hrf. specialize (H (fun x : A => x =? h)).
      cbn in H. trich.
Qed.

Theorem Permutation_perm :
  forall (A : Type) (l1 l2 : list A),
    Permutation l1 l2 -> perm l1 l2.
Proof.
  induction 1; cbn; intros; auto.
    eapply perm_trans; eauto.
Qed.

Theorem perm_Permutation :
  forall (A : Ord) (l1 l2 : list A),
    perm l1 l2 -> Permutation l1 l2.
Proof.
  induction l1 as [| h1 t1]; cbn; intros.
    destruct l2; cbn; auto. red in H. cbn in H.
      specialize (H (fun _ => true)). inv H.
    apply perm_front_ex' in H. destruct H as (l1 & l3 & H1 & H3). subst.
      rewrite <- Permutation_cons_app.
        reflexivity.
        apply IHt1. symmetry. assumption.
Qed.

(** Moved from ListLemmas to avoid circularity. *)

Lemma perm_min_front :
  forall (A : Ord) (h : A) (t : list A),
    let m := min_dflt A h t in
      perm (m :: removeFirst (fun x => x =? m) (h :: t)) (h :: t).
Proof.
  intros. destruct (min_split A h t) as [l1 [l2 [H H']]].
  fold m in H, H'. rewrite H, <- H' in *. apply perm_symm, perm_front.
Qed.

Theorem trifilter_spec' :
  forall (A : Ord) (pivot : A) (l lo eq hi : list A),
    trifilter pivot l = (lo, eq, hi) ->
      perm (lo ++ eq) (filter (fun x : A => x ≤? pivot) l)
        /\
      hi = filter (fun x : A => pivot <? x) l.
Proof.
  intros. rewrite trifilter_spec in H.
  inv H. split.
    induction l as [| h t]; cbn.
      reflexivity.
      trich.
        cbn. apply perm_cons. assumption.
        rewrite perm_front. apply perm_cons. assumption.
    reflexivity.
Qed.


Require Import Coq.Lists.List Program. Import ListNotations.
Require Import SyDPaCC.Core.Bmf SyDPaCC.Support.List.
Set Implicit Arguments.
Generalizable All Variables.

(*---------------------------------------------------------*)

(** * The Diffusion Theorem for Accumulative Computations  *)

Theorem diffusion:
  forall A B C (h: B -> list A -> C) (g:B->C) (p:A*B->C) (q:A->B)
    (oplus:C->C->C) (otimes:B->B->B)
    `(Monoid _ oplus e_oplus)
    `(Monoid _ otimes e_otimes),
    (forall c, h c [] = g c) ->
    (forall c x xs,  h c (x::xs) = oplus (p (x,c)) (h (otimes c (q x)) xs)) ->
    forall xs c,
      let bs := map (otimes c) (scan otimes (map q xs)) in
      let ys := List.combine xs (removelast bs) in
      h c xs = oplus ( reduce oplus (map p ys) ) (g (last bs)).
Proof.
  intros A B C h g p q oplus otimes e_oplus Hopluq e_otimes Hotimes H1 H2.
  induction xs as [ | x xs IH]; intros c bs ys.
  - rewrite H1; unfold bs; compute.
    now rewrite left_neutral, right_neutral.
  - assert(bs = c :: map (otimes (otimes c (q x))) (scan otimes (map q xs))) as Hbs.
    {
      clear; unfold bs; simpl; clear bs.
      rewrite right_neutral. f_equal.
      autounfold with sydpacc; repeat rewrite <- scanl_map.
      f_equal.
      symmetry; rewrite right_neutral.
      f_equal; now rewrite left_neutral.
    }
    assert(last bs = last (map(otimes(otimes c (q x)))(scan otimes (map q xs)))) as Hlast.
    {
      assert(last bs = last (c::map(otimes(otimes c (q x)))(scan otimes (map q xs)))) as H'
          by now apply last_pi.
      rewrite H'.
      apply last_cons_non_empty.
    }
    set(bs' := map (otimes (otimes c (q x))) (scan otimes (map q xs))) in *.
    set(ys' := combine xs (removelast bs')).
    assert(ys = (x,c)::ys') as Hys.
    {
      unfold ys, ys'.
      rewrite Hbs.
      replace (c :: bs') with ([c] ++ bs') by trivial.
      now rewrite removelast_app by (apply non_emptiness; typeclasses eauto).
    }
    rewrite Hys.
    replace (g(last bs)) with (g(last bs'))
      by (f_equal; now rewrite <- Hlast).
    simpl. rewrite reduce_eq.
    rewrite H2.
    rewrite IH.
    now rewrite associative.
Qed.

Theorem diffusion_scanl_last:
  forall A B C (h: B -> list A -> C) (g:B->C) (p:A*B->C) (q:A->B)
    (oplus:C->C->C) (otimes:B->B->B)
    `(Monoid _ oplus e_oplus)
    `(Monoid _ otimes e_otimes),
    (forall c, h c [] = g c) ->
    (forall c x xs,  h c (x::xs) = oplus (p (x,c)) (h (otimes c (q x)) xs)) ->
    forall xs c,
      let bsb := scanl_last otimes e_otimes (map q xs) in
      let (bs,b) := (map (otimes c) (fst bsb), otimes c (snd bsb)) in
      let ys := List.combine xs bs in
      h c xs = oplus ( reduce oplus (map p ys) ) (g b).
Proof.
  intros A B C h g p q oplus otimes e_oplus Moplus e_otimes Motimes Heq1 Heq2 xs c bsb.
  set(Diff := diffusion h g p q Moplus Motimes Heq1 Heq2).
  rewrite Diff; simpl; unfold bsb; do 2 f_equal.
  - unfold scan; rewrite scanl_scanl_last; simpl.
    rewrite removelast_map, removelast_app by
      (intros; discriminate); simpl.
    now rewrite app_nil_r.
  - rewrite last_map; f_equal.
    unfold scan; erewrite last_pi with (l':=scanl otimes e_otimes (map q xs)) by auto.
    apply last_scanl.
Qed.

(** * The Sequential [accumulate] Function *)

Fixpoint accumulate A B C (g:B->C) (p:A*B->C) (q:A->B)(oplus:C->C->C) (otimes:B->B->B)
         c l : C :=
  match l with
  | [ ] => g c
  | x::xs => oplus (p (x,c)) (accumulate g p q oplus otimes (otimes c (q x)) xs)
  end.

Open Scope sydpacc_scope.

(** * Diffusion for [accumulate] *)

#[export] Instance diffusion_accumulate
         `(g:B->C) `(p:A*B->C) (q:A->B)
         `{Hp:Monoid C oplus e_oplus} `{Ht:Monoid B otimes e_otimes}
         (c:B) :
  Opt (accumulate g p q oplus otimes c)
      ( (prod_curry oplus)
          ∘ ( ((prod_curry (fold_left2 (fun (u:C) (vw:A*B)=>oplus u (p vw)) e_oplus)) × g )
                ∘ ( ( (id × fst) △ (snd ∘ snd) )
                      ∘ ( id △ (scanl_last (fun s t=>otimes s (q t)) c) ) ) ) ).
Proof.
  constructor; intro xs; autounfold with sydpacc; simpl.
  set(Diff := diffusion_scanl_last (accumulate g p q oplus otimes) g p q Hp Ht); simpl in Diff.
  rewrite Diff by auto; unfold reduce.
  rewrite fold_left2_prop2.
  repeat rewrite scanl_last_fst_scanl.
  rewrite <- removelast_map.
  rewrite <- @scanl_map with (op:=otimes)(x:=c) by typeclasses eauto.
  repeat rewrite scanl_last_snd.
  erewrite map_scanl by typeclasses eauto.
  rewrite fold_left_map_r with (g:=q).
  rewrite <- fold_left_prop by typeclasses eauto.
  now repeat rewrite @right_neutral with (op:=otimes) by typeclasses eauto.
Qed.

Close Scope sydpacc_scope.


(************************************************************************)
(* Copyright 2006 Milad Niqui                                           *)
(* This file is distributed under the terms of the                      *)
(* GNU Lesser General Public License Version 2.1                        *)
(* A copy of the license can be found at                                *)
(*                  <http://www.gnu.org/licenses/lgpl-2.1.html>         *)
(************************************************************************)

From QArithSternBrocot Require Export Qsyntax.
From QArithSternBrocot Require Export Field_Theory_Q.
From QArithSternBrocot Require Export Q_ordered_field_properties.

Definition Qmax p q := if Q_le_lt_dec p q then q else p.

Definition Qmin p q := if Q_le_lt_dec p q then p else q.

Lemma Qle_max_l: forall p q, p <= Qmax p q.
Proof.
 intros p q; unfold Qmax; destruct (Q_le_lt_dec p q); simpl; trivial.
Qed.

Lemma Qle_max_r: forall p q, q <= Qmax p q.
Proof.
 intros p q; unfold Qmax; destruct (Q_le_lt_dec p q); auto.
Qed.

Lemma Qmax_lub: forall q1 q2 p, q1 <= p -> q2 <= p -> Qmax q1 q2 <= p.
Proof.
 intros q1 q2 p H1 H2; unfold Qmax; destruct (Q_le_lt_dec q1 q2); trivial.
Qed.

Lemma Qmax_Qlt_upper_bound:forall p q1 q2, p<q1 -> p<q2 ->p < Qmax q1 q2.
Proof.
 intros p q1 q2 H1 H2; unfold Qmax; destruct (Q_le_lt_dec q1 q2); trivial.
Qed.

Lemma Qmax_nondecreasing: forall q1 q2 p1 p2, q1 <= p1 -> q2 <= p2 -> Qmax q1 q2 <= Qmax p1 p2.
Proof.
 intros q1 q2 p1 p2 H1 H2; unfold Qmax; destruct (Q_le_lt_dec q1 q2); destruct (Q_le_lt_dec p1 p2); trivial;
 [apply Qlt_le_weak; apply Qle_lt_trans with p2 | apply Qle_trans with p1]; trivial.
Qed.

Lemma Qmin_Qmax_Qle:forall q1 q2, Qmin q1 q2 <= Qmax q1 q2.
Proof.
 intros q1 q2; unfold Qmax, Qmin; destruct (Q_le_lt_dec q1 q2); trivial; apply Qlt_le_weak; assumption.
Qed.

Lemma Qmin_nondecreasing: forall q1 q2 p1 p2, q1 <= p1 -> q2 <= p2 -> Qmin q1 q2 <= Qmin p1 p2.
Proof.
 intros q1 q2 p1 p2 H1 H2; unfold Qmin; destruct (Q_le_lt_dec q1 q2); destruct (Q_le_lt_dec p1 p2); trivial;
 [apply Qle_trans with q2| apply Qlt_le_weak; apply Qlt_le_trans with q1]; trivial.
Qed.

Lemma Qmin_glb: forall q1 q2 p, p<=q1 -> p<=q2 -> p<=Qmin q1 q2.
Proof.
 intros q1 q2 p H1 H2; unfold Qmin; destruct (Q_le_lt_dec q1 q2); trivial.
Qed.

Lemma Qmin_Qlt_upper_bound:forall p q1 q2, p<q1 -> p<q2 ->p < Qmin q1 q2.
Proof.
 intros p q1 q2 H1 H2; unfold Qmin; destruct (Q_le_lt_dec q1 q2); trivial.
Qed.

Lemma Qle_min_l: forall p q : Q, Qmin p q <= p.
Proof.
 intros p q; unfold Qmin; destruct (Q_le_lt_dec p q); trivial ; apply Qlt_le_weak; assumption.
Qed.

Lemma Qle_min_r: forall p q : Q, Qmin p q <= q.
Proof.
 intros p q; unfold Qmin; destruct (Q_le_lt_dec p q); trivial ; apply Qlt_le_weak; assumption.
Qed.

Lemma Qmax_or_informative:forall p q, {Qmax p q = p} + {Qmax p q = q}.
Proof.
 intros p q; unfold Qmax; destruct (Q_le_lt_dec p q); auto.
Qed.

Lemma Qmin_or_informative:forall p q, {Qmin p q = p} + {Qmin p q = q}.
Proof.
 intros p q; unfold Qmin; destruct (Q_le_lt_dec p q); auto.
Qed.

Definition Qmax4 q1 q2 q3 q4 := Qmax (Qmax q1 q2) (Qmax q3 q4).
Definition Qmin4 q1 q2 q3 q4 := Qmin (Qmin q1 q2) (Qmin q3 q4).

Lemma Qmax4_informative:forall q1 q2 q3 q4, {Qmax4 q1 q2 q3 q4=q1} + {Qmax4 q1 q2 q3 q4=q2} + {Qmax4 q1 q2 q3 q4=q3} + {Qmax4 q1 q2 q3 q4=q4}.
Proof.
 intros q1 q2 q3 q4; unfold Qmax4;
 destruct (Qmax_or_informative (Qmax q1 q2) (Qmax q3 q4)) as [H|H]; rewrite H;
  [ left; left; exact (Qmax_or_informative q1 q2)
  | destruct (Qmax_or_informative q3 q4) as [H'|H']; rewrite H'; auto].
Qed.

Lemma Qmin4_informative:forall q1 q2 q3 q4, {Qmin4 q1 q2 q3 q4=q1} + {Qmin4 q1 q2 q3 q4=q2} + {Qmin4 q1 q2 q3 q4=q3} + {Qmin4 q1 q2 q3 q4=q4}.
Proof.
 intros q1 q2 q3 q4; unfold Qmin4;
 destruct (Qmin_or_informative (Qmin q1 q2) (Qmin q3 q4)) as [H|H]; rewrite H;
  [ left; left; exact (Qmin_or_informative q1 q2)
  | destruct (Qmin_or_informative q3 q4) as [H'|H']; rewrite H'; auto].
Qed.

Lemma Qmin4_Qmax4_Qle:forall q1 q2 q3 q4, Qmin4 q1 q2 q3 q4<= Qmax4 q1 q2 q3 q4.
Proof.
 intros q1 q2 q3 q4; unfold Qmax4, Qmin4;
 apply Qle_trans with (Qmin (Qmax q1 q2) (Qmax q3 q4)); [apply Qmin_nondecreasing|]; apply Qmin_Qmax_Qle.
Qed.

Lemma Qle_Qmax4_1:forall q1 q2 q3 q4, q1<=Qmax4 q1 q2 q3 q4.
Proof.
 intros q1 q2 q3 q4; apply Qle_trans with (Qmax q1 q2); unfold Qmax4; apply Qle_max_l.
Qed.

Lemma Qle_Qmax4_2:forall q1 q2 q3 q4, q2<=Qmax4 q1 q2 q3 q4.
Proof.
 intros q1 q2 q3 q4; apply Qle_trans with (Qmax q1 q2); unfold Qmax4; apply Qle_max_l || apply Qle_max_r.
Qed.

Lemma Qle_Qmax4_3:forall q1 q2 q3 q4, q3<=Qmax4 q1 q2 q3 q4.
Proof.
 intros q1 q2 q3 q4; apply Qle_trans with (Qmax q3 q4); unfold Qmax4; apply Qle_max_l || apply Qle_max_r.
Qed.

Lemma Qle_Qmax4_4:forall q1 q2 q3 q4, q4<=Qmax4 q1 q2 q3 q4.
Proof.
 intros q1 q2 q3 q4; apply Qle_trans with (Qmax q3 q4); unfold Qmax4; apply Qle_max_r.
Qed.

Lemma Qle_Qmin4_1:forall q1 q2 q3 q4, Qmin4 q1 q2 q3 q4<= q1.
Proof.
 intros q1 q2 q3 q4; apply Qle_trans with (Qmin q1 q2); unfold Qmin4; apply Qle_min_l.
Qed.

Lemma Qle_Qmin4_2:forall q1 q2 q3 q4, Qmin4 q1 q2 q3 q4<= q2.
Proof.
 intros q1 q2 q3 q4; apply Qle_trans with (Qmin q1 q2); unfold Qmin4; apply Qle_min_l || apply Qle_min_r.
Qed.

Lemma Qle_Qmin4_3:forall q1 q2 q3 q4, Qmin4 q1 q2 q3 q4<= q3.
Proof.
 intros q1 q2 q3 q4; apply Qle_trans with (Qmin q3 q4); unfold Qmin4; apply Qle_min_l || apply Qle_min_r.
Qed.

Lemma Qle_Qmin4_4:forall q1 q2 q3 q4, Qmin4 q1 q2 q3 q4<= q4.
Proof.
 intros q1 q2 q3 q4; apply Qle_trans with (Qmin q3 q4); unfold Qmin4; apply Qle_min_r.
Qed.

Lemma Qmax4_Qlt_upper_bound:forall p q1 q2 q3 q4, p<q1 -> p<q2 -> p<q3 -> p<q4 -> p < Qmax4 q1 q2 q3 q4.
Proof.
 intros p q1 q2 q3 q4 H1 H2 H3 H4; unfold Qmax4; repeat apply Qmax_Qlt_upper_bound; assumption.
Qed.

Lemma Qlt_Qmin_upper_bound: forall p q1 q2 : Q, p < Qmin q1 q2 -> p < q1 /\ p < q2.
Proof.
 intros p q1 q2; split; apply Qlt_le_trans with (Qmin q1 q2); trivial; [apply Qle_min_l|apply Qle_min_r].
Qed.

Definition Qlt_Qmin_upper_bound_l p q1 q2 (hyp:p < Qmin q1 q2) : p < q1 :=proj1 (Qlt_Qmin_upper_bound p q1 q2 hyp).
Definition Qlt_Qmin_upper_bound_r p q1 q2 (hyp:p < Qmin q1 q2) : p < q2 :=proj2 (Qlt_Qmin_upper_bound p q1 q2 hyp).

Lemma Qmax_Qlt_lower_bound: forall p q1 q2 : Q, q1 < p  -> q2 < p -> Qmax q1 q2 < p.
Proof.
 intros p q1 q2 H1 H2; unfold Qmax; destruct (Q_le_lt_dec q1 q2); trivial.
Qed.

Lemma Qlt_Qmax_lower_bound: forall p q1 q2 : Q, Qmax q1 q2 < p -> q1 < p /\ q2 < p.
Proof.
 intros p q1 q2; split; apply Qle_lt_trans with (Qmax q1 q2); trivial; [apply Qle_max_l|apply Qle_max_r].
Qed.

Definition Qlt_Qmax_lower_bound_l p q1 q2 (hyp:Qmax q1 q2 < p) := proj1 (Qlt_Qmax_lower_bound p q1 q2 hyp).
Definition Qlt_Qmax_lower_bound_r p q1 q2 (hyp:Qmax q1 q2 < p) := proj2 (Qlt_Qmax_lower_bound p q1 q2 hyp).

Lemma Qmin_involutive : forall q, Qmin q q = q.
Proof.
 intros q; destruct (Qmin_or_informative q q); trivial.
Qed.

Lemma Qmax_involutive : forall q, Qmax q q = q.
Proof.
 intros q; destruct (Qmax_or_informative q q); trivial.
Qed.

Definition Qmean (x y:Q):Q := (x+y) / (Qone + Qone).

Lemma Qmean_property:forall (x y:Q), x < y -> x < Qmean x y /\ Qmean x y < y.
Proof.
 intros x y H; split; unfold Qmean.
  apply Qmult_pos_Qlt_Qdiv; auto; stepl (x+x); auto; ring.
  apply Qmult_pos_Qdiv_Qlt; auto; stepr (y+y); auto; ring.
Qed.

Definition Qmean_property_l x y (hyp:x<y) := proj1 (Qmean_property x y hyp).
Definition Qmean_property_r x y (hyp:x<y) := proj2 (Qmean_property x y hyp).

Lemma Qmean_incr: forall x1 x2 y1 y2, x1< x2 -> y1 < y2 ->  Qmean x1 y1 < Qmean x2 y2.
Proof.
 intros x1 x2 y1 y2 Hx Hy; unfold Qmean;
 apply Qmult_Qdiv_pos; auto;
 (stepl (x1 + x1 + y1 + y1) by ring); stepr (x2 + x2 + y2 + y2) ; auto; ring.
Qed.

Theorem Q_is_dense:forall x y, x<y -> {z:Q | x<z /\ z<y}.
Proof.
 intros x y Hxy; exists (Qmean x y); apply Qmean_property; trivial.
Qed.


Set Implicit Arguments.

Require Import kat normalisation rewriting kat_tac.
Require Import rel comparisons.

Require Import Packet.

Local Open Scope bool_scope.

Inductive pred : Type :=
| pr_true
| pr_false
| pr_and : pred -> pred -> pred
| pr_or : pred -> pred -> pred
| pr_not : pred -> pred
| pr_test : hdr -> val -> pred.

Inductive pol : Type :=
| po_id : pol
| po_drop : pol
| po_sum : pol -> pol -> pol
| po_seq : pol -> pol -> pol
| po_star : pol -> pol
| po_pred : pred -> pol
| po_upd : hdr -> val -> pol
| po_upd_obs : hdr -> val -> pol.

Definition test0 h v : dset trace :=
  fun tr => test h v (head tr).

Fixpoint eval_pred (pr : pred) : dset trace  :=
  match pr with
    | pr_and pr1 pr2 => eval_pred pr1 \cap eval_pred pr2
    | pr_or pr1 pr2 => eval_pred pr1 \cup eval_pred pr2
    | pr_true => top
    | pr_false => bot
    | pr_not pr' => ! (eval_pred pr')
    | pr_test h v => test0 h v
  end.

Definition upd0 h v : rel trace trace :=
  fun t1 t2 => replace_head (upd h v (head t1)) t1 = t2.

Definition obs0 h v : rel trace trace :=
  fun t1 t2 => tr_cons (upd h v (head t1)) t1 = t2.

Fixpoint eval_pol (po : pol) : rel trace trace :=
  match po with
    | po_id => 1
    | po_drop => 0
    | po_sum e1 e2 => eval_pol e1 + eval_pol e2
    | po_seq e1 e2 => eval_pol e1 * eval_pol e2
    | po_star e' => (eval_pol e')^*
    | po_pred pr => [eval_pred pr]
    | po_upd h v => upd0 h v
    | po_upd_obs h v => obs0 h v
  end.

Coercion po_pred : pred >-> pol.

Reserved Notation "h ~:= n" (at level 48, no associativity).
Reserved Notation "h ^:= n" (at level 48, no associativity).
Reserved Notation "h =? n" (at level 48, no associativity).
Reserved Notation "x ; y" (at level 50, left associativity).

Module KatNotation.

  Notation "h =? n" := (pr_test h n) : kat_scope.
  Notation "h ~:= n" := (po_upd h n) : kat_scope.
  Notation "h ^:= n" := (po_upd_obs h n) : kat_scope.
  Notation "x + y" := (po_sum x y) : kat_scope.
  Notation "x ; y" := (po_seq x y) : kat_scope.
  Notation "x ^*" := (po_star x) : kat_scope.
  Notation "#t" := pr_true : kat_scope.
  Notation "#f" := pr_false : kat_scope.
  Notation "x && y" := (pr_and x y) : kat_scope.
  Notation "x || y" := (pr_or x y) : kat_scope.
  Notation "p ~ q" := (eval_pol p == eval_pol q) (at level 80) : kat_scope.
  Notation "~ p" := (pr_not p).

End KatNotation.

Module Notation.

  Notation "h =? n" := (test0 h n) : netcore_scope.
  Notation "h ~:= n" := (upd0 h n) : netcore_scope.
  Notation "h ^:= n" := (obs0 h n) : netcore_scope.
  Notation "x + y" := (x + y) : netcore_scope.
  Notation "x ; y" := (x * y) : netcore_scope.
  Notation "p ~ q" :=
    (eval_pol p == eval_pol q) (at level 80) : netcore_scope.
  Notation "~ p" := (pr_not p).

End Notation.

Section DomainEquations.

  Variable h h1 h2 : hdr.
  Variable m n : val.

  Import Notation.
  Local Open Scope netcore_scope.

  Hint Unfold rel_dot rel_inj test0 obs0 upd0.
  Lemma upd_compress : (h~:=m) * (h~:=n) == (h~:=n).
  Proof with auto.
    simpl. intros. autounfold. split; intros.
    + destruct H.
      destruct (head a) as [[[sw pt] src] dst].
      subst.
      autorewrite with pkt using simpl...
      rewrite -> upd_upd_compress...
    + destruct (head a) as [[[sw pt] src] dst].
      subst. eexists. reflexivity.
      autorewrite with pkt using simpl...
      rewrite -> upd_upd_compress...
  Qed.

  Lemma upd_comm : h1 <> h2 -> h1~:=m; h2~:=n == h2~:=n; h1~:=m.
  Proof with auto.
    simpl. intros. autounfold. split; intros.
    + destruct H0.
      subst.
      destruct (head a) as [[[sw pt] src] dst].
      unfold not in H.
      destruct h1; destruct h2;
      try solve [contradiction H; trivial |
                 destruct a; eexists; simpl; eauto].
    + intros.
      destruct H0.
      subst.
      destruct (head a) as [[[sw pt] src] dst].
      unfold not in H.
      destruct h1; destruct h2;
      try solve [contradiction H; trivial |
                 destruct a; eexists; simpl; eauto].
  Qed.

  Lemma upd_test_compress : h~:=n; [h=?n] == h~:=n.
  Proof with eauto.
    simpl. intros. autounfold. split; intros.
    + destruct H. destruct H0. subst.
      trivial.
    + subst. eexists. reflexivity.
      unfold rel_inj.
      split...
      autorewrite with pkt using simpl.
      rewrite -> test_upd_true...
  Qed.

  Lemma upd_test_comm : h1 <> h2 -> h1~:=m; [h2=?n] == [h2=?n]; h1~:=m.
  Proof with eauto.
    simpl. intros. autounfold. split; intros.
    + destruct H0. destruct H1. subst.
      autorewrite with pkt in H2 using (simpl in H2). subst.
      rewrite -> test_upd_ignore in H2...
    + destruct H0. destruct H0. subst.
      eexists. reflexivity.
      split...
      autorewrite with pkt using simpl.
      rewrite -> test_upd_ignore...
  Qed.

  Lemma test_test_zero : m <> n -> [h=?m]; [h=?n] == bot.
  Proof with eauto.
    simpl. intros. autounfold. split; intros.
    + destruct H0 as [a1 [H0 H1] [H2 H3]].
      subst.
      assert (m = n).
      { eapply test_true_diff... }
      subst...
    + inversion H0.
  Qed.

  Lemma upd_test_zero : m <> n -> h~:=n; [h=?m] == bot.
  Proof with eauto.
    simpl. intros. autounfold. split; intros.
    destruct H0.
    + destruct H1. subst.
      remember (test h m (head a)) as b.
      destruct b.
      - subst.
        autorewrite with pkt in H2 using (simpl in H2)...
        rewrite -> test_upd_0 in H2...
        inversion H2.
      - subst.
        autorewrite with pkt in H2 using (simpl in H2)...
        rewrite -> test_upd_0 in H2...
        inversion H2.
    + inversion H0.
  Qed.

  Lemma obs_test_compress : h^:=n; [h=?n] == h^:=n.
  Proof with eauto.
    simpl. intros. autounfold. split; intros.
    + destruct H as [a1 H [H0 H1]]. subst.
      simpl in H1.
      rewrite -> test_upd_true in H1...
    + subst. eexists. reflexivity.
      split...
      simpl.
      rewrite -> test_upd_true...
  Qed.

  Lemma obs_test_comm : h1 <> h2 -> h1^:=m; [h2=?n] == [h2=?n]; h1^:=m.
  Proof with eauto.
    simpl. intros. autounfold. split; intros.
    + destruct H0 as [tr J [J0 J1]]. subst.
      simpl in J1.
      rewrite -> test_upd_ignore in J1...
    + destruct H0 as [tr [J0 J1] J]. subst.
      eexists...
      split...
      simpl.
      rewrite -> test_upd_ignore...
  Qed.

  Lemma obs_test_zero : m <> n -> h^:=m; [h=?n] == bot.
  Proof with eauto.
    simpl. intros. autounfold. split; intros.
    + destruct H0 as [tr J [J0 J1]]. subst.
      simpl in J1.
      rewrite -> test_upd_0 in J1...
      inversion J1.
    + inversion H0.
  Qed.

  Lemma obs_upd_compress : h^:=m; h~:=n == h^:=n.
  Proof with eauto.
    simpl. intros. autounfold. split; intros.
    + destruct H. subst. simpl.
      rewrite -> upd_upd_compress...
    + subst.
      eexists. reflexivity.
      simpl.
      rewrite -> upd_upd_compress...
  Qed.

End DomainEquations.

Ltac kat_simpl :=
  unfold eval_pol; unfold eval_pred; fold eval_pred; fold eval_pol.


Module FormulaTheory.
Require Export form name decidability feature_model.
Import Name Form Decidability FeatureModel.
Require Import Coq.Lists.ListSet Coq.Lists.List.

(*yields names for a formula*)
Fixpoint names_ (f : Formula) : set Name :=
  match f with
    | TRUE_FORMULA    => empty_set Name
    | FALSE_FORMULA   => empty_set Name
    | NAME_FORMULA n1 => set_add name_dec n1 nil
    | NOT_FORMULA f1  => names_ f1
    | AND_FORMULA f1 f2     => set_union name_dec  (names_ f1)
                                  (set_diff name_dec  (names_ f2) (names_ f1))
    | IMPLIES_FORMULA f1 f2 => set_union name_dec  (names_ f1)
                                  (set_diff name_dec  (names_ f2) (names_ f1))
  end.

(* indicates whether a formula is well-typed*)
Fixpoint wt (fm : FM) (f : Formula) : Prop :=
  match f with
    | TRUE_FORMULA    => True
    | FALSE_FORMULA   => True
    | NAME_FORMULA n1 => set_In n1 (fst fm)
    | NOT_FORMULA f1  => wt fm f1
    | AND_FORMULA f1 f2     => (wt fm f1) /\ (wt fm f2)
    | IMPLIES_FORMULA f1 f2 => (wt fm f1) /\ (wt fm f2)
   end.

(*indicates whether a feature model has all of its formulae well-typed*)
Definition wfFormulae (fm: FM) : Prop :=
  forall (f: Formula), set_In f (formulas fm) -> wt fm f.

(*indicates when a configuration satisfies a formula*)
Fixpoint satisfies (f: Formula) ( c : Configuration) : Prop :=
  match f with
    | TRUE_FORMULA   => True
    | FALSE_FORMULA  => False
    | NAME_FORMULA n => set_In n c
    | NOT_FORMULA f1 => not (satisfies f1 c)
    | AND_FORMULA f1 f2     => and(satisfies f1 c) (satisfies f2 c)
    | IMPLIES_FORMULA f1 f2 => (satisfies f1 c) -> (satisfies f2 c)
   end.

(*a well-typed formula only contains names from the feature model*)
Lemma formNames : forall (fm : FM) (f : Formula),
 (wt fm f) -> ( forall (n : Name), set_In n (names_ f) -> set_In n (fst fm)).
Proof.
induction f.
   + simpl. intuition.
   + simpl. intuition.
   + simpl. intuition. rewrite H1 in H. apply H.
   + intuition.
   + simpl. intros H ; destruct H. intros. apply set_union_elim in H1. inversion H1.
      - apply IHf1. apply H. apply H2.
      - apply set_diff_elim1 in H2. apply IHf2. apply H0. apply H2.
    + simpl. intros H. destruct H. intros. apply set_union_elim in H1. inversion H1.
      - apply IHf1. apply H. apply H2.
      - apply set_diff_elim1 in H2. apply IHf2. apply H0. apply H2.
Qed.

Lemma formNames2 : forall (fm : FM) (f : Formula) (n: Name) , and (wt fm f)
  (not(set_In n (fst fm))) -> (not(set_In n (names_ f))).
Proof.
induction f.
   + intuition.
   + intuition.
   + simpl. intuition. rewrite H in H1. apply H2. apply H1.
   + intuition.
   + simpl. intros. destruct H; destruct H.  intuition. apply set_union_elim in H2. inversion H2.
      - apply (IHf1 n). intuition. apply H3.
      - apply set_diff_elim1 in H3. apply (IHf2 n). intuition. apply H3.
   + simpl. intros. destruct H. destruct H. intuition. apply set_union_elim in H2. inversion H2.
      - apply (IHf1 n). intuition. apply H3.
      - apply set_diff_elim1 in H3. apply (IHf2 n). intuition. apply H3.
Qed.

Theorem not_compat : forall A B : Prop,
  (A = B) -> ((~ A) = (~B)).
Proof.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma set_union_elim_not :
   forall (a:Name) (x y:set Name),
     ~(set_In a (set_union name_dec x y)) -> ~(set_In a x) /\ ~(set_In a y).
Proof.
  intros. split.
    + intuition. apply H. apply set_union_intro1. apply H0.
    + intuition. apply H. apply set_union_intro2. apply H0.
Qed.

Lemma set_union_elim_not2 :
   forall (a:Name) (x y:set Name),
     ~(set_In a x) /\ ~(set_In a y) ->  ~(set_In a (set_union name_dec x y)).
Proof.
  intros. destruct H.
  intuition. apply H.
  apply set_union_elim in H1.
  generalize H1. tauto.
Qed.

Theorem or_commut : forall P Q : Prop,
  P \/ Q -> Q \/ P.
Proof.
  intros P Q H.
  tauto. Qed.

Lemma set_diff_elim_not:
    forall (n : Name) (f1 f2 : Formula),
    (not (set_In n (set_diff name_dec (names_ f1) (names_ f2)))) -> or (not (set_In n (names_ f1))) (set_In n (names_ f2)).
Proof.
  intros. left.
  intuition. apply H.
  apply set_diff_intro.
  + apply H0.
  + unfold not. intro.
  apply H. apply set_diff_intro.
  apply H0.
Admitted.

(* satisfies's result is equal if we add a feature to the configuration that is not in the formula *)
Lemma satisfies1 : forall (f: Formula) (c : Configuration) (n : Name),
  not(set_In n (names_ f)) -> satisfies f c = satisfies f (set_add name_dec n c).
Proof.
induction f.
  + intuition.
  + intuition.
  + simpl. intuition. exfalso. apply H0. rewrite n. rewrite n0. reflexivity.
  + simpl. intros. apply not_compat. apply (IHf c). apply H.
  + simpl. intros. apply set_union_elim_not in H. destruct H as [H1 H2].
    specialize (IHf1 c n). specialize (IHf2 c n).
    apply set_diff_elim_not in H2. inversion H2.
    -  apply IHf1 in H1. apply IHf2 in H. rewrite H1.
      rewrite H. reflexivity.
    - contradiction.
 + simpl. intros. apply set_union_elim_not in H. destruct H as [H1 H2].
    specialize (IHf1 c n). specialize (IHf2 c n).
    apply set_diff_elim_not in H2. inversion H2.
    -  apply IHf1 in H1. apply IHf2 in H. rewrite H1.
      rewrite H. reflexivity.
    - contradiction.
Qed.

(*satisfies's result is equal if we remove a feature from the configuration that is not in the formula*)
Lemma satisfies2 : forall (f: Formula) (c : Configuration) (n : Name),
  not(set_In n (names_ f)) -> satisfies f c = satisfies f (set_remove name_dec n c).
Proof.
induction f.
  + intuition.
  + intuition.
  + simpl. intuition. exfalso. apply H0. rewrite n. rewrite n0. reflexivity.
  + simpl. intros. apply not_compat. apply (IHf c). apply H.
  + simpl. intros. apply set_union_elim_not in H. destruct H as [H1 H2].
    specialize (IHf1 c n). specialize (IHf2 c n).
    apply set_diff_elim_not in H2. inversion H2.
    -  apply IHf1 in H1. apply IHf2 in H. rewrite H1.
      rewrite H. reflexivity.
    - contradiction.
 + simpl. intros. apply set_union_elim_not in H. destruct H as [H1 H2].
    specialize (IHf1 c n). specialize (IHf2 c n).
    apply set_diff_elim_not in H2. inversion H2.
    -  apply IHf1 in H1. apply IHf2 in H. rewrite H1.
      rewrite H. reflexivity.
    - contradiction.
Qed.

(* well-typed formulae from a FM continue well-typed in another FM with the same features *)
Lemma wtFormSameFeature : forall (abs : FM) (con : FM), (fst abs = fst con
  /\ (wfTree abs) /\ (wfTree con) -> ( forall (f : Formula), (wt abs f) ->  (wt con f))).
Proof.
  intros.
  destruct H as [equals_abs_con wf_abs_con].
  destruct wf_abs_con as [wf_abs wf_con].
  induction f.
    + auto.
    + auto.
    + simpl. simpl in H0. rewrite equals_abs_con in H0. apply H0.
    + auto.
    + induction abs, con. simpl. destruct H0. intuition.
    + induction abs, con. simpl. destruct H0. intuition.
Qed.

End FormulaTheory.


Require Export TopologicalSpaces.
Require Import WeakTopology.

Section Subspace.

Variable X:TopologicalSpace.
Variable A:Ensemble (point_set X).

Definition SubspaceTopology : TopologicalSpace :=
  WeakTopology1 (proj1_sig (P:=fun x:point_set X => In A x)).

Definition subspace_inc : point_set SubspaceTopology ->
  point_set X :=
  proj1_sig (P:=fun x:point_set X => In A x).

Lemma subspace_topology_topology: forall U:Ensemble {x:point_set X | In A x},
  @open SubspaceTopology U -> exists V:Ensemble (point_set X),
  open V /\ U = inverse_image subspace_inc V.
Proof.
apply weak_topology1_topology.
Qed.

Lemma subspace_inc_continuous:
  continuous subspace_inc.
Proof.
apply weak_topology1_makes_continuous_func.
Qed.

End Subspace.

Arguments SubspaceTopology {X}.
Arguments subspace_inc {X}.


Require Export GeoCoq.Elements.OriginalProofs.lemma_lessthantransitive.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_TTtransitive :
   forall A B C D E F G H P Q R S,
   TT A B C D E F G H -> TT E F G H P Q R S ->
   TT A B C D P Q R S.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists K, (BetS E F K /\ Cong F K G H /\ TG A B C D E K)) by (conclude_def TT );destruct Tf as [K];spliter.
let Tf:=fresh in
assert (Tf:exists J, (BetS A B J /\ Cong B J C D /\ Lt E K A J)) by (conclude_def TG );destruct Tf as [J];spliter.
let Tf:=fresh in
assert (Tf:exists L, (BetS P Q L /\ Cong Q L R S /\ TG E F G H P L)) by (conclude_def TT );destruct Tf as [L];spliter.
let Tf:=fresh in
assert (Tf:exists M, (BetS E F M /\ Cong F M G H /\ Lt P L E M)) by (conclude_def TG );destruct Tf as [M];spliter.
assert (eq K K) by (conclude cn_equalityreflexive).
assert (neq F K) by (forward_using lemma_betweennotequal).
assert (neq F M) by (forward_using lemma_betweennotequal).
assert (Out F K M) by (conclude_def Out ).
assert (Out F K K) by (conclude lemma_ray4).
assert (Cong G H F M) by (conclude lemma_congruencesymmetric).
assert (Cong F K F M) by (conclude lemma_congruencetransitive).
assert (eq K M) by (conclude lemma_layoffunique).
assert (Lt P L E K) by (conclude cn_equalitysub).
assert (Lt P L A J) by (conclude lemma_lessthantransitive).
assert (TG A B C D P L) by (conclude_def TG ).
assert (TT A B C D P Q R S) by (conclude_def TT ).
close.
Qed.

End Euclid.


Load "Tactics4_Constructions.v".

Section INCIDENCE.

(* On verifie que les axiomes d'incidence du systeme de Hilbert sont des theoremes dans notre systeme d'axiomes. *)

(* I1 : For any two points A, B, there exists a line L containing A, B. If A and B are distincts points, L is a unique line.*)

Lemma I1 : forall A B : Point, exists d : Line, OnLine d A /\ OnLine d B.
Proof.
	intros; byApartCases Oo Uu ipattern:A.
	 by3Cases Oo A B.
	  setLine A B ipattern:d.
	    answerIs d.
	  setLine A B ipattern:d.
	    answerIs d.
	  setLine Oo A ipattern:d.
	    answerIs d.
	 by3Cases Uu A B.
	  setLine A B ipattern:d.
	    answerIs d.
	  setLine A B ipattern:d.
	    answerIs d.
	  setLine Uu A ipattern:d.
	    answerIs d.
Qed.

Lemma I1' : forall A B : Point, forall d1 d2 : Line,
	A <> B -> OnLine d1 A -> OnLine d1 B -> OnLine d2 A -> OnLine d2 B ->
	EqLine d1 d2.
Proof.
	intros.
	step H.
Qed.

(* I2 : Every line contains at least two points. *)

Lemma I2 : forall d : Line, exists A : Point, exists B : Point, A <> B /\ OnLine d A /\ OnLine d B.
Proof.
	intros; destruct d.
	answerIs A; answerIs B.
Qed.

(* I3 : There exist three noncollinear points (that is, three points not all contained in a single line). *)

Lemma I3 : exists A : Point, exists B : Point, exists C : Point, forall d : Line,
	~(OnLine d A /\ OnLine d B /\ OnLine d C).
Proof.
	answerIs Oo; answerIs Uu; answerIs Vv; intros.
	since (~ Collinear Oo Uu Vv).
	contrapose H.
	step d; canonize.
Qed.

End INCIDENCE.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (x : natural) (y : natural) (lf2 : natural)
  : natural := plus (Succ y) Zero.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (z : natural) (lf2 : natural) (lf1 : natural)
  : natural := mult (Succ Zero) lf1.