(* Disable notation conflict warnings *)
Set Warnings "-notation-overridden".

From Coq Require Import ssreflect ssrbool ssrfun.

Require Import GHC.Base.
Require Import HsToCoq.Nat.
Require Import Proofs.GHC.Base.
Require Import Proofs.GHC.List.
Require Import Proofs.Data.Foldable.
Require Import Proofs.GhcTactics.

Require Import Coq.Lists.List.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import SetoidList.

Import ListNotations.

Open Scope Z_scope.

Set Bullet Behavior "Strict Subproofs".

(**
Some of this can migrate to [base-thy] at some point, but maybe some lemmas or
tactics are rather specific.
*)

Lemma eqlist_Foldable_elem : forall a (s s' : list a) `{EqLaws a},
      eqlistA (fun x y => x == y) s s' ->
      (forall a, Foldable.elem a s = Foldable.elem a s').
Proof.
  intros a s s' EQ EQL. intro H. induction H.
  intro x.
  rewrite elem_nil. auto.
  intro y.
  repeat rewrite -> elem_cons.
  rewrite IHeqlistA.
  erewrite eq_replace_r; eauto.
Qed.

Lemma elem_exists_in {a}`{Eq_ a} (x:a) (xs : list a) :  Foldable.elem x xs -> exists y, List.In y xs /\ (x == y).
Proof.
   elim: xs => [|y ys IH].
   hs_simpl. done.
   hs_simpl.
   move => /orP.
   move => [h1| h2].
   exists y. unfold List.In. split; auto.
   move: (IH h2) => [z [Inz eqz]].
   exists z. unfold List.In. split; auto.
Qed.

Lemma list_in_elem {a} `{Base.EqLaws a} (x:a) xs: List.In x xs -> Foldable.elem x xs.
Proof. elim: xs => [|y ys IH]. hs_simpl. auto.
hs_simpl. simpl. intuition. subst. apply /orP. left. eapply Eq_refl.
Qed.

Lemma forallb_imp:
  forall a P Q (xs : list a),
  forallb P xs = true ->
  (forall x, P x = true -> Q x = true) ->
  forallb Q xs = true.
Proof.
  induction xs; simpl; intros; auto.
  apply andb_prop in H.
  apply andb_true_intro.
  intuition.
Qed.


(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2015 Guillaume Melquiond

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

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

From Coq Require Import Reals ssreflect.

From Coquelicot Require Import Rcomplements Derive RInt Hierarchy Derive_2d AutoDerive.

(** This file aims at proving that d'Alembert's formula defines a
function that is solution to the one-dimensional wave equation. We
also need to prove the regularity of this function. *)

Local Open Scope R_scope.

Ltac auto_derive_2 :=
  match goal with
  | |- is_derive_n ?f 2 ?x ?d =>
    auto_derive_fun f ;
    match goal with
    | |- (forall x, _ -> is_derive _ x (@?d x)) -> _ =>
      let H := fresh "H" in
      let u := fresh "u" in
      intro H ;
      apply (is_derive_ext d) ;
      [ intro u ;
        apply sym_eq, is_derive_unique ;
        apply H
      | auto_derive ] ;
      clear H
    end
  end.

Section DAlembert.

Parameter c : R.

Hypothesis Zc : c <> 0.

Parameter u0 : R -> R.

Hypothesis Du0 : forall x, ex_derive (fun u => u0 u) x.
Hypothesis D2u0 : forall x, ex_derive_n (fun u => u0 u) 2 x.

Section Alpha.

Definition alpha x t := 1/2 * (u0 (x + c * t) + u0 (x - c * t)).
Definition alpha20 x t := 1/2 * (Derive_n u0 2 (x + c * t) + Derive_n u0 2 (x - c * t)).
Definition alpha02 x t := c^2/2 * (Derive_n u0 2 (x + c * t) + Derive_n u0 2 (x - c * t)).

Lemma alpha_20_lim :
  forall x t, is_derive_n (fun u => alpha u t) 2 x (alpha20 x t).
Proof.
intros x t.
unfold alpha.
auto_derive_2.
repeat split ; apply Du0.
repeat split ; apply D2u0.
unfold alpha20, Derive_n, Rminus.
ring.
Qed.

Lemma alpha_02_lim :
  forall x t, is_derive_n (fun u => alpha x u) 2 t (alpha02 x t).
Proof.
intros x t.
unfold alpha.
auto_derive_2.
repeat split ; apply Du0.
repeat split ; apply D2u0.
unfold alpha02, Derive_n, Rminus, Rdiv.
ring.
Qed.

End Alpha.

Parameter u1 : R -> R.

Hypothesis Du1 : forall x, ex_derive (fun u => u1 u) x.

Lemma Cu1 : forall x, continuity_pt (fun u => u1 u) x.
intros x.
destruct (Du1 x) as (l,Hl).
apply derivable_continuous_pt.
unfold derivable_pt, derivable_pt_abs.
exists l.
now apply is_derive_Reals.
Qed.

Lemma continuity_implies_ex_Rint: forall f a b,
   (forall x, continuity_pt f x) -> ex_RInt f a b.
intros f a b H.
case (Rle_or_lt a b); intros H1.
apply ex_RInt_Reals_1.
apply continuity_implies_RiemannInt.
exact H1.
intros x _; apply H.
apply ex_RInt_swap.
apply ex_RInt_Reals_1.
apply continuity_implies_RiemannInt.
left; exact H1.
intros x _; apply H.
Qed.

Lemma Iu1: forall a b, ex_RInt (fun u => u1 u) a b.
intros a b.
apply continuity_implies_ex_Rint.
apply Cu1.
Qed.

Section Beta.

Definition beta (x t : R) := 1/(2*c) * RInt (fun u => u1 u) (x - c * t) (x + c * t).
Definition beta20 x t := 1/(2*c) * (Derive (fun u => u1 u) (x + c * t) - Derive (fun u => u1 u) (x - c * t)).
Definition beta01 x t := 1/2 * (u1 (x + c * t) + u1 (x - c * t)).
Definition beta02 x t := c/2 * (Derive (fun u => u1 u) (x + c * t) - Derive (fun u => u1 u) (x - c * t)).

Lemma beta20_lim :
  forall x t, is_derive_n (fun u => beta u t) 2 x (beta20 x t).
Proof.
intros x t.
unfold beta.
auto_derive_2.
(* . *)
split.
apply Iu1.
repeat split.
apply filter_forall.
apply Cu1.
apply filter_forall.
apply Cu1.
repeat split ; apply Du1.
unfold beta20, Rminus.
ring.
Qed.

Lemma beta01_lim :
  forall x t, is_derive (fun u => beta x u) t (beta01 x t).
Proof.
intros x t.
unfold beta.
auto_derive.
split.
apply Iu1.
repeat split.
apply filter_forall.
apply Cu1.
apply filter_forall.
apply Cu1.
unfold beta01, Rminus, Rdiv.
now field.
Qed.

Lemma beta02_lim :
  forall x t, is_derive_n (fun u => beta x u) 2 t (beta02 x t).
Proof.
intros x t.
unfold beta.
auto_derive_2.
split.
apply Iu1.
repeat split.
apply filter_forall.
apply Cu1.
apply filter_forall.
apply Cu1.
repeat split ; apply Du1.
unfold beta02, Rminus, Rdiv.
now field.
Qed.

End Beta.

Hypothesis f : R -> R -> R.

Section Gamma.

Definition gamma x t := 1/(2*c) * RInt (fun tau => RInt (fun xi => f xi tau) (x - c * (t - tau)) (x + c * (t - tau))) 0 t.
Definition gamma20 x t := 1/(2*c) * RInt (fun tau => Derive (fun u => f u tau) (x + c * (t - tau)) - Derive (fun u => f u tau) (x - c * (t - tau))) 0 t.
Definition gamma02 x t := (f x t + c/2 * RInt (fun tau => Derive (fun u => f u tau) (x + c * (t - tau)) - Derive (fun u => f u tau) (x - c * (t - tau))) 0 t).

Lemma gamma20_lim :
  forall x t, is_derive_n (fun u => gamma u t) 2 x (gamma20 x t).
Proof.
intros x t.
unfold gamma.
auto_derive_2.
repeat split.
exists (mkposreal _ Rlt_0_1).
simpl.
intros t' u' _ _.
repeat split.
apply continuity_implies_ex_Rint => y.
admit. (* cont 2D -> 1D *)
apply filter_forall => y.
admit. (* cont 2D -> 1D *)
apply filter_forall => y.
admit. (* cont 2D -> 1D *)
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
apply derivable_continuous_pt.
admit. (* ??? *)
intros t' _.
admit.
repeat split.
exists (mkposreal _ Rlt_0_1).
intros t' u' _ _.
repeat split.
admit.
admit.
apply filter_forall => y.
admit.
intros t' _.
admit.
unfold gamma20.
apply f_equal.
apply RInt_ext => z _.
now rewrite 4!Rmult_1_l.
Admitted.

Lemma gamma02_lim :
  forall x t, is_derive_n (fun u => gamma x u) 2 t (gamma02 x t).
Proof.
intros x t.
unfold gamma.
auto_derive_2.
repeat split.
apply locally_2d_forall => y z.
admit.
intros t' _.
admit.
apply filter_forall => y.
admit.
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
simpl.
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
simpl.
intros t' u' _ _.
repeat split.
apply continuity_implies_ex_Rint => y.
admit.
apply filter_forall => y.
admit.
apply filter_forall => y.
admit.
repeat split.
apply locally_2d_forall => y z.
admit.
apply locally_2d_forall => y z.
admit.
intros x' _.
admit.
apply filter_forall => y.
admit.
apply filter_forall => y.
admit.
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
intros t' u' _ _.
admit.
apply locally_2d_forall => y z.
admit.
intros t' _.
admit.
apply filter_forall => y.
admit.
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
intros t' u' _ _.
repeat split.
admit.
admit.
unfold gamma02.
ring_simplify.
rewrite Rplus_opp_r Rmult_0_r Ropp_0 Rplus_0_r.
rewrite RInt_point Rmult_0_r Rplus_0_r.
apply Rplus_eq_reg_l with (- f x t).
field_simplify.
2: exact Zc.
rewrite Rmult_1_r.
rewrite /Rdiv Rmult_comm.
rewrite Rmult_assoc (Rmult_comm _ (/2)) -Rmult_assoc.
rewrite -[Rmult]/(@scal _ R_ModuleSpace) -RInt_scal.
rewrite -RInt_scal.
apply RInt_ext => u _.
rewrite /scal /= /mult /= /Rminus.
now field.
admit.
admit.
Admitted.

End Gamma.

End DAlembert.


Require Import Arith Max Min ZArith_base NArith Nnat.

Open Local Scope Z_scope.

(** * zify: the Z-ification tactic *)

(* This tactic searches for nat and N and positive elements in the goal and
   translates everything into Z. It is meant as a pre-processor for
   (r)omega; for instance a positivity hypothesis is added whenever
     - a multiplication is encountered
     - an atom is encountered (that is a variable or an unknown construct)

   Recognized relations (can be handled as deeply as allowed by setoid rewrite):
     - { eq, le, lt, ge, gt } on { Z, positive, N, nat }

   Recognized operations:
     - on Z: Zmin, Zmax, Zabs, Zsgn are translated in term of <= < =
     - on nat: + * - S O pred min max nat_of_P nat_of_N Zabs_nat
     - on positive: Zneg Zpos xI xO xH + * - Psucc Ppred Pmin Pmax P_of_succ_nat
     - on N: N0 Npos + * - Nsucc Nmin Nmax N_of_nat Zabs_N
*)

(** I) translation of Zmax, Zmin, Zabs, Zsgn into recognized equations *)

Ltac zify_unop_core t thm a :=
 (* Let's introduce the specification theorem for t *)
 let H:= fresh "H" in assert (H:=thm a);
 (* Then we replace (t a) everywhere with a fresh variable *)
 let z := fresh "z" in set (z:=t a) in *; clearbody z.

Ltac zify_unop_var_or_term t thm a :=
 (* If a is a variable, no need for aliasing *)
 let za := fresh "z" in
 (rename a into za; rename za into a; zify_unop_core t thm a) ||
 (* Otherwise, a is a complex term: we alias it. *)
 (remember a as za; zify_unop_core t thm za).

Ltac zify_unop t thm a :=
 (* if a is a scalar, we can simply reduce the unop *)
 let isz := isZcst a in
 match isz with
  | true => simpl (t a) in *
  | _ => zify_unop_var_or_term t thm a
 end.

Ltac zify_unop_nored t thm a :=
 (* in this version, we don't try to reduce the unop (that can be (Zplus x)) *)
 let isz := isZcst a in
 match isz with
  | true => zify_unop_core t thm a
  | _ => zify_unop_var_or_term t thm a
 end.

Ltac zify_binop t thm a b:=
 (* works as zify_unop, except that we should be careful when
    dealing with b, since it can be equal to a *)
 let isza := isZcst a in
 match isza with
   | true => zify_unop (t a) (thm a) b
   | _ =>
       let za := fresh "z" in
       (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) ||
       (remember a as za; match goal with
         | H : za = b |- _ => zify_unop_nored (t za) (thm za) za
         | _ => zify_unop_nored (t za) (thm za) b
        end)
 end.

Ltac zify_op_1 :=
  match goal with
   | |- context [ Zmax ?a ?b ] => zify_binop Zmax Zmax_spec a b
   | H : context [ Zmax ?a ?b ] |- _ => zify_binop Zmax Zmax_spec a b
   | |- context [ Zmin ?a ?b ] => zify_binop Zmin Zmin_spec a b
   | H : context [ Zmin ?a ?b ] |- _ => zify_binop Zmin Zmin_spec a b
   | |- context [ Zsgn ?a ] => zify_unop Zsgn Zsgn_spec a
   | H : context [ Zsgn ?a ] |- _ => zify_unop Zsgn Zsgn_spec a
   | |- context [ Zabs ?a ] => zify_unop Zabs Zabs_spec a
   | H : context [ Zabs ?a ] |- _ => zify_unop Zabs Zabs_spec a
  end.

Ltac zify_op := repeat zify_op_1.

(** II) Conversion from nat to Z *)

Definition Z_of_nat' := Z_of_nat.

Ltac hide_Z_of_nat t :=
  let z := fresh "z" in set (z:=Z_of_nat t) in *;
  change Z_of_nat with Z_of_nat' in z;
  unfold z in *; clear z.

Ltac zify_nat_rel :=
 match goal with
  (* I: equalities *)
  | H : (@eq nat ?a ?b) |- _ => generalize (inj_eq _ _ H); clear H; intro H
  | |- (@eq nat ?a ?b) => apply (inj_eq_rev a b)
  | H : context [ @eq nat ?a ?b ] |- _ => rewrite (inj_eq_iff a b) in H
  | |- context [ @eq nat ?a ?b ] =>       rewrite (inj_eq_iff a b)
  (* II: less than *)
  | H : (lt ?a ?b) |- _ => generalize (inj_lt _ _ H); clear H; intro H
  | |- (lt ?a ?b) => apply (inj_lt_rev a b)
  | H : context [ lt ?a ?b ] |- _ => rewrite (inj_lt_iff a b) in H
  | |- context [ lt ?a ?b ] =>       rewrite (inj_lt_iff a b)
  (* III: less or equal *)
  | H : (le ?a ?b) |- _ => generalize (inj_le _ _ H); clear H; intro H
  | |- (le ?a ?b) => apply (inj_le_rev a b)
  | H : context [ le ?a ?b ] |- _ => rewrite (inj_le_iff a b) in H
  | |- context [ le ?a ?b ] =>       rewrite (inj_le_iff a b)
  (* IV: greater than *)
  | H : (gt ?a ?b) |- _ => generalize (inj_gt _ _ H); clear H; intro H
  | |- (gt ?a ?b) => apply (inj_gt_rev a b)
  | H : context [ gt ?a ?b ] |- _ => rewrite (inj_gt_iff a b) in H
  | |- context [ gt ?a ?b ] =>       rewrite (inj_gt_iff a b)
  (* V: greater or equal *)
  | H : (ge ?a ?b) |- _ => generalize (inj_ge _ _ H); clear H; intro H
  | |- (ge ?a ?b) => apply (inj_ge_rev a b)
  | H : context [ ge ?a ?b ] |- _ => rewrite (inj_ge_iff a b) in H
  | |- context [ ge ?a ?b ] =>       rewrite (inj_ge_iff a b)
 end.

Ltac zify_nat_op :=
 match goal with
  (* misc type conversions: positive/N/Z to nat *)
  | H : context [ Z_of_nat (nat_of_P ?a) ] |- _ => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a) in H
  | |- context [ Z_of_nat (nat_of_P ?a) ] => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a)
  | H : context [ Z_of_nat (nat_of_N ?a) ] |- _ => rewrite (Z_of_nat_of_N a) in H
  | |- context [ Z_of_nat (nat_of_N ?a) ] => rewrite (Z_of_nat_of_N a)
  | H : context [ Z_of_nat (Zabs_nat ?a) ] |- _ => rewrite (inj_Zabs_nat a) in H
  | |- context [ Z_of_nat (Zabs_nat ?a) ] => rewrite (inj_Zabs_nat a)

  (* plus -> Zplus *)
  | H : context [ Z_of_nat (plus ?a ?b) ] |- _ => rewrite (inj_plus a b) in H
  | |- context [ Z_of_nat (plus ?a ?b) ] => rewrite (inj_plus a b)

  (* min -> Zmin *)
  | H : context [ Z_of_nat (min ?a ?b) ] |- _ => rewrite (inj_min a b) in H
  | |- context [ Z_of_nat (min ?a ?b) ] => rewrite (inj_min a b)

  (* max -> Zmax *)
  | H : context [ Z_of_nat (max ?a ?b) ] |- _ => rewrite (inj_max a b) in H
  | |- context [ Z_of_nat (max ?a ?b) ] => rewrite (inj_max a b)

  (* minus -> Zmax (Zminus ... ...) 0 *)
  | H : context [ Z_of_nat (minus ?a ?b) ] |- _ => rewrite (inj_minus a b) in H
  | |- context [ Z_of_nat (minus ?a ?b) ] => rewrite (inj_minus a b)

  (* pred -> minus ... -1 -> Zmax (Zminus ... -1) 0 *)
  | H : context [ Z_of_nat (pred ?a) ] |- _ => rewrite (pred_of_minus a) in H
  | |- context [ Z_of_nat (pred ?a) ] => rewrite (pred_of_minus a)

  (* mult -> Zmult and a positivity hypothesis *)
  | H : context [ Z_of_nat (mult ?a ?b) ] |- _ =>
        let H:= fresh "H" in
        assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in *
  | |- context [ Z_of_nat (mult ?a ?b) ] =>
        let H:= fresh "H" in
        assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in *

  (* O -> Z0 *)
  | H : context [ Z_of_nat O ] |- _ => simpl (Z_of_nat O) in H
  | |- context [ Z_of_nat O ] => simpl (Z_of_nat O)

  (* S -> number or Zsucc *)
  | H : context [ Z_of_nat (S ?a) ] |- _ =>
     let isnat := isnatcst a in
     match isnat with
      | true => simpl (Z_of_nat (S a)) in H
      | _ => rewrite (inj_S a) in H
     end
  | |- context [ Z_of_nat (S ?a) ] =>
     let isnat := isnatcst a in
     match isnat with
      | true => simpl (Z_of_nat (S a))
      | _ => rewrite (inj_S a)
     end

  (* atoms of type nat : we add a positivity condition (if not already there) *)
  | H : context [ Z_of_nat ?a ] |- _ =>
        match goal with
          | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a
          | H' : 0 <= Z_of_nat' a |- _ => fail
          | _ => let H:= fresh "H" in
                 assert (H:=Zle_0_nat a); hide_Z_of_nat a
        end
  | |- context [ Z_of_nat ?a ] =>
        match goal with
          | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a
          | H' : 0 <= Z_of_nat' a |- _ => fail
          | _ => let H:= fresh "H" in
                 assert (H:=Zle_0_nat a); hide_Z_of_nat a
        end
 end.

Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *.

(* III) conversion from positive to Z *)

Definition Zpos' := Zpos.
Definition Zneg' := Zneg.

Ltac hide_Zpos t :=
  let z := fresh "z" in set (z:=Zpos t) in *;
  change Zpos with Zpos' in z;
  unfold z in *; clear z.

Ltac zify_positive_rel :=
 match goal with
  (* I: equalities *)
  | H : (@eq positive ?a ?b) |- _ => generalize (Zpos_eq _ _ H); clear H; intro H
  | |- (@eq positive ?a ?b) => apply (Zpos_eq_rev a b)
  | H : context [ @eq positive ?a ?b ] |- _ => rewrite (Zpos_eq_iff a b) in H
  | |- context [ @eq positive ?a ?b ] =>       rewrite (Zpos_eq_iff a b)
  (* II: less than *)
  | H : context [ (?a<?b)%positive ] |- _ => change (a<b)%positive with (Zpos a<Zpos b) in H
  | |- context [ (?a<?b)%positive ] => change (a<b)%positive with (Zpos a<Zpos b)
  (* III: less or equal *)
  | H : context [ (?a<=?b)%positive ] |- _ => change (a<=b)%positive with (Zpos a<=Zpos b) in H
  | |- context [ (?a<=?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b)
  (* IV: greater than *)
  | H : context [ (?a>?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H
  | |- context [ (?a>?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b)
  (* V: greater or equal *)
  | H : context [ (?a>=?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H
  | |- context [ (?a>=?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b)
 end.

Ltac zify_positive_op :=
 match goal with
  (* Zneg -> -Zpos (except for numbers) *)
  | H : context [ Zneg ?a ] |- _ =>
     let isp := isPcst a in
     match isp with
      | true => change (Zneg a) with (Zneg' a) in H
      | _ => change (Zneg a) with (- Zpos a) in H
     end
  | |- context [ Zneg ?a ] =>
     let isp := isPcst a in
     match isp with
      | true => change (Zneg a) with (Zneg' a)
      | _ => change (Zneg a) with (- Zpos a)
     end

  (* misc type conversions: nat to positive *)
  | H : context [ Zpos (P_of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H
  | |- context [ Zpos (P_of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a)

  (* Pplus -> Zplus *)
  | H : context [ Zpos (Pplus ?a ?b) ] |- _ => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b)) in H
  | |- context [ Zpos (Pplus ?a ?b) ] => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b))

  (* Pmin -> Zmin *)
  | H : context [ Zpos (Pmin ?a ?b) ] |- _ => rewrite (Zpos_min a b) in H
  | |- context [ Zpos (Pmin ?a ?b) ] => rewrite (Zpos_min a b)

  (* Pmax -> Zmax *)
  | H : context [ Zpos (Pmax ?a ?b) ] |- _ => rewrite (Zpos_max a b) in H
  | |- context [ Zpos (Pmax ?a ?b) ] => rewrite (Zpos_max a b)

  (* Pminus -> Zmax 1 (Zminus ... ...) *)
  | H : context [ Zpos (Pminus ?a ?b) ] |- _ => rewrite (Zpos_minus a b) in H
  | |- context [ Zpos (Pminus ?a ?b) ] => rewrite (Zpos_minus a b)

  (* Psucc -> Zsucc *)
  | H : context [ Zpos (Psucc ?a) ] |- _ => rewrite (Zpos_succ_morphism a) in H
  | |- context [ Zpos (Psucc ?a) ] => rewrite (Zpos_succ_morphism a)

  (* Ppred -> Pminus ... -1 -> Zmax 1 (Zminus ... - 1) *)
  | H : context [ Zpos (Ppred ?a) ] |- _ => rewrite (Ppred_minus a) in H
  | |- context [ Zpos (Ppred ?a) ] => rewrite (Ppred_minus a)

  (* Pmult -> Zmult and a positivity hypothesis *)
  | H : context [ Zpos (Pmult ?a ?b) ] |- _ =>
        let H:= fresh "H" in
        assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in *
  | |- context [ Zpos (Pmult ?a ?b) ] =>
        let H:= fresh "H" in
        assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in *

  (* xO *)
  | H : context [ Zpos (xO ?a) ] |- _ =>
     let isp := isPcst a in
     match isp with
      | true => change (Zpos (xO a)) with (Zpos' (xO a)) in H
      | _ => rewrite (Zpos_xO a) in H
     end
  | |- context [ Zpos (xO ?a) ] =>
     let isp := isPcst a in
     match isp with
      | true => change (Zpos (xO a)) with (Zpos' (xO a))
      | _ => rewrite (Zpos_xO a)
     end
  (* xI *)
  | H : context [ Zpos (xI ?a) ] |- _ =>
     let isp := isPcst a in
     match isp with
      | true => change (Zpos (xI a)) with (Zpos' (xI a)) in H
      | _ => rewrite (Zpos_xI a) in H
     end
  | |- context [ Zpos (xI ?a) ] =>
     let isp := isPcst a in
     match isp with
      | true => change (Zpos (xI a)) with (Zpos' (xI a))
      | _ => rewrite (Zpos_xI a)
     end

  (* xI : nothing to do, just prevent adding a useless positivity condition *)
  | H : context [ Zpos xH ] |- _ => hide_Zpos xH
  | |- context [ Zpos xH ] => hide_Zpos xH

  (* atoms of type positive : we add a positivity condition (if not already there) *)
  | H : context [ Zpos ?a ] |- _ =>
        match goal with
         | H' : Zpos a > 0 |- _ => hide_Zpos a
         | H' : Zpos' a > 0 |- _ => fail
         | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a
        end
  | |- context [ Zpos ?a ] =>
        match goal with
         | H' : Zpos a > 0 |- _ => hide_Zpos a
         | H' : Zpos' a > 0 |- _ => fail
         | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a
        end
 end.

Ltac zify_positive :=
 repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *.

(* IV) conversion from N to Z *)

Definition Z_of_N' := Z_of_N.

Ltac hide_Z_of_N t :=
  let z := fresh "z" in set (z:=Z_of_N t) in *;
  change Z_of_N with Z_of_N' in z;
  unfold z in *; clear z.

Ltac zify_N_rel :=
 match goal with
  (* I: equalities *)
  | H : (@eq N ?a ?b) |- _ => generalize (Z_of_N_eq _ _ H); clear H; intro H
  | |- (@eq N ?a ?b) => apply (Z_of_N_eq_rev a b)
  | H : context [ @eq N ?a ?b ] |- _ => rewrite (Z_of_N_eq_iff a b) in H
  | |- context [ @eq N ?a ?b ] =>       rewrite (Z_of_N_eq_iff a b)
  (* II: less than *)
  | H : (?a<?b)%N |- _ => generalize (Z_of_N_lt _ _ H); clear H; intro H
  | |- (?a<?b)%N => apply (Z_of_N_lt_rev a b)
  | H : context [ (?a<?b)%N ] |- _ => rewrite (Z_of_N_lt_iff a b) in H
  | |- context [ (?a<?b)%N ] =>       rewrite (Z_of_N_lt_iff a b)
  (* III: less or equal *)
  | H : (?a<=?b)%N |- _ => generalize (Z_of_N_le _ _ H); clear H; intro H
  | |- (?a<=?b)%N => apply (Z_of_N_le_rev a b)
  | H : context [ (?a<=?b)%N ] |- _ => rewrite (Z_of_N_le_iff a b) in H
  | |- context [ (?a<=?b)%N ] =>       rewrite (Z_of_N_le_iff a b)
  (* IV: greater than *)
  | H : (?a>?b)%N |- _ => generalize (Z_of_N_gt _ _ H); clear H; intro H
  | |- (?a>?b)%N => apply (Z_of_N_gt_rev a b)
  | H : context [ (?a>?b)%N ] |- _ => rewrite (Z_of_N_gt_iff a b) in H
  | |- context [ (?a>?b)%N ] =>       rewrite (Z_of_N_gt_iff a b)
  (* V: greater or equal *)
  | H : (?a>=?b)%N |- _ => generalize (Z_of_N_ge _ _ H); clear H; intro H
  | |- (?a>=?b)%N => apply (Z_of_N_ge_rev a b)
  | H : context [ (?a>=?b)%N ] |- _ => rewrite (Z_of_N_ge_iff a b) in H
  | |- context [ (?a>=?b)%N ] =>       rewrite (Z_of_N_ge_iff a b)
 end.

Ltac zify_N_op :=
 match goal with
  (* misc type conversions: nat to positive *)
  | H : context [ Z_of_N (N_of_nat ?a) ] |- _ => rewrite (Z_of_N_of_nat a) in H
  | |- context [ Z_of_N (N_of_nat ?a) ] => rewrite (Z_of_N_of_nat a)
  | H : context [ Z_of_N (Zabs_N ?a) ] |- _ => rewrite (Z_of_N_abs a) in H
  | |- context [ Z_of_N (Zabs_N ?a) ] => rewrite (Z_of_N_abs a)
  | H : context [ Z_of_N (Npos ?a) ] |- _ => rewrite (Z_of_N_pos a) in H
  | |- context [ Z_of_N (Npos ?a) ] => rewrite (Z_of_N_pos a)
  | H : context [ Z_of_N N0 ] |- _ => change (Z_of_N N0) with Z0 in H
  | |- context [ Z_of_N N0 ] => change (Z_of_N N0) with Z0

  (* Nplus -> Zplus *)
  | H : context [ Z_of_N (Nplus ?a ?b) ] |- _ => rewrite (Z_of_N_plus a b) in H
  | |- context [ Z_of_N (Nplus ?a ?b) ] => rewrite (Z_of_N_plus a b)

  (* Nmin -> Zmin *)
  | H : context [ Z_of_N (Nmin ?a ?b) ] |- _ => rewrite (Z_of_N_min a b) in H
  | |- context [ Z_of_N (Nmin ?a ?b) ] => rewrite (Z_of_N_min a b)

  (* Nmax -> Zmax *)
  | H : context [ Z_of_N (Nmax ?a ?b) ] |- _ => rewrite (Z_of_N_max a b) in H
  | |- context [ Z_of_N (Nmax ?a ?b) ] => rewrite (Z_of_N_max a b)

  (* Nminus -> Zmax 0 (Zminus ... ...) *)
  | H : context [ Z_of_N (Nminus ?a ?b) ] |- _ => rewrite (Z_of_N_minus a b) in H
  | |- context [ Z_of_N (Nminus ?a ?b) ] => rewrite (Z_of_N_minus a b)

  (* Nsucc -> Zsucc *)
  | H : context [ Z_of_N (Nsucc ?a) ] |- _ => rewrite (Z_of_N_succ a) in H
  | |- context [ Z_of_N (Nsucc ?a) ] => rewrite (Z_of_N_succ a)

  (* Nmult -> Zmult and a positivity hypothesis *)
  | H : context [ Z_of_N (Nmult ?a ?b) ] |- _ =>
        let H:= fresh "H" in
        assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in *
  | |- context [ Z_of_N  (Nmult ?a ?b) ] =>
        let H:= fresh "H" in
        assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in *

  (* atoms of type N : we add a positivity condition (if not already there) *)
  | H : context [ Z_of_N ?a ] |- _ =>
        match goal with
         | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a
         | H' : 0 <= Z_of_N' a |- _ => fail
         | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a
        end
  | |- context [ Z_of_N ?a ] =>
        match goal with
         | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a
         | H' : 0 <= Z_of_N' a |- _ => fail
         | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a
        end
 end.

Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *.

(** The complete Z-ification tactic *)

Ltac zify :=
 repeat progress (zify_nat; zify_positive; zify_N); zify_op.


Fixpoint fact (x:nat) :=
  match x with
    | 0 => 1
    | S x' => x * fact x'
  end.

fact _|_ =>

match _|_ with
  | 0 => 1
  | S x' => x * fact x'
end


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Reduction from:
    Diophantine Constraint Solvability (H10C_SAT)
  to:
    Square Diophantine Constraint Solvability (H10SQC_SAT)
*)

Require Import List Lia.
Require Cantor.
Import ListNotations.

Require Import Undecidability.DiophantineConstraints.H10C.

Require Import ssreflect ssrbool ssrfun.

Set Default Proof Using "Type".
Set Default Goal Selector "!".

Module Argument.

Notation encode := Cantor.to_nat.
Notation decode := Cantor.of_nat.
Opaque Cantor.to_nat Cantor.of_nat.

Section Reduction.
(* given instance of Diophantine constraint solvability *)
Context (cs: list h10c).

(* variable renaming *)
Definition ζ (x: nat) := encode (x, 0).

(*
  fresh variables
  θ x y 0 ~ x^2
  θ x y 1 ~ y^2
  θ x y 2 ~ x^2 + y^2
  θ x y 3 ~ x + y
  θ x y 4 ~ (x + y)^2
  θ x y 5 ~ 2xy
*)
Definition θ (x y t: nat) := encode (x, 1 + encode (y, t)).

(* x * y = z <-> x^2 + 2z + y^2 = (x + y)^2 *)
Definition h10c_to_h10sqcs (c : h10c) : list h10sqc :=
  match c with
  | h10c_one x      => [h10sqc_one (ζ x)]
  | h10c_plus x y z => [h10sqc_plus (ζ x) (ζ y) (ζ z)]
  | h10c_mult x y z => [
      h10sqc_sq (ζ x) (θ x y 0); h10sqc_sq (ζ y) (θ x y 1); h10sqc_plus (θ x y 0) (θ x y 1) (θ x y 2);
      h10sqc_plus (ζ x) (ζ y) (θ x y 3); h10sqc_sq (θ x y 3) (θ x y 4);
      h10sqc_plus (ζ z) (ζ z) (θ x y 5); h10sqc_plus (θ x y 2) (θ x y 5) (θ x y 4)]
  end.

(* constructed instance of square Diophantine constraint solvability *)
Definition sqcs := flat_map h10c_to_h10sqcs cs.

Section Transport.
(* solution of the given instance cs *)
Context (φ : nat -> nat) (Hφ: forall c, In c cs -> h10c_sem c φ).

(* solution of the constructed instance sqcs *)
Definition φ' (n: nat) :=
  match decode n with
  | (x, 0) => φ x
  | (x, S m) =>
    match decode m with
    | (y, 0) => (φ x) * (φ x)
    | (y, 1) => (φ y) * (φ y)
    | (y, 2) => (φ x) * (φ x) + (φ y) * (φ y)
    | (y, 3) => (φ x) + (φ y)
    | (y, 4) => ((φ x) + (φ y)) * ((φ x) + (φ y))
    | (y, 5) => (φ x) * (φ y) + (φ x) * (φ y)
    | (_, _) => 0
    end
  end.

Lemma h10c_to_h10sqcs_spec {c} : h10c_sem c φ -> Forall (h10sqc_sem φ') (h10c_to_h10sqcs c).
Proof.
  case: c => /=.
  - move=> x ?. constructor; last done.
    by rewrite /= /ζ /φ' Cantor.cancel_of_to.
  - move=> x y z ?. constructor; last done.
    by rewrite /= /ζ /φ' ?Cantor.cancel_of_to.
  - move=> x y z ?. (do ? constructor);
      rewrite /= /ζ /φ' ?Cantor.cancel_of_to /= ?Cantor.cancel_of_to; by nia.
Qed.

End Transport.

Lemma transport : H10C_SAT cs -> H10SQC_SAT sqcs.
Proof.
  move=> [φ Hφ]. exists (φ' φ).
  move: Hφ. rewrite -?Forall_forall /sqcs Forall_flat_map.
  apply: Forall_impl => ?. by move /h10c_to_h10sqcs_spec.
Qed.

Section InverseTransport.
(* solution of the constructed instance sqcs *)
Context (φ' : nat -> nat) (Hφ': forall c, In c sqcs -> h10sqc_sem φ' c).

(* solution of the given instance cs *)
Definition φ (x: nat) := φ' (ζ x).

Lemma h10c_of_h10sqcs_spec {c} : Forall (h10sqc_sem φ') (h10c_to_h10sqcs c) -> h10c_sem c φ.
Proof.
  case: c => /=.
  - by move=> x /Forall_cons_iff [].
  - by move=> x y z /Forall_cons_iff [].
  - move=> x y z. do 7 (move=> /Forall_cons_iff /and_comm []).
    rewrite /= /φ. by nia.
Qed.

End InverseTransport.

Lemma inverse_transport : H10SQC_SAT sqcs -> H10C_SAT cs.
Proof.
  move=> [φ' Hφ']. exists (φ φ').
  move: Hφ'. rewrite -?Forall_forall /sqcs Forall_flat_map.
  apply: Forall_impl => ?. by move=> /h10c_of_h10sqcs_spec.
Qed.

End Reduction.
End Argument.

Require Import Undecidability.Synthetic.Definitions.

(* Diophantine Constraint Solvability many-one reduces to Square Diophantine Constraint Solvability *)
Theorem reduction : H10C_SAT ⪯ H10SQC_SAT.
Proof.
  exists (fun cs => Argument.sqcs cs) => cs. constructor.
  - exact: Argument.transport.
  - exact: Argument.inverse_transport.
Qed.


Parameter object : Type.
Definition PN   : Type := object.
Definition VP   : Type := object -> Prop.

Definition NP    : Type := VP -> Prop .   (* NP := (PN -> Prop) -> Prop *)
Definition UsePN : PN -> NP := fun pn vp => vp pn.
Definition Cl   : Type := Prop .

Definition PredVP  : NP -> VP -> Cl := fun np vp => np vp.
Definition V    : Type := object -> Prop.
Definition UseV  : V -> VP := fun v => v.
Definition S    : Type := Prop .

Definition Pol  : Type := Prop -> Prop .

Definition Pos : Pol := fun p => p.
Definition Neg : Pol := fun p => not p.
Definition UseCl : Pol -> Cl -> S :=
  fun pol c => pol c.

Parameter AP   : Type.
Parameter A    : Type.
Parameter CN   : Type.
Parameter Det  : Type.
Parameter N    : Type.
Parameter V2   : Type.
Parameter AdA  : Type.
Parameter Conj : Type.

Parameter ComplV2 : V2 -> NP -> VP.
Parameter DetCN   : Det -> CN -> NP.
Parameter ModCN   : AP -> CN -> CN.
Parameter CompAP  : AP -> VP.
Parameter AdAP    : AdA -> AP -> AP.
Parameter ConjS   : Conj -> S  -> S  -> S.
Parameter ConjNP  : Conj -> NP -> NP -> NP.
Parameter UseN    : N -> CN.
Parameter UseA    : A -> AP.
Parameter some_Det : Det.
Parameter every_Det : Det.
Parameter we_NP   : NP.
Parameter you_NP : NP.
Parameter very_AdA : AdA.
Parameter and_Conj : Conj.
Parameter or_Conj : Conj.

Parameter man_N :  N.
Parameter woman_N : N .
Parameter house_N :  N.
Parameter tree_N : N .
Parameter   big_A : A .
Parameter small_A : A .
Parameter green_A : A .
Parameter  walk_V : V  .
Parameter arrive_V : V .
Parameter love_V2 : V2  .
Parameter please_V2 : V2 .
Parameter john_PN : PN .
Parameter mary_PN : PN.

Definition everyoneNP : NP := fun vp => forall x, vp x.

Theorem everyone:  everyoneNP walk_V-> walk_V john_PN. cbv. intros. apply H. Qed.


Require Export Term.
Require Export Formula.
Require Export SignedSubformula.
Require Export Sequent.

Require Import Base.Lists.
Require Import Base.Permutation.
Require Import Tactics.FormulaEquality.
Require Import Tactics.TermEquality.
Require Import Tactics.WellFormedFormulaNoProofs.
Require Import Tactics.TermHasSortNoFormulas.

Module Type Consistency (G : GroundInfo) (GTerm : Term G) (GFormula : Formula G GTerm)
       (TE : TermEquality G GTerm) (FE : FormulaEquality G GTerm GFormula TE)
       (SSFormula : SignedSubformula G GTerm GFormula TE FE)
       (THS : TermHasSort'' G GTerm TE)
       (WFF : WellFormedFormula' G GTerm TE THS GFormula FE)
       (PF : Sequent G GTerm GFormula TE FE THS WFF).
  Import G. Import GTerm. Import GFormula. Import SSFormula. Import PF.
  Import ListNotations. Import THS. Import WFF.

  Inductive Falsy : flafolFormula -> Prop :=
    falseFalsy : Falsy FF
  | saysFalsy : forall p labl phi, Falsy phi -> Falsy (p □ ⟨ labl ⟩ phi).

  Hint Constructors Falsy.

  Theorem FalsySubst' : forall (x : var) (t : flafolTerm) (phi : flafolFormula),
      Falsy phi -> Falsy (phi f[x ↦ t]).
  Proof.
    intros x t phi H; induction phi; inversion H; simpl; constructor; auto.
  Qed.

  Theorem FalsySubst'' : forall (x : var) (t : flafolTerm) (phi : flafolFormula),
      Falsy (phi f[x ↦ t]) -> Falsy phi.
  Proof.
    intros x t phi H; induction phi; inversion H; simpl; try (constructor; auto).
    all: destruct (varEqDec x v); inversion H1.
    all: inversion H0.
  Qed.

  Theorem FalsySubst : forall (x : var) (t : flafolTerm) (phi : flafolFormula),
      Falsy phi <-> Falsy (phi f[ x ↦ t]).
  Proof.
    intros x t phi; split; [apply FalsySubst' | apply FalsySubst''].
  Qed.

  Open Scope formula_scope. Open Scope proof_scope.

  Ltac PositiveConsistency :=
    repeat match goal with
           | [ H : @InBool Belief BeliefEqDec ?a ?l = true |- _ ] =>
             match goal with
             | [_ : In ?a ?l |- _ ] => fail 1
             | _ => pose proof ((proj1 InBoolSpec) H)
             end
           | [ H :In ?a ?l |- _ ] =>
             match goal with
             | [ _ : InBool BeliefEqDec ?a ?l = true |- _ ] => fail 1
             | _ => pose proof ((proj2 InBoolSpec) H)
             end
           | [ H : _ ⊢[ _ ] (_ ⊑ _) @ _ |- _ ] => clear H
           | [ H : _ ⊢[ _ ] (canRead _ _) @ _ |- _ ] => clear H
           | [ H : _ ⊢[ _ ] (canWrite _ _) @ _ |- _ ] => clear H
           | [ IH : (forall (m0 : Modality) (phi0 psi0 : flafolFormula),
                        Path (phi0 @ m0) ?Gamma = true -> (psi0 s: Neg) ≤s (phi0 s: Neg) -> ~ Falsy psi0) ->
                    Falsy ?chi -> False,
                    H : ?Gamma ⊢[ _ ] ?chi @ _
               |- False] =>
             apply IH; auto
           | [ H : In _ (?Delta ++ ?Gamma) |- _ ] => apply in_app_or in H; destruct H
           | [ H : In _ (_ :: _) |- _ ] => destruct H
           | [ H0 : (forall (m0 : Modality) (phi0 psi0: flafolFormula),
                        Path (phi0 @ m0) (?Delta ++ _ :: ?Gamma) ->
                        (psi0, Neg) ≤s (phi0, Neg) -> ~ Falsy psi0),
                    H1 : Path (?phi1 @?m1) ?Delta,
                         H2 : (?psi1, Neg) ≤s (?phi1, Neg)
               |- ~ Falsy ?psi1 ] =>
             apply (H0 m1 phi1); [apply in_or_app; left | ]; auto
           | [ H0 : (forall (m0 : Modality) (phi0 psi0 : flafolFormula),
                        Path (phi0 @ m0) (?Delta ++ _ :: ?Gamma) ->
                        (psi0, Neg) ≤s (phi0, Neg) -> ~ Falsy psi0),
                    H1 : Path (?phi1 @ ?m1) ?Gamma,
                         H2 : (?psi1, Neg) ≤s (?phi1, Neg)
               |- ~ Falsy ?psi1 ] =>
             apply (H0 m1 phi1); [apply in_or_app; right; right | ]; auto
           | [ H0 : (forall (m0 : Modality) (phi0 psi0 : flafolFormula),
                        Path (phi0 @ m0) (?Delta ++ ((?f ?phi ?psi) @ ?m) :: ?Gamma) ->
                        (psi0, Neg) ≤s (phi0, Neg) -> ~ Falsy psi0),
                    H1 : (?phi @ ?m) = (?phi1 @ ?m1),
                         H2 : (?psi1, Neg) ≤s (?phi1, Neg)
               |- ~ Falsy ?psi1] =>
             let H3 := fresh "H" in
             let H4 := fresh "H" in
             assert (m = m1) as H3 by (inversion H1; auto);
             assert (phi = phi1) as H4 by (inversion H1; auto);
             apply (H0 m (f phi psi)); [apply in_or_app; right; left; auto | ];
             apply SSTrans with (psi := phi s: Neg);
             [rewrite H4; auto | constructor]
           | [ H0 : (forall (m0 : Modality) (phi0 psi0 : flafolFormula),
                        Path (phi0 @ m0) (?Delta ++ ((?f ?phi ?psi) @ ?m) :: ?Gamma) ->
                        (psi0, Neg) ≤s (phi0, Neg) -> ~ Falsy psi0),
                    H1 : (?psi @ ?m) = (?phi1 @ ?m1),
                         H2 : (?psi1, Neg) ≤s (?phi1, Neg)
               |- ~ Falsy ?psi1] =>
             let H3 := fresh "H" in
             let H4 := fresh "H" in
             assert (m = m1) as H3 by (inversion H1; auto);
             assert (psi = phi1) as H4 by (inversion H1; auto);
             apply (H0 m (f phi psi)); [apply in_or_app; right; left; auto | ];
             apply SSTrans with (psi := psi s: Neg);
             [rewrite H4; auto | constructor]
           | [ H0 : (forall (m0 : Modality) (phi0 psi0: flafolFormula),
                        Path (phi0 @ m0) (?Delta ++ ((?f ?phi ?psi) @ ?m) :: ?Gamma) ->
                        (psi0, Neg) ≤s (phi0, Neg) -> ~ Falsy psi0),
                    H1 : ((?f ?phi ?psi) @ ?m ) = (?phi1 @ ?m1),
                         H2 : (?psi0, Neg) ≤s (?phi1, Neg)
               |- ~ Falsy ?psi1] =>
             let H3 := fresh "H" in
             let H4 := fresh "H" in
             assert (m = m1) as H3 by (inversion H1; auto);
             assert (f phi psi = phi1) as H4 by (inversion H1; auto);
             apply (H0 m (f phi psi)); [apply in_or_app; right; left; auto | ];
             rewrite H4; auto
           | [ H0 : (forall (m0 : Modality) (phi0 psi0: flafolFormula) pc,
                        Path (phi0 @ m0) (?Delta ++ ((?f ?x ?phi) @ ?m) :: ?Gamma) ->
                        (psi0, Neg) ≤s (phi0, Neg) -> ~ Falsy psi0),
                    H1 : (?phi @ ?m) = (?phi1 @ ?m1),
                         H2 : (?psi0, Neg) ≤s (?phi1, Neg)
               |- ~ Falsy ?psi1] =>
             let H3 := fresh "H" in
             let H4 := fresh "H" in
             assert (m = m1) as H3 by (inversion H1; auto);
             assert (phi = phi1) as H4 by (inversion H1; auto);
             apply (H0 m (f x phi)); [apply in_or_app; right; left; auto | ];
             apply SSTrans with (psi := phi s: Neg);
             [rewrite H4; auto | constructor]; auto
           | [ H0 : (forall (m0 : Modality) (phi0 psi0: flafolFormula),
                        Path (phi0 @ m0) (?Delta ++ ((?f ?x ?phi) @ ?m) :: ?Gamma) ->
                        (psi0, Neg) ≤s (phi0, Neg) -> ~ Falsy psi0),
                    H1 : ((?phi f[?x ↦ ?t]) @ ?m) = (?phi1 @ ?m1),
                         H2 : (?psi0, Neg) ≤s (?phi1, Neg)
               |- ~ Falsy ?psi1] =>
             let H3 := fresh "H" in
             let H4 := fresh "H" in
             assert (m = m1) as H3 by (inversion H1; auto);
             assert (phi f[x ↦ t] = phi1) as H4 by (inversion H1; auto);
             apply (H0 m (f x phi)); [apply in_or_app; right; left; auto | ];
             apply SSTrans with (psi := (phi f[x ↦ t]) s: Neg);
             [rewrite H4; auto | constructor]; auto
           | [ |- forall _, _ ] => intro
           end.

  Hint Constructors SignedSubformulaOf.

  Definition phiBelief (b : Belief) : flafolFormula :=
    match b with
    | mkBelief phi m => phi
    end.

  Theorem PositiveConsistency' : forall {Gamma : Context} {b : Belief},
      (forall m phi, Path (phi @ m) Gamma -> ~((FF s: Neg) ≤s (phi s: Neg))) -> Gamma ⊢ b -> (phiBelief b <> FF).
  Proof.
    intros Gamma b H pf.
    induction pf; subst; auto; try (simpl; discriminate).
    all: try (repeat match goal with
                     | [ H : (forall (m : Modality) (phi : flafolFormula), Path (phi @ m) ?Gamma -> ~ (FF, Neg) ≤s (phi, Neg)), p : Path (?phi @ ?m) ?Gamma |- ~ (FF, Neg) ≤s (?phi, Neg) ] => apply (H m phi p)
                     | [ H : ?P -> ?Q |- ?Q ] => apply H; intros
                     | [ H : Path ?b1 (_ :: ?Gamma) |- _] => apply PathToIn in H; destruct H
                     | [ H : In ?b ?Gamma |- _ ] => apply (InToPath BeliefEqDec) in H
                     | [ H : ?phi @ ?m1 = ?psi @ ?m2 |- _ ] =>
                       match goal with
                       | [ _ : phi = psi, _ : m1 = m2 |- _ ] => fail 1
                       | _ => inversion H
                       end
                     end) .
    - destruct b. intro. simpl in H0. apply (H m f p0).
      rewrite H0; auto.
    - exfalso; apply (H m FF p1); auto.
    - intro Hphi0. apply (H m (phi & psi) pth).
      inversion H0; eapply SSTrans; eauto.
    - intro Hphi0; apply (H m (phi & psi) pth).
      inversion H0; eapply SSTrans; eauto.
    - intro Hphi0; apply (H m (phi ⊕ psi) pth).
      inversion H0; eapply SSTrans; eauto.
    - intro H1; apply (H m (phi ==⟨ l ⟩> psi) pth).
      inversion H2; eapply SSTrans; eauto.
    - intro Hphi0; apply (H m (∀ sigma; phi) pth).
      eapply SSTrans; eauto.
    - intro Hphi0; apply (H m (∃ VarSort y; phi) pth).
      eapply SSTrans; eauto.
    - intro Hphi0; apply (H m (p □ ⟨ lab ⟩ phi) pth).
      pose proof (provenProperContext pf).
      apply ConsProperContext in H1.
      destruct H1.
      inversion H1. inversion H5.
      inversion H2; eapply SSTrans; eauto.
    - rewrite <- H2. apply H with (m := CollapseDoubleInModality pth); auto.
    - rewrite <- H2. apply H with (m := m); auto.
    - rewrite <- H2. apply H with (m := m); auto.
    - rewrite <- H2; apply H with (m := m); auto.
  Qed.

  Theorem PositiveConsistency : forall (Gamma : Context) (m : Modality),
      (forall m' phi, Path (phi @ m') Gamma -> ~ ((FF s: Neg) ≤s (phi s: Neg))) ->
      Gamma ⊢ FF @ m -> False.
  Proof.
    intros Gamma m H H0.
    eapply @PositiveConsistency' with (b := FF @ m); eauto.
  Qed.

  Theorem Consistency : forall m, [] ⊢ FF @ m -> False.
  Proof.
    intros m H; eapply PositiveConsistency; eauto.
    intros m' phi H0; inversion H0.
  Qed.

End Consistency.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Functor.
Require Blech.Reflect.

Import CategoryNotations.
Import FunctorNotations.
Import BishopNotations.

Open Scope category_scope.
Open Scope bishop_scope.

#[local]
Obligation Tactic := Reflect.category_simpl.

Definition Natural {C D: Category} {F G: Functor C D} (α: ∀ x, D (F x) (G x)): Prop :=
  ∀ {x y} (m: C x y), map G m ∘ α _ == α _ ∘ map F m.
Existing Class Natural.

Definition natural {C D: Category} {F G: Functor C D} {α: ∀ x, D (F x) (G x)} `{N:Natural C D F G α}:
  ∀ {x y} (m: C x y), map G m ∘ α _ == α _ ∘ map F m := N.

#[program]
Definition Funct (K L: Category): Category := {|
  Obj := Functor K L ;
  Mor A B := { f | Natural f } ;
  Mor_Setoid _ _ := {| equiv f g := ∀ x, f x == g x |} ;
  id A _ := id _ ;
  compose _ _ _ f g _ := f _  ∘ g _  ;
|}.

Next Obligation.
Proof.
  exists.
  all: unfold Reflexive, Symmetric, Transitive; cbn.
  - intros.
    reflexivity.
  - intros ? ? p ?.
    symmetry.
    apply (p _).
  - intros ? ? ? p q ?.
    rewrite (p _), (q _).
    reflexivity.
Qed.

Next Obligation.
Proof.
  intros ? ? ?.
  Reflect.category.
  reflexivity.
Qed.

Next Obligation.
Proof.
  intros ? ? ?.
  repeat rewrite compose_assoc.
  rewrite natural.
  repeat rewrite <- compose_assoc.
  apply compose_compat.
  1: reflexivity.
  rewrite natural.
  reflexivity.
Qed.

Next Obligation.
Proof.
  intros ? ? p ? ? q ?.
  cbn in *.
  rewrite (p _), (q _).
  reflexivity.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e192m2e64m1_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e192m2e64m1_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


(* -*- company-coq-local-symbols: (("|=" . ?⊨) ("=|" . ?⫤) ("->>" . ?↠) ("=~" . ?≈) ("<|" . ?⟨) ("|>" . ?⟩) ); -*- *)
Set Warnings "-notation-overridden".

Require Import Prelude.Prelude.
Require Import Defs.Defs.

Require Export Wf.InfGen.
Require Export Wf.Inst.
Require Export Wf.U.
Require Export Wf.Uss.

Theorem Inst_wf : forall (env : Env) (sch : Sch) (a : A) (ty : Ty),
    env |= sch ≤ ⟨a⟩ ty
  -> wf(env)
  -> env |=ty sch
  -> wf(env ::o ⟦⟨a⟩ S_Mono ty⟧).
Proof. exact Wf.Inst.Inst_Wf. Qed.

Theorem U_Wf : forall (env__in : Env) (eqs : Eqs) (env__out : Env),
    U env__in eqs env__out
  -> wf(env__in)
  -> wf(env__out).
Proof. exact Wf.U.U_Wf. Qed.

Theorem Us_Wf : forall (env__in : Env) (eqs : Eqs) (env__out : Env) (sub : Sub),
    Us env__in eqs env__out sub
  -> wf(env__in)
  -> wf(env__out).
Proof. exact Wf.U.Us_Wf. Qed.

Theorem Uss_Wf : forall (env__in : Env) (eqs__in : Eqs) (env__out : Env) (eqs__out : Eqs) (sub : Sub),
    Uss env__in eqs__in env__out eqs__out sub
  -> wf(env__in)
  -> wf(Sub_app_Env env__out sub).
Proof. exact Wf.Uss.Uss_Wf. Qed.

Theorem Inf_Wf : forall (env__in : Env) (e : e) (a : A) (ty : Ty) (env__out : Env),
    env__in |= e ▸ ⟨a⟩ ty =| env__out
  -> wf(env__in)
  -> wf(env__out ::o ⟦⟨a⟩ S_Mono ty⟧).
Proof. exact (proj1 Inf_Gen_Wf). Qed.

Theorem Gen_Wf : forall (env__in : Env) (e : e) (sch : Sch) (env__out : Env),
    env__in |= e ▸ sch =| env__out
  -> wf(env__in)
  -> wf(env__out ::o ⟦sch⟧).
Proof. exact (proj2 Inf_Gen_Wf). Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.

(* Why3 assumption *)
Definition unit  := unit.

Parameter qtmark : Type.

Parameter at1: forall (a:Type), a -> qtmark -> a.
Implicit Arguments at1.

Parameter old: forall (a:Type), a -> a.
Implicit Arguments old.

(* Why3 assumption *)
Definition implb(x:bool) (y:bool): bool := match (x,
  y) with
  | (true, false) => false
  | (_, _) => true
  end.

(* Why3 assumption *)
Inductive term  :=
  | S : term
  | K : term
  | App : term -> term -> term .

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint is_value(t:term) {struct t}: Prop :=
  match t with
  | (K|S) => True
  | ((App K v)|(App S v)) => (is_value v)
  | (App (App S v1) v2) => (is_value v1) /\ (is_value v2)
  | _ => False
  end.
Unset Implicit Arguments.

(* Why3 assumption *)
Inductive context  :=
  | Hole : context
  | Left : context -> term -> context
  | Right : term -> context -> context .

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint is_context(c:context) {struct c}: Prop :=
  match c with
  | Hole => True
  | (Left c1 _) => (is_context c1)
  | (Right v c1) => (is_value v) /\ (is_context c1)
  end.
Unset Implicit Arguments.

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint subst(c:context) (t:term) {struct c}: term :=
  match c with
  | Hole => t
  | (Left c1 t2) => (App (subst c1 t) t2)
  | (Right v1 c2) => (App v1 (subst c2 t))
  end.
Unset Implicit Arguments.

(* Why3 assumption *)
Inductive infix_mnmngt : term -> term -> Prop :=
  | red_K : forall (c:context), (is_context c) -> forall (v1:term) (v2:term),
      (is_value v1) -> ((is_value v2) -> (infix_mnmngt (subst c (App (App K
      v1) v2)) (subst c v1)))
  | red_S : forall (c:context), (is_context c) -> forall (v1:term) (v2:term)
      (v3:term), (is_value v1) -> ((is_value v2) -> ((is_value v3) ->
      (infix_mnmngt (subst c (App (App (App S v1) v2) v3)) (subst c
      (App (App v1 v3) (App v2 v3)))))).

Axiom red_left : forall (t1:term) (t2:term) (t:term), (infix_mnmngt t1 t2) ->
  (infix_mnmngt (App t1 t) (App t2 t)).

Axiom red_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((infix_mnmngt t1 t2) -> (infix_mnmngt (App v t1) (App v t2))).

(* Why3 assumption *)
Inductive relTR : term -> term -> Prop :=
  | BaseTransRefl : forall (x:term), (relTR x x)
  | StepTransRefl : forall (x:term) (y:term) (z:term), (relTR x y) ->
      ((infix_mnmngt y z) -> (relTR x z)).

Axiom relTR_transitive : forall (x:term) (y:term) (z:term), (relTR x y) ->
  ((relTR y z) -> (relTR x z)).

Axiom red_star_left : forall (t1:term) (t2:term) (t:term), (relTR t1 t2) ->
  (relTR (App t1 t) (App t2 t)).

Axiom red_star_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((relTR t1 t2) -> (relTR (App v t1) (App v t2))).

Hint Constructors infix_mnmngt.
Require Import Why3. Ltac ae := why3 "alt-ergo".

(* Why3 goal *)
Theorem reducible_or_value : forall (t:term), (exists tqt:term,
  (infix_mnmngt t tqt)) \/ (is_value t).
induction t; intuition.
right; simpl; auto.
right; simpl; auto.
left.
destruct H as (t1',h1).
exists (App t1' t2); intuition. ae.
left.
destruct H as (t1',h1).
exists (App t1' t2); intuition. ae.
left.
destruct H0 as (t2',h2).
exists (App t1 t2'); intuition. ae.
(* is_value t1 && is_value t2 *)
destruct t1; intuition.
destruct t1_1; intuition.
simpl in H.
right; red; intuition.
simpl in H.
left; intuition.
exists t1_2; intuition.
apply (red_K Hole); auto. ae.
simpl in H.
destruct t1_1_1; intuition.
left.
rename t1_1_2 into v1. rename t1_2 into v2. rename t2 into v3.
exists (App (App v1 v3) (App v2 v3)); intuition.
apply (red_S Hole); auto.
ae.
Qed.


Require Import Coq.omega.Omega.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Crypto.Util.Strings.Equality.
Require Import Crypto.Util.Strings.Ascii.

Local Open Scope list_scope.
Local Open Scope string_scope.

(** *** String concatenation *)
(** [concat sep sl] concatenates the list of strings [sl], inserting
    the separator string [sep] between each. *)

Definition concat (sep : string) : list string -> string
  := fix concat (sl : list string) : string
       := match sl with
          | nil => EmptyString
          | cons x nil => x
          | cons x xs => x ++ sep ++ concat xs
          end.

(** *** Conversion to and from lists *)
Fixpoint to_list (s : string) : list ascii
  := match s with
     | EmptyString => nil
     | String x xs => cons x (to_list xs)
     end.
Fixpoint of_list (s : list ascii) : string
  := match s with
     | nil => EmptyString
     | cons x xs => String x (of_list xs)
     end.

Lemma to_of_list s : to_list (of_list s) = s.
Proof. induction s as [|x xs IHxs]; cbn; [ | rewrite IHxs ]; reflexivity. Qed.
Lemma of_to_list s : of_list (to_list s) = s.
Proof. induction s as [|x xs IHxs]; cbn; [ | rewrite IHxs ]; reflexivity. Qed.

Lemma of_list_app s1 s2 : of_list (s1 ++ s2) = of_list s1 ++ of_list s2.
Proof. induction s1 as [|x xs IHxs]; cbn; [ | rewrite IHxs ]; reflexivity. Qed.
Lemma to_list_app s1 s2 : to_list (s1 ++ s2) = (to_list s1 ++ to_list s2)%list.
Proof. induction s1 as [|x xs IHxs]; cbn; [ | rewrite IHxs ]; reflexivity. Qed.

Definition lift_list_function (f : list ascii -> list ascii) (s : string) : string
  := of_list (f (to_list s)).

(** *** Mapping over a string *)
(** [map f s] applies function [f] in turn to all the characters of
    [s], creating a new string to return *)
Definition map (f : ascii -> ascii) : string -> string
  := lift_list_function (List.map f).
Lemma map_step f s
  : map f s = match s with
              | EmptyString => EmptyString
              | String x xs => String (f x) (map f xs)
              end.
Proof. destruct s; reflexivity. Qed.

(** *** string reversal *)
(** [rev s] reverses the string [s] *)
Definition rev : string -> string
  := lift_list_function (@List.rev _).

Lemma rev_step s
  : rev s
    = match s with
      | EmptyString => EmptyString
      | String x xs => rev xs ++ String x EmptyString
      end.
Proof. destruct s; cbn; rewrite ?of_list_app; reflexivity. Qed.

(** *** trimming a string *)
(** [trim s] returns a copy of the argument, without leading and trailing
    whitespace. The characters regarded as whitespace are: ' ',
    '\012', '\n', '\r', and '\t'. *)
Fixpoint ltrim (s : string) : string
  := match s with
     | EmptyString => EmptyString
     | String x xs
       => if ((x =? " ") || (x =? NewPage) || (x =? LF) || (x =? CR) || (x =? Tab))%char%bool
          then ltrim xs
          else s
     end.
Definition rtrim (s : string) : string
  := rev (ltrim (rev s)).

Definition trim (s : string) : string
  := rtrim (ltrim s).

(** Finds last occurence of [s1] in [s2], where the first character
    after [s1] is at position less than or equal to [n + 1].  Returns
    the location of the first character of [s1] in that occurence in
    [s2], if it exists. *)

Definition rindex (n : nat) (s1 s2 : string) : option nat :=
  option_map
    (fun n => length s2 - n - length s1)
    (index (length s2 - n - 1) (rev s1) (rev s2)).

Lemma append_alt s1 s2 : s1 ++ s2 = of_list (to_list s1 ++ to_list s2).
Proof. rewrite of_list_app, !of_to_list; reflexivity. Qed.
Lemma append_empty_r s : s ++ "" = s.
Proof.
  rewrite append_alt; cbn; rewrite List.app_nil_r, of_to_list. reflexivity.
Qed.
Lemma append_assoc s1 s2 s3 : s1 ++ (s2 ++ s3) = (s1 ++ s2) ++ s3.
Proof.
  rewrite !append_alt, ?to_of_list; cbn; rewrite List.app_assoc; reflexivity.
Qed.

Lemma length_substring n1 n2 s
  : length (substring n1 n2 s) = Nat.min n2 (length s - n1).
Proof.
  revert n1 n2; induction s as [|a s IHs]; intros; cbn.
  { destruct n1, n2; cbn; reflexivity. }
  { destruct n1; [ destruct n2 | ]; cbn; rewrite ?IHs, <- ?Minus.minus_n_O; reflexivity. }
Qed.

Lemma length_append s1 s2 : length (s1 ++ s2) = length s1 + length s2.
Proof.
  revert s1; induction s1 as [|a s1 IHs1]; cbn; congruence.
Qed.

(** *** membership *)
(** [contains n s1 s2] returns [true] if [s1] occurs in [s2] starting
    at position [n], and false otherwise *)
Definition contains (n : nat) (s1 s2 : string) : bool :=
  match index n s1 s2 with
  | Some _ => true
  | None => false
  end.

Section strip_prefix_cps.
  Context {R} (found : string -> R)
          (remaining : string -> string -> R).

  Fixpoint strip_prefix_cps (sepch : ascii) (sep : string) (s2 : string) {struct s2} : R
    := match s2 with
       | EmptyString => remaining (String sepch sep) s2
       | String x xs
         => if ascii_beq sepch x
            then match sep with
                 | EmptyString => found xs
                 | String sepch sep
                   => strip_prefix_cps sepch sep xs
                 end
            else remaining (String sepch sep) s2
       end.
End strip_prefix_cps.

(** *** splitting a string *)
(** [split sep s] returns the list of all (possibly empty) substrings
    of [s] that are delimited by the [sep] character.

    The function's output is specified by the following invariants:

    - The list is not empty.

    - Concatenating its elements using sep as a separator returns a
      string equal to the input

        [concat sep (split sep s) = s]

    - No string in the result contains [sep] as a substring, unless
      [sep] is the empty string, in which case this function returns
      [map (fun ch => String ch "") (to_list s)] if [s] is non-empty,
      and [""::nil] if [s] is also empty. *)

Fixpoint split_helper (sepch : ascii) (sep : string) (s : string) (rev_acc : string) {struct s}
  : list string
  := strip_prefix_cps
       (fun s => rev rev_acc :: split_helper sepch sep s "")
       (fun _ _
        => match s with
           | EmptyString => rev rev_acc :: nil
           | String x xs
             => split_helper sepch sep xs (String x rev_acc)
           end)
       sepch sep s.

Definition split (sep : string) (s : string) : list string
  := match sep with
     | EmptyString
       => if string_beq s EmptyString
          then "" :: nil
          else List.map (fun ch => String ch "") (to_list s)
     | String sepch sep
       => split_helper sepch sep s ""
     end.

Fixpoint split_helper_non_empty sepch sep s rev_acc {struct s}
  : split_helper sepch sep s rev_acc <> nil.
Proof.
  destruct s as [|x xs]; cbn [split_helper];
    [ cbn; clear split_helper_non_empty; congruence | ].
  generalize (split_helper_non_empty sepch sep xs (String x rev_acc)).
  generalize (split_helper sepch sep xs (String x rev_acc)).
  intros ls H.
  generalize (String x xs).
  generalize sep at 2.
  generalize sepch at 2.
  fix H' 3.
  intros sepch' sep' s'.
  destruct s' as [|a s']; cbn; [ assumption | ].
  destruct (sepch' =? a)%char, sep'; try (clear H' split_helper_non_empty; congruence).
  apply H'.
Qed.

Lemma split_non_empty sep s : split sep s <> nil.
Proof.
  unfold split; destruct sep, s; try apply split_helper_non_empty; cbn;
    congruence.
Qed.

Lemma split_empty_empty : split EmptyString EmptyString = "" :: nil.
Proof. reflexivity. Qed.
Lemma split_empty_non_empty s
  : s <> EmptyString
    -> split EmptyString s = List.map (fun ch => String ch "") (to_list s).
Proof.
  intro H; destruct s; cbn; congruence.
Qed.

Fixpoint split_helper_no_substring sepch sep s rev_acc
  : List.Forall (fun s' => contains 0 (rev rev_acc ++ String sepch sep) s' = false)
                (split_helper sepch sep s rev_acc).
Proof.
  destruct s as [|x xs]; cbn [split_helper];
    [ cbn; clear split_helper_no_substring;
      repeat constructor
    | ].
  { unfold contains.
    edestruct index eqn:H; [ | reflexivity ].
    apply index_correct1 in H.
    apply (f_equal length) in H.
    rewrite length_substring, !length_append in H.
    revert H; apply PeanoNat.Nat.min_case_strong; cbn; intros; omega. }
  { generalize (split_helper_no_substring sepch sep xs (String x rev_acc)).
    generalize (split_helper sepch sep xs (String x rev_acc)).
    intros ls.
Abort.
Lemma split_no_substring sep s (Hsep : sep <> EmptyString)
  : List.Forall (fun s' => contains 0 sep s' = false)
                (split sep s).
Proof.
  destruct sep as [|sepch sep]; [ congruence | ].
  unfold split.
Abort.

Fixpoint concat_split_helper sepch sep s rev_acc
  : concat (String sepch sep) (split_helper sepch sep s rev_acc)
    = rev rev_acc ++ s.
Proof.
  destruct s as [|x xs]; cbn [split_helper];
    [ cbn; rewrite append_empty_r; reflexivity | ].
  generalize (concat_split_helper sepch sep xs (String x rev_acc)).
  generalize (split_helper sepch sep xs (String x rev_acc)).
  intros ls H.
  rewrite rev_step, <- append_assoc in H; cbn in H; revert H.
  generalize (String x xs); clear x xs.
  revert sep.
  revert sepch.
  fix H' 3.
  intros sepch' sep' s'; intros.
  destruct s' as [|a s']; cbn; [ assumption | ].
  destruct (sepch' =? a)%char eqn:Hsep, sep'; try (clear H' concat_split_helper; congruence).
  { cbn [concat].
    rewrite (concat_split_helper sepch' "" s').
    destruct (split_helper sepch' "" s' "") eqn:H''.
    { apply split_helper_non_empty in H''; exfalso; assumption. }
    { cbn.
      apply internal_ascii_dec_bl in Hsep; subst; reflexivity. } }
  { apply internal_ascii_dec_bl in Hsep; subst.
Abort.

Lemma concat_split sep s : concat sep (split sep s) = s.
Proof.
  destruct sep; cbn.
  { destruct s as [|x xs]; [ reflexivity | cbn ].
    revert x; induction xs as [|x' xs' IHxs]; intro x; cbn; trivial.
    apply f_equal; auto. }
  {
Abort.


Require Export TcfgReach PPexhead.
Require Import Lia.

Section cfg.

  Context `(C : redCFG).

  (* the more general formulation with deq_loop is wrong *)
  Lemma tpath_tag_take_r_eq p i q j t h n
        (Hlen : |j| = depth q)
        (Hpath : TPath (q,j) (p,i) t)
        (Hincl : forall r, r ∈ map fst t -> deq_loop r h)
        (Hdep : depth h = n)
    : take_r (n-1) j = take_r (n-1) i.
  Proof.
    revert p i Hpath.
    induction t;intros; inv_path Hpath.
    - reflexivity.
    - case (depth h) eqn:E.
      { cbn. reflexivity. }
      exploit' IHt.
      { intros. eapply Hincl. right. auto. }
      destruct x.
      copy Hincl Hincl'.
      eapply deq_loop_depth in Hincl.
      2: { right. eapply path_contains_front in H. eapply in_map with (f:=fst) in H. cbn in H;eauto. }
      eapply tcfg_edge_destruct' in H0.
      eapply tag_depth_unroot in H as Htagt0;eauto.
      destruct H0 as [[H0 Q0]|[[H0 Q0]|[[H0 Q0]|[H0 Q0]]]].
      + subst. eapply IHt;eauto.
      + subst.
        eapply depth_entry in Q0.
        rewrite take_r_cons_drop.
        * eapply IHt;eauto.
        * rewrite Htagt0. lia.
      + destruct t0.
        { cbn in Htagt0. lia. }
        cbn in H0. subst i.
        erewrite take_r_cons_replace.
        * eapply IHt;eauto.
        * cbn in Htagt0. clear - E Hincl Htagt0. rewrite E in Hincl. rewrite <-Htagt0 in Hincl. lia.
      + destruct t0. 1:cbn in Htagt0;lia.
        cbn in H0. subst.
        setoid_rewrite <-take_r_cons_drop at 2.
        * eapply IHt;eauto.
        * cbn in Htagt0. lia.
  Qed.

  Lemma weak_monotonicity q j p i t h n
        (Hlen : |j| = depth q)
        (Hpath : TPath (q,j) (p,i) t)
        (Hincl : forall r, r ∈ map fst t -> deq_loop r h)
        (Hdep : depth h = n)
    : take_r n j ⊴ take_r n i.
  Proof.
    revert p i Hpath.
    induction t;intros; inv_path Hpath.
    - reflexivity.
    - case (depth h) eqn:E.
      { cbn. reflexivity. }
      exploit' IHt.
      { intros. eapply Hincl. right. auto. }
      destruct x.
      copy Hincl Hincl'.
      eapply deq_loop_depth in Hincl.
      2: { right. eapply path_contains_front in H. eapply in_map with (f:=fst) in H. cbn in H;eauto. }
      eapply tcfg_edge_destruct' in H0.
      eapply tag_depth_unroot in H as Htagt0;eauto.
      destruct H0 as [[H0 Q0]|[[H0 Q0]|[[H0 Q0]|[H0 Q0]]]].
      + subst. eapply IHt;eauto.
      + subst.
        eapply depth_entry in Q0.
        setoid_rewrite take_r_cons_drop.
        * eapply IHt;eauto.
        * rewrite Htagt0. lia.
      + destruct t0.
        { cbn in Htagt0. lia. }
        rewrite H0.
        transitivity (take_r (S n) (n0 :: t0)).
        * eapply IHt;eauto.
        * unfold STag.
          eapply tagle_take_r.
          econstructor.
          econstructor.
          lia.
      + specialize (Hincl' p). exploit Hincl'. 1: left;cbn;eauto.
        destruct t0. 1:cbn in Htagt0;lia.
        cbn in H0. subst.
        setoid_rewrite <-take_r_cons_drop at 2.
        * eapply IHt;eauto.
        * cbn in Htagt0.
          eapply depth_exit in Q0.
          eapply deq_loop_depth in Hincl'.
          rewrite Q0 in Htagt0. lia.
  Qed.

  Lemma tcfg_fresh p i j t
        (Hpath : TPath (p,i) (p,j) t)
        (Hdep : | i | = depth p)
        (Hlen : | t | >= 2)
    : i ◁ j.
  Proof.
    eapply TPath_CPath in Hpath as Hpp.
    eapply p_p_ex_head in Hpp.
    2: rewrite map_length;eauto.
    destructH.
    destruct t. 1: inv Hpath.
    eapply in_fst in Hpp0. destruct Hpp0 as [k Hpp0].
    unfold TPath in *. path_simpl' Hpath.
    eapply path_from_elem' in Hpp0 as Hπ;eauto.
    destructH.
    eapply postfix_eq in Hπ1.
    destruct Hπ1 as [ϕ Hπ1].
    rewrite <-app_assoc in Hπ1.
    unfold app at 2 in Hπ1.
    assert (Prefix ((h,k) :: ϕ) ((p,j) :: t)) as Hpreϕ.
    { eapply prefix_eq. eexists;eauto. }
    eapply path_prefix_path in Hpath as Hϕ;eauto.
    inv_path Hϕ.
    {
      cbn in Hπ1.
      destruct equiv_dec in Hπ1.
      - cbn in Hπ1.
        destruct t;[|congruence]. cbn in Hlen. lia.
      - eapply tagle_neq_taglt.
        + erewrite <-take_r_geq with (n:=depth h).
          2: { erewrite tag_depth_unroot;eauto. }
          rewrite <-take_r_geq with (n:=depth h) at 1.
          2: { erewrite tag_depth_unroot;eauto. }
          eapply weak_monotonicity in Hpath. all:eauto.
          eauto using loop_contains_deq_loop.
        + contradict c0. intro. subst. apply H. reflexivity.
    }
    destruct x.
    assert (e ↪ h) as Hback.
    { eapply non_entry_head_back_edge. 1: destruct H0;eauto.
      eapply Hpp1. fold (fst (e,t0)). eapply in_map. eapply prefix_incl;eauto.
      right. eapply path_contains_front;eauto.
    }
    eapply weak_monotonicity in H;eauto.
    2: { intros. eapply loop_contains_deq_loop. eapply Hpp1. eapply prefix_incl;eauto.
         eapply prefix_map_fst;eauto. eapply prefix_cons;eauto.
    }
    eapply weak_monotonicity in Hπ0;eauto.
    3: {
      intros. eapply loop_contains_deq_loop. eapply Hpp1. eapply postfix_incl;eauto.
      eapply postfix_map_fst.
      eapply postfix_nincl_spec;eauto.
    }
    2: { eapply tag_depth_unroot in Hdep;eauto. }
    assert (| k | = depth h) as Hhdep.
    { eapply tag_depth_unroot;eauto. }
    destruct t0.
    { eapply back_edge_eq_loop in Hback. eapply tcfg_edge_depth_iff in Hhdep;eauto.
      rewrite Hback  in Hhdep. cbn in Hhdep.
      enough (0 > 0) by lia.
      rewrite Hhdep at 1. eapply depth_loop_head.
      eapply loop_contains_loop_head. eapply Hpp1. fold (fst (h,k)). eapply in_map. eauto.
    }
    eapply tag_back_edge_iff in Hback;eauto.
    specialize (taglt_stag n t0) as Hlt. subst k.
    rewrite take_r_geq in Hπ0. 2: setoid_rewrite Hhdep; lia.
    setoid_rewrite take_r_geq in H at 2. 2: setoid_rewrite Hhdep; lia.
    eapply tagle_taglt_trans in Hlt;eauto.
    eapply taglt_tagle_trans in Hlt;eauto.
    eapply taglt_take_r_taglt;eauto.
    rewrite Hdep.
    erewrite tag_depth_unroot;eauto.
  Qed.

  Lemma ex_entry (h p q : Lab) (i j j' k : Tag) t
        (Hin : loop_contains h q)
        (Hnin : ~ loop_contains h p)
        (Hpath : TPath (p,i) (q,j) t)
        (Hleni : | i | = depth p)
        (Heq : j = j' ++ k)
        (Hlen : | k | = depth h - 1)
    : (h,0 :: k) ∈ t.
  Proof.
    revert j' j q Heq Hpath Hin.
    induction t;intros;inv_path Hpath.
    - contradiction.
    - destruct x as [u l].
      decide (loop_contains h u).
      + right.
        copy H0 Htedge.
        eapply tcfg_edge_destruct' in H0.
        destruct H0 as [[H0 H1]|[[H0 H1]|[[H0 H1]|[H0 H1]]]].
        * eapply IHt. all: cycle 1; eauto.
        * destruct j'.
          -- exfalso.
             cbn in Hpath.
             eapply tag_depth_unroot in Hpath;eauto.
             eapply loop_contains_deq_loop in Hin. eapply deq_loop_depth in Hin.
             rewrite Hpath in Hlen.
             destruct k;cbn in *;[congruence|lia].
          -- eapply IHt. all: cycle 1; eauto. cbn in H0. inversion H0. eauto.
        * destruct j'.
          -- exfalso.
             cbn in Hpath.
             eapply tag_depth_unroot in Hpath;eauto.
             eapply loop_contains_deq_loop in Hin. eapply deq_loop_depth in Hin.
             rewrite Hpath in Hlen.
             destruct k;cbn in *;[|lia].
             eapply loop_contains_loop_head in l0.
             eapply depth_loop_head in l0. lia.
          -- destruct l;cbn in H0;[congruence|].
             eapply IHt. all: cycle 1; eauto.
             instantiate (1:=(n0 :: j')). cbn. inv H0. reflexivity.
        * destruct l.
          -- exfalso.
             eapply tag_depth_unroot in Hpath;eauto.
             rewrite H0 in Hpath. cbn in Hpath.
             eapply loop_contains_deq_loop in Hin as Hdeq. eapply deq_loop_depth in Hdeq.
             eapply loop_contains_loop_head in Hin.
             eapply depth_loop_head in Hin. lia.
          -- cbn in H0. eapply IHt. all: cycle 1; eauto. instantiate (1:=n :: j').
             cbn. rewrite H0. reflexivity.
      + eapply entry_through_header in Hin as Hin'. 2:eauto. 2: destruct H0;eauto.
        subst q.
        assert (entry_edge u h) as Hentry.
        { split. 1: eapply loop_contains_loop_head;eauto. split;destruct H0;eauto. }
        rewrite <-tag_entry_iff in Hentry;eauto.
        assert (| j' ++ k | = depth h).
        { eapply tag_depth_unroot in Hpath;eauto. }
        destruct j'.
        * exfalso.
          cbn in H1, Hentry. destruct k;[congruence|]. rewrite <-H1 in Hlen. cbn in Hlen. lia.
        * destruct j'.
          -- cbn in Hentry. inv Hentry. left. reflexivity.
          -- exfalso.
             rewrite <- H1 in Hlen. cbn in Hlen.
             rewrite app_length in Hlen. lia.
  Qed.

  Lemma ex_entry_rooted (h q : Lab) (j : Tag) n t
        (Hin : loop_contains h q)
        (Hpath : TPath (root,start_tag) (q,j) t)
        (Hdep : depth h = n)
    : (h,0 :: (take_r (n-1) j)) ∈ t.
  Proof.
    assert (n <= |j|) as Hnj.
    {
      eapply loop_contains_deq_loop in Hin.
      eapply deq_loop_depth in Hin.
      eapply tag_depth' in Hpath. rewrite Hpath.
      lia.
    }
    eapply ex_entry in Hpath;eauto.
    - eapply root_no_loop.
    - cbn. symmetry. eapply depth_root.
    - eapply take_take_r with (n:=|j| - (n - 1)).
      lia.
    - rewrite <- Hdep.
      eapply (take_r_length_le).
      lia.
  Qed.

  Lemma ex_entry_innermost (h p q : Lab) (i j : Tag) t
        (Hdep : | i | = depth p)
        (Hin : innermost_loop h q)
        (Hnin : ~ loop_contains h p)
        (Hpath : TPath (p,i) (q,j) t)
    : (h,0 :: tl j) ∈ t.
  Proof.
    destruct Hin as [Hloop Hinner].
    eapply loop_contains_deq_loop in Hloop as Hdeq.
    eapply deq_loop_depth in Hdeq.
    eapply loop_contains_loop_head in Hloop as Hhead.
    eapply depth_loop_head in Hhead. cbn in Hpath.
    eapply tag_depth_unroot in Hpath as Hq;eauto.
    destruct j;cbn;[exfalso;cbn in Hq;lia|].
    eapply ex_entry with (j':=[n]) in Hloop;eauto.
    cbn in Hq. eapply deq_loop_depth in Hinner. lia.
  Qed.

  Lemma tagle_monotone q j p i t h n
        (Hlen : |j| = depth q)
        (Hpath : TPath (q,j) (p,i) t)
        (Hdeqq : deq_loop q h)
        (Hdeqp : deq_loop p h)
        (Hdep : depth h = n)
    : take_r n j ⊴ take_r n i.
  Proof.
    revert n h p i Hpath Hdeqp Hdeqq Hdep.
    induction t;intros; inv_path Hpath.
    - reflexivity.
    - case (depth h) eqn:E.
      { cbn. reflexivity. }
      destruct x.
      eapply tcfg_edge_destruct' in H0.
      eapply tag_depth_unroot in H as Htagt0;eauto.
      destruct H0 as [[H0 Q0]|[[H0 Q0]|[[H0 Q0]|[H0 Q0]]]].
      + subst. eapply IHt;eauto.
        eapply basic_edge_eq_loop in Q0. symmetry in Q0. eapply eq_loop1;eauto.
      + decide (loop_contains p q).
        * subst i.
          specialize (tcfg_reachability Hlen) as Hreach.
          destructH.
          eapply ex_entry_rooted in Hreach as Hentry;eauto.
          eapply path_from_elem in Hentry;eauto.
          destructH.
          eapply path_app' in Hpath;eauto.
          eapply depth_entry in Q0 as Q1.
          eapply loop_contains_deq_loop in l as Hdeppq. eapply deq_loop_depth in Hdeppq.
          assert (depth p - 1 = depth e) as Hdeppe by lia.
          eapply deq_loop_depth in Hdeqq as Hdepq.
          eapply deq_loop_depth in Hdeqp as Hdepp.
          eapply tcfg_fresh in Hpath.
          2: {
            cbn.
            rewrite take_r_length_le.
            1: lia.
            lia.
          }
          2: { cbn. destruct t;[inv H|]. cbn. lia. }
          rewrite taglt_cons in Hpath.
          decide (depth p - 1 <= S n).
          -- left.
             eapply taglt_leq with (m:=depth p - 1).
             2-4: cbn;lia.
             rewrite take_r_cons_drop.
             2: lia.
             rewrite Hdeppe at 2. rewrite <-Htagt0.
             rewrite take_r_self. eassumption.
          -- eapply taglt_tagle in Hpath. eapply tagle_take_r with (n:=S n) in Hpath.
             rewrite take_r_cons_drop.
             2: lia.
             rewrite take_r_take_r_leq in Hpath.
             2: lia.
             eassumption.
        * subst i.
          assert (deq_loop e h) as Hdeqe.
          {
            intros h' Hh'.
             eapply deq_loop_entry_or in Q0;cycle 1.
             { eapply Hdeqp;eauto. }
             destruct Q0.
             - auto.
             - exfalso.
               subst p. eapply n0. eauto using loop_contains_deq_loop.
          }
          rewrite take_r_cons_drop.
          -- eapply IHt;eauto.
          -- rewrite Htagt0. rewrite <-E. eapply deq_loop_depth. auto.
      + destruct t0.
        { exfalso. cbn in Htagt0. eapply back_edge_eq_loop in Q0.
          rewrite Q0 in Htagt0. enough (depth p > 0) by lia.
          eapply deq_loop_depth in Hdeqp. lia.
        }
        rewrite H0.
        transitivity (take_r (S n) (n0 :: t0)).
        * eapply IHt;eauto.
          eapply back_edge_eq_loop in Q0. symmetry in Q0. eapply eq_loop1;eauto.
        * unfold STag.
          eapply tagle_take_r.
          econstructor.
          econstructor.
          lia.
      + destruct t0.
        {
          exfalso.
          cbn in Htagt0.
          eapply depth_exit in Q0.
          lia.
        }
        eapply IHt in H;eauto.
        * cbn in H0. subst t0.
          setoid_rewrite <-take_r_cons_drop at 2;eauto.
          eapply deq_loop_depth in Hdeqp.
          erewrite tag_depth_unroot;eauto. lia.
        * transitivity p;eauto.
          destruct Q0. eapply deq_loop_exited;eauto.
  Qed.

  Lemma tagle_monotone_eq_loop q1 q2 j1 j2 r
        (Hdep : | j1 | = depth q1)
        (Hpath : TPath (q1,j1) (q2,j2) r)
        (Hin : forall x, x ∈ map fst r -> deq_loop x q1)
        (Heq : eq_loop q1 q2)
    : j1 ⊴ j2.
  Proof.
    copy Hpath Hpath1.
    eapply tagle_monotone in Hpath.
    4: destruct Heq as [_ Heq];eapply Heq.
    3: reflexivity.
    2: assumption.
    2: reflexivity.
    rewrite take_r_geq in Hpath.
    2: rewrite <-Hdep;eauto.
    rewrite take_r_geq in Hpath.
    1: assumption.
    rewrite Heq.
    eapply tag_depth_unroot in Hpath1;eauto.
    rewrite Hpath1;eauto.
  Qed.

  Lemma tcfg_acyclic p i q j t
        (Hdep : | i | = depth p)
        (Hedge : tcfg_edge (q,j) (p,i))
        (Hpath : TPath (p,i) (q,j) t)
    : False.
  Proof.
    eapply PathCons in Hedge;eauto.
    eapply tcfg_fresh in Hedge;cbn;eauto.
    2: inv_path Hpath;cbn;eauto;lia.
    eapply Taglt_irrefl;eassumption.
  Qed.

End cfg.


Require Import Frap Pset11Sig.

Theorem deadlock_freedom : forall h p,
    Forall (fun c => goodCitizen {} c {}) p
    -> invariantFor (trsys_of h {} p) (fun h_l_p =>
                                         let '(_, _, p') := h_l_p in
                                         Forall finished p'
                                         \/ exists h_l_p', step h_l_p h_l_p').
Proof.
  (* To begin with, we weaken the invariant to the one proved in Pset11Sig. *)
  simplify.
  eapply invariant_weaken.
  eauto using a_useful_invariant.

  (* What's left is to prove that that invariant implies deadlock-freedom. *)
  first_order.
  cases s.
  cases p0.
  invert H0.

  (* We don't actually need to use the [disjointLocks] property.  It was only
   * important in strengthening the induction to prove that other invariant.
   * Also, the original hypothesis won't be needed anymore.*)
  clear H H6.
Admitted.


Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Export DeclarationEvaluation.

(******************************************************************************)
(* Weakening lemmas                                                           *)
(******************************************************************************)

Lemma shift_value {t} :
  ∀ {c}, Value t → Value (shiftTm c t).
Proof.
  induction t; simpl; intros; try contradiction; destruct_conjs; auto.
Qed.

Lemma weaken_value u :
  ∀ {t}, Value t → Value (weakenTm t u).
Proof.
  induction u as [|[]]; simpl; auto using shift_value.
Qed.

(******************************************************************************)
(* Progress                                                                   *)
(******************************************************************************)

Lemma can_form_tarr {Γ t T1 T2} (v: Value t) (wt: Typing Γ t (tarr T1 T2)) :
  ∃ t2, t = abs T1 t2.
Proof.
  depind wt; try contradiction; exists t; reflexivity.
Qed.

Lemma can_form_tprod {Γ t T1 T2} (v: Value t) (wt: Typing Γ t (tprod T1 T2)) :
  ∃ t1 t2, t = prod t1 t2 ∧ Typing Γ t1 T1 ∧ Typing Γ t2 T2.
Proof.
  depind wt; try contradiction; exists t1, t2; split; auto.
Qed.

Lemma matching_defined {Γ p T1 Δ} (wp: PTyping Γ p T1 Δ) :
  ∀ {t1}, Value t1 → Typing Γ t1 T1 → ∀ t2, ∃ t2', Match p t1 t2 t2'.
Proof.
  induction wp; intros t1 v1 wt1 t2; isimpl.
  - exists (substTm X0 t1 t2).
    refine M_Var.
  - destruct (can_form_tprod v1 wt1) as (t11 & t12 & eq & wt11 & wt12); subst.
    destruct v1 as [v11 v12].
    apply (weaken_Typing G) in wt12.
    assert (val12' : Value (weakenTm t12 (domainEnv G)))
      by (apply weaken_value; auto).
    rewrite <- (domain_PTyping_bindPat _ _ _ _  wp1) in *.
    destruct (IHwp2 (weakenTm t12 (domainEnv G)) val12' wt12 t2) as [t2' m2].
    destruct (IHwp1 _ v11 wt11 t2') as [t2'' m1].
    rewrite (domain_PTyping_bindPat _ _ _ _ wp1) in m2.
    exists t2''.
    exact (M_Prod m2 m1).
Qed.

Lemma progress {t U} (wt: Typing empty t U) :
  Value t ∨ ∃ t', red t t'.
Proof with try (subst; eauto using red).
  depind wt; isimpl; auto.
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
    destruct (can_form_tarr v1 wt1)...
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct (matching_defined wtp v1 wt1 t2)...
Qed.

(******************************************************************************)
(* Preservation                                                               *)
(******************************************************************************)

Lemma local_preservation_lett {p t1 t2 t2'} (m: Match p t1 t2 t2') :
  ∀ {Γ T1 T2 Δ}, PTyping Γ p T1 Δ → Typing Γ t1 T1 →
    Typing (appendEnv Γ Δ) t2 (weakenTy T2 (domainEnv Δ)) → Typing Γ t2' T2.
Proof.
  induction m; intros Γ T1 T2 Δ wtp wt1 wt2; isimpl.
  - dependent destruction wtp.
    eauto using subst_evar_Typing with infra.
  - dependent destruction wtp. dependent destruction wt1. isimpl.
    eapply IHm2; eauto.
    eapply IHm1; eauto.
    rewrite <- (domain_PTyping_bindPat _ _ _ _ wtp1) in *.
    eauto using weaken_Typing with infra.
Qed.

Lemma preservation {Γ t U} (wt: Typing Γ t U) :
  ∀ {t'}, red t t' → Typing Γ t' U.
Proof.
  induction wt; intros t' r; inversion r; subst;
    eauto using Typing, local_preservation_lett.
  - inversion wt1; eauto using subst_evar_Typing with infra.
  - eapply local_preservation_lett; eauto; isimpl.
    rewrite <- (domain_PTyping_bindPat _ _ _ _ wtp) in *; eauto.
Qed.


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University
  Copyright 2018 Luxembourg University
  Copyright 2019 Luxembourg University

  This file is part of Velisarios.

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

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

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

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Import QArith.
Require Export DTime.

Section DTimeQ.

  Definition Q_dt_T : Type := Q.

  Definition Q_dt_0 : Q_dt_T := 0%Q.

  Definition Q_dt_1 : Q_dt_T := 1%Q.

  Definition Q_dt_add : Q_dt_T -> Q_dt_T -> Q_dt_T := Qplus.

  Definition Q_dt_mul : Q_dt_T -> Q_dt_T -> Q_dt_T := Qmult.

  Definition Q_dt_sub : Q_dt_T -> Q_dt_T -> Q_dt_T := Qminus.

  Definition Q_dt_opp : Q_dt_T -> Q_dt_T := Qopp.

  Definition Q_dt_eq : relation Q_dt_T := Qeq.

  Definition Q_dt_lt : relation Q_dt_T := Qlt.

  Definition Q_dt_le : relation Q_dt_T := Qle.

  Definition Q_dt_eqv : Equivalence Q_dt_eq := Q_Setoid.

  Definition Q_dt_ring : ring_theory Q_dt_0 Q_dt_1 Q_dt_add Q_dt_mul Q_dt_sub Q_dt_opp Q_dt_eq.
  Proof.
    exact Qsrt.
  Qed.

  Definition Q_dt_nat_inj : nat -> Q_dt_T := fun n => inject_Z (Z.of_nat n).

  Definition Q_dt_add_morph : forall x y, Q_dt_eq x y -> forall u v, Q_dt_eq u v -> Q_dt_eq (Q_dt_add x u) (Q_dt_add y v).
  Proof.
    introv a b; rewrite a, b; reflexivity.
  Qed.

  Definition Q_dt_mul_morph : forall x y, Q_dt_eq x y -> forall u v, Q_dt_eq u v -> Q_dt_eq (Q_dt_mul x u) (Q_dt_mul y v).
  Proof.
    introv a b; rewrite a, b; reflexivity.
  Qed.

  Definition Q_dt_opp_morph : forall x y, Q_dt_eq x y -> Q_dt_eq (Q_dt_opp x) (Q_dt_opp y).
  Proof.
    introv a; rewrite a; reflexivity.
  Qed.

  Definition Q_dt_le_morph : forall x y, Q_dt_eq x y -> forall u v, Q_dt_eq u v -> Q_dt_le x u -> Q_dt_le y v.
  Proof.
    introv a b h; rewrite a, b in h; auto.
  Qed.

  Definition Q_dt_lt_morph : forall x y, Q_dt_eq x y -> forall u v, Q_dt_eq u v -> Q_dt_lt x u -> Q_dt_lt y v.
  Proof.
    introv a b h; rewrite a, b in h; auto.
  Qed.

  Definition Q_dt_nat_inj_cond : forall (n : nat), Q_dt_eq (Q_dt_nat_inj n) (ntimes n Q_dt_0 Q_dt_1 Q_dt_add).
  Proof.
    unfold Q_dt_eq, Q_dt_nat_inj, Q_dt_0; induction n; simpl; auto; try reflexivity.
    rewrite <- IHn; clear IHn.
    unfold Q_dt_nat_inj, Q_dt_add, Q_dt_1; simpl.
    assert (1%Q = inject_Z (Z.of_nat 1)) as xx by auto; rewrite xx; clear xx.
    rewrite <- inject_Z_plus.
    rewrite <- Nat2Z.inj_add; simpl; auto; try reflexivity.
  Qed.

  Definition Q_dt_le_refl : forall t , Q_dt_le t t.
  Proof.
    apply Qle_refl.
  Qed.

  Definition Q_dt_lt_irrefl : forall t , ~ (Q_dt_lt t t).
  Proof.
    apply Qlt_irrefl.
  Qed.

  Definition Q_dt_add_le_compat : forall a b c d, Q_dt_le a c -> Q_dt_le b d -> Q_dt_le (Q_dt_add a b) (Q_dt_add c d).
  Proof.
    introv; apply Qplus_le_compat.
  Qed.

  Definition Q_dt_add_lt_le_compat : forall a b c d, Q_dt_lt a c -> Q_dt_le b d -> Q_dt_lt (Q_dt_add a b) (Q_dt_add c d).
  Proof.
    introv; apply Qplus_lt_le_compat.
  Qed.

  Definition Q_dt_mul_le_compat_r : forall a b c, Q_dt_le a b -> Q_dt_le Q_dt_0 c -> Q_dt_le (Q_dt_mul a c) (Q_dt_mul b c).
  Proof.
    introv; apply Qmult_le_compat_r.
  Qed.

  Definition Q_dt_le_trans : forall a b c, Q_dt_le a b -> Q_dt_le b c -> Q_dt_le a c.
  Proof.
    introv; apply Qle_trans.
  Qed.

  Definition Q_dt_lt_trans : forall a b c, Q_dt_lt a b -> Q_dt_lt b c -> Q_dt_lt a c.
  Proof.
    introv; apply Qlt_trans.
  Qed.

  Definition Q_dt_le_lt_trans : forall a b c, Q_dt_le a b -> Q_dt_lt b c -> Q_dt_lt a c.
  Proof.
    introv; apply Qle_lt_trans.
  Qed.

  Definition Q_dt_lt_le_trans : forall a b c, Q_dt_lt a b -> Q_dt_le b c -> Q_dt_lt a c.
  Proof.
    introv; apply Qlt_le_trans.
  Qed.

  Definition Q_dt_mul_0_l : forall x, Q_dt_eq (Q_dt_mul Q_dt_0 x) Q_dt_0.
  Proof.
    introv; apply Qmult_0_l.
  Qed.

  Definition Q_dt_lt_0_1 : Q_dt_lt Q_dt_0 Q_dt_1.
  Proof.
    unfold Q_dt_lt, Q_dt_0, Q_dt_1; simpl.
    assert (1%Q = inject_Z (Z.of_nat 1)) as xx by auto; rewrite xx; clear xx.
    assert (0%Q = inject_Z (Z.of_nat 0)) as xx by auto; rewrite xx; clear xx.
    rewrite <- Zlt_Qlt.
    apply inj_lt; omega.
  Qed.

  Definition Q_dt_lt_le_weak : forall a b, Q_dt_lt a b -> Q_dt_le a b.
  Proof.
    introv; apply Qlt_le_weak.
  Qed.

  Definition Q_dt_lt_le_dec : forall x y, {Q_dt_lt x y} + {Q_dt_le y x}.
  Proof.
    introv; apply Qlt_le_dec.
  Qed.

  Definition Q_dt_eq_dec : forall x y, {Q_dt_eq x y} + {~ Q_dt_eq x y}.
  Proof.
    introv; apply Qeq_dec.
  Qed.

  Definition Q_dt_nat_inj_add_dist : forall n m, Q_dt_eq (Q_dt_add (Q_dt_nat_inj n) (Q_dt_nat_inj m)) (Q_dt_nat_inj (n + m)).
  Proof.
    introv; unfold Q_dt_eq, Q_dt_add, Q_dt_nat_inj; simpl.
    rewrite <- inject_Z_plus.
    rewrite <- Nat2Z.inj_add; simpl; auto; try reflexivity.
  Qed.

  Definition Q_dt_nat_nat_inj_le : forall n m, n <= m -> Q_dt_le (Q_dt_nat_inj n) (Q_dt_nat_inj m).
  Proof.
    introv h; unfold Q_dt_eq, Q_dt_add, Q_dt_nat_inj, Q_dt_le; simpl.
    rewrite <- Zle_Qle; apply inj_le; auto.
  Qed.

  Definition Q_dt_nat_nat_inj_lt : forall n m, n < m -> Q_dt_lt (Q_dt_nat_inj n) (Q_dt_nat_inj m).
  Proof.
    introv h; unfold Q_dt_eq, Q_dt_add, Q_dt_nat_inj, Q_dt_lt; simpl.
    rewrite <- Zlt_Qlt; apply inj_lt; auto.
  Qed.

  Definition Q_dt_mul_le_r_le : forall x y z, Q_dt_lt Q_dt_0 z -> Q_dt_le (Q_dt_mul x z) (Q_dt_mul y z) -> Q_dt_le x y.
  Proof.
    introv h q.
    apply (Qmult_le_r x y z h); auto.
  Qed.

  Definition Q_dt_mul_lt_compat_r : forall a b c, Q_dt_lt a b -> Q_dt_lt Q_dt_0 c -> Q_dt_lt (Q_dt_mul a c) (Q_dt_mul b c).
  Proof.
    introv h q; apply Qmult_lt_r; auto.
  Qed.

  Definition Q_dt_mul_lt_r_lt : forall x y z, Q_dt_lt Q_dt_0 z -> Q_dt_lt (Q_dt_mul x z) (Q_dt_mul y z) -> Q_dt_lt x y.
  Proof.
    introv h q; eapply Qmult_lt_r; eauto.
  Qed.

  Definition Q_dt_nat_inj_lt_nat : forall n m, Q_dt_lt (Q_dt_nat_inj n) (Q_dt_nat_inj m) -> n < m.
  Proof.
    introv h; unfold Q_dt_lt, Q_dt_nat_inj in *.
    rewrite <- Zlt_Qlt in h.
    apply Nat2Z.inj_lt in h; auto.
  Qed.

  Definition Q_dt_approx (x : Q) : nat :=
    Z.abs_nat (Qnum x).

  Global Instance DTimeContextQ : DTimeContext :=
    MkDTimeContext
      Q_dt_T
      Q_dt_0
      Q_dt_1
      Q_dt_add
      Q_dt_mul
      Q_dt_sub
      Q_dt_opp
      Q_dt_eq
      Q_dt_lt
      Q_dt_le
      Q_dt_eqv
      Q_dt_ring
      Q_dt_nat_inj
      Q_dt_approx
      Q_dt_add_morph
      Q_dt_mul_morph
      Q_dt_opp_morph
      Q_dt_le_morph
      Q_dt_lt_morph
      Q_dt_nat_inj_cond
      Q_dt_le_refl
      Q_dt_lt_irrefl
      Q_dt_add_le_compat
      Q_dt_add_lt_le_compat
      Q_dt_mul_le_compat_r
      Q_dt_mul_lt_compat_r
      Q_dt_le_trans
      Q_dt_lt_trans
      Q_dt_le_lt_trans
      Q_dt_lt_le_trans
      Q_dt_mul_0_l
      Q_dt_mul_le_r_le
      Q_dt_mul_lt_r_lt
      Q_dt_lt_0_1
      Q_dt_lt_le_weak
      Q_dt_lt_le_dec
      Q_dt_eq_dec
      Q_dt_nat_inj_add_dist
      Q_dt_nat_nat_inj_le
      Q_dt_nat_nat_inj_lt
      Q_dt_nat_inj_lt_nat.

End DTimeQ.


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

Require Export CoRN.ftc.PartInterval.
Require Export CoRN.ftc.DerivativeOps.

Section Definitions.

(**
* Differentiability

We will now use our work on derivatives to define a notion of
differentiable function and prove its main properties.

%\begin{convention}% Throughout this section, [a,b] will be real
numbers with [a [<] b], [I] will denote the interval [[a,b]]
and [F,G,H] will be differentiable functions.
%\end{convention}%

Usually a function [F] is said to be differentiable in a proper
compact interval [[a,b]] if there exists another function [F']
such that [F'] is a derivative of [F] in that interval.  There is a
problem in formalizing this definition, as we pointed out earlier on,
which is that if we simply write it down as is we are not able to get
such a function [F'] from a hypothesis that [F] is differentiable.

However, it turns out that this is not altogether the best definition
for the following reason: if we say that [F] is differentiable in
[[a,b]], we mean that there is a partial function [F'] which is
defined in [[a,b]] and satisfies a certain condition in that
interval but nothing is required of the behaviour of the function
outside [[a,b]].  Thus we can argue that, from a mathematical
point of view, the [F'] that we get eliminating a hypothesis of
differentiability should be defined exactly on that interval.  If we
do this, we can quantify over the set of setoid functions in that
interval and eliminate the existencial quantifier without any
problems.
*)

Definition Diffble_I (a b : IR) (Hab : a [<] b) (F : PartIR) :=
 {f' : CSetoid_fun (subset (Compact (less_leEq _ _ _ Hab))) IR |
  Derivative_I Hab F (PartInt f')}.

End Definitions.

Arguments Diffble_I [a b].

Section Local_Properties.

(**
From this point on, we just prove results analogous to the ones for derivability.

A function differentiable in [[a,b]] is differentiable in every proper compact subinterval of [[a,b]].
*)

Lemma included_imp_diffble : forall a b Hab c d Hcd F,
 included (compact c d (less_leEq _ _ _ Hcd)) (compact a b (less_leEq _ _ _ Hab)) ->
 Diffble_I Hab F -> Diffble_I Hcd F.
Proof.
 intros a b Hab c d Hcd F H H0.
 elim H0; clear H0; intros f' derF.
 exists (IntPartIR (F:=(Frestr (F:=PartInt f') (compact_wd _ _ _) H)) (included_refl _ _)).
 apply Derivative_I_wdr with (PartInt f').
  FEQ.
  simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra.
 exact (included_imp_deriv _ _ _ _ _ _ _ _ H derF).
Qed.

(**
A function differentiable in an interval is everywhere defined in that interval.
*)

Variables a b : IR.
Hypothesis Hab' : a [<] b.

(* begin hide *)
Let Hab := less_leEq _ _ _ Hab'.
Let I := Compact Hab.
(* end hide *)

Lemma diffble_imp_inc : forall F, Diffble_I Hab' F -> included I (Dom F).
Proof.
 intros F H.
 inversion_clear H.
 unfold I, Hab in |- *; Included.
Qed.

(**
If a function has a derivative in an interval then it is differentiable in that interval.
*)

Lemma deriv_imp_Diffble_I : forall F F', Derivative_I Hab' F F' -> Diffble_I Hab' F.
Proof.
 intros F F' H.
 exists (IntPartIR (derivative_imp_inc' _ _ _ _ _ H)).
 apply Derivative_I_wdr with F'.
  apply int_part_int.
 assumption.
Qed.

End Local_Properties.

#[global]
Hint Resolve diffble_imp_inc: included.

Section Operations.

(**
All the algebraic results carry on.
*)

Variables a b : IR.
Hypothesis Hab' : a [<] b.

(* begin hide *)
Let Hab := less_leEq _ _ _ Hab'.
Let I := Compact Hab.
(* end hide *)

Section Constants.

Lemma Diffble_I_const : forall c : IR, Diffble_I Hab' [-C-]c.
Proof.
 intros.
 exists (IConst (Hab:=Hab) [0]).
 apply Derivative_I_wdr with ( [-C-][0]:PartIR).
  apply part_int_const.
 Deriv.
Qed.

Lemma Diffble_I_id : Diffble_I Hab' FId.
Proof.
 exists (IConst (Hab:=Hab) [1]).
 apply Derivative_I_wdr with ( [-C-][1]:PartIR).
  apply part_int_const.
 Deriv.
Qed.

Lemma Diffble_I_poly : forall p, Diffble_I Hab' (FPoly _ p).
Proof.
 intros p.
 exists (@IntPartIR (FPoly _ (_D_ p)) _ _ Hab (included_IR _)).
 apply Derivative_I_wdr with (FPoly _ (_D_ p)).
  apply int_part_int.
 Deriv.
Qed.

End Constants.

Section Well_Definedness.

Variables F H : PartIR.

Hypothesis diffF : Diffble_I Hab' F.

Lemma Diffble_I_wd : Feq (Compact Hab) F H -> Diffble_I Hab' H.
Proof.
 intro H0.
 exists (ProjT1 diffF).
 eapply Derivative_I_wdl.
  apply H0.
 apply projT2.
Qed.

End Well_Definedness.

Variables F G : PartIR.

Hypothesis diffF : Diffble_I Hab' F.
Hypothesis diffG : Diffble_I Hab' G.

Lemma Diffble_I_plus : Diffble_I Hab' (F{+}G).
Proof.
 elim diffF; intros F' derF.
 elim diffG; intros G' derG.
 exists (IPlus F' G').
 eapply Derivative_I_wdr.
  apply part_int_plus with (F := PartInt F') (G := PartInt G').
   apply Feq_reflexive; Included.
  apply Feq_reflexive; Included.
 Deriv.
Qed.

Lemma Diffble_I_inv : Diffble_I Hab' {--}F.
Proof.
 elim diffF; intros F' derF.
 exists (IInv F').
 eapply Derivative_I_wdr.
  apply part_int_inv with (F := PartInt F').
  apply Feq_reflexive; Included.
 Deriv.
Qed.

Lemma Diffble_I_mult : Diffble_I Hab' (F{*}G).
Proof.
 elim diffF; intros F' derF.
 elim diffG; intros G' derG.
 exists (IPlus (IMult (IntPartIR (diffble_imp_inc _ _ _ _ diffF)) G')
   (IMult F' (IntPartIR (diffble_imp_inc _ _ _ _ diffG)))).
 eapply Derivative_I_wdr.
  apply part_int_plus with (F := PartInt (IMult (IntPartIR (diffble_imp_inc _ _ _ _ diffF)) G'))
    (G := PartInt (IMult F' (IntPartIR (diffble_imp_inc _ _ _ _ diffG)))).
   apply Feq_reflexive; Included.
  apply Feq_reflexive; Included.
 eapply Derivative_I_wdr.
  apply Feq_plus with (F := F{*}PartInt G') (G := PartInt F'{*}G).
   apply part_int_mult.
    FEQ.
   apply Feq_reflexive; Included.
  apply part_int_mult.
   apply Feq_reflexive; Included.
  FEQ.
 Deriv.
Qed.

(* begin show *)
Hypothesis Gbnd : bnd_away_zero I G.
(* end show *)

Lemma Diffble_I_recip : Diffble_I Hab' {1/}G.
Proof.
 elim diffG; intros G' derG.
 cut (included I (Dom G)); [ intro Hg' | unfold I, Hab in |- *; Included ].
 unfold I in Hg';
   cut (forall x : subset I, IMult (IntPartIR Hg') (IntPartIR Hg') x [#] [0]). intro H.
  exists (IInv (IDiv G' _ H)).
  eapply Derivative_I_wdr.
   apply part_int_inv with (F := PartInt (IDiv G' _ H)).
   apply Feq_reflexive; Included.
  eapply Derivative_I_wdr.
   apply Feq_inv with (F := PartInt G'{/}PartInt (IMult (IntPartIR Hg') (IntPartIR Hg'))).
   apply part_int_div.
     apply Feq_reflexive; Included.
    apply Feq_reflexive; simpl in |- *; Included.
   red in |- *; intros.
   split.
    simpl in |- *; Included.
   elim Gbnd; intros Hinc c.
   elim c; clear c; intros c H0 H1.
   exists (c[*]c).
    apply mult_resp_pos; assumption.
   intros.
   simpl in |- *.
   eapply leEq_wdr.
    2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult.
   apply mult_resp_leEq_both; auto; apply less_leEq; assumption.
  eapply Derivative_I_wdr.
   apply Feq_inv with (F := PartInt G'{/}G{*}G).
   apply Feq_div.
     Included.
    apply Feq_reflexive; Included.
   apply part_int_mult.
    FEQ.
   FEQ.
  Deriv.
 intro x.
 simpl in |- *.
 apply mult_resp_ap_zero; apply bnd_imp_ap_zero with I; auto; apply scs_prf.
Qed.

End Operations.

Section Corollaries.

Variables a b : IR.
Hypothesis Hab' : a [<] b.

(* begin hide *)
Let Hab := less_leEq _ _ _ Hab'.
Let I := Compact Hab.
(* end hide *)

Variables F G : PartIR.

Hypothesis diffF : Diffble_I Hab' F.
Hypothesis diffG : Diffble_I Hab' G.

Lemma Diffble_I_minus : Diffble_I Hab' (F{-}G).
Proof.
 apply Diffble_I_wd with (F{+}{--}G).
  apply Diffble_I_plus.
   assumption.
  apply Diffble_I_inv; assumption.
 FEQ.
Qed.

Lemma Diffble_I_scal : forall c : IR, Diffble_I Hab' (c{**}F).
Proof.
 intro.
 unfold Fscalmult in |- *.
 apply Diffble_I_mult.
  apply Diffble_I_const.
 assumption.
Qed.

Lemma Diffble_I_nth : forall n : nat, Diffble_I Hab' (F{^}n).
Proof.
 intro.
 induction  n as [| n Hrecn].
  eapply Diffble_I_wd.
   2: apply FNth_zero'; Included.
  apply Diffble_I_const.
 eapply Diffble_I_wd.
  2: apply FNth_mult'; Included.
 apply Diffble_I_mult; assumption.
Qed.

Hypothesis Gbnd : bnd_away_zero I G.

Lemma Diffble_I_div : Diffble_I Hab' (F{/}G).
Proof.
 apply Diffble_I_wd with (F{*}{1/}G).
  apply Diffble_I_mult.
   assumption.
  apply Diffble_I_recip; assumption.
 FEQ.
Qed.

End Corollaries.

Section Other_Properties.

(**
Differentiability of families of functions is proved by
induction using the constant and addition rules.
*)

Variables a b : IR.
Hypothesis Hab' : a [<] b.

Lemma Diffble_I_Sum0 : forall (f : nat -> PartIR),
 (forall n, Diffble_I Hab' (f n)) -> forall n, Diffble_I Hab' (FSum0 n f).
Proof.
 intros f diffF.
 induction  n as [| n Hrecn].
  apply Diffble_I_wd with (Fconst (S:=IR) [0]).
   apply Diffble_I_const.
  FEQ.
  red in |- *; simpl in |- *; intros.
  apply (diffble_imp_inc _ _ _ _ (diffF n)); assumption.
 apply Diffble_I_wd with (FSum0 n f{+}f n).
  apply Diffble_I_plus.
   auto.
  auto.
 FEQ.
  simpl in |- *; red in |- *; intros.
  apply (diffble_imp_inc _ _ _ _ (diffF n0)); assumption.
 simpl in |- *.
 apply bin_op_wd_unfolded; try apply Sum0_wd; intros; rational.
Qed.

Lemma Diffble_I_Sumx : forall n (f : forall i, i < n -> PartIR),
 (forall i Hi, Diffble_I Hab' (f i Hi)) -> Diffble_I Hab' (FSumx n f).
Proof.
 intro; induction  n as [| n Hrecn]; intros.
  simpl in |- *; apply Diffble_I_const.
 simpl in |- *.
 apply Diffble_I_plus; auto.
Qed.

Lemma Diffble_I_Sum : forall (f : nat -> PartIR),
 (forall n, Diffble_I Hab' (f n)) -> forall m n, Diffble_I Hab' (FSum m n f).
Proof.
 intros.
 eapply Diffble_I_wd.
  2: apply Feq_symmetric; apply FSum_FSum0'; Included.
 apply Diffble_I_minus; apply Diffble_I_Sum0; auto.
Qed.

End Other_Properties.

(**
Finally, a differentiable function is continuous.

%\begin{convention}% Let [F] be a partial function with derivative [F'] on [I].
%\end{convention}%
*)

Lemma diffble_imp_contin_I : forall a b (Hab' : a [<] b) (Hab : a [<=] b) F,
 Diffble_I Hab' F -> Continuous_I Hab F.
Proof.
 intros a b Hab' Hab F H.
 apply deriv_imp_contin_I with Hab' (PartInt (ProjT1 H)).
 apply projT2.
Qed.

#[global]
Hint Immediate included_imp_contin deriv_imp_contin_I deriv_imp_contin'_I
  diffble_imp_contin_I: continuous.

#[global]
Hint Immediate included_imp_deriv: derivate.