(**************************************************************************)
(*                                                                        *)
(*     SMTCoq                                                             *)
(*     Copyright (C) 2011 - 2021                                          *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

(*** Spl -- a small checker for simplifications ***)

Require Import List PArray Bool Int63 ZMicromega.
Require Import Misc State SMT_terms.

Local Open Scope array_scope.
Local Open Scope int63_scope.

(* Simplification of SMTLIB-2 operators *)

Section Operators.

  Import Form.

  Variable t_form : PArray.array Form.form.
  Variable t_atom : PArray.array Atom.atom.

  Local Notation get_form := (PArray.get t_form).
  Local Notation get_atom := (PArray.get t_atom).

  Fixpoint check_in x l :=
    match l with
      | nil => false
      | t::q => if x == t then true else check_in x q
    end.

  Lemma check_in_spec : forall x l, check_in x l = true <-> In x l.
  Proof.
    intro x; induction l as [ |t q IHq]; simpl.
    split; intro H; try discriminate; elim H.
    case_eq (x == t).
    rewrite eqb_spec; intro; subst t; split; auto.
    intro H; rewrite IHq; split; auto; intros [H1|H1]; auto; rewrite H1, eqb_refl in H; discriminate.
  Qed.

  Fixpoint check_diseqs_complete_aux a dist t :=
    match dist with
      | nil => true
      | b::q => if PArray.existsb (fun (x:option (int*int)) =>
        match x with
          | Some (a',b') => ((a == a') && (b == b')) || ((a == b') && (b == a'))
          | None => false
        end
      ) t then check_diseqs_complete_aux a q t else false
    end.

  Lemma check_diseqs_complete_aux_spec : forall a dist t,
    check_diseqs_complete_aux a dist t = true <->
    forall y, In y dist -> exists i, i < length t /\
      (t.[i] = Some (a,y) \/ t.[i] = Some (y,a)).
  Proof.
    intros a dist t; induction dist as [ |b q IHq]; simpl; split; auto.
    intros _ y H; inversion H.
    case_eq (PArray.existsb (fun x : option (int * int) => match x with | Some (a', b') => (a == a') && (b == b') || (a == b') && (b == a') | None => false end) t); try discriminate; rewrite PArray.existsb_spec; intros [i [H1 H2]]; rewrite IHq; clear IHq; intros H3 y [H4|H4]; auto; subst y; exists i; split; auto; generalize H2; case (t .[ i]); try discriminate; intros [a' b']; rewrite orb_true_iff, !andb_true_iff, !Int63Properties.eqb_spec; intros [[H4 H5]|[H4 H5]]; subst a' b'; auto.
    intro H1; case_eq (PArray.existsb (fun x : option (int * int) => match x with | Some (a', b') => (a == a') && (b == b') || (a == b') && (b == a') | None => false end) t).
    intros _; rewrite IHq; clear IHq; intros y Hy; apply H1; auto.
    rewrite array_existsb_false_spec; destruct (H1 b (or_introl (refl_equal b))) as [i [H2 H3]]; intro H; rewrite <- (H _ H2); destruct H3 as [H3|H3]; rewrite H3; rewrite !eqb_refl; auto; rewrite orb_true_r; auto.
  Qed.

  Lemma check_diseqs_complete_aux_false_spec : forall a dist t,
    check_diseqs_complete_aux a dist t = false <->
    exists y, In y dist /\ forall i, i < length t ->
      (t.[i] <> Some (a,y) /\ t.[i] <> Some (y,a)).
  Proof.
    intros a dist t; induction dist as [ |b q IHq]; simpl; split; try discriminate.
    intros [y [H _]]; elim H.
    case_eq (PArray.existsb (fun x : option (int * int) => match x with | Some (a', b') => (a == a') && (b == b') || (a == b') && (b == a') | None => false end) t).
    intros _; rewrite IHq; clear IHq; intros [y [H3 H4]]; exists y; auto.
    rewrite array_existsb_false_spec; intros H _; exists b; split; auto; intros i Hi; split; intro H1; generalize (H _ Hi); rewrite H1, !eqb_refl; try discriminate; rewrite orb_true_r; discriminate.
    intros [y [H1 H2]]; case_eq (PArray.existsb (fun x : option (int * int) => match x with | Some (a', b') => (a == a') && (b == b') || (a == b') && (b == a') | None => false end) t); auto; rewrite PArray.existsb_spec; intros [i [H3 H4]]; rewrite IHq; clear IHq; exists y; destruct H1 as [H1|H1]; auto; subst y; case_eq (t.[i]); [intros [a' b'] Heq|intro Heq]; rewrite Heq in H4; try discriminate; rewrite orb_true_iff, !andb_true_iff, !eqb_spec in H4; destruct H4 as [[H4 H5]|[H4 H5]]; subst a' b'; generalize (H2 _ H3); rewrite Heq; intros [H4 H5]; [elim H4|elim H5]; auto.
  Qed.

  Fixpoint check_diseqs_complete dist t :=
    match dist with
      | nil => true
      | a::q => if check_diseqs_complete_aux a q t then check_diseqs_complete q t else false
    end.

  Lemma check_diseqs_complete_spec : forall dist t,
    check_diseqs_complete dist t = true <->
    forall x y, In2 x y dist -> exists i, i < length t /\
      (t.[i] = Some (x,y) \/ t.[i] = Some (y,x)).
  Proof.
    intros dist t; induction dist as [ |a q IHq]; simpl; split; auto.
    intros _ x y H; inversion H.
    case_eq (check_diseqs_complete_aux a q t); try discriminate; rewrite check_diseqs_complete_aux_spec, IHq; clear IHq; intros H1 H2 x y H3; inversion H3; auto.
    intro H; case_eq (check_diseqs_complete_aux a q t).
    rewrite IHq; clear IHq; intros _ x y H1; apply H; constructor 2; auto.
    rewrite check_diseqs_complete_aux_false_spec; clear IHq; intros [y [H1 H2]]; destruct (H _ _ (In2_hd _ a _ _ H1)) as [i [H3 [H4|H4]]]; elim (H2 _ H3); rewrite H4; intros H5 H6; [elim H5|elim H6]; auto.
  Qed.

  Lemma check_diseqs_complete_false_spec : forall dist t,
    check_diseqs_complete dist t = false <->
    exists x y, In2 x y dist /\ forall i, i < length t ->
      (t.[i] <> Some (x,y) /\ t.[i] <> Some (y,x)).
  Proof.
    intros dist t; induction dist as [ |a q IHq]; simpl; split; try discriminate.
    intros [x [y [H _]]]; inversion H.
    case_eq (check_diseqs_complete_aux a q t).
    rewrite IHq; clear IHq; intros _ [x [y [H2 H3]]]; inversion H2; clear H2; subst q; exists x; exists y; split; auto; constructor 2.
    constructor 1; auto.
    constructor 2; auto.
    rewrite check_diseqs_complete_aux_false_spec; intros [y [H1 H2]] _; clear IHq; exists a; exists y; split; auto; constructor; auto.
    intros [x [y [H1 H2]]]; case_eq (check_diseqs_complete_aux a q t); auto; rewrite IHq; clear IHq; inversion H1; clear H1.
    subst x q; rewrite check_diseqs_complete_aux_spec; intro H; destruct (H _ H0) as [i [H1 H3]]; elim (H2 _ H1); intros H4 H5; destruct H3; [elim H4|elim H5]; auto.
    subst k q; intros _; exists x; exists y; split; auto.
  Qed.

  Definition check_diseqs ty dist diseq :=
    let t := PArray.mapi (fun _ t =>
      if Lit.is_pos t then None else
        match get_form (Lit.blit t) with
          | Fatom a =>
            match get_atom a with
              | Atom.Abop (Atom.BO_eq A) h1 h2 =>
                if (Typ.eqb ty A) && (negb (h1 == h2)) && (check_in h1 dist) && (check_in h2 dist) then
                  Some (h1,h2)
                else
                  None
              | _ => None
            end
          | _ => None
        end
    ) diseq in
    PArray.forallb (fun x => match x with | None => false | _ => true end) t &&
    check_diseqs_complete dist t.

  Lemma check_diseqs_spec : forall A dist diseq,
    check_diseqs A dist diseq = true <->
    ((forall i, i < length diseq ->
      let t := diseq.[i] in
        ~ Lit.is_pos t /\
        exists a, get_form (Lit.blit t) = Fatom a /\
          exists h1 h2, get_atom a = Atom.Abop (Atom.BO_eq A) h1 h2 /\
            h1 <> h2 /\ (In2 h1 h2 dist \/ In2 h2 h1 dist))
    /\
    (forall x y, In2 x y dist -> exists i, i < length diseq /\
      let t := diseq.[i] in
        ~ Lit.is_pos t /\
        exists a, get_form (Lit.blit t) = Fatom a /\
          x <> y /\
          (get_atom a = Atom.Abop (Atom.BO_eq A) x y \/
            get_atom a = Atom.Abop (Atom.BO_eq A) y x))).
  Proof.
    intros A dist diseq; unfold check_diseqs; rewrite andb_true_iff,
     PArray.forallb_spec, check_diseqs_complete_spec, length_mapi; split; intros [H1 H2]; split.
    clear H2; intros i Hi; generalize (H1 _ Hi); rewrite get_mapi;
    auto; case_eq (Lit.is_pos (diseq .[ i])); try discriminate; intro Heq1; case_eq (get_form (Lit.blit (diseq .[ i])));
    try discriminate; intros a Heq2; case_eq (get_atom a); try discriminate; intros [ | | | | | | | B | | | | | | | | | | | | ]; try discriminate; intros h1 h2 Heq3; case_eq (Typ.eqb A B); try discriminate; change (Typ.eqb A B = true) with (is_true (Typ.eqb A B)); rewrite Typ.eqb_spec; intro; subst B; case_eq (h1 == h2); try discriminate; rewrite eqb_false_spec; intro H2; case_eq (check_in h1 dist); try discriminate; case_eq (check_in h2 dist); try discriminate; rewrite !check_in_spec; intros H3 H4 _; split; try discriminate; exists a; split; auto; exists h1, h2; repeat split; auto; rewrite <- In2_In; auto.
    clear H1; intros x y Hxy; destruct (H2 _ _ Hxy) as [i [H1 H4]]; clear H2; rewrite get_mapi in H4; auto; exists i; split; auto; generalize H4;

    case_eq (Lit.is_pos (diseq .[ i])); intro Heq; try (intros [H|H]; discriminate); case_eq (get_form (Lit.blit (diseq .[ i]))); [intros a| | |intros a1 a2|intros a1|intros a1|intros a1|intros a1 a2|intros a1 a2| intros a1 a2 a3|intros a ls]; intro Heq2; try (intros [H|H]; discriminate); case_eq (get_atom a); [intros a1|intros a1 a2|intros [ | | | | | | | B | | | | | | | | | | | | ] h1 h2|intros a1 a2|intros a1 a2 | intros a1 a2]; intro Heq3; try (intros [H|H]; discriminate); try (case_eq (Typ.eqb A B); try (intros _ [H|H]; discriminate); change (Typ.eqb A B = true) with (is_true (Typ.eqb A B)); rewrite Typ.eqb_spec; intro; subst B; case_eq (h1 == h2); try (intros _ [H|H]; discriminate); rewrite eqb_false_spec; intro H10; case (check_in h1 dist); try (intros [H|H]; discriminate); case (check_in h2 dist); try (intros [H|H]; discriminate); simpl; intro H3; split; try discriminate; exists a; split; auto; destruct H3 as [H3|H3]; inversion H3; subst; auto).
intros. destruct H0; now contradict H0.

    clear H2; intros i Hi; rewrite get_mapi; auto; destruct (H1 _ Hi) as [H2 [a [H3 [h1 [h2 [H4 [H5 H6]]]]]]]; clear H1; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); rewrite H3, H4, Typ.eqb_refl; simpl; replace (h1 == h2) with false by (case_eq (h1 == h2); auto; rewrite eqb_spec; intro H; elim H5; auto); simpl; rewrite <- In2_In, <- !check_in_spec in H6; auto; destruct H6 as [H6 H7]; rewrite H6, H7; auto.
    clear H1; intros x y Hxy; destruct (H2 _ _ Hxy) as [i [H1 [H3 [a [H4 [H6 H5]]]]]]; clear H2; exists i; split; auto; rewrite get_mapi; auto; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); rewrite H4; assert (H7 := or_introl (In2 y x dist) Hxy); rewrite <- In2_In, <- !check_in_spec in H7; auto; destruct H7 as [H7 H8]; destruct H5 as [H5|H5]; rewrite H5, Typ.eqb_refl; [replace (x == y) with false by (case_eq (x == y); auto; rewrite eqb_spec; auto)|replace (y == x) with false by (case_eq (y == x); auto; rewrite eqb_spec; auto)]; simpl; rewrite H7, H8; auto.
  Qed.

  (* Definition check_diseqs ty dist diseq := *)
  (*   PArray.forallb (fun t => *)
  (*     if Lit.is_pos t then false else *)
  (*       match get_form (Lit.blit t) with *)
  (*         | Fatom a => *)
  (*           match get_atom a with *)
  (*             | Atom.Abop (Atom.BO_eq A) h1 h2 => *)
  (*               (Typ.eqb ty A) && (negb (h1 == h2)) && (check_in h1 dist) && (check_in h2 dist) *)
  (*             | _ => false *)
  (*           end *)
  (*         | _ => false *)
  (*       end) diseq. *)

  (* Lemma check_diseqs_spec : forall A dist diseq, *)
  (*   check_diseqs A dist diseq <-> forall i, i < length diseq -> *)
  (*     let t := diseq.[i] in *)
  (*     ~ Lit.is_pos t /\ *)
  (*     exists a, get_form (Lit.blit t) = Fatom a /\ *)
  (*       exists h1 h2, get_atom a = Atom.Abop (Atom.BO_eq A) h1 h2 /\ *)
  (*         (h1 <> h2) /\ ((In2 h1 h2 dist) \/ (In2 h2 h1 dist)). *)
  (* Proof. *)
  (*   intros A dist diseq; unfold check_diseqs; unfold is_true at 1; rewrite PArray.forallb_spec; split. *)
  (*   intros H i Hi; generalize (H _ Hi); clear H; case (Lit.is_pos (diseq .[ i])); try discriminate; case (get_form (Lit.blit (diseq .[ i]))); try discriminate; intros a H1; split; try discriminate; exists a; split; auto; generalize H1; clear H1; case (get_atom a); try discriminate; intros [ | | | | | | |B] h1 h2; try discriminate; rewrite !andb_true_iff; change (check_in h1 dist = true) with (is_true (check_in h1 dist)); change (check_in h2 dist = true) with (is_true (check_in h2 dist)); rewrite !check_in_spec; intros [[[H1 H4] H2] H3]; change (is_true (Typ.eqb A B)) in H1; rewrite Typ.eqb_spec in H1; subst B; exists h1; exists h2; split; auto; assert (H5: h1 <> h2) by (intro H; rewrite H, eqb_refl in H4; discriminate); split; auto; rewrite <- In2_In; auto. *)
  (*   intros H i Hi; generalize (H _ Hi); clear H; case (Lit.is_pos (diseq .[ i])); try (intros [H _]; elim H; reflexivity); intros [_ [a [H1 [h1 [h2 [H2 [H3 H4]]]]]]]; rewrite H1, H2; rewrite !andb_true_iff; rewrite <- (In2_In H3) in H4; destruct H4 as [H4 H5]; change (check_in h1 dist = true) with (is_true (check_in h1 dist)); change (check_in h2 dist = true) with (is_true (check_in h2 dist)); rewrite !check_in_spec; repeat split; auto; case_eq (h1 == h2); auto; try (rewrite Typ.eqb_refl; auto); rewrite eqb_spec; intro; subst h1; elim H3; auto. *)
  (* Qed. *)

  Definition check_distinct ha diseq :=
    match get_atom ha with
      | Atom.Anop (Atom.NO_distinct ty) dist =>
        check_diseqs ty dist diseq
      | _ => false
    end.

  Lemma check_distinct_spec : forall ha diseq,
    check_distinct ha diseq = true <-> exists A dist,
      get_atom ha = Atom.Anop (Atom.NO_distinct A) dist /\
      check_diseqs A dist diseq = true.
  Proof.
    intros ha diseq; unfold check_distinct; split.
    case (get_atom ha); try discriminate; intros [A] l H; exists A; exists l; auto.
    intros [A [dist [H1 H2]]]; rewrite H1; auto.
  Qed.

  Definition check_distinct_two_args f1 f2 :=
    match get_form f1, get_form f2 with
      | Fatom ha, Fatom hb =>
        match get_atom ha, get_atom hb with
          | Atom.Anop (Atom.NO_distinct ty) (x::y::nil), Atom.Abop (Atom.BO_eq ty') x' y' => (Typ.eqb ty ty') && (((x == x') && (y == y')) || ((x == y') && (y == x')))
          | _, _ => false
        end
      | _, _ => false
    end.

  Lemma check_distinct_two_args_spec : forall f1 f2,
    check_distinct_two_args f1 f2 = true <-> exists ha hb ty x y,
      get_form f1 = Fatom ha /\
      get_form f2 = Fatom hb /\
      get_atom ha = Atom.Anop (Atom.NO_distinct ty) (x::y::nil) /\
      (get_atom hb = Atom.Abop (Atom.BO_eq ty) x y \/
       get_atom hb = Atom.Abop (Atom.BO_eq ty) y x).
  Proof.
    intros f1 f2; unfold check_distinct_two_args; split.
    case (get_form f1); try discriminate; intro ha; case (get_form f2); try discriminate; intro hb; case_eq (get_atom ha); try discriminate; intros [A] [ |x [ |y [ |l]]] Heq1; try discriminate; case_eq (get_atom hb); try discriminate; intros [ | | | | | | |B | | | | | | | | | | | | ] x' y' Heq2; try discriminate; rewrite !andb_true_iff, orb_true_iff, !andb_true_iff; change (Typ.eqb A B = true) with (is_true (Typ.eqb A B)); rewrite Typ.eqb_spec, !Int63Properties.eqb_spec; intros [H1 [[H2 H3]|[H2 H3]]]; subst B x' y'; exists ha, hb, A, x, y; auto.
    intros [ha [hb [A [x [y [H1 [H2 [H3 [H4|H4]]]]]]]]]; rewrite H1, H2, H3, H4, Typ.eqb_refl, !eqb_refl; auto; rewrite orb_true_r; auto.
  Qed.

  Section Valid1.

    Variables (t_i : array SMT_classes.typ_compdec)
              (t_func : array (Atom.tval t_i))
              (ch_atom : Atom.check_atom t_atom)
              (ch_form : Form.check_form t_form)
              (wt_t_atom : Atom.wt t_i t_func t_atom).

    Local Notation interp_form_hatom :=
      (Atom.interp_form_hatom t_i t_func t_atom).
    Local Notation interp_form_hatom_bv :=
      (Atom.interp_form_hatom_bv t_i t_func t_atom).
    Local Notation rho :=
      (Form.interp_state_var interp_form_hatom interp_form_hatom_bv t_form).

    Let wf_t_atom : Atom.wf t_atom.
    Proof. destruct (Atom.check_atom_correct _ ch_atom); auto. Qed.

    Let default_t_atom : default t_atom = Atom.Acop Atom.CO_xH.
    Proof. destruct (Atom.check_atom_correct _ ch_atom); auto. Qed.

    Lemma default_t_form : default t_form = Ftrue.
    Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form) as [[H _] _]; auto. Qed.

    Lemma wf_t_form : wf t_form.
    Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form) as [[_ H] _]; auto. Qed.

    Local Hint Immediate wf_t_atom default_t_atom default_t_form wf_t_form.

    Lemma interp_check_distinct : forall ha diseq,
      check_distinct ha diseq = true ->
      interp_form_hatom ha = afold_left bool int true andb (Lit.interp rho) diseq.
    Proof.
      intros ha diseq; rewrite check_distinct_spec; intros [A [dist [H1 H2]]]; rewrite check_diseqs_spec in H2; destruct H2 as [H2 H3]; unfold Atom.interp_form_hatom, Atom.interp_bool, Atom.interp_hatom; rewrite Atom.t_interp_wf; auto; rewrite H1; simpl; generalize (Atom.compute_interp_spec_rev t_i (get (Atom.t_interp t_i t_func t_atom)) A dist); case (Atom.compute_interp t_i (get (Atom.t_interp t_i t_func t_atom)) A nil); simpl.
      intros l H4; case_eq (distinct (Typ.i_eqb t_i A) (rev l)).
      rewrite distinct_spec; intro H5; symmetry; apply afold_left_andb_true; intros i Hi; destruct (H2 _ Hi) as [H9 [a [H10 [h1 [h2 [H6 [H7 H8]]]]]]]; unfold Lit.interp; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); unfold Var.interp; rewrite Form.wf_interp_form; auto; rewrite H10; simpl; rewrite Atom.t_interp_wf; auto; rewrite H6; simpl; unfold Atom.apply_binop; unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; assert (H11: a < length t_atom).
      case_eq (a < length t_atom); auto; intro H11; rewrite (get_outofbound _ _ _ H11) in H6; rewrite default_t_atom in H6; inversion H6.
      generalize (wt_t_atom _ H11); rewrite H6; simpl; rewrite !andb_true_iff; change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h1) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h1) A)); change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h2) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h2) A)); rewrite !Typ.eqb_spec; intros [[_ H13] H12]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h1); rewrite H13; intros [v1 HH1]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h2); rewrite H12; intros [v2 HH2]; rewrite HH1, HH2; simpl; rewrite Typ.cast_refl; simpl; destruct H8 as [H8|H8]; [ |rewrite Typ.i_eqb_sym]; rewrite H5; auto; rewrite H4; [exists h2; exists h1|exists h1; exists h2]; auto.
      rewrite distinct_false_spec; intros [v2 [v1 [H5 H6]]]; rewrite H4 in H5; destruct H5 as [a [b [H5 [H7 H8]]]]; clear H4; change (Typ.i_eqb t_i A v2 v1 = true) with (is_true (Typ.i_eqb t_i A v2 v1)) in H6; rewrite Typ.i_eqb_spec in H6; subst v2; clear H2; destruct (H3 _ _ H5) as [i [H2 [H4 [hb [H6 [H9 H10]]]]]]; clear H3; symmetry; apply (afold_left_andb_false _ i); auto; unfold Lit.interp; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); unfold Var.interp; rewrite Form.wf_interp_form; auto; rewrite H6; simpl; rewrite Atom.t_interp_wf; auto; destruct H10 as [H10|H10]; rewrite H10; simpl; rewrite H7, H8; simpl; rewrite Typ.cast_refl; simpl; replace (Typ.i_eqb t_i A v1 v1) with true; auto; symmetry; change (is_true (Typ.i_eqb t_i A v1 v1)); rewrite Typ.i_eqb_spec; auto.
      intros [a [H20 H21]]; assert (H4: ha < length t_atom).
      case_eq (ha < length t_atom); auto; intro Heq; generalize H1; rewrite get_outofbound; auto; rewrite default_t_atom; discriminate.
      unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; generalize (wt_t_atom _ H4); rewrite H1; simpl; rewrite andb_true_iff, forallb_forall; intros [_ H5]; assert (H6 := H5 _ H20); generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a); intros [va Ha]; rewrite Ha in H21; simpl in H21; elim H21; apply Typ.eqb_spec; auto.
    Qed.

    Lemma interp_check_distinct_two_args : forall f1 f2,
      check_distinct_two_args f1 f2 = true ->
      rho f1 = negb (rho f2).
    Proof.
      intros f1 f2; rewrite check_distinct_two_args_spec; intros [ha [hb [A [x [y [H1 [H2 [H3 [H4|H4]]]]]]]]]; unfold Form.interp_state_var; assert (H5: f1 < length t_form) by (case_eq (f1 < length t_form); auto; intro Heq; generalize H1; rewrite get_outofbound; auto; rewrite default_t_form; discriminate); assert (H6: f2 < length t_form) by (case_eq (f2 < length t_form); auto; intro Heq; generalize H2; rewrite get_outofbound; auto; rewrite default_t_form; discriminate); rewrite !Form.t_interp_wf; auto; rewrite H1, H2; simpl; unfold Atom.interp_form_hatom, Atom.interp_hatom; rewrite !Atom.t_interp_wf; auto; rewrite H3, H4; simpl; unfold Atom.wt,is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; assert (H7: hb < length t_atom) by (case_eq (hb < length t_atom); auto; intro Heq; generalize H4; rewrite get_outofbound; auto; rewrite default_t_atom; discriminate); generalize (wt_t_atom _ H7); rewrite H4; simpl; case (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) hb); try discriminate; simpl; rewrite andb_true_iff; change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) x) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) x) A)); change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) y) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) y) A)); rewrite !Typ.eqb_spec; intros [H8 H9]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom x), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom y); rewrite H8, H9; intros [v1 HH1] [v2 HH2]; rewrite HH1, HH2; simpl; rewrite Typ.cast_refl; auto; rewrite Typ.i_eqb_sym; auto.
    Qed.

    (* Lemma interp_check_distinct : forall ha diseq, *)
    (*   check_distinct ha diseq -> *)
    (*   interp_form_hatom ha -> afold_left bool int true andb (Lit.interp rho) diseq. *)
    (* Proof. *)
  (*     intros ha diseq; rewrite check_distinct_spec; intros [A [dist [H1 H]]]; rewrite check_diseqs_spec in H; unfold Atom.interp_form_hatom, Atom.interp_bool, Atom.interp_hatom; rewrite Atom.t_interp_wf; auto; rewrite H1; simpl; generalize (Atom.compute_interp_spec_rev t_i (get (Atom.t_interp t_i t_func t_atom)) A dist); case (Atom.compute_interp t_i (get (Atom.t_interp t_i t_func t_atom)) A nil); simpl. *)
  (*     intros l H2; unfold is_true; rewrite distinct_spec; intro H3; apply afold_left_andb_true; intros i Hi; destruct (H _ Hi) as [H4 [a [H5 [h1 [h2 [H6 [H7 H8]]]]]]]; unfold Lit.interp; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); unfold Var.interp; rewrite Form.wf_interp_form; auto; rewrite H5; simpl; rewrite Atom.t_interp_wf; auto; rewrite H6; simpl; unfold Atom.apply_binop; unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; assert (H10: a < length t_atom). *)
  (*     case_eq (a < length t_atom); auto; intro H10; rewrite (get_outofbound _ _ _ H10) in H6; rewrite default_t_atom in H6; inversion H6. *)
  (*     generalize (wt_t_atom _ H10); rewrite H6; simpl; rewrite !andb_true_iff. change (Typ.eqb (Atom.get_type t_i t_func t_atom h1) A = true) with (is_true (Typ.eqb (Atom.get_type t_i t_func t_atom h1) A)); change (Typ.eqb (Atom.get_type t_i t_func t_atom h2) A = true) with (is_true (Typ.eqb (Atom.get_type t_i t_func t_atom h2) A)); rewrite !Typ.eqb_spec; intros [[_ H11] H12]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h1); rewrite H11; intros [v1 HH1]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h2); rewrite H12; intros [v2 HH2]; rewrite HH1, HH2; simpl; rewrite Typ.cast_refl; simpl; destruct H8 as [H8|H8]; [ |rewrite Typ.i_eqb_sym]; rewrite H3; auto; rewrite H2; [exists h2; exists h1|exists h1; exists h2]; auto. *)
  (*     intros [a [H2 H3]] _; assert (H4: ha < length t_atom). *)
  (*     case_eq (ha < length t_atom); auto; intro Heq; generalize H1; rewrite get_outofbound; auto; rewrite default_t_atom; discriminate. *)
  (*     unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; generalize (wt_t_atom _ H4); rewrite H1; simpl; rewrite andb_true_iff, forallb_forall; intros [_ H5]; assert (H6 := H5 _ H2); generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a); intros [va Ha]; rewrite Ha in H3; simpl in H3; elim H3; apply Typ.eqb_spec; auto. *)
  (*   Qed. *)

  End Valid1.

  Section AUX.

    Variable check_var : var -> var -> bool.

    Definition check_lit l1 l2 :=
      (l1 == l2) || ((Bool.eqb (Lit.is_pos l1) (Lit.is_pos l2)) && (check_var (Lit.blit l1) (Lit.blit l2))) || ((Bool.eqb (Lit.is_pos l1) (negb (Lit.is_pos l2))) && (check_distinct_two_args (Lit.blit l1) (Lit.blit l2))).

    (* Definition check_lit l1 l2 := *)
    (*   (l1 == l2) || ((Lit.is_pos l1) && (Lit.is_pos l2) && (check_var (Lit.blit l1) (Lit.blit l2))) || ((negb (Lit.is_pos l1)) && (negb (Lit.is_pos l2)) && (check_var (Lit.blit l2) (Lit.blit l1))). *)

    Definition check_form_aux a b :=
      match a, b with
        | Fatom ha, Fand diseq => check_distinct ha diseq
        | Fatom a, Fatom b => a == b
        | Ftrue, Ftrue => true
        | Ffalse, Ffalse => true
        | Fnot2 i1 l1, Fnot2 i2 l2 => (i1 == i2) && (check_lit l1 l2)
        | Fand a1, Fand a2 => (length a1 == length a2) && (forallbi (fun i l => check_lit l (a2.[i])) a1)
        | For a1, For a2 => (length a1 == length a2) && (forallbi (fun i l => check_lit l (a2.[i])) a1)
        | Fimp a1, Fimp a2 => (length a1 == length a2) && (forallbi (fun i l => check_lit l (a2.[i])) a1)
          (* (length a1 == length a2) && (forallbi (fun i l => if i < length a1 - 1 then check_lit (a2.[i]) l else check_lit l (a2.[i])) a1) *)
        | Fxor l1 l2, Fxor j1 j2 => check_lit l1 j1 && check_lit l2 j2
          (* check_lit l1 j1 && check_lit j1 l1 && check_lit l2 j2 && check_lit j2 l2 *)
          (* (* let a := check_lit l1 j1 in *) *)
          (* (* let b := check_lit l2 j2 in *) *)
          (* (* let c := check_lit l1 j2 in *) *)
          (* (* let d := check_lit l2 j1 in *) *)
          (* (* let e := check_lit j1 l1 in *) *)
          (* (* let f := check_lit j1 l2 in *) *)
          (* (*   negb (((negb a) && b && (negb c)) || (c && e && (negb f)) || (b && (negb e) && f) || (a && (negb b) && (negb d))) *) *)
        | Fiff l1 l2, Fiff j1 j2 => check_lit l1 j1 && check_lit l2 j2
          (* check_lit l1 j1 && check_lit j1 l1 && check_lit l2 j2 && check_lit j2 l2 *)
        | Fite l1 l2 l3, Fite j1 j2 j3 => check_lit l1 j1 && check_lit l2 j2 && check_lit l3 j3
          (* check_lit l1 j1 && check_lit j1 l1 && check_lit l2 j2 && check_lit l3 j3 *)
        | _, _ => false
      end.

    Variables (t_i : array SMT_classes.typ_compdec)
              (t_func : array (Atom.tval t_i))
              (ch_atom : Atom.check_atom t_atom)
              (ch_form : Form.check_form t_form)
              (wt_t_atom : Atom.wt t_i t_func t_atom).

    Local Notation interp_form_hatom :=
      (Atom.interp_form_hatom t_i t_func t_atom).
    Local Notation interp_form_hatom_bv :=
      (Atom.interp_form_hatom_bv t_i t_func t_atom).
    Local Notation rho :=
      (Form.interp_state_var interp_form_hatom interp_form_hatom_bv t_form).

    Hypothesis interp_check_var : forall x y,
      check_var x y -> Var.interp rho x = Var.interp rho y.

    (* Hypothesis interp_check_var : forall x y, *)
    (*   check_var x y -> Var.interp rho x -> Var.interp rho y. *)

    (* Local Hint Resolve interp_check_var. *)

    Lemma interp_check_lit : forall l1 l2,
      check_lit l1 l2 -> Lit.interp rho l1 = Lit.interp rho l2.
    Proof.
      unfold check_lit; intros l1 l2; unfold is_true; rewrite !orb_true_iff, !andb_true_iff; intros [[H1|[H1 H2]]|[H1 H2]].
      rewrite eqb_spec in H1; rewrite H1; auto.
      rewrite Bool.eqb_true_iff in H1; unfold Lit.interp; rewrite H1, (interp_check_var _ _ H2); auto.
      generalize H1; unfold Lit.interp; case (Lit.is_pos l1); case (Lit.is_pos l2); try discriminate; intros _; unfold Var.interp; rewrite (interp_check_distinct_two_args _ t_func ch_atom ch_form wt_t_atom _ _ H2); auto; case (rho (Lit.blit l2)); auto.
    Qed.

    (* Lemma interp_check_lit : forall l1 l2, *)
    (*   check_lit l1 l2 -> Lit.interp rho l1 -> Lit.interp rho l2 = true. *)
    (* Proof. *)
    (*   unfold check_lit; intros l1 l2; unfold is_true; rewrite !orb_true_iff, !andb_true_iff; intros [[H1|[[H1 H2] H3]]|[[H1 H2] H3]]. *)
    (*   rewrite Int63Properties.eqb_spec in H1; subst l1; auto. *)
    (*   unfold Lit.interp; rewrite H1, H2; apply interp_check_var; auto. *)
    (*   unfold Lit.interp; case_eq (Lit.is_pos l1); intro Heq; rewrite Heq in H1; try discriminate; clear Heq H1; case_eq (Lit.is_pos l2); intro Heq; rewrite Heq in H2; try discriminate; clear Heq H2; case_eq (Var.interp rho (Lit.blit l1)); try discriminate; intros H4 _; case_eq (Var.interp rho (Lit.blit l2)); auto; intro H5; rewrite (interp_check_var _ _ H3 H5) in H4; discriminate. *)
    (* Qed. *)

    (* Local Hint Resolve interp_check_lit. *)

    Lemma interp_check_form_aux : forall a b,
      check_form_aux a b ->
      Form.interp interp_form_hatom interp_form_hatom_bv t_form a = Form.interp interp_form_hatom interp_form_hatom_bv t_form b.
    Proof.
      intros [a| | |i1 l1|a1|a1|a1|l1 l2|l1 l2|l1 l2 l3|a l1] [b| | |j1 m1|a2|a2|a2|j1 j2|j1 j2|j1 j2 j3|b m1]; simpl; try discriminate;auto.
      (* Atom *)
      unfold is_true; rewrite Int63Properties.eqb_spec; intro; subst a; auto.
      (* Interesting case *)
      apply interp_check_distinct; auto.
      (* Double negation *)
      unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; subst j1. rewrite (interp_check_lit _ _ H2). auto.
      (* Conjunction *)
      unfold is_true; rewrite andb_true_iff, eqb_spec, forallbi_spec; intros [H1 H2]; apply afold_left_eq; auto; intros i Hi; apply interp_check_lit; auto.
      (* Disjunction *)
      unfold is_true; rewrite andb_true_iff, eqb_spec, forallbi_spec; intros [H1 H2]; apply afold_left_eq; auto; intros i Hi; apply interp_check_lit; auto.
      (* Implication *)
      unfold is_true; rewrite andb_true_iff, eqb_spec, forallbi_spec; intros [H1 H2]; apply afold_right_eq; auto; intros i Hi; apply interp_check_lit; auto.
      (* Xor *)
      unfold is_true; rewrite andb_true_iff; intros [H1 H2]; rewrite (interp_check_lit _ _ H1), (interp_check_lit _ _ H2); auto.
      (* Iff *)
      unfold is_true; rewrite andb_true_iff; intros [H1 H2]; rewrite (interp_check_lit _ _ H1), (interp_check_lit _ _ H2); auto.
      (* Ite *)
      unfold is_true; rewrite !andb_true_iff; intros [[H1 H2] H3]; rewrite (interp_check_lit _ _ H1), (interp_check_lit _ _ H2), (interp_check_lit _ _ H3); auto.
    Qed.

    (* Lemma interp_check_lit_equiv : forall l1 l2, *)
    (*   check_lit l1 l2 -> check_lit l2 l1 -> *)
    (*   Lit.interp rho l1 = Lit.interp rho l2. *)
    (* Proof. *)
    (*   intros l1 l2 H1 H2; generalize (interp_check_lit _ _ H1) (interp_check_lit _ _ H2); case (Lit.interp rho l1); case (Lit.interp rho l2); auto; symmetry; auto. *)
    (* Qed. *)

    (* Lemma interp_check_form_aux : forall a b, *)
    (*   check_form_aux a b -> *)
    (*   Form.interp interp_form_hatom t_form a -> Form.interp interp_form_hatom t_form b. *)
    (* Proof. *)
    (*   intros [a| | |i1 l1|a1|a1|a1|l1 l2|l1 l2|l1 l2 l3] [b| | |j1 m1|a2|a2|a2|j1 j2|j1 j2|j1 j2 j3]; simpl; try discriminate;auto. *)
    (*   (* Atom *) *)
    (*   unfold is_true; rewrite Int63Properties.eqb_spec; intro; subst a; auto. *)
    (*   (* Interesting case *) *)
    (*   apply interp_check_distinct; auto. *)
    (*   (* Double negation *) *)
    (*   unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; subst j1; apply (fold_ind2 _ _ (fun x y => x = true -> y = true)). *)
    (*   apply interp_check_lit; auto. *)
    (*   intros a b; case a; try discriminate; intros H _; rewrite H; auto. *)
    (*   (* Conjunction *) *)
    (*   unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; rewrite forallbi_spec in H2; intro H3; assert (H4 := afold_left_andb_true_inv _ _ _ H3); clear H3; apply afold_left_andb_true; rewrite <- H1; intros i Hi; eapply interp_check_lit; eauto. *)
    (*   (* Disjunction *) *)
    (*   unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; rewrite forallbi_spec in H2; intro H3; assert (H4 := afold_left_orb_true_inv _ _ _ H3); clear H3; destruct H4 as [i [H3 H4]]; eapply afold_left_orb_true. *)
    (*   rewrite <- H1; eauto. *)
    (*   eapply interp_check_lit; eauto. *)
    (*   (* Implication *) *)
    (*   unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; rewrite forallbi_spec in H2; intro H3; apply afold_right_implb_true; case_eq (length a1 == 0); intro Heq. *)
    (*   left; rewrite eqb_spec in Heq; rewrite <- H1; auto. *)
    (*   destruct (afold_right_implb_true_inv _ _ _ H3) as [H4|[[i [H4 H5]]|H4]]. *)
    (*   rewrite H4 in Heq; discriminate. *)
    (*   right; left; exists i; rewrite <- H1; split; auto; case_eq (Lit.interp rho (a2 .[ i])); auto; intro H6; assert (H7: i < length a1 = true). *)
    (*   rewrite ltb_spec in *; rewrite eqb_false_spec in Heq; rewrite to_Z_sub_1_diff in H4; auto; omega. *)
    (*   generalize (H2 _ H7); rewrite H4; intro H8; rewrite (interp_check_lit _ _ H8 H6) in H5; auto. *)
    (*   right; case_eq (existsbi (fun i l => (i < length a2 - 1) && (negb (Lit.interp rho l))) a2). *)
    (*   rewrite existsbi_spec; intros [i [_ H5]]; rewrite andb_true_iff in H5; destruct H5 as [H5 H6]; left; exists i; split; auto; generalize H6; case (Lit.interp rho (a2 .[ i])); auto; discriminate. *)
    (*   rewrite existsbi_false_spec; intro H; right; intros i Hi; assert (Hi' := Hi); rewrite <- H1 in Hi'; generalize (H2 _ Hi') (H _ Hi); rewrite <- H1; case (i < length a1 - 1); simpl. *)
    (*   intros _; case (Lit.interp rho (a2 .[ i])); auto; discriminate. *)
    (*   intros H5 _; apply (interp_check_lit _ _ H5); apply H4; auto. *)
    (*   (* Xor *) *)
    (*   unfold is_true; rewrite !andb_true_iff; intros [[[H1 H2] H3] H4]; rewrite (interp_check_lit_equiv _ _ H1 H2), (interp_check_lit_equiv _ _ H3 H4); auto. *)
    (*   (* Iff *) *)
    (*   unfold is_true; rewrite !andb_true_iff; intros [[[H1 H2] H3] H4]; rewrite (interp_check_lit_equiv _ _ H1 H2), (interp_check_lit_equiv _ _ H3 H4); auto. *)
    (*   (* Ite *) *)
    (*   unfold is_true; rewrite !andb_true_iff; intros [[[H1 H2] H3] H4]; rewrite (interp_check_lit_equiv _ _ H1 H2); case (Lit.interp rho j1); apply interp_check_lit; auto. *)
    (* Qed. *)

  End AUX.

  Definition check_hform h1 h2 :=
    foldi_down_cont
    (fun _ cont h1 h2 => (h1 == h2) || check_form_aux cont (get_form h1) (get_form h2))
    (PArray.length t_form) 0 (fun h1 h2 => false) h1 h2.

  Definition check_form := check_form_aux check_hform.

  Definition check_lit' := check_lit check_hform.

  Fixpoint check_distinct_elim input res :=
    match input with
      | nil => nil
      | l::q => if check_lit' l res then res::q else l::(check_distinct_elim q res)
    end.

  Section Valid.

    Variables (t_i : array SMT_classes.typ_compdec)
              (t_func : array (Atom.tval t_i))
              (ch_atom : Atom.check_atom t_atom)
              (ch_form : Form.check_form t_form)
              (wt_t_atom : Atom.wt t_i t_func t_atom).

    Local Notation interp_form_hatom :=
      (Atom.interp_form_hatom t_i t_func t_atom).
    Local Notation interp_form_hatom_bv :=
      (Atom.interp_form_hatom_bv t_i t_func t_atom).
    Local Notation rho :=
      (Form.interp_state_var interp_form_hatom interp_form_hatom_bv t_form).

    Let wf_rho : Valuation.wf rho.
    Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form); auto. Qed.

    Let default_t_form : default t_form = Ftrue.
    Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form) as [[H _] _]; auto. Qed.

    Let wf_t_form : wf t_form.
    Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form) as [[_ H] _]; auto. Qed.

    Local Hint Immediate wf_rho default_t_form wf_t_form.

    Lemma interp_check_hform : forall h1 h2,
      check_hform h1 h2 -> Var.interp rho h1 = Var.interp rho h2.
    Proof.
      unfold check_hform; apply foldi_down_cont_ind; try discriminate. intros i cont _ _ Hrec h1 h2. unfold is_true; rewrite orb_true_iff; intros [H|H].
      rewrite Int63Properties.eqb_spec in H; rewrite H; auto.
      unfold Var.interp; rewrite !wf_interp_form; auto; eapply interp_check_form_aux; eauto.
    Qed.

    Local Hint Resolve interp_check_hform.

    Lemma interp_check_form : forall a b,
      check_form a b ->
      Form.interp interp_form_hatom interp_form_hatom_bv t_form a = Form.interp interp_form_hatom interp_form_hatom_bv t_form b.
    Proof. apply interp_check_form_aux, interp_check_hform; auto. Qed.

    Lemma interp_check_lit' : forall l res,
      check_lit' l res -> Lit.interp rho l = Lit.interp rho res.
    Proof. apply interp_check_lit, interp_check_hform; auto. Qed.

    Lemma valid_check_distinct_elim :
      forall input, C.valid rho input ->
        forall res, C.valid rho (check_distinct_elim input res).
    Proof.
      induction input as [ |l c IHc]; auto; simpl; unfold C.valid; simpl; rewrite orb_true_iff; intros [H|H] res.
      case_eq (check_lit' l res); intro Heq; simpl.
      rewrite <- (interp_check_lit' _ _ Heq), H; auto.
      rewrite H; auto.
      case (check_lit' l res).
      simpl; rewrite H, orb_true_r; auto.
      simpl; rewrite (IHc H), orb_true_r; auto.
    Qed.

  End Valid.

End Operators.

(*
   Local Variables:
   coq-load-path: ((rec ".." "SMTCoq"))
   End:
*)


(* * Inhabited types *)

(* Author: Maximilian Wuttke *)

From Undecidability.Shared.Libs.PSL Require Prelim.
From Coq.Vectors Require Import Vector Fin.
From Undecidability.Shared.Libs.PSL Require Import FiniteTypes.FinTypes.

Class inhabitedC (X : Type) :=
    {
      default : X;
    }.

#[export]
Instance inhabited_unit : inhabitedC unit.
Proof. do 2 constructor. Defined.

#[export]
Instance inhabited_True : inhabitedC True.
Proof. do 2 constructor. Defined.

#[export]
Instance inhabited_inl (A B : Type) (inh_a : inhabitedC A) : inhabitedC (A + B).
Proof. constructor. left. apply default. Defined.

#[export]
Instance inhabited_inr (A B : Type) (inh_B : inhabitedC B) : inhabitedC (A + B).
Proof. constructor. right. apply default. Defined.

#[export]
Instance inhabited_option (A : Type) : inhabitedC (option A).
Proof. constructor. right. Defined.

#[export]
Instance inhabited_bool : inhabitedC bool.
Proof. do 2 constructor. Defined.

#[export]
Instance inhabited_list (A : Type) : inhabitedC (list A).
Proof. do 2 constructor. Defined.

#[export]
Instance inhabited_vector (A : Type) (n : nat) (inh_A : inhabitedC A) : inhabitedC (Vector.t A n).
Proof. constructor. eapply VectorDef.const. apply default. Defined.

#[export]
Instance inhabited_fin (n : nat) : inhabitedC (Fin.t (S n)).
Proof. repeat constructor. Defined.

#[export]
Instance inhabited_nat : inhabitedC nat.
Proof. do 2 constructor. Defined.

#[export]
Instance inhabited_prod (A B : Type) : inhabitedC A -> inhabitedC B -> inhabitedC (A*B).
Proof. intros ia ib. do 2 constructor; apply default. Defined.

#[export]
Instance inhabited_arrow (A B : Type) : inhabitedC B -> inhabitedC (A -> B).
Proof. intros. constructor. intros _. apply default. Defined.

#[export]
Instance inhabited_arrow_empty (B : Type) : inhabitedC (Empty_set -> B).
Proof. intros. constructor. apply Empty_set_rect. Defined.

#[export]
Instance inhabited_arrow_sum (A B C : Type) : inhabitedC (A->C) -> inhabitedC (B->C) -> inhabitedC (A+B->C).
Proof. intros iac ibc. constructor. intros [?|?]. now apply iac. now apply ibc. Defined.

#[export]
Instance inhabited_arrow_prod (A B C : Type) : inhabitedC (A->B) -> inhabitedC (A->C) -> inhabitedC (A->B*C).
Proof. intros iab iac. constructor. intros a. constructor. now apply iab. now apply iac. Defined.

(* Derive inhabitedC instances, if an instance of this type is a hypothesis *)
#[export] Hint Extern 10 => match goal with
                | [ H : ?X |- inhabitedC ?X ] => now econstructor
                end : typeclass_instances.
(*
Section Test.
  Variable lie : False.
  Compute default : False.
  Variable somebool : bool.
  (* This should prefer the instance, not the variable. *)
  Compute default : bool.
End Test.
*)


From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat.

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

Lemma test_dup1 : forall n : nat, odd n.
Proof. move=> /[dup] m n; suff: odd n by []. Abort.

Lemma test_dup2 : let n := 1 in False.
Proof. move=> /[dup] m n; have : m = n := erefl. Abort.

Lemma test_swap1 : forall (n : nat) (b : bool), odd n = b.
Proof. move=> /[swap] b n; suff: odd n = b by []. Abort.

Lemma test_swap1 : let n := 1 in let b := true in False.
Proof. move=> /[swap] b n; have : odd n = b := erefl. Abort.

Lemma test_apply A B : forall (f : A -> B) (a : A), False.
Proof.
move=> /[apply] b.
Check (b : B).
Abort.

Lemma test_swap_plus P Q : P -> Q -> False.
Proof.
move=> + /[dup] q.
suff: P -> Q -> False by [].
Abort.

Lemma test_dup_plus2 P : P -> let x := 0 in False.
Proof.
move=> + /[dup] y.
suff: P -> let x := 0 in False by [].
Abort.

Lemma test_swap_plus P Q R : P -> Q -> R -> False.
Proof.
move=> + /[swap].
suff: P -> R -> Q -> False by [].
Abort.

Lemma test_swap_plus2 P : P -> let x := 0 in let y := 1 in False.
Proof.
move=> + /[swap].
suff: P -> let y := 1 in let x := 0 in False by [].
Abort.


(*
 * Strong Normalization for Nested Relational Calculus.
 * Copyright Ezra Cooper, 2008-2020.
 *)

Require Import Arith.
Require Import List.

Add Rec LoadPath "Listkit" as Listkit.

Require Import Listkit.Foreach.

Create HintDb Term.

(** Definitions *)
Inductive Ty : Set :=
  TyBase
| TyPair : Ty -> Ty -> Ty
| TyArr : Ty -> Ty -> Ty
(* | TyAny : Ty *)
| TyList : Ty -> Ty.

(** Terms *)
Inductive Term : Set :=
  TmConst
| TmVar (x : nat) : Term
| TmPair : Term -> Term -> Term
| TmProj : bool -> Term -> Term
| TmAbs : Term -> Term
| TmApp : Term -> Term -> Term
| TmNull : Term
| TmSingle : Term -> Term
| TmUnion : Term -> Term -> Term
| TmBind : Term -> Term -> Term
| TmIf : Term -> Term -> Term -> Term
| TmTable : Ty -> Term.

Notation "L @ M" := (TmApp L M) (at level 500).
Notation "〈 L , M 〉" := (TmPair L M) (at level 400).

(** Typing derivations *)
Inductive Typing env : Term -> Ty -> Set :=
| TBase : Typing env TmConst TyBase
| TVar : forall (x:nat) ty,
    value ty = nth_error env x ->
    Typing env (TmVar x) ty
| TPair : forall l m s t, Typing env l s -> Typing env m t ->
    Typing env (TmPair l m) (TyPair s t)
| TApp : forall l m a b,
    Typing env l (TyArr a b) -> Typing env m a ->
    Typing env (TmApp l m) b
| TAbs : forall n s t,
    Typing (s :: env) n t ->
    Typing env (TmAbs n) (TyArr s t)
| TProj1 : forall m s t,
    Typing env m (TyPair s t) ->
    Typing env (TmProj false m) s
| TProj2 : forall m s t,
    Typing env m (TyPair s t) ->
    Typing env (TmProj true m) t
| TSingle : forall m t,
    Typing env m t ->
    Typing env (TmSingle m) (TyList t)
| TUnion : forall m n t,
    Typing env m (TyList t) ->
    Typing env n (TyList t) ->
    Typing env (TmUnion m n) (TyList t)
| TNull : forall t,
    Typing env TmNull (TyList t)
| TBind : forall m s n t,
    Typing env m (TyList s) ->
    Typing (s::env) n (TyList t) ->
    Typing env (TmBind m n) (TyList t)
| TTable : forall r, Typing env (TmTable r) (TyList r)
.

#[export]
Hint Constructors Typing.

(** [env_typing] relates a value environment to its typing. It asserts
    the types (in a [nil] environment) of each of a series of values. *)
Definition env_typing Vs Ts :=
  ((length Vs = length Ts) *
  foreach2_ty _ _ Vs Ts (fun x y => (Typing nil x y)))%type.

(** [env_typing_env] also relates a value environment to its typing. It asserts
    the types (in a given environment) of each of a series of values. *)
Definition env_typing_env env Vs Ts :=
  ((length Vs = length Ts) *
  foreach2_ty _ _ Vs Ts (fun x y => (Typing env x y)))%type.

#[export]
Hint Unfold env_typing.

(** [env_typing_env] environments can be extended, one term-type pair at a time. *)
Lemma env_typing_intro:
  forall env V Vs T Ts,
    Typing env V T ->
    env_typing_env env Vs Ts ->
    env_typing_env env (V::Vs) (T::Ts).
Proof.
 intros.
 unfold env_typing_env in *.
 unfold foreach2_ty in *.
 simpl in *.
 intuition.
Qed.

(** [env_typing_env] environments can be destructed into their first
pair and a remaining [env_typing_env] environment. *)
Lemma env_typing_elim:
  forall env V Vs T Ts,
    env_typing_env env (V::Vs) (T::Ts) ->
    (env_typing_env env Vs Ts
    * Typing env V T).
Proof.
 intros env V Vs T Ts X.
 unfold env_typing_env in X.
 unfold foreach2_ty in X.
 unfold env_typing_env.
 simpl in *.
 intuition.
Qed.

Lemma env_typing_cons :
  forall V T Vs env,
    Typing nil V T -> env_typing Vs env -> env_typing (V::Vs) (T::env).
Proof.
 (* Could use foreach2_ty_cons, to maintain that abstraction. *)
 intros.
 simpl;  firstorder.
 unfold foreach2_ty; simpl; intuition.
Qed.

#[export]
Hint Resolve env_typing_cons : Term.

Require Import Coq.Lists.ListSet.

Require Import Listkit.Sets.

Definition set_remove := Listkit.Sets.set_remove.

(** The free variables of a Term, as a set of nats. *)
Fixpoint freevars (M:Term) : set nat :=
  match M with
  | TmConst => empty_set nat
  | TmVar x => set_add eq_nat_dec x (empty_set nat)
  | TmPair L M => set_union eq_nat_dec (freevars L) (freevars M)
  | TmProj b M => freevars M
  | TmAbs N => set_map eq_nat_dec pred
                 (set_remove _ eq_nat_dec 0 (freevars N))
  | TmApp L M => set_union eq_nat_dec (freevars L) (freevars M)
  | TmNull => empty_set nat
  | TmSingle x => freevars x
  | TmUnion a b => set_union eq_nat_dec (freevars a) (freevars b)
  | TmBind M N => set_union eq_nat_dec (freevars M)
                            (set_map eq_nat_dec pred
                                     (set_remove _ eq_nat_dec 0 (freevars N)))
  | TmIf b M N => set_union eq_nat_dec (freevars b)
                            (set_union eq_nat_dec (freevars M) (freevars N))
  | TmTable _ => empty_set nat
  end.

Definition free_in x M := set_In x (freevars M).

Definition in_env_domain (n:nat) (env:list Term) := fun x => n <= x < n+length env.
(* (* Alt definition, reuses outside_range; consider it! *)
   Definition in_env_domain (n:nat) (env:list Term) :=
   fun x => false = outside_range n (n+length env) x. *)

(* TODO: in_env_domain and outside_range are essentially logical inverses,
   but are defined in different sorts. Consolidate them! *)

Lemma in_env_domain_map :
    forall n f env, in_env_domain n (map f env) = in_env_domain n env.
 unfold in_env_domain.
 intros.
 rewrite map_length.
 auto.
Qed.

(** A term [M] is [Neutral] if, when it reduces in context, [C[M] ~> Z], the
    reduction either in C or in M:
      C[M] ~> Z  ==  C[M] ~> C[M']  or
      C[M] ~> Z  ==  C[M] ~> C'[M].
    In other words, [M] cannot react with [C] immediately.

    But we define it here by the cases that we know have that property.
    TODO: Fix that!
 *)
Inductive Neutral : Term -> Type :=
  | Neutral_App : forall L M, Neutral (TmApp L M)
  | Neutral_Proj : forall b M, Neutral (TmProj b M)
  | Neutral_Table : forall t, Neutral (TmTable t).

#[export]
Hint Constructors Neutral.

#[export]
Hint Resolve Neutral_App.
#[export]
Hint Resolve Neutral_Proj.


(* Mohamed Sami Cherif and Paolo Torrini,
   Universite' Lille-1 - CRIStAL-CNRS
*)
(* test module *)

Require Export Basics.

Require Export EnvLibA.
Require Export RelLibA.
Require Export PRelLibA.

Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.

Require Import StaticSemA.
Require Import DynamicSemA.
Require Import TRInductA.
Require Import WeakenA.
Require Import TSoundnessA.
Require Import IdModTypeA.
Require Import AbbrevA.
Require Import ModNat1A.

Module Test_Nat1 <: IdModType.

Module LM := Abbrev ModNat1.
Export LM.

Definition Id := LM.Id.
Definition IdEqDec := LM.IdEqDec.
Definition IdEq := LM.IdEq.
Definition W := LM.W.
Definition Loc_PI := LM.Loc_PI.
Definition BInit := LM.BInit.
Definition WP := LM.WP.

Open Scope string_scope.
Import ListNotations.

Definition nat_read : XFun unit nat := xf_read id.

Definition nat_write : XFun nat unit := xf_write id.

Definition nat_reset : XFun (PState nat) unit := xf_reset.

Definition nat_incr : XFun nat unit := {|
   b_mod := fun x y => (x + 1, tt)
|}.

Definition ReadN : Exp := Read NatVT id.

Definition WriteN (x: nat) : Exp := Write NatVT id x.

Definition ResetN : Exp := Reset.

Definition Incr (x: nat) : Exp :=
  Modify nat unit NatVT UnitVT nat_incr (QV (cst nat x)).

Lemma expTypingTest1 : expTypingTest (BindN ResetN ReadN) Nat.
  econstructor.
  econstructor.
  econstructor.
  constructor.
  simpl.
  auto.
  simpl.
  apply PState_ValTyp.
  constructor.
  constructor.
  constructor.
  simpl.
  auto.
  simpl.
  apply UnitVT.
Defined.

Definition Test1 (n: nat) := runTest (BindN ResetN ReadN) Nat
  expTypingTest1 n.

Lemma Test1L (n: nat) : Test1 n = cst nat 0.
  auto.
Qed.

(**************************************************)

(* line 1 : if true then 3 else 3) *)

Definition three : Exp := Val (cst nat 3).
Definition line1 : Exp := IfThenElse TrueV three three.
Lemma expTypingline1 : ExpTyping emptyE emptyE emptyE line1 Nat.
Proof.
  repeat constructor.
Defined.

Definition line1Test (n: nat) := runTest line1 Nat expTypingline1 n.

Lemma Test2 (n: nat) : line1Test n = cst nat 3.
  auto.
Defined.

Lemma Test3 (n: nat) : exists x:nat, line1Test n = cst nat x.
  eexists.
  compute.
  reflexivity.
Defined.

Eval compute in (line1Test 0).

(***********************************************)
(* binds1 : ... *)

Definition binds1 : Exp := BindS "x" (Val (cst nat 0)) (Return RR (Var "x")).

Definition expTypingTest (e: Exp) (t: VTyp): Type :=
  ExpTyping emptyE emptyE emptyE e t.

Lemma binds1typing: expTypingTest binds1 Nat.
  econstructor.
  instantiate (1:= Nat).
  constructor.
  constructor.
  reflexivity.
  repeat constructor.
  repeat constructor.
Defined.

Definition binds1Test (n: nat) := runTest binds1 Nat binds1typing n.

Lemma binds1Test_proof : binds1Test 0 = cst nat 0.
  auto.
Qed.

(*********************************************************)
(* line 2 : apply add3 to 0*)

Definition zero: Exp := Val (cst nat 0).

Definition xf_add3 : XFun nat nat := {|
   b_mod := fun st x => (st, x+3)
|}.

Definition add3': Exp := Modify nat nat NatVT NatVT xf_add3 (Var "x").
Definition add3: QFun := QF (FC emptyE [("x",Nat)] add3' zero "add3" 0).

Definition line2: Exp := Apply add3 (PS [zero]).

Lemma expTypingline2 : ExpTyping emptyE emptyE emptyE line2 Nat.
Proof.
  repeat econstructor.
Defined.

Definition line2Test (n: nat) := runTest line2 Nat
  expTypingline2 n.

Lemma line2Test_lemma1 :
  EClosure emptyE emptyE (Conf Exp 0 line2) (Conf Exp 0 three).
  unfold line2, three.
  unfold add3.
  unfold add3'.
  unfold xf_add3.
  unfold cst.
  econstructor.
  econstructor.
  econstructor.
  instantiate (1:= [(existT ValueI nat (Cst nat 0))]).
  auto.
  reflexivity.
  simpl.
  reflexivity.
  econstructor.
  econstructor.
  reflexivity.
  reflexivity.
  simpl.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  reflexivity.
  reflexivity.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
Defined.

Lemma line2Test_lemma2 :
  EClosure emptyE emptyE (Conf Exp 0 line2) (Conf Exp 0 three).
  econstructor.
  econstructor.
  econstructor.
  instantiate (1:= [(existT ValueI nat (Cst nat 0))]).
  auto.
  auto.
  auto.
  repeat econstructor.
Defined.

Lemma line2ExpTyping : forall (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
  (k1: MatchEnvsT FunTyping fenv ftenv),
  ExpTyping ftenv tenv fenv line2 Nat.
Proof.
  intros.
  econstructor.
  reflexivity.
  assumption.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  reflexivity.
  econstructor.
  econstructor.
  econstructor.
  constructor.
  reflexivity.
  constructor.
  constructor.
Defined.

(**************************************************)

Definition line3: Exp := BindN line1 line2.
Lemma expTypingline3 : ExpTyping emptyE emptyE emptyE line3 Nat.
Proof.
econstructor.
eapply expTypingline1.
apply expTypingline2.
Defined.

Definition line3Test (n: nat) := runTest line3 Nat
  expTypingline3 n.

End Test_Nat1.


Require Import ZArith.
Require Import String.
Require Import Ascii.
Require Import List.

Open Scope string_scope.

Inductive json : Set :=
  | Bool : bool -> json
  (* TODO: numbers *)
  | Null : json
(*  | J_String : string -> json *)
  | Array : list json -> json
(*  | Object : list (string * json) -> json *)
  .

Fixpoint intercalate (sep : string) (xs : list string) : string :=
  match xs with
  | nil => ""
  | x :: nil => x
  | x :: xs => x ++ sep ++ intercalate sep xs
  end%string.

Definition escape_string str := ("""" ++ str ++ """").

Fixpoint encode (v : json) : string :=
  match v with
  | Bool true => "true"
  | Bool false => "false"
  | Null => "null"
(*  | J_String str => escape_string str *)
  | Array items => "[" ++ intercalate "," (map encode items) ++ "]"
(*  | Object kvs => "{" ++ intercalate ","
        ((fix encode_kvs (kvs : list (string * json)) :=
            match kvs with
            | nil => nil
            | (k, v) :: kvs => (escape_string k ++ ":" ++ encode v) :: encode_kvs kvs
            end) kvs) ++ "}" *)
  end.

Parameter hole : Type.

Section Parser.

  Notation "[]" := EmptyString.
  Notation "x :: xs" := (String x xs) (at level 60, right associativity).

  Definition is_space (c : ascii) : bool :=
    match c with
    | " " => true
    | "009" => true
    | "010" => true
    | _ => false
    end%char.

  Inductive Stack :=
    | S_Top : Stack
    | S_Array : list json -> Stack -> Stack.

  Fixpoint parse_json (s : string) (stack : Stack) : option json :=
    let fix parse_end_no_ws obj stack str {struct str} :=
          match stack, str with
          | S_Array objs next, "," :: rest =>
              parse_json rest (S_Array (obj :: objs) next)
          | S_Array objs next, "]" :: rest =>
              parse_end_no_ws (Array (rev (obj :: objs))) next rest
          | S_Top, "" => Some obj
          | _, _ => None
          end
    in
    let fix parse_end obj str :=
          match str with
          | [] => parse_end_no_ws obj stack str
          | c :: rest =>
              if is_space c
                then parse_end obj rest
                else parse_end_no_ws obj stack (c :: rest)
          end
    in
    match s with
    | [] => None
    | c :: rest =>
        if is_space c then parse_json rest stack else
        match s with
        | "t" :: "r" :: "u" :: "e" :: rest => parse_end (Bool true) rest
        | "t" :: rest => parse_end (Bool true) rest
        | "f" :: "a" :: "l" :: "s" :: "e" :: rest => parse_end (Bool false) rest
        | "n" :: "u" :: "l" :: "l" :: rest => parse_end Null rest
        | "[" :: rest => parse_json rest (S_Array nil stack)
        | _ => None
        end
    end.

  Fixpoint parse_json_no_ws (s : string) (stack : Stack) : option json :=
    let fix parse_end obj stack str {struct str} :=
          match stack, str with
          | S_Array objs next, "," :: rest =>
              parse_json_no_ws rest (S_Array (obj :: objs) next)
          | S_Array objs next, "]" :: rest =>
              parse_end (Array (rev (obj :: objs))) next rest
          | S_Top, "" => Some obj
          | _, _ => None
          end
    in
    match stack, s with
    | _, "t" :: "r" :: "u" :: "e" :: rest =>
        parse_end (Bool true) stack rest
    | _, "f" :: "a" :: "l" :: "s" :: "e" :: rest =>
        parse_end (Bool false) stack rest
    | _, "n" :: "u" :: "l" :: "l" :: rest =>
        parse_end Null stack rest
    | _, "[" :: rest =>
        parse_json_no_ws rest (S_Array nil stack)
    | S_Array objs next, "]" :: rest =>
        parse_end (Array (rev objs)) next rest
    | _, _ => None
    end.

  Eval simpl in (option_map encode (parse_json_no_ws "[true,[],[false],[false,true]]" S_Top)).

  Eval simpl in (parse_json " [ true , false , [ true ]]" S_Top).

End Parser.

Inductive All {A} (P : A -> Prop) : list A -> Prop :=
  | All_nil : All P nil
  | All_cons : forall x xs, P x -> All P xs -> All P (x :: xs).

Fixpoint json_ind_2 (P : json -> Prop) x
    (Hbool : forall b, P (Bool b))
    (Hnull : P Null)
    (Harray : forall l, All P l -> P (Array l))
    : P x :=

  match x as x return P x with
  | Bool b => Hbool b
  | Null => Hnull
  | Array l => Harray l
      ((fix list_proof l : All P l :=
        match l as l return All P l with
        | nil => All_nil P
        | x :: xs => All_cons P x xs (json_ind_2 P x Hbool Hnull Harray) (list_proof xs)
        end
      ) l)
  end.

Theorem json_roundtrip : forall v, parse_json_no_ws (encode v) S_Top = Some v.
Proof.
  intro v.
  apply json_ind_2 with (x:=v).
  - intro b.
    destruct b; reflexivity.
  - reflexivity.
  - intros l Hall.
    induction Hall.
    + reflexivity.
    + unfold encode. fold @encode.
      destruct xs.
      * simpl.
        unfold parse_json_no_ws. fold @parse_json_no_ws.
        admit.
      * assert (intercalate "," (map encode (x :: j :: xs)) = encode x ++ "," ++ intercalate "," (map encode (j :: xs))) as H1.
        reflexivity.
        rewrite H1.
      unfold parse_json_no_ws.
Abort.

(*
Inductive Rep : json -> string -> Prop :=
  | R_True : Rep (Bool true) "true"
  | R_False : Rep (Bool false) "false"
  | R_Null : Rep Null "null"
  | R_Array : forall items str,
      RepItems items str -> Rep (Array items) ("[" ++ str ++ "]")

with RepItems : list json -> string -> Prop :=
  | RI_Empty : RepItems [] ""
  | RI_One : forall item str, Rep item str -> RepItems item str
  | RI_Many : forall item items str strs, Rep item str, Rep
*)


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

Section ycngstys.

Require Import Reals.
Require Import trajectory_def.
Require Import trajectory_const.
Require Import constants.
Require Import ycngftys.
Require Import rrho.

Unset Standard Proposition Elimination Names.

Variable intr : Trajectory.

Definition thetat : R -> R := theta intr.
Definition Rs (t : R) : R :=
  sqrt (Rsqr (xi intr t - xi intr 0) + Rsqr (yi intr t - yi intr 0)).

Axiom
  alphas_exists :
    { f : Differential_D2 |
       forall t : R,
       xi intr t = (Rs t * cos (f t) + xi intr 0)%R /\
       yi intr t = (Rs t * sin (f t) + yi intr 0)%R }.

Definition alphas := let (a,_) := alphas_exists in a.

Lemma alphas_def :
 forall t : R,
 xi intr t = (Rs t * cos (alphas t) + xi intr 0)%R /\
 yi intr t = (Rs t * sin (alphas t) + yi intr 0)%R.
unfold alphas in |- *; case alphas_exists; trivial.
Qed.

(**********)
Lemma Rsx : forall t : R, xi intr t = (xi intr 0 + Rs t * cos (alphas t))%R.
intros; generalize (alphas_def t); intro H; elim H; intros;
 rewrite Rplus_comm; assumption.
Qed.

Lemma Rsy : forall t : R, yi intr t = (yi intr 0 + Rs t * sin (alphas t))%R.
intros; generalize (alphas_def t); intro H; elim H; intros;
 rewrite Rplus_comm; assumption.
Qed.

Lemma Rs_x :
 forall t : R,
 cos (alphas t) <> 0%R -> Rs t = ((xi intr t - xi intr 0) / cos (alphas t))%R.
intros; rewrite Rsx; unfold Rminus, Rdiv in |- *;
 rewrite (Rplus_comm (xi intr 0)); rewrite Rplus_assoc;
 rewrite Rplus_opp_r; rewrite Rplus_0_r; rewrite Rmult_assoc;
 rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r; reflexivity | assumption ].
Qed.

Lemma Rs_y :
 forall t : R,
 sin (alphas t) <> 0%R -> Rs t = ((yi intr t - yi intr 0) / sin (alphas t))%R.
intros; rewrite Rsy; unfold Rminus, Rdiv in |- *;
 rewrite (Rplus_comm (yi intr 0)); rewrite Rplus_assoc;
 rewrite Rplus_opp_r; rewrite Rplus_0_r; rewrite Rmult_assoc;
 rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r; reflexivity | assumption ].
Qed.

(* With the two formulas above, you can prove the following result *)
(* Using the cos_sin_0's lemma                                     *)
Lemma Rs_derivable : derivable Rs.
unfold derivable in |- *; intro.
case (total_order_T (cos (alphas x)) 0); intro.
elim s; intro.
cut (cos (alphas x) <> 0%R).
intro;
 cut
  (exists eps : posreal,
     (forall h : R, (Rabs h < eps)%R -> cos (alphas (x + h)%R) <> 0%R)).
set (xi_p := fun t : R => xi intr t).
intro;
 cut (derivable_pt (fun t : R => ((xi_p t - xi_p 0) / cos (alphas t))%R) x).
intro X; unfold derivable_pt in X; elim X; intros l H1.
unfold derivable_pt in |- *; exists l.
unfold derivable_pt_abs in H1; unfold derivable_pt_lim in H1;
 unfold derivable_pt_abs in |- *; unfold derivable_pt_lim in |- *;
 intros.
elim (H1 eps H2); intros del H3.
elim H0; intros dom H4.
cut (0 < Rmin del dom)%R.
intro; exists (mkposreal (Rmin del dom) H5); intros.
repeat rewrite Rs_x.
unfold xi_p in H3; apply H3.
assumption.
apply Rlt_le_trans with (Rmin del dom); [ apply H7 | apply Rmin_l ].
apply H.
apply H4; apply Rlt_le_trans with (Rmin del dom); [ apply H7 | apply Rmin_r ].
unfold Rmin in |- *; case (Rle_dec del dom); intro.
apply (cond_pos del).
apply (cond_pos dom).
set (alphas_p := d2 alphas); reg.
unfold alphas_p in |- *; apply (cond_D1 alphas).
apply (xi_derivable intr x).
set (alphas_p := d2 alphas); set (f := fun t : R => cos (alphas_p t)).
cut
 (exists eps : posreal,
    (forall h : R, (Rabs h < eps)%R -> f (x + h)%R <> 0%R)).
intro; elim H0; intros.
exists x0; intros; unfold f in H1; apply H1; assumption.
apply continuous_neq_0.
unfold f in |- *; reg; apply derivable_continuous_pt; apply (cond_D1 alphas).
apply H.
red in |- *; intro; rewrite H in a; elim (Rlt_irrefl _ a).
cut (sin (alphas x) <> 0%R).
intro;
 cut
  (exists eps : posreal,
     (forall h : R, (Rabs h < eps)%R -> sin (alphas (x + h)%R) <> 0%R)).
set (yi_p := fun t : R => yi intr t).
intro;
 cut (derivable_pt (fun t : R => ((yi_p t - yi_p 0) / sin (alphas t))%R) x).
intro X; unfold derivable_pt in X.
elim X; intros l H1.
unfold derivable_pt in |- *; exists l.
unfold derivable_pt_abs in H1; unfold derivable_pt_lim in H1;
 unfold derivable_pt_abs in |- *; unfold derivable_pt_lim in |- *;
 intros.
elim (H1 eps H2); intros del H3.
elim H0; intros dom H4.
cut (0 < Rmin del dom)%R.
intro; exists (mkposreal (Rmin del dom) H5); intros.
repeat rewrite Rs_y.
unfold yi_p in H3; apply H3.
assumption.
apply Rlt_le_trans with (Rmin del dom); [ apply H7 | apply Rmin_l ].
apply H.
apply H4; apply Rlt_le_trans with (Rmin del dom); [ apply H7 | apply Rmin_r ].
unfold Rmin in |- *; case (Rle_dec del dom); intro.
apply (cond_pos del).
apply (cond_pos dom).
set (alphas_p := d2 alphas); reg.
unfold alphas_p in |- *; apply (cond_D1 alphas).
apply (yi_derivable intr x).
set (alphas_p := d2 alphas); set (f := fun t : R => sin (alphas_p t)).
cut
 (exists eps : posreal,
    (forall h : R, (Rabs h < eps)%R -> f (x + h)%R <> 0%R)).
intro; elim H0; intros.
exists x0; intros; unfold f in H1; apply H1; assumption.
apply continuous_neq_0.
unfold f in |- *; reg; apply derivable_continuous_pt; apply (cond_D1 alphas).
apply H.
assert (H := cos_sin_0_var (alphas x)); elim H; intro.
elim H0; assumption.
exact H0.
cut (cos (alphas x) <> 0%R).
intro;
 cut
  (exists eps : posreal,
     (forall h : R, (Rabs h < eps)%R -> cos (alphas (x + h)%R) <> 0%R)).
set (xi_p := fun t : R => xi intr t).
intro;
 cut (derivable_pt (fun t : R => ((xi_p t - xi_p 0) / cos (alphas t))%R) x).
intro X; unfold derivable_pt in X; elim X; intros l H1.
unfold derivable_pt in |- *; exists l.
unfold derivable_pt_abs in H1; unfold derivable_pt_lim in H1;
 unfold derivable_pt_abs in |- *; unfold derivable_pt_lim in |- *;
 intros.
elim (H1 eps H2); intros del H3.
elim H0; intros dom H4.
cut (0 < Rmin del dom)%R.
intro; exists (mkposreal (Rmin del dom) H5); intros.
repeat rewrite Rs_x.
unfold xi_p in H3; apply H3.
assumption.
apply Rlt_le_trans with (Rmin del dom); [ apply H7 | apply Rmin_l ].
apply H.
apply H4; apply Rlt_le_trans with (Rmin del dom); [ apply H7 | apply Rmin_r ].
unfold Rmin in |- *; case (Rle_dec del dom); intro.
apply (cond_pos del).
apply (cond_pos dom).
set (alphas_p := d2 alphas); reg.
unfold alphas_p in |- *; apply (cond_D1 alphas).
apply (xi_derivable intr x).
set (alphas_p := d2 alphas); set (f := fun t : R => cos (alphas_p t)).
cut
 (exists eps : posreal,
    (forall h : R, (Rabs h < eps)%R -> f (x + h)%R <> 0%R)).
intro; elim H0; intros.
exists x0; intros; unfold f in H1; apply H1; assumption.
apply continuous_neq_0.
unfold f in |- *; reg; apply derivable_continuous_pt; apply (cond_D1 alphas).
apply H.
red in |- *; intro; rewrite H in r; elim (Rlt_irrefl _ r).
Qed.

Definition alphas_p : R -> R := d2 alphas.

Lemma fct_der4 :
 forall t : R,
 derivable_pt ((Rs * comp cos alphas_p)%F + fct_cte (xi intr 0)) t.
intro; reg. apply (cond_D1 alphas).
apply Rs_derivable.
Qed.

(**********)
Lemma Dxi :
 forall t : R,
 derive_pt (xi intr) t (xi_derivable intr t) =
 (derive_pt Rs t (Rs_derivable t) * cos (alphas t) -
  Rs t * sin (alphas t) * derive_pt alphas t (cond_D1 alphas t))%R.
intro.
assert (H := fct_der4).
replace (derive_pt (xi intr) t (xi_derivable intr t)) with
 (derive_pt ((Rs * comp cos alphas_p)%F + fct_cte (xi intr 0)) t (H t)).
unfold plus_fct, mult_fct, comp, fct_cte in |- *.
set (H0 := Rs_derivable t).
cut (derivable_pt alphas_p t); [ intro X | apply (cond_D1 alphas) ].
replace (derive_pt alphas t (cond_D1 alphas t)) with (derive_pt alphas_p t X);
 [ idtac | apply pr_nu ].
reg.
unfold comp, alphas_p in |- *; ring.
unfold derive_pt in |- *.
case (H t).
case (xi_derivable intr t).
simpl.
intros.
eapply uniqueness_limite.
unfold derivable_pt_abs in d0.
apply d0.
unfold derivable_pt_lim in |- *; intros.
unfold derivable_pt_abs in d; unfold derivable_pt_lim in d.
elim (d eps H0); intros.
exists x1; intros.
unfold plus_fct, mult_fct, comp, fct_cte in |- *.
assert (H4 := H1 _ H2 H3).
replace
 ((Rs (t + h) * cos (alphas_p (t + h)) + xi intr 0 -
   (Rs t * cos (alphas_p t) + xi intr 0)) / h - x)%R with
 ((xi intr (t + h) - xi intr t) / h - x)%R.
apply H4.
rewrite (Rsx t).
rewrite (Rsx (t + h)).
replace
 (xi intr 0 + Rs (t + h) * cos (alphas (t + h)) -
  (xi intr 0 + Rs t * cos (alphas t)))%R with
 (Rs (t + h) * cos (alphas_p (t + h)) + xi intr 0 -
  (Rs t * cos (alphas_p t) + xi intr 0))%R.
reflexivity.
unfold alphas_p in |- *; ring.
Qed.

Lemma Dyi :
 forall t : R,
 derive_pt (yi intr) t (yi_derivable intr t) =
 (derive_pt Rs t (Rs_derivable t) * sin (alphas t) +
  Rs t * cos (alphas t) * derive_pt alphas t (cond_D1 alphas t))%R.
intro.
set (H := Rs_derivable t).
cut (derivable_pt alphas_p t); [ intro X | apply (cond_D1 alphas) ].
cut (derivable_pt ((Rs * comp sin alphas_p)%F + fct_cte (yi intr 0)) t);
 [ intro X0 | reg ].
replace (derive_pt (yi intr) t (yi_derivable intr t)) with
 (derive_pt ((Rs * comp sin alphas_p)%F + fct_cte (yi intr 0)) t X0).
replace (derive_pt alphas t (cond_D1 alphas t)) with (derive_pt alphas_p t X);
 [ idtac | apply pr_nu ].
unfold plus_fct, mult_fct, comp, fct_cte in |- *.
reg.
unfold comp, alphas_p in |- *; ring.
unfold derive_pt in |- *.
case X0.
case (yi_derivable intr t).
simpl.
intros.
eapply uniqueness_limite.
unfold derivable_pt_abs in d0.
apply d0.
unfold derivable_pt_lim in |- *; intros.
unfold derivable_pt_abs in d; unfold derivable_pt_lim in d.
elim (d eps H0); intros.
exists x1; intros.
unfold plus_fct, mult_fct, comp, fct_cte in |- *.
assert (H4 := H1 _ H2 H3).
replace
 ((Rs (t + h) * sin (alphas_p (t + h)) + yi intr 0 -
   (Rs t * sin (alphas_p t) + yi intr 0)) / h - x)%R with
 ((yi intr (t + h) - yi intr t) / h - x)%R.
apply H4.
rewrite (Rsy t).
rewrite (Rsy (t + h)).
replace
 (yi intr 0 + Rs (t + h) * sin (alphas (t + h)) -
  (yi intr 0 + Rs t * sin (alphas t)))%R with
 (Rs (t + h) * sin (alphas_p (t + h)) + yi intr 0 -
  (Rs t * sin (alphas_p t) + yi intr 0))%R.
reflexivity.
unfold alphas_p in |- *; ring.
Qed.

(**********)
Lemma DRs_cos :
 forall t : R,
 (derive_pt Rs t (Rs_derivable t) * cos (alphas t) -
  Rs t * sin (alphas t) * derive_pt alphas t (cond_D1 alphas t))%R =
 (vi intr * cos (thetat t))%R.
intro.
assert (H := Dxi t).
unfold xi in H.
assert (H0 := cond_x intr t).
cut
 (derive_pt (x intr) t (xi_derivable intr t) =
  derive_pt (x intr) t (cond_diff (x intr) t)); [ intro | apply pr_nu ].
rewrite H1 in H.
rewrite H0 in H.
unfold vi, thetat in |- *; symmetry  in |- *; assumption.
Qed.

Lemma DRs_sin :
 forall t : R,
 (derive_pt Rs t (Rs_derivable t) * sin (alphas t) +
  Rs t * cos (alphas t) * derive_pt alphas t (cond_D1 alphas t))%R =
 (vi intr * sin (thetat t))%R.
intro; assert (H := Dyi t).
unfold yi in H; assert (H0 := cond_y intr t).
cut
 (derive_pt (y intr) t (yi_derivable intr t) =
  derive_pt (y intr) t (cond_diff (y intr) t)); [ intro | apply pr_nu ].
rewrite H1 in H.
rewrite H0 in H.
unfold vi, thetat in |- *; symmetry  in |- *; assumption.
Qed.

(**********)
Lemma eq_plus_eq_is_eq :
 forall x y z t : R, x = y -> z = t -> (x + z)%R = (y + t)%R.
intros; rewrite H; rewrite H0; reflexivity.
Qed.

(**********)
Lemma DRs :
 forall t : R,
 derive_pt Rs t (Rs_derivable t) = (vi intr * cos (thetat t - alphas t))%R.
intro.
assert (H := DRs_cos t).
assert (H0 := DRs_sin t).
assert (H1 := Rmult_eq_compat_l (cos (alphas t)) _ _ H).
assert (H2 := Rmult_eq_compat_l (sin (alphas t)) _ _ H0).
replace (derive_pt Rs t (Rs_derivable t)) with
 (cos (alphas t) *
  (derive_pt Rs t (Rs_derivable t) * cos (alphas t) -
   Rs t * sin (alphas t) * derive_pt alphas t (cond_D1 alphas t)) +
  sin (alphas t) *
  (derive_pt Rs t (Rs_derivable t) * sin (alphas t) +
   Rs t * cos (alphas t) * derive_pt alphas t (cond_D1 alphas t)))%R.
replace (vi intr * cos (thetat t - alphas t))%R with
 (cos (alphas t) * (vi intr * cos (thetat t)) +
  sin (alphas t) * (vi intr * sin (thetat t)))%R.
apply eq_plus_eq_is_eq; assumption.
rewrite cos_minus; ring.
unfold Rminus in |- *.
repeat rewrite Rmult_plus_distr_l.
replace
 (cos (alphas t) * (derive_pt Rs t (Rs_derivable t) * cos (alphas t)) +
  cos (alphas t) *
  - (Rs t * sin (alphas t) * derive_pt alphas t (cond_D1 alphas t)) +
  (sin (alphas t) * (derive_pt Rs t (Rs_derivable t) * sin (alphas t)) +
   sin (alphas t) *
   (Rs t * cos (alphas t) * derive_pt alphas t (cond_D1 alphas t))))%R with
 (derive_pt Rs t (Rs_derivable t) *
  (Rsqr (sin (alphas t)) + Rsqr (cos (alphas t))) +
  cos (alphas t) *
  - (Rs t * sin (alphas t) * derive_pt alphas t (cond_D1 alphas t)) +
  sin (alphas t) *
  (Rs t * cos (alphas t) * derive_pt alphas t (cond_D1 alphas t)))%R;
 [ idtac | unfold Rsqr in |- *; ring ].
rewrite sin2_cos2; ring.
Qed.

(**********)
Lemma Rs_alphas :
 forall t : R,
 (Rs t * derive_pt alphas t (cond_D1 alphas t))%R =
 (vi intr * sin (thetat t - alphas t))%R.
intro.
assert (H := DRs_cos t).
assert (H0 := DRs_sin t).
assert (H1 := Rmult_eq_compat_l (- sin (alphas t)) _ _ H).
assert (H2 := Rmult_eq_compat_l (cos (alphas t)) _ _ H0).
replace (Rs t * derive_pt alphas t (cond_D1 alphas t))%R with
 (- sin (alphas t) *
  (derive_pt Rs t (Rs_derivable t) * cos (alphas t) -
   Rs t * sin (alphas t) * derive_pt alphas t (cond_D1 alphas t)) +
  cos (alphas t) *
  (derive_pt Rs t (Rs_derivable t) * sin (alphas t) +
   Rs t * cos (alphas t) * derive_pt alphas t (cond_D1 alphas t)))%R.
replace (vi intr * sin (thetat t - alphas t))%R with
 (- sin (alphas t) * (vi intr * cos (thetat t)) +
  cos (alphas t) * (vi intr * sin (thetat t)))%R.
apply eq_plus_eq_is_eq; assumption.
rewrite sin_minus; ring.
unfold Rminus in |- *.
repeat rewrite Rmult_plus_distr_l.
replace
 (- sin (alphas t) * (derive_pt Rs t (Rs_derivable t) * cos (alphas t)) +
  - sin (alphas t) *
  - (Rs t * sin (alphas t) * derive_pt alphas t (cond_D1 alphas t)) +
  (cos (alphas t) * (derive_pt Rs t (Rs_derivable t) * sin (alphas t)) +
   cos (alphas t) *
   (Rs t * cos (alphas t) * derive_pt alphas t (cond_D1 alphas t))))%R with
 (Rs t * derive_pt alphas t (cond_D1 alphas t) *
  (Rsqr (sin (alphas t)) + Rsqr (cos (alphas t))) +
  cos (alphas t) * - sin (alphas t) * derive_pt Rs t (Rs_derivable t) +
  sin (alphas t) * cos (alphas t) * derive_pt Rs t (Rs_derivable t))%R;
 [ idtac | unfold Rsqr in |- *; ring ].
rewrite sin2_cos2; ring.
Qed.

Lemma fct_der5 :
 forall t : R,
 derivable_pt (fun y : R => (Rs y * derive_pt alphas y (cond_D1 alphas y))%R)
   t.
intro; set (alpha_p := d2 alphas);
 set (f := fun x : R => derive_pt alpha_p x (cond_D1 alphas x)).
change (derivable_pt (fun y : R => (Rs y * f y)%R) t) in |- *.
reg.
apply (cond_D2 alphas).
apply Rs_derivable.
Qed.

(**********)
Lemma D_Rs_alphas1 :
 forall t : R,
 derive_pt (fun y : R => (Rs y * derive_pt alphas y (cond_D1 alphas y))%R) t
   (fct_der5 t) =
 (derive_pt Rs t (Rs_derivable t) * derive_pt alphas t (cond_D1 alphas t) +
  Rs t * derive_pt (derive alphas (cond_D1 alphas)) t (cond_D2 alphas t))%R.
intro.
set (f := fun x : R => derive_pt alphas x (cond_D1 alphas x)).
replace
 (derive_pt (fun y : R => (Rs y * derive_pt alphas y (cond_D1 alphas y))%R) t
    (fct_der5 t)) with
 (derive_pt (fun y : R => (Rs y * f y)%R) t (fct_der5 t));
 [ idtac | reflexivity ].
replace (derive_pt alphas t (cond_D1 alphas t)) with (f t);
 [ idtac | reflexivity ].
replace (derive_pt (derive alphas (cond_D1 alphas)) t (cond_D2 alphas t))
 with (derive_pt f t (cond_D2 alphas t)); [ idtac | reflexivity ].
cut (derivable_pt Rs t); [ intro X | apply Rs_derivable ].
cut (derivable_pt f t); [ intro X0 | apply (cond_D2 alphas) ].
reg.
replace (derive_pt f t (cond_D2 alphas t)) with (derive_pt f t X0);
 [ idtac | apply pr_nu ].
replace (derive_pt Rs t (Rs_derivable t)) with (derive_pt Rs t X);
 [ idtac | apply pr_nu ].
ring.
Qed.

(**********)
Lemma thetat_derivable : derivable thetat.
unfold thetat in |- *; apply (cond_diff (theta intr)).
Qed.

(**********)
Lemma D_Rs_alphas2 :
 forall t : R,
 derive_pt (fun y : R => (Rs y * derive_pt alphas y (cond_D1 alphas y))%R) t
   (fct_der5 t) =
 (vi intr * cos (thetat t - alphas t) *
  (derive_pt thetat t (thetat_derivable t) -
   derive_pt alphas t (cond_D1 alphas t)))%R.
intro.
cut (derivable_pt (fun x : R => (vi intr * sin (thetat x - alphas x))%R) t).
intro X.
replace
 (derive_pt (fun y : R => (Rs y * derive_pt alphas y (cond_D1 alphas y))%R) t
    (fct_der5 t)) with
 (derive_pt (fun x : R => (vi intr * sin (thetat x - alphas x))%R) t X).
set (f := d2 alphas).
cut (derivable_pt f t); [ intro X0 | apply (cond_D1 alphas) ].
cut (derivable_pt thetat t); [ intro X1 | apply thetat_derivable ].
reg.
unfold fct_cte, minus_fct in |- *.
replace (derive_pt f t (cond_D1 alphas t)) with (derive_pt f t X0);
 [ idtac | apply pr_nu ].
replace (derive_pt thetat t (thetat_derivable t)) with
 (derive_pt thetat t X1); [ idtac | apply pr_nu ].
ring.
unfold derive_pt in |- *.
case X; case (fct_der5 t); simpl; intros.
eapply uniqueness_limite.
unfold derivable_pt_abs in d0; apply d0.
unfold derivable_pt_lim in |- *; intros.
unfold derivable_pt_abs in d; unfold derivable_pt_lim in d; elim (d eps H);
 intros.
exists x1; intros.
do 2 rewrite <- Rs_alphas.
apply H0; assumption.
fold alphas_p in |- *; reg.
apply (cond_D1 alphas).
apply thetat_derivable.
Qed.

(**********)
Lemma D_Rs_2 :
 forall t : R,
 (derive_pt Rs t (Rs_derivable t) *
  (2 * derive_pt alphas t (cond_D1 alphas t) -
   derive_pt thetat t (thetat_derivable t)))%R =
 (- Rs t * derive_pt (derive alphas (cond_D1 alphas)) t (cond_D2 alphas t))%R.
intro.
assert (H := D_Rs_alphas1 t).
assert (H0 := D_Rs_alphas2 t).
assert (H1 := DRs t).
rewrite H in H0; rewrite <- H1 in H0.
assert
 (H2 :=
  Rplus_eq_compat_l
    (- derive_pt Rs t (Rs_derivable t) *
     (derive_pt thetat t (thetat_derivable t) -
      derive_pt alphas t (cond_D1 alphas t)) +
     - Rs t * derive_pt (derive alphas (cond_D1 alphas)) t (cond_D2 alphas t))
    _ _ H0).
cut
 ((- derive_pt Rs t (Rs_derivable t) *
   (derive_pt thetat t (thetat_derivable t) -
    derive_pt alphas t (cond_D1 alphas t)) +
   - Rs t * derive_pt (derive alphas (cond_D1 alphas)) t (cond_D2 alphas t) +
   (derive_pt Rs t (Rs_derivable t) * derive_pt alphas t (cond_D1 alphas t) +
    Rs t * derive_pt (derive alphas (cond_D1 alphas)) t (cond_D2 alphas t)))%R =
  (derive_pt Rs t (Rs_derivable t) *
   (2 * derive_pt alphas t (cond_D1 alphas t) -
    derive_pt thetat t (thetat_derivable t)))%R); [ intro | ring ].
cut
 ((- derive_pt Rs t (Rs_derivable t) *
   (derive_pt thetat t (thetat_derivable t) -
    derive_pt alphas t (cond_D1 alphas t)) +
   - Rs t * derive_pt (derive alphas (cond_D1 alphas)) t (cond_D2 alphas t) +
   derive_pt Rs t (Rs_derivable t) *
   (derive_pt thetat t (thetat_derivable t) -
    derive_pt alphas t (cond_D1 alphas t)))%R =
  (- Rs t * derive_pt (derive alphas (cond_D1 alphas)) t (cond_D2 alphas t))%R);
 [ intro | ring ].
rewrite H3 in H2; rewrite H4 in H2.
assumption.
Qed.

(**********)
Lemma Rsqr_DRs :
 forall t : R,
 (Rsqr (derive_pt Rs t (Rs_derivable t)) +
  Rsqr (Rs t) * Rsqr (derive_pt alphas t (cond_D1 alphas t)))%R =
 Rsqr (vi intr).
intro; rewrite <- Rsqr_mult; rewrite DRs; rewrite Rs_alphas;
 repeat rewrite Rsqr_mult; rewrite Rplus_comm;
 rewrite <- (Rmult_comm (Rsqr (cos (thetat t - alphas t))));
 rewrite <- (Rmult_comm (Rsqr (sin (thetat t - alphas t))));
 rewrite <- Rmult_plus_distr_r; rewrite sin2_cos2;
 rewrite Rmult_1_l; reflexivity.
Qed.

(**********)
Lemma Rs_pos : forall t : R, (0 <= Rs t)%R.
intro; unfold Rs in |- *; apply sqrt_positivity; apply Rplus_le_le_0_compat;
 apply Rle_0_sqr.
Qed.

Lemma Rs_0 : Rs 0 = 0%R.
unfold Rs in |- *; unfold Rminus in |- *; repeat rewrite Rplus_opp_r;
 repeat rewrite Rsqr_0; rewrite Rplus_0_r; rewrite sqrt_0;
 reflexivity.
Qed.

(**********)
Lemma D_Rs_0 : (0 <= derive_pt Rs 0 (Rs_derivable 0))%R.
case (Rtotal_order 0 (derive_pt Rs 0 (Rs_derivable 0%R))); intro.
left; assumption.
elim H; intro.
right; assumption.
generalize (derivable_derive Rs 0 (Rs_derivable 0%R)); intro; elim H1;
 intros l H2; rewrite H2 in H0.
generalize (derive_pt_eq_1 Rs 0 l (Rs_derivable 0%R) H2); intros;
 cut (0 < - (l / 2))%R.
intro H4; elim (H3 (- (l / 2))%R H4).
intros; cut ((x / 2)%R <> 0%R).
intro H6; cut (Rabs (x / 2) < x)%R.
intro H7; generalize (H5 (x / 2)%R H6 H7); intro H8; rewrite Rs_0 in H8;
 rewrite Rplus_0_l in H8; unfold Rminus in H8; rewrite Ropp_0 in H8;
 rewrite Rplus_0_r in H8;
 generalize (Rabs_def2 (Rs (x / 2) / (x / 2) + - l) (- (l / 2)) H8);
 intro H9; elim H9; intros;
 generalize
  (Rplus_lt_compat_r l (Rs (x / 2) / (x / 2) + - l) (- (l / 2)) H10);
 rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
 replace (- (l / 2) + l)%R with (l / 2)%R.
intro H12; cut (l / 2 < 0)%R.
intro H13; generalize (Rlt_trans (Rs (x / 2) / (x / 2)) (l / 2) 0 H12 H13);
 intro H14; unfold Rdiv in H14; cut (0 < x * / 2)%R.
intro H15;
 generalize
  (Rmult_lt_compat_r (x * / 2) (Rs (x * / 2) * / (x * / 2)) 0 H15 H14);
 rewrite Rmult_0_l; rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
rewrite Rmult_1_r; intro H16;
 elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rs (x * / 2)) 0 (Rs_pos (x * / 2)) H16)).
apply prod_neq_R0.
generalize (cond_pos x); intro H16; red in |- *; intro H17;
 rewrite H17 in H16; elim (Rlt_irrefl 0 H16).
apply Rinv_neq_0_compat; discrR.
apply Rmult_lt_0_compat;
 [ apply (cond_pos x) | apply Rinv_0_lt_compat; prove_sup0 ].
assert (Hyp : (0 < 2)%R).
prove_sup0.
unfold Rdiv in |- *;
 generalize (Rmult_lt_compat_r (/ 2) l 0 (Rinv_0_lt_compat 2 Hyp) H0);
 rewrite Rmult_0_l; intro H13; exact H13.
pattern l at 3 in |- *; rewrite double_var.
ring.
cut (0 < x / 2)%R.
intro H7; apply Rabs_def1.
pattern x at 1 in |- *; replace (pos x) with (2 * (x / 2))%R.
pattern (x / 2)%R at 1 in |- *; replace (x / 2)%R with (x / 2 + 0)%R.
replace (2 * (x / 2))%R with (x / 2 + x / 2)%R.
apply Rplus_lt_compat_l; assumption.
ring.
apply Rplus_0_r.
pattern (pos x) at 2 in |- *; rewrite double_var.
ring.
apply Rlt_trans with 0%R.
rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; apply (cond_pos x).
assumption.
unfold Rdiv in |- *; apply Rmult_lt_0_compat;
 [ apply (cond_pos x) | apply Rinv_0_lt_compat; prove_sup0 ].
unfold Rdiv in |- *; apply prod_neq_R0.
generalize (cond_pos x); intro H6; red in |- *; intro H7; rewrite H7 in H6;
 elim (Rlt_irrefl 0 H6).
apply Rinv_neq_0_compat; discrR.
assert (Hyp : (0 < 2)%R).
prove_sup0.
unfold Rdiv in |- *; rewrite <- Ropp_0; apply Ropp_lt_gt_contravar;
 generalize (Rmult_lt_compat_r (/ 2) l 0 (Rinv_0_lt_compat 2 Hyp) H0);
 rewrite Rmult_0_l; intro H4; assumption.
Qed.

Lemma eq_sym : forall x y : R, x = y -> y = x.
intros; rewrite H; reflexivity.
Qed.

(**********)
Lemma D_Rs_0_strong : (0 < derive_pt Rs 0 (Rs_derivable 0))%R.
case (Rtotal_order 0 (derive_pt Rs 0 (Rs_derivable 0%R))); intro.
assumption.
elim H; intro.
generalize (Rsqr_DRs 0); intro H1; rewrite <- H0 in H1; rewrite Rs_0 in H1;
 repeat rewrite Rsqr_0 in H1; rewrite Rplus_0_l in H1;
 rewrite Rmult_0_l in H1; generalize (eq_sym 0 (Rsqr (vi intr)) H1).
clear H1; intro H1; generalize (Rsqr_eq_0 (vi intr) H1).
intro H2; generalize (TypeSpeed_pos (vi intr)); intro H3; rewrite H2 in H3;
 elim (Rlt_irrefl 0 H3).
generalize D_Rs_0; intro H1;
 elim
  (Rlt_irrefl 0 (Rle_lt_trans 0 (derive_pt Rs 0 (Rs_derivable 0%R)) 0 H1 H0)).
Qed.

(**********)
Lemma D_alphas_0 :
 (2 * derive_pt alphas 0 (cond_D1 alphas 0))%R =
 derive_pt thetat 0 (thetat_derivable 0%R).
generalize (D_Rs_2 0); intro; rewrite Rs_0 in H; rewrite Ropp_0 in H;
 rewrite Rmult_0_l in H;
 generalize
  (Rmult_integral (derive_pt Rs 0 (Rs_derivable 0%R))
     (2 * derive_pt alphas 0 (cond_D1 alphas 0%R) -
      derive_pt thetat 0 (thetat_derivable 0%R)) H);
 intro H1; elim H1; intro; generalize D_Rs_0_strong;
 intro.
rewrite H0 in H2; elim (Rlt_irrefl 0 H2).
generalize
 (Rminus_diag_uniq_sym (derive_pt thetat 0 (thetat_derivable 0%R))
    (2 * derive_pt alphas 0 (cond_D1 alphas 0%R)) H0);
 intro; symmetry  in |- *; assumption.
Qed.

(**********)
Lemma D_Rs_pos_non_null :
 forall t : R,
 (0 < t)%R ->
 (forall x : R, (0 < x < t)%R -> (0 < derive_pt Rs x (Rs_derivable x))%R) ->
 (0 < Rs t)%R.
intros; generalize (derive_increasing_interv 0 t Rs Rs_derivable H H0);
 intros; cut (0 <= 0 <= t)%R;
 [ cut (0 <= t <= t)%R;
    [ intros; rewrite <- Rs_0; apply (H1 0%R t H3 H2 H)
    | split; [ left; assumption | right; reflexivity ] ]
 | split; [ right; reflexivity | left; assumption ] ].
Qed.

(* To prove the following axioms, you need more sophisticated analysis *)
Axiom
  D_Rs_pos :
    forall t : R,
    (0 <= t)%R ->
    (t < 2 / rho (vi intr))%R -> (0 < derive_pt Rs t (Rs_derivable t))%R.

Axiom
  D_abs_alpha :
    forall t : R,
    (0 <= t)%R ->
    (t < 2 / rho (vi intr))%R ->
    (- rho (vi intr) / 2 <= derive_pt alphas t (cond_D1 alphas t))%R /\
    (derive_pt alphas t (cond_D1 alphas t) <= rho (vi intr) / 2)%R.

Definition F (t : R) : R :=
  (2 * (vi intr / rho (vi intr)) * sin (rho (vi intr) * (t / 2)))%R.

Lemma F_derivable : derivable F.
unfold F in |- *; reg.
Qed.

(**********)
Lemma D_F :
 forall t : R,
 derive_pt F t (F_derivable t) = (vi intr * cos (rho (vi intr) * (t / 2)))%R.
intro; unfold F in |- *; reg.
unfold Rdiv in |- *;  field.
assert (H0 := rho_pos (vi intr)); red in |- *; intro; rewrite H in H0;
 elim (Rlt_irrefl 0 H0).
Qed.

(**********)
Lemma D_F_Rsqr_v :
 forall t : R,
 (Rsqr (derive_pt F t (F_derivable t)) +
  Rsqr (rho (vi intr) / 2) * Rsqr (F t))%R = Rsqr (vi intr).
intro; rewrite (D_F t); rewrite <- Rsqr_mult;
 cut
  ((rho (vi intr) / 2 * F t)%R = (vi intr * sin (rho (vi intr) * (t / 2)))%R).
intro H; rewrite H; repeat rewrite Rsqr_mult;
 replace
  (Rsqr (vi intr) * Rsqr (cos (rho (vi intr) * (t / 2))) +
   Rsqr (vi intr) * Rsqr (sin (rho (vi intr) * (t / 2))))%R with
  (Rsqr (vi intr) *
   (Rsqr (sin (rho (vi intr) * (t / 2))) +
    Rsqr (cos (rho (vi intr) * (t / 2)))))%R.
rewrite sin2_cos2; rewrite Rmult_1_r; reflexivity.
ring.
unfold F in |- *; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
 replace (rho (vi intr) * / 2 * (2 * (vi intr * / rho (vi intr))))%R with
  (2 * / 2 * (rho (vi intr) * / rho (vi intr)) * vi intr)%R.
repeat rewrite <- Rinv_r_sym.
repeat rewrite Rmult_1_l; reflexivity.
generalize (rho_pos (vi intr)); intro; red in |- *; intro; rewrite H0 in H;
 elim (Rlt_irrefl 0 H).
discrR.
ring.
Qed.

Definition G (t : R) : R := (Rs t - F t)%R.

Lemma G_derivable : derivable G.
unfold G in |- *; reg.
apply F_derivable.
apply Rs_derivable.
Qed.

(**********)
Lemma D_G_alphas :
 forall t : R,
 (derive_pt G t (G_derivable t) *
  (derive_pt Rs t (Rs_derivable t) + derive_pt F t (F_derivable t)))%R =
 (- Rsqr (derive_pt alphas t (cond_D1 alphas t)) * G t * (Rs t + F t) +
  Rsqr (F t) *
  (Rsqr (rho (vi intr) / 2) - Rsqr (derive_pt alphas t (cond_D1 alphas t))))%R.
intro.
cut
 (derive_pt G t (G_derivable t) =
  (derive_pt Rs t (Rs_derivable t) - derive_pt F t (F_derivable t))%R).
intro; rewrite H;
 rewrite
  (Rsqr_minus_plus (derive_pt Rs t (Rs_derivable t))
     (derive_pt F t (F_derivable t))); unfold G in |- *;
 repeat rewrite Rmult_assoc; rewrite (Rsqr_minus_plus (Rs t) (F t)).
replace
 (- Rsqr (derive_pt alphas t (cond_D1 alphas t)) * (Rsqr (Rs t) - Rsqr (F t)) +
  Rsqr (F t) *
  (Rsqr (rho (vi intr) / 2) - Rsqr (derive_pt alphas t (cond_D1 alphas t))))%R
 with
 (- Rsqr (derive_pt alphas t (cond_D1 alphas t)) * Rsqr (Rs t) +
  Rsqr (F t) * Rsqr (rho (vi intr) / 2))%R.
apply
 Rplus_eq_reg_l
  with
    (Rsqr (derive_pt F t (F_derivable t)) +
     Rsqr (derive_pt alphas t (cond_D1 alphas t)) * Rsqr (Rs t))%R.
replace
 (Rsqr (derive_pt F t (F_derivable t)) +
  Rsqr (derive_pt alphas t (cond_D1 alphas t)) * Rsqr (Rs t) +
  (Rsqr (derive_pt Rs t (Rs_derivable t)) -
   Rsqr (derive_pt F t (F_derivable t))))%R with
 (Rsqr (derive_pt Rs t (Rs_derivable t)) +
  Rsqr (Rs t) * Rsqr (derive_pt alphas t (cond_D1 alphas t)))%R.
replace
 (Rsqr (derive_pt F t (F_derivable t)) +
  Rsqr (derive_pt alphas t (cond_D1 alphas t)) * Rsqr (Rs t) +
  (- Rsqr (derive_pt alphas t (cond_D1 alphas t)) * Rsqr (Rs t) +
   Rsqr (F t) * Rsqr (rho (vi intr) / 2)))%R with
 (Rsqr (derive_pt F t (F_derivable t)) +
  Rsqr (rho (vi intr) / 2) * Rsqr (F t))%R.
rewrite Rsqr_DRs; rewrite D_F_Rsqr_v; reflexivity.
ring.
ring.
ring.
unfold G in |- *.
cut (derivable_pt Rs t); [ intro X | apply Rs_derivable ].
cut (derivable_pt F t); [ intro X0 | apply F_derivable ].
reg.
replace (derive_pt F t (F_derivable t)) with (derive_pt F t X0);
 [ idtac | apply pr_nu ].
replace (derive_pt Rs t (Rs_derivable t)) with (derive_pt Rs t X);
 [ idtac | apply pr_nu ].
ring.
Qed.

(**********)
Lemma Rlt_1_PI2 : (1 < PI / 2)%R.
generalize PI_approx; intro; elim H; intros.
apply Rlt_le_trans with (PI_lb / 2)%R.
unfold PI_lb in |- *; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2%R.
prove_sup.
rewrite Rmult_1_r; rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m;
 [ prove_sup | discrR ].
left; unfold Rdiv in |- *; repeat rewrite <- (Rmult_comm (/ 2));
 apply Rmult_lt_compat_l; [ apply Rinv_0_lt_compat; prove_sup | assumption ].
Qed.

(**********)
Lemma D_G_pos :
 forall t : R,
 (0 <= t)%R ->
 (t < 2 / rho (vi intr))%R ->
 (G t <= 0)%R -> (0 <= derive_pt G t (G_derivable t))%R.
intros.
case (Rcase_abs (derive_pt G t (G_derivable t))); intro.
generalize (D_G_alphas t); intro.
generalize (D_Rs_pos t H H0); intro.
cut (0 <= derive_pt F t (F_derivable t))%R.
intro.
generalize (Rs_pos t); intro.
cut (0 <= F t)%R.
intro.
cut
 (derive_pt G t (G_derivable t) *
  (derive_pt Rs t (Rs_derivable t) + derive_pt F t (F_derivable t)) < 0)%R.
intro.
cut
 (0 <=
  - Rsqr (derive_pt alphas t (cond_D1 alphas t)) * G t * (Rs t + F t) +
  Rsqr (F t) *
  (Rsqr (rho (vi intr) / 2) - Rsqr (derive_pt alphas t (cond_D1 alphas t))))%R.
intro.
rewrite <- H2 in H8.
elim
 (Rlt_irrefl 0
    (Rle_lt_trans 0
       (derive_pt G t (G_derivable t) *
        (derive_pt Rs t (Rs_derivable t) + derive_pt F t (F_derivable t))) 0
       H8 H7)).
apply Rplus_le_le_0_compat.
replace
 (- Rsqr (derive_pt alphas t (cond_D1 alphas t)) * G t * (Rs t + F t))%R with
 (Rsqr (derive_pt alphas t (cond_D1 alphas t)) * - G t * (Rs t + F t))%R.
repeat simple apply Rmult_le_pos.
apply Rle_0_sqr.
rewrite <- Ropp_0.
apply Ropp_ge_le_contravar.
apply Rle_ge; assumption.
apply Rplus_le_le_0_compat; assumption.
ring.
apply Rmult_le_pos.
apply Rle_0_sqr.
apply Rplus_le_reg_l with (Rsqr (derive_pt alphas t (cond_D1 alphas t))).
rewrite Rplus_0_r.
rewrite Rplus_comm.
unfold Rminus in |- *.
repeat rewrite Rplus_assoc.
rewrite Rplus_opp_l.
rewrite Rplus_0_r.
generalize (D_abs_alpha t H H0); intro.
elim H8; intros.
case (Rtotal_order 0 (derive_pt alphas t (cond_D1 alphas t))); intro.
apply Rsqr_incr_1.
assumption.
left; assumption.
unfold Rdiv in |- *; left; apply Rmult_lt_0_compat.
apply rho_pos.
apply Rinv_0_lt_compat; prove_sup0.
elim H11; intros.
rewrite <- H12.
rewrite Rsqr_0.
apply Rle_0_sqr.
rewrite (Rsqr_neg (derive_pt alphas t (cond_D1 alphas t))).
apply Rsqr_incr_1.
rewrite <- (Ropp_involutive (rho (vi intr) / 2)).
apply Ropp_ge_le_contravar.
apply Rle_ge.
replace (- (rho (vi intr) / 2))%R with (- rho (vi intr) / 2)%R.
assumption.
unfold Rdiv in |- *; ring.
rewrite <- Ropp_0.
apply Ropp_ge_le_contravar; apply Rle_ge; left; assumption.
unfold Rdiv in |- *; left; apply Rmult_lt_0_compat.
apply rho_pos.
apply Rinv_0_lt_compat; prove_sup0.
rewrite <- (Ropp_involutive 0).
replace
 (derive_pt G t (G_derivable t) *
  (derive_pt Rs t (Rs_derivable t) + derive_pt F t (F_derivable t)))%R with
 (-
  (- derive_pt G t (G_derivable t) *
   (derive_pt Rs t (Rs_derivable t) + derive_pt F t (F_derivable t))))%R.
apply Ropp_lt_gt_contravar.
rewrite Ropp_0.
apply Rmult_lt_0_compat.
rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
apply Rplus_lt_le_0_compat; assumption.
ring.
unfold F in |- *.
repeat simple apply Rmult_le_pos.
left; prove_sup0.
unfold Rdiv in |- *; left; apply Rmult_lt_0_compat.
apply TypeSpeed_pos.
apply Rinv_0_lt_compat; apply rho_pos.
apply sin_ge_0.
unfold Rdiv in |- *; repeat simple apply Rmult_le_pos.
left; apply rho_pos.
assumption.
left; apply Rinv_0_lt_compat; prove_sup0.
left; apply Rlt_trans with 1%R.
unfold Rdiv in |- *.
apply Rmult_lt_reg_l with (2 * / rho (vi intr))%R.
apply Rmult_lt_0_compat;
 [ prove_sup0 | apply Rinv_0_lt_compat; apply rho_pos ].
rewrite Rmult_1_r.
replace (2 * / rho (vi intr) * (rho (vi intr) * (t * / 2)))%R with t.
assumption.
repeat rewrite Rmult_assoc.
rewrite Rmult_comm.
repeat rewrite Rmult_assoc.
rewrite <- Rinv_l_sym.
repeat rewrite <- Rmult_assoc.
rewrite <- Rinv_l_sym.
rewrite Rmult_1_r; symmetry  in |- *; apply Rmult_1_l.
red in |- *; generalize (rho_pos (vi intr)); intros; rewrite H7 in H6;
 elim (Rlt_irrefl 0 H6).
discrR.
apply Rlt_trans with (PI / 2)%R.
apply Rlt_1_PI2.
apply PI2_Rlt_PI.
rewrite D_F.
apply Rmult_le_pos.
left; apply TypeSpeed_pos.
apply cos_ge_0.
left; apply Rlt_le_trans with 0%R.
rewrite <- Ropp_0.
apply Ropp_lt_gt_contravar.
apply PI2_RGT_0.
unfold Rdiv in |- *; repeat simple apply Rmult_le_pos.
left; apply rho_pos.
assumption.
left; apply Rinv_0_lt_compat; prove_sup0.
left; apply Rlt_le_trans with 1%R.
apply Rmult_lt_reg_l with (2 / rho (vi intr))%R.
unfold Rdiv in |- *; apply Rmult_lt_0_compat;
 [ prove_sup0 | apply Rinv_0_lt_compat; apply rho_pos ].
rewrite Rmult_1_r.
replace (2 / rho (vi intr) * (rho (vi intr) * (t / 2)))%R with t.
assumption.
unfold Rdiv in |- *.
repeat rewrite Rmult_assoc.
rewrite (Rmult_comm 2).
repeat rewrite <- Rmult_assoc.
rewrite <- Rinv_l_sym.
repeat rewrite Rmult_assoc.
rewrite <- Rinv_l_sym.
rewrite Rmult_1_r; rewrite Rmult_1_l.
reflexivity.
discrR.
red in |- *; generalize (rho_pos (vi intr)); intros; rewrite H5 in H4;
 elim (Rlt_irrefl 0 H4).
left; apply Rlt_1_PI2.
apply Rge_le.
assumption.
Qed.

Lemma G_0 : G 0 = 0%R.
unfold G in |- *; rewrite Rs_0; unfold Rminus, F in |- *; unfold Rdiv in |- *;
 rewrite Rmult_0_l; rewrite Rmult_0_r; rewrite sin_0;
 repeat rewrite Rmult_0_r; rewrite Rplus_0_l; apply Ropp_0.
Qed.

(**********)
Axiom
  G_pos :
    forall t : R, (0 <= t)%R -> (t < 2 / rho (vi intr))%R -> (0 <= G t)%R.

(**************************)
(******* THEOREM **********)
(**************************)

Theorem YCNGSTYS :
 forall t : R,
 (0 <= t)%R ->
 (rho (vi intr) * t < 2)%R ->
 (2 * r (vi intr) * sin (rho (vi intr) * (t / 2)) <=
  sqrt (Rsqr (xi intr t - xi intr 0) + Rsqr (yi intr t - yi intr 0)))%R.
intros; generalize (rho_pos (vi intr)); intro H1;
 generalize (Rinv_0_lt_compat (rho (vi intr)) H1);
 intro H2;
 generalize (Rmult_lt_compat_l (/ rho (vi intr)) (rho (vi intr) * t) 2 H2 H0);
 intro H3; rewrite <- Rmult_assoc in H3; rewrite <- Rinv_l_sym in H3.
rewrite Rmult_1_l in H3; rewrite Rmult_comm in H3; generalize (G_pos t H H3);
 unfold G in |- *; intro H4;
 generalize (Rplus_le_compat_l (F t) 0 (Rs t - F t) H4);
 rewrite Rplus_0_r; intro H5; unfold Rminus in H5;
 rewrite <- Rplus_assoc in H5; rewrite Rplus_comm in H5;
 rewrite <- Rplus_assoc in H5; rewrite Rplus_opp_l in H5;
 rewrite Rplus_0_l in H5; unfold Rs, F in H5; unfold r in |- *;
 assumption.
red in |- *; intro H4; rewrite H4 in H1; elim (Rlt_irrefl 0 H1).
Qed.

End ycngstys.


From Cat Require Export Cat.
From Cat.Universal Require Import Initial Terminal Product Coproduct.
From Cat Require Export Instances.SETOID.

Set Implicit Arguments.

Class Reloid : Type :=
{
  carrier : Setoid';
  rel : carrier -> carrier -> Prop;
  Proper_rel :> Proper (equiv ==> equiv ==> iff) rel
}.

Coercion carrier : Reloid >-> Setoid'.

Ltac reloidob X := try intros until X;
match type of X with
| Reloid =>
  let a := fresh X "_rel" in
  let b := fresh X "_Proper_rel" in destruct X as [X a b]; setoidob X
| Ob _ => progress cbn in X; reloidob X
end.

Ltac reloidobs := repeat
match goal with
| X : Reloid |- _ => reloidob X
| X : Ob _ |- _ => reloidob X
end.

Class ReloidHom (X Y : Reloid) : Type :=
{
  func : SetoidHom X Y;
  pres_rel : Proper (@rel X ==> @rel Y) func
}.

Coercion func : ReloidHom >-> SetoidHom.

Ltac reloidhom f := try intros until f;
match type of f with
| ReloidHom _ _ =>
    let a := fresh f "_pres_rel" in destruct f as [f a]; setoidhom f
| Hom _ _ => progress cbn in f; reloidhom f
end.

Ltac reloidhoms := intros; repeat
match goal with
| f : ReloidHom _ _ |- _ => reloidhom f
| f : Hom _ _ |- _ => reloidhom f
| _ => idtac
end.

Ltac reloid := intros; repeat
match goal with
| |- Equivalence _ => solve_equiv
| |- Proper _ _ => proper
| _ => repeat (my_simpl || reloidobs || reloidhoms || cat)
end.

#[refine]
#[export]
Instance ReloidHomSetoid (X Y : Reloid) : Setoid (ReloidHom X Y) :=
{
  equiv := fun f g => forall x : X, f x == g x
}.
Proof. now solve_equiv. Defined.

#[refine]
#[export]
Instance ReloidComp {X Y Z : Reloid} (f : ReloidHom X Y) (g : ReloidHom Y Z) : ReloidHom X Z :=
{
  func := SetoidComp f g
}.
Proof. now reloid. Defined.

#[refine]
#[export]
Instance ReloidId (X : Reloid) : ReloidHom X X :=
{
  func := SetoidId X
}.
Proof. now reloid. Defined.

#[refine]
#[export]
Instance ReloidCat : Cat :=
{
  Ob := Reloid;
  Hom := ReloidHom;
  HomSetoid := ReloidHomSetoid;
  comp := @ReloidComp;
  id := @ReloidId;
}.
Proof. all: now reloid. Defined.

#[export]
Instance Reloid_init : Reloid :=
{
  carrier := SETOID_init;
  rel := relate_Empty;
}.

#[refine]
#[export]
Instance Reloid_create (X : Reloid) : ReloidHom Reloid_init X :=
{
  func := SETOID_create X
}.
Proof. now proper. Defined.

#[refine]
#[export]
Instance HasInit_Reloid : HasInit ReloidCat :=
{
  init := Reloid_init;
  create := Reloid_create
}.
Proof. easy. Defined.

#[export]
Instance HasStrictInit_Reloid : HasStrictInit ReloidCat.
Proof.
  intros A f.
  exists (create A); split.
  - now intros x; destruct (f x).
  - now apply equiv_initial.
Defined.

#[export]
Instance Reloid_term : Reloid :=
{
  carrier := SETOID_term;
  rel := relate_unit;
}.

#[refine]
#[export]
Instance Reloid_delete (X : Reloid) : ReloidHom X Reloid_term :=
{
  func := SETOID_delete X
}.
Proof. easy. Defined.

#[refine]
#[export]
Instance HasTerm_Reloid : HasTerm ReloidCat :=
{
  term := Reloid_term;
  delete := Reloid_delete;
}.
Proof. easy. Defined.

#[refine]
#[export]
Instance Reloid_product (X Y : Reloid) : Reloid :=
{
  carrier := SETOID_product X Y;
  rel := relate_prod' rel rel;
}.
Proof.
  intros [f1 Hf1] [f2 Hf2] [Hf1' Hf2'] [g1 Hg1] [g2 Hg2] [Hg1' Hg2']; cbn.
  now rewrite Hf1', Hf2', Hg1', Hg2'.
Defined.

#[refine]
#[export]
Instance Reloid_outl (X Y : Reloid) : ReloidHom (Reloid_product X Y) X :=
{
  func := SETOID_outl X Y
}.
Proof. now intros [] []; cbn. Defined.

#[refine]
#[export]
Instance Reloid_outr (X Y : Reloid) : ReloidHom (Reloid_product X Y) Y :=
{
  func := SETOID_outr X Y
}.
Proof. now intros [] []; cbn. Defined.

#[refine]
#[export]
Instance Reloid_fpair (X Y A : Reloid)
  (f : ReloidHom A X) (g : ReloidHom A Y)
  : ReloidHom A (Reloid_product X Y) :=
{
  func := SETOID_fpair f g
}.
Proof.
  now intros a1 a2 ra; cbn; split; apply pres_rel.
Defined.

#[refine]
#[export]
Instance HasProducts_Reloid : HasProducts ReloidCat :=
{
  product := Reloid_product;
  outl := Reloid_outl;
  outr := Reloid_outr;
  fpair := Reloid_fpair;
}.
Proof.
  now repeat split; cbn in *.
Defined.

#[refine]
#[export]
Instance Reloid_coproduct (X Y : Reloid) : Reloid :=
{
  carrier := SETOID_coproduct X Y;
  rel := relate_sum rel rel;
}.
Proof.
  now proper; destruct x, x0, y, y0; cbn in *; rewrite ?H, ?H0 in *.
Defined.

#[refine]
#[export]
Instance Reloid_finl (X Y : Reloid) : ReloidHom X (Reloid_coproduct X Y) :=
{
  func := SETOID_finl X Y;
}.
Proof. easy. Defined.

#[refine]
#[export]
Instance Reloid_finr (X Y : Reloid) : ReloidHom Y (Reloid_coproduct X Y) :=
{
  func := SETOID_finr X Y;
}.
Proof. easy. Defined.

#[refine]
#[export]
Instance Reloid_copair
  (X Y A : Reloid) (f : ReloidHom X A) (g : ReloidHom Y A)
  : ReloidHom (Reloid_coproduct X Y) A :=
{
  func := SETOID_copair f g
}.
Proof.
  now proper; destruct x, y; try apply pres_rel.
Defined.

#[refine]
#[export]
Instance HasCoproducts_Reloid : HasCoproducts ReloidCat :=
{
  coproduct := Reloid_coproduct;
  finl := Reloid_finl;
  finr := Reloid_finr;
  copair := Reloid_copair;
}.
Proof.
  split; cbn.
  - easy.
  - easy.
  - now intros P' h1 h2 HA HB [a | b]; cbn.
Defined.