Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.omega.Omega.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimunLogic.Syntax.

Local Open Scope logic_base.
Local Open Scope syntax.

Inductive expr {Var: Type}: Type :=
  | impp : expr -> expr -> expr
  | varp : Var -> expr.

Arguments expr Var: clear implicits.

Instance L (Var: Type): Language :=
  Build_Language (expr Var).

Instance minL (Var: Type): MinimunLanguage (L Var) :=
  Build_MinimunLanguage (L Var) impp.

Definition rank {Var: Type}: expr Var -> nat :=
  fix rank (x: expr Var): nat :=
    match x with
    | impp y z => 1 + rank y + rank z
    | varp p => 0
    end.

Definition formula_countable: forall Var, Countable Var -> Countable (expr Var).
  intros.
  assert (forall n, Countable (sig (fun x: expr Var => rank x <= n))).
  + induction n.
    - apply (@bijection_Countable _ Var); [| solve_Countable].
      apply bijection_sym.
      apply (FBuild_bijection _ _ (fun p => exist (fun x: expr Var => rank x <= 0) (varp p) (le_n 0))).
      * hnf; intros.
        inversion H; auto.
      * hnf; intros.
        destruct b as [[] HH]; try solve [inversion HH].
        exists v.
        eauto; f_equal; apply proof_irrelevance.
    - set (s := sig (fun x: expr Var => rank x <= n)).
      apply (@injection_Countable _ (s * s + Var)%type); [| solve_Countable].

      apply (Build_injection _ _ (fun x y =>
        match y with
        | inl (exist _ y _, exist _ z _) => proj1_sig x = impp y z
        | inr p => proj1_sig x = varp p
        end)).
      * hnf; intros.
        destruct a as [[y z | p] ?H].
        (* 1 *) simpl in H. assert (rank y <= n) by omega. assert (rank z <= n) by omega.
                exists (inl (exist _ y H0, exist _ z H1)); auto.
        (* 2 *) exists (inr p); auto.
      * hnf; intros.
        destruct a as [[y z | p] ?H];
        destruct b1 as [[[y1 ?H] [z1 ?H]] | p1]; try solve [inversion H];
        destruct b2 as [[[y2 ?H] [z2 ?H]] | p2]; try solve [inversion H0].
        (* 1 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 2 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
      * hnf; intros.
        destruct b as [[[y ?H] [z ?H]] | p];
        destruct a1 as [[y1 z1 | p1] ?H]; try solve [inversion H];
        destruct a2 as [[y2 z2 | p2] ?H]; try solve [inversion H0].
        (* 1 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 2 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
  + apply (@injection_Countable _ (sigT (fun n => sig (fun x: expr Var => rank x <= n)))); [| solve_Countable; auto].
    apply (FBuild_injection _ _ (fun x0 => existT (fun n => sig (fun x => rank x <= n)) (rank x0) (exist (fun x => rank x <= rank x0) x0 (le_n (rank x0))))).
    hnf; intros.
    simpl in H.
    inversion H; auto.
Qed.


(** Definition of Finite Bags using listish representation. *)
Require Import HoTT HitTactics.
Require Export set_names.

Lemma ap_f_eq_l
      {A B : Type}
      (f g : A -> B)
      (e : f == g)
      {a b : A}
      (p : a = b)
  : ap f p = e a @ ap g p @ (e b)^.
Proof.
  induction p ; simpl.
  refine (_ @ ap (fun q => q @ _) (concat_p1 _)^).
  apply (concat_pV _)^.
Defined.

Lemma ap_f_eq_r
      {A B : Type}
      (f g : A -> B)
      (e : f == g)
      {a b : A}
      (p : a = b)
  : (e a)^ @ ap f p @ e b = ap g p.
Proof.
  rewrite (ap_f_eq_l f g e). hott_simpl.
Defined.

Definition concat_Y
           {A : Type}
           {Y : A -> Type}
           {a b c : A}
           (p1 : a = b)
           (p2 : b = c)
           {x : Y a} {y : Y b} {z : Y c}
           (q1 : p1 # x = y)
           (q2 : p2 # y = z)
  : (p1 @ p2) # x = z.
Proof.
  refine (transport_pp Y p1 p2 x @ _).
  refine (ap (transport Y p2) q1 @ q2).
Defined.

Definition inverse_Y
           {A : Type}
           {Y : A -> Type}
           {a b : A}
           (p : a = b)
           {x : Y a} {y : Y b}
           (q : p # x = y)
  : p^ # y = x.
Proof.
  refine (ap (transport Y p^) q^ @ transport_Vp _ _ _).
Defined.

Lemma transport_const_pp
      {A B : Type}
      {a b c : A}
      (p1 : a = b)
      (p2 : b = c)
      (x : B)
  : transport_const (p1 @ p2) x
    =
    (transport_pp (fun _ : A => B) p1 p2 x)
      @ (transport_const p2 (transport (fun _ : A => B) p1 x))
      @ transport_const p1 x.
Proof.
  induction p1, p2.
  reflexivity.
Defined.

Lemma transport_const_V
      {A B : Type}
      {a b : A}
      (p : a = b)
      (x : B)
  : transport_const p^ x
    =
    (ap (transport _ p^) (transport_const p x)^)
      @ transport_Vp _ p x.
Proof.
  induction p ; reflexivity.
Defined.

Module Export FBagL.
  Section FBagL.
    Private Inductive FBagL (A : Type) : Type :=
    | Nil : FBagL A
    | Cns : A ->  FBagL A -> FBagL A.

    Global Instance fset_empty : forall A,hasEmpty (FBagL A) := Nil.

    Arguments Nil {_}.
    Arguments Cns {_} _ _.

    Global Instance fset_singleton :
      forall A, hasSingleton (FBagL A) A := (fun A x => Cns x Nil).

    Variable A : Type.

    Infix " ;;" := Cns (at level 8, right associativity).

    Axiom comm : forall (a b : A) (x : FBagL A),  a ;; b ;; x = b ;; a ;; x.

    Axiom comm_refl : forall (a b : A) (x : FBagL A),
        (comm a b x) @ (comm b a x) = idpath.
  End FBagL.

  Arguments Cns {_} _ _.
  Arguments comm {_} _ _.
  Arguments comm_refl {_} _ _.
  Infix " ;;" := Cns (at level 8, right associativity).

  Section FBagL_induction.
    Variable (A : Type)
             (P : FBagL A -> Type)
             (eP : P ∅)
             (cnsP : forall (a:A) (x: FBagL A), P x -> P (a ;; x))
             (commP : forall (a b: A) (x: FBagL A) (px: P x),
		 comm a b x # cnsP a (b ;; x) (cnsP b x px) =
		 cnsP b (a ;; x) (cnsP a x px)).
    Variable (comm_reflP :
                forall (a b : A) (x : FBagL A) (px : P x),
                  transport2 P (comm_refl a b x) (cnsP a b ;; x (cnsP b x px))
                  =
                  concat_Y (comm a b x)
                           (comm b a x)
                           (commP a b x px)
                           (commP b a x px)).

    (* Induction principle *)
    Fixpoint FBagL_ind
             (x : FBagL A)
             {struct x}
      : P x
      := (match x return _ -> _ -> P x with
          | Nil => fun _ _ => eP
          | a ;; y => fun _ _ => cnsP a y (FBagL_ind y)
          end) commP comm_reflP.

    Axiom FSetC_ind_beta_comm : forall (a b: A) (x : FBagL A),
        apD FBagL_ind (comm a b x) = commP a b x (FBagL_ind x).

    Lemma coh : forall (a b: A) (x: FBagL A),
        (apD FBagL_ind (comm a b x @ comm b a x)) =
        (let abxP := cnsP a b ;; x (cnsP b x (FBagL_ind x)) in
         let baxP := cnsP b a ;; x (cnsP a x (FBagL_ind x)) in
         let step1 := transport_pp P (comm a b x) (comm b a x) abxP in
         let step2 :=
             ap (transport P (comm b a x))
                (commP a b x (FBagL_ind x)) in
         let step3 := commP b a x (FBagL_ind x) in
         (step1 @ step2) @ step3).
    Proof.
      intros.
      simpl. rewrite <- FSetC_ind_beta_comm.
      simple refine ((apD_pp _ _ _) @ _).
      cbn. rewrite <- FSetC_ind_beta_comm.
      reflexivity.
    Defined.

    Lemma coh' : forall (a b: A) (x: FBagL A),
        transport2 P (comm_refl a b x)
                   (cnsP a b ;; x (cnsP b x (FBagL_ind x))) =
        transport2 P (comm_refl a b x)
                   (FBagL_ind a ;; b ;; x) @ apD FBagL_ind 1.
    Proof.
      intros.  hott_simpl.
    Defined.

(*    Axiom FSetC_ind_beta_comm_refl : forall (a b: A) (x : FBagL A),
        (apD02 FBagL_ind (comm_refl a b x)) =
        (coh a b x @ comm_reflP a b x (FBagL_ind x)) @ coh' a b x.
*)

  End FBagL_induction.

  Section FBagL_recursion.
    Variable (A : Type)
             (P : Type)
             (nilP : P)
             (cnsP : A -> P -> P)
             (commP : forall (a b: A) (x : P), cnsP a (cnsP b x) = cnsP b (cnsP a x))
             (comm_reflP:  forall (a b : A) (x: P), commP a b x @ commP b a x = idpath).

    (* Recursion princople *)
    Definition FBagL_rec : FBagL A -> P.
    Proof.
      simple refine (FBagL_ind A _ _ _ _ _).
      - apply nilP.
      - apply (fun a _ px => cnsP a px).
      - intros.
        refine ((transport_const _ _) @ commP _ _ _).
      - intros. simpl.
        apply (cancelR _ _ (transport_const 1 (cnsP a (cnsP b px)))).
        refine ((transport2_const (comm_refl a b x) (cnsP a (cnsP b px)))^ @ _).
        refine (transport_const_pp _ _ _ @ _).
        refine (_ @ (concat_p1 _)^).
        unfold concat_Y.
        refine (concat_pp_p _ _ _ @ ap _ _).
        rewrite (ap_f_eq_l _ _ (fun z => transport_const _ _ )).
        hott_simpl.
        rewrite !concat_pp_p.
        rewrite comm_reflP.
        refine (ap _ (concat_p1 _)^).
    Defined.
  End FBagL_recursion.

End FBagL.

Section Membership.
Context `{Univalence}.

(* TODO: Dan: PR this to the HoTT? *)
Lemma equiv_sum_symm_comm A B :
  (equiv_sum_symm A B = (equiv_sum_symm B A)^-1)%equiv.
Proof. by apply path_equiv. Defined.

Variable A : Type.

Definition member : A -> FBagL A -> Type.
  intros a.
  simple refine (FBagL_rec _ _ _ _ _ _ ).
  - apply Empty.
  - intros hd tl. apply (merely (hd = a) + tl).
  - intros x y tl. simpl.
    refine ((path_universe (equiv_sum_assoc (Trunc -1 (x = a)) _ _))^ @ _).
    refine (ap (fun z => z + tl) (path_universe (equiv_sum_symm _ _)) @ _).
    refine (path_universe (equiv_sum_assoc (Trunc -1 (y = a)) _ _)).
  - intros x y tl. hott_simpl.
    do 2 rewrite concat_pp_p.
    rewrite (concat_p_pp (ap (fun z : Type => z + tl) _) ).
    rewrite <- (ap_pp (fun z : Type => z + tl)).
    rewrite equiv_sum_symm_comm.
    rewrite path_universe_V.
    hott_simpl.
Defined.

End Membership.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW
  Require Import utils.

Set Implicit Arguments.

Section subcode.

  Variable (X : Type).

  Definition code := (nat * list X)%type.

  Implicit Type P : code.

  Definition code_start P := fst P.
  Definition code_end P := fst P + length (snd P).
  Definition code_length P := length (snd P).

  Definition in_code i P := code_start P <= i < code_end P.
  Definition out_code i P := i < code_start P \/ code_end P <= i.

  Fact in_out_code i P : in_code i P -> out_code i P -> False.
  Proof. unfold in_code, out_code; lia. Qed.

  Definition subcode P Q :=
    match P, Q with (i,li), (n,code) => exists l r, code = l ++ li ++ r /\ i = n+length l end.

  Arguments code_start P /.
  Arguments code_end P /.
  Arguments code_length P /.
  Arguments in_code i P /.
  Arguments out_code i P /.
  Arguments subcode P Q /.

  Fact in_out_code_dec i P : { in_code i P } + { out_code i P }.
  Proof. destruct P as (n,c); simpl; apply interval_dec. Qed.

  Infix "<sc" := subcode (at level 70, no associativity).

  Fact subcode_cons_inj i ρ δ P : (i,ρ::nil) <sc P -> (i,δ::nil) <sc P -> ρ = δ.
  Proof.
    destruct P as (j, P).
    intros (l1 & r1 & H1 & H2) (l2 & r2 & H3 & H4).
    rewrite H1 in H3.
    apply list_app_inj, proj2 in H3; try lia.
    inversion H3; trivial.
  Qed.

  Fact subcode_length P Q : P <sc Q -> code_start Q <= code_start P /\ code_end P <= code_end Q.
  Proof.
   destruct P as (iP,cP); destruct Q as (iQ,cQ); simpl.
   intros (l & r & H1 & H2).
   apply f_equal with (f := @length _) in H1.
   revert H1; rew length; split; lia.
  Qed.

  Fact subcode_length' P Q : P <sc Q -> length (snd P) <= length (snd Q).
  Proof.
    revert P Q; intros [] [] (? & ? & ? & ?); simpl; subst; rew length; lia.
  Qed.

  Fact subcode_length_le : forall P Q, P <sc Q -> fst Q <= fst P
                                               /\ fst P + length (snd P) <= fst Q + length (snd Q).
  Proof.
    intros (iP,cP) (iQ,cQ) (l & r & ? & ?); subst; simpl; rew length; lia.
  Qed.

  Fact subcode_start_in_code : forall P Q, 0 < code_length P -> P <sc Q -> in_code (code_start P) Q.
  Proof.
    intros (iP,cP) (iQ,cQ) H (l & r & H1 & H2); simpl in *; subst; revert H; rew length; intro; lia.
  Qed.

  Fact subcode_refl P : P <sc P.
  Proof.
    destruct P; exists nil, nil; split; simpl.
    rewrite <- app_nil_end; auto.
    lia.
  Qed.

  Fact subcode_trans P Q R : P <sc Q -> Q <sc R -> P <sc R.
  Proof.
    revert P Q R; intros (iP,cP) (iQ,cQ) (iR,cR).
    intros (ll1 & rr1 & H1 & H2) (ll2 & rr2 & H3 & H4); subst.
    exists (ll2++ll1), (rr1++rr2); split.
    solve list eq.
    rew length; lia.
  Qed.

  Fact subcode_in_code P Q i : P <sc Q -> in_code i P -> in_code i Q.
  Proof.
    revert P Q; intros (iP,cP) (iQ,cQ) (l & r & H1 & H2); simpl.
    subst; rew length; lia.
  Qed.

  Fact subcode_out_code P Q i : P <sc Q -> out_code i Q -> out_code i P.
  Proof.
    revert P Q; intros (iP,cP) (iQ,cQ) (l & r & H1 & H2); simpl.
    subst; rew length; lia.
  Qed.

  Fact subcode_left n m l r : n = m -> (n,l) <sc (m,l++r).
  Proof. exists nil, r; simpl; split; auto; lia. Qed.

  Fact subcode_right n m l r : n = m+length l -> (n,r) <sc (m,l++r).
  Proof.
    exists l, nil; split; auto.
    rewrite <- app_nil_end; auto.
  Qed.

  Fact subcode_app_end P n l r : P <sc (n,l) -> P <sc (n,l++r).
  Proof.
    intros; apply subcode_trans with (1 := H).
    exists nil, r; auto.
  Qed.

  Fact subcode_cons P n x l : P <sc (1+n,l) -> P <sc (n,x::l).
  Proof.
    intros; apply subcode_trans with (1 := H).
    exists (x::nil), nil; split.
    solve list eq.
    rew length; lia.
  Qed.

  Fact in_code_subcode i P : in_code i P -> exists a, (i,a::nil) <sc P.
  Proof.
    destruct P as (iP,cP); simpl; intros H.
    destruct (list_split_length cP) with (k := i-iP) as (l & [ | a r ] & H1 & H2).
    + lia.
    + exfalso; subst; solve list eq in H; lia.
    + exists a, l, r; split; auto; lia.
  Qed.

  Fact subcode_app_invert_right j Q1 Q2 i I :
        (i,I::nil) <sc (j,Q1++Q2) -> (i,I::nil) <sc (j,Q1)
                                  \/ (i,I::nil) <sc (length Q1+j,Q2).
  Proof.
    intros (l & r & H1 & H2); simpl in *.
    apply list_app_cons_eq_inv in H1.
    destruct H1 as [ (m & G1 & G2) | (m & G1 & G2) ]; subst.
    + right; exists m, r; rew length; split; auto; lia.
    + left; exists l, m; rew length; split; auto; lia.
  Qed.

  Fact subcode_cons_invert_right j J Q i I :
        (i,I::nil) <sc (j,J::Q) -> i = j /\ I = J
                                \/ (i,I::nil) <sc (S j,Q).
  Proof.
    intros ([ | K l ] & r & H1 & H2); simpl in *.
    + inversion H1; left; split; auto; lia.
    + right; inversion H1; exists l, r; split; auto; lia.
  Qed.

  Variable Q : code.

  Fact subcode_app_inv i j a l r : j = i+length l -> (i,l++a++r) <sc Q -> (j,a) <sc Q.
  Proof.
    intro; apply subcode_trans.
    exists l, r; auto.
  Qed.

  Fact subcode_cons_inv i j a r : j = i -> (i,a++r) <sc Q -> (j,a) <sc Q.
  Proof.
    intro; apply subcode_app_inv with (l := nil); simpl; lia.
  Qed.

  Fact subcode_snoc_inv i j a l : j = i+length l -> (i,l++a) <sc Q -> (j,a) <sc Q.
  Proof.
    intros H.
    apply subcode_trans.
    exists l, nil; split; auto.
    solve list eq.
  Qed.

  Fact subcode_cons_invert_left i I l : (i,I::l) <sc Q -> (i,I::nil) <sc Q /\ (S i,l) <sc Q.
  Proof.
    intros H1; split.
    + revert H1; apply subcode_cons_inv with (a := _::nil); auto.
    + revert H1; apply subcode_snoc_inv with (l := _::nil); simpl; lia.
  Qed.

End subcode.

Arguments code_start {X} P /.
Arguments code_end {X} P /.
Arguments in_code {X} i P /.
Arguments out_code {X} i P /.
Arguments subcode {X} P Q /.

Infix "<sc" := subcode (at level 70, no associativity).

(* Solve many subcode goals looking for a solution into hyps *)

Ltac subcode_tac :=
       unfold fst, snd;
       try match goal with | H: subcode (_,?l) ?c |- subcode (_,?i) ?c
            => (match i with ?j::nil => match type of H with context[j] => apply subcode_trans with (2 := H) end end ||
                match type of H with context[i] => apply subcode_trans with (2 := H) end)
       end;
       try match goal with
         | |- subcode (_,?i) (_,?c) => focus_goal i c
       end;
       match goal with
         | |- subcode (_,?i)      (_,?l++?i)      => exists l, nil
         | |- subcode (_,?i::nil) (_,?l++?i::?r)  => exists l, r
         | |- subcode (_,?i)      (_,?l++?i++?r)  => exists l, r
       end; try rewrite <- !app_nil_end;
       split; auto; rew length; try lia.

(* Add it to auto so that fam sss * will try it to solve the subcode goal it generates *)

#[export] Hint Extern 4 (subcode _ _) => subcode_tac : core.


(* Bartłomiej Królikowski *)

Load "myBinTree". (* path to myBintree.v*)

Fixpoint insert_t (A : Type) (t : nat) (ord : A -> A -> bool) (a : A) (T : BinTree A) :
  BinTree A * nat :=
match T with
  | Node _ a' Tl Tr =>
  if ord a a'
    then let Tt := insert_t A (S t) ord a Tl
         in  (Node A a' (fst Tt) Tr, snd Tt)
    else let Tt := insert_t A (S t) ord a Tr
         in  (Node A a' Tl (fst Tt), snd Tt)
  | Empty _ => (Node A a (Empty A) (Empty A), t)
end.

Definition insert' (A : Type) : (A -> A -> bool) -> A -> BinTree A -> BinTree A * nat :=
  insert_t A 1.

Fixpoint find_t (A : Type) (t : nat) (ord : A -> A -> bool) (a : A) (T : BinTree A) :
  bool * nat:=
match T with
  | Node _ a' Tl Tr =>
  if ord a a'
    then if ord a' a
           then (true, t)
           else find_t A (S t) ord a Tl
    else find_t A (S t) ord a Tr
  | Empty _ => (false, t)
end.

Definition find' (A : Type) : (A -> A -> bool) -> A -> BinTree A -> bool * nat :=
  find_t A 1.

Fixpoint min_t (A : Type) (t : nat) (T : BinTree A) : Maybe A * nat :=
match T with
  | Node _ a (Empty _) _ => (Just A a, (S t))
  | Node _ _ Tl _ => min_t A (S t) Tl
  | Empty _ => (Nothing A, t)
end.

Definition min' (A : Type) : BinTree A -> Maybe A * nat := min_t A 1.

Fixpoint max_t (A : Type) (t : nat) (T : BinTree A) : Maybe A * nat :=
match T with
  | Node _ a _ (Empty _) => (Just A a, (S t))
  | Node _ _ _ Tr => max_t A (S t) Tr
  | Empty _ => (Nothing A, t)
end.

Definition max' (A : Type) : BinTree A -> Maybe A * nat := max_t A 1.

Fixpoint removeMax_t (A : Type) (t : nat) (T : BinTree A) : BinTree A * nat :=
match T with
  | Node _ _ Tl (Empty _) => (Tl, (S t))
  | Node _ a Tl Tr => let Tt := removeMax_t A (S t) Tr
                      in  (Node A a Tl (fst Tt), snd Tt)
  | Empty _ => (Empty A, t)
end.

Definition removeMax' (A : Type) : BinTree A -> BinTree A * nat :=
  removeMax_t A 1.

Definition root' (A : Type) (T : BinTree A) : Maybe A * nat :=
match T with
  | Node _ a _ _ => (Just A a, 1)
  | Empty _ => (Nothing A, 1)
end.

Definition remove' (A : Type) (T : BinTree A) : BinTree A * nat :=
match T with
  | Node _ _ Tl Tr =>
  match max' A Tl with
    | (Just _ a, t) => let Tt := removeMax' A Tl
                     in  (Node A a (fst Tt) Tr, 1 + t + snd Tt)
    | (Nothing _, t) => (Tr, 1 + t)
  end
  | Empty _ => (Empty A, 1)
end.

Fixpoint delete_t (A : Type) (t : nat) (ord : A -> A -> bool) (a : A) (T : BinTree A) :
  BinTree A * nat :=
match T with
  | Node _ a' Tl Tr =>
  if ord a a'
    then if ord a' a
           then let Tt := remove' A T
                in  (fst Tt, 1 + snd Tt)
           else let Tt := delete_t A (S t) ord a Tl
                in  (Node A a' (fst Tt) Tr, 1 + snd Tt)
    else let Tt := delete_t A (S t) ord a Tr
         in  (Node A a' Tl (fst Tt), snd Tt)
  | Empty _ => (Empty A, t)
end.

Definition delete' (A : Type) : (A -> A -> bool) -> A -> BinTree A -> BinTree A * nat :=
  delete_t A 1.

Fixpoint size' (A : Type) (T : BinTree A) : nat * nat :=
match T with
  | Node _ _ Tl Tr => let Stl := size' A Tl
                      in  let Str := size' A Tr
                          in  (1 + fst Stl + fst Str, 1 + snd Stl + snd Str)
  | Empty _ => (0, 1)
end.

Fixpoint height (A : Type) (T : BinTree A) : nat :=
match T with
  | Node _ _ Tl Tr => 1 + Nat.max (height A Tl) (height A Tr)
  | Empty _ => 0
end.

Fact insert_t_equiv :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A) (t : nat),
    fst (insert_t A t ord a T) = insert A ord a T.
Proof.
  induction T; intros; cbn.
  - destruct (ord a a0); cbn; f_equal; trivial.
  - trivial.
Qed.

Fact insert'_equiv :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A),
    fst (insert' A ord a T) = insert A ord a T.
Proof.
  unfold insert'. intros. apply insert_t_equiv.
Qed.

Fact find_t_equiv :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A) (t : nat),
    fst (find_t A t ord a T) = find A ord a T.
Proof.
  induction T; intros; cbn.
  - destruct (ord a a0).
   + destruct (ord a0 a).
     * trivial.
     * apply IHT1.
   + apply IHT2.
  - trivial.
Qed.

Fact find'_equiv :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A),
    fst (find' A ord a T) = find A ord a T.
Proof.
  unfold find'. intros. apply find_t_equiv.
Qed.

Fact min_t_equiv :
  forall (A : Type) (T : BinTree A) (t : nat),
    fst (min_t A t T) = min A T.
Proof.
  induction T; intros; cbn.
  - destruct T1.
    + apply IHT1.
    + trivial.
  - trivial.
Qed.

Fact min'_equiv :
  forall (A : Type) (T : BinTree A),
    fst (min' A T) = min A T.
Proof.
  unfold min'. intros. apply min_t_equiv.
Qed.

Fact max_t_equiv :
  forall (A : Type) (T : BinTree A) (t : nat),
    fst (max_t A t T) = max A T.
Proof.
  induction T; intros; cbn.
  - destruct T2.
    + apply IHT2.
    + trivial.
  - trivial.
Qed.

Fact max'_equiv :
  forall (A : Type) (T : BinTree A),
    fst (max' A T) = max A T.
Proof.
  unfold max'. intros. apply max_t_equiv.
Qed.

Fact removeMax_t_equiv :
  forall (A : Type) (T : BinTree A) (t : nat),
    fst (removeMax_t A t T) = removeMax A T.
Proof.
  induction T; intros; cbn.
  - destruct T2.
    + unfold fst. f_equal. apply IHT2.
    + trivial.
  - trivial.
Qed.

Fact removeMax'_equiv :
  forall (A : Type) (T : BinTree A),
    fst (removeMax' A T) = removeMax A T.
Proof.
  unfold removeMax'. intros. apply removeMax_t_equiv.
Qed.

Fact root'_equiv :
  forall (A : Type) (T : BinTree A),
    fst (root' A T) = root A T.
Proof.
  destruct T; trivial.
Qed.

Fact remove'_equiv :
  forall (A : Type) (T : BinTree A),
    fst (remove' A T) = remove A T.
Proof.
  destruct T; cbn.
  - assert (forall (A B : Type) (p : A * B), p = (fst p, snd p)).
    + destruct p. trivial.
    + rewrite H with (Maybe A) nat (max' A T1). rewrite max'_equiv. destruct (max A T1).
      * cbn. f_equal. apply removeMax'_equiv.
      * trivial.
  - trivial.
Qed.

Fact delete_t_equiv :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A) (t : nat),
    fst (delete_t A t ord a T) = delete A ord a T.
Proof.
  induction T; intros; cbn.
  - destruct (ord a a0); cbn.
    + destruct (ord a0 a); cbn.
      * assert (forall (A B : Type) (p : A * B), p = (fst p, snd p)).
        -- destruct p. trivial.
        -- rewrite H with (Maybe A) nat (max' A T1). rewrite max'_equiv. destruct (max A T1).
          ++ cbn. f_equal. apply removeMax'_equiv.
          ++ trivial.
      * f_equal. apply IHT1.
    + f_equal. apply IHT2.
  - trivial.
Qed.

Fact delete'_equiv :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A),
    fst (delete' A ord a T) = delete A ord a T.
Proof.
  unfold delete'. intros. apply delete_t_equiv.
Qed.

Fact size'_equiv :
  forall (A : Type) (T : BinTree A),
    fst (size' A T) = size A T.
Proof.
  induction T; cbn.
  - f_equal. f_equal; assumption.
  - trivial.
Qed.

Lemma insert_t_complex :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A) (t : nat),
    snd (insert_t A t ord a T) <= t + height A T.
Proof.
  induction T; intros; cbn.
  - destruct (ord a  a0); cbn.
    + apply Nat.le_trans with (S t + height A T1).
      * apply IHT1.
      * rewrite Nat.add_succ_r. rewrite <- Nat.add_succ_l. apply Nat.add_le_mono_l.
        apply Nat.le_max_l.
    + apply Nat.le_trans with (S t + height A T2).
      * apply IHT2.
      * rewrite Nat.add_succ_r. rewrite <- Nat.add_succ_l. apply Nat.add_le_mono_l.
        apply Nat.le_max_r.
  - rewrite Nat.add_0_r. apply Nat.le_refl.
Qed.

Theorem insert'_complex :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A),
    snd (insert' A ord a T) <= 1 + height A T.
Proof.
  unfold insert'. intros. apply insert_t_complex.
Qed.

Lemma find_t_complex :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A) (t : nat),
    snd (find_t A t ord a T) <= t + height A T.
Proof.
  induction T; intros; cbn.
  - destruct (ord a a0).
   + destruct (ord a0 a).
     * cbn. apply Nat.le_add_r.
     * apply Nat.le_trans with (S t + height A T1).
       -- apply IHT1.
       -- rewrite Nat.add_succ_r. rewrite <- Nat.add_succ_l. apply Nat.add_le_mono_l.
          apply Nat.le_max_l.
   + apply Nat.le_trans with (S t + height A T2).
     * apply IHT2.
     * rewrite Nat.add_succ_r. rewrite <- Nat.add_succ_l. apply Nat.add_le_mono_l.
       apply Nat.le_max_r.
  - intuition.
Qed.

Theorem find'_complex :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A),
    snd (find' A ord a T) <= 1 + height A T.
Proof.
  unfold find'. intros. apply find_t_complex.
Qed.

Lemma min_t_complex :
  forall (A : Type) (T : BinTree A) (t : nat),
    snd (min_t A t T) <= t + height A T.
Proof.
  induction T; intros; cbn.
  - destruct T1.
    + apply Nat.le_trans with (S t + height A (Node A a0 T1_1 T1_2)).
      * apply IHT1.
      * rewrite Nat.add_succ_r. rewrite <- Nat.add_succ_l. apply Nat.add_le_mono_l.
        apply Nat.le_max_l.
    + cbn. rewrite Nat.add_succ_r. intuition.
  - intuition.
Qed.

Theorem min'_complex :
  forall (A : Type) (T : BinTree A),
    snd (min' A T) <= 1 + height A T.
Proof.
  unfold min'. intros. apply min_t_complex.
Qed.

Lemma max_t_complex :
  forall (A : Type) (T : BinTree A) (t : nat),
    snd (max_t A t T) <= t + height A T.
Proof.
  induction T; intros; cbn.
  - destruct T2.
    + apply Nat.le_trans with (S t + height A (Node A a0 T2_1 T2_2)).
      * apply IHT2.
      * rewrite Nat.add_succ_r. rewrite <- Nat.add_succ_l. apply Nat.add_le_mono_l.
        apply Nat.le_max_r.
    + cbn. rewrite Nat.add_succ_r. intuition.
  - intuition.
Qed.

Theorem max'_complex :
  forall (A : Type) (T : BinTree A),
    snd (max' A T) <= 1 + height A T.
Proof.
  unfold max'. intros. apply max_t_complex.
Qed.

Lemma removeMax_t_complex :
  forall (A : Type) (T : BinTree A) (t : nat),
    snd (removeMax_t A t T) <= t + height A T.
Proof.
  induction T; intros; cbn.
  - destruct T2.
    + apply Nat.le_trans with (S t + height A (Node A a0 T2_1 T2_2)).
      * unfold snd. fold (snd (removeMax_t A (S t) (Node A a0 T2_1 T2_2))). apply IHT2.
      * rewrite Nat.add_succ_r. rewrite <- Nat.add_succ_l. apply Nat.add_le_mono_l.
        apply Nat.le_max_r.
    + cbn. rewrite Nat.add_succ_r. intuition.
  - intuition.
Qed.

Theorem removeMax'_complex :
  forall (A : Type) (T : BinTree A),
    snd (removeMax' A T) <= 1 + height A T.
Proof.
  unfold removeMax'. intros. apply removeMax_t_complex.
Qed.

Theorem root'_complex :
  forall (A : Type) (T : BinTree A),
    snd (root' A T) = 1.
Proof.
  destruct T; trivial.
Qed.

Theorem remove'_complex :
  forall (A : Type) (T : BinTree A),
    snd (remove' A T) <= 1 + 2 * height A T.
Proof.
  destruct T; cbn.
  - assert (forall (A B : Type) (p : A * B), p = (fst p, snd p)).
    + destruct p. trivial.
    + rewrite H with (Maybe A) nat (max' A T1). destruct (fst (max' A T1)).
      * cbn. apply le_n_S. rewrite <-Nat.add_succ_l. apply Nat.add_le_mono.
        -- apply Nat.le_trans with (1 + height A T1).
          ++ apply max'_complex.
          ++ cbn. apply le_n_S, Nat.le_max_l.
        -- apply Nat.le_trans with (1 + height A T1).
          ++ apply removeMax'_complex.
          ++ cbn. apply le_n_S. rewrite Nat.add_0_r. apply Nat.le_max_l.
      * cbn. apply le_n_S. rewrite <-Nat.add_succ_l. apply le_plus_trans.
        apply le_trans with (1 + height A T1).
        -- apply max'_complex.
        -- apply le_n_S, Nat.le_max_l.
  - trivial.
Qed.

Lemma delete_t_complex :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A) (t : nat),
    snd (delete_t A t ord a T) <= t + 2 * (1 + height A T).
Proof.
  induction T; intros; cbn.
  - destruct (ord a a0); cbn.
    + destruct (ord a0 a); cbn.
      * rewrite Nat.add_comm. apply le_plus_trans.
        assert (forall (A B : Type) (p : A * B), p = (fst p, snd p)).
        -- destruct p. trivial.
        -- rewrite H with (Maybe A) nat (max' A T1). destruct (fst (max' A T1)).
          ++ cbn. apply le_n_S, le_n_S. rewrite Nat.add_succ_r, <-Nat.add_succ_l.
             apply Nat.add_le_mono.
            ** apply Nat.le_trans with (1 + height A T1).
              --- apply max'_complex.
              --- cbn. apply le_n_S, Nat.le_max_l.
            ** apply Nat.le_trans with (1 + height A T1).
              --- apply removeMax'_complex.
              --- cbn. apply le_n_S. rewrite Nat.add_0_r. apply Nat.le_max_l.
          ++ cbn. apply le_n_S, le_n_S. rewrite Nat.add_succ_r, <-Nat.add_succ_l.
             apply le_plus_trans, Nat.le_trans with (1 + height A T1).
             ** apply max'_complex.
             ** apply le_n_S, Nat.le_max_l.
      * rewrite Nat.add_succ_r, Nat.add_succ_r. apply le_n_S.
        apply Nat.le_trans with (S t + 2 * (1 + height A T1)).
        -- apply IHT1.
        -- cbn. apply le_n_S, Nat.add_le_mono_l.
           rewrite Nat.add_succ_r, Nat.add_succ_r, Nat.add_succ_r. apply le_n_S, le_n_S.
           apply Nat.add_le_mono.
          ++ apply Nat.le_max_l.
          ++ apply Nat.add_le_mono_r, Nat.le_max_l.
    + apply Nat.le_trans with (S t + 2 * (1 + height A T2)).
      * apply IHT2.
      * cbn. rewrite <-Nat.add_succ_r, <-Nat.add_succ_r.
        apply Nat.add_le_mono_l, le_S, le_n_S, Nat.add_le_mono.
        -- apply Nat.le_max_r.
        -- apply le_n_S, le_n_S, Nat.add_le_mono_r, Nat.le_max_r.
  - intuition.
Qed.

Theorem delete'_complex :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A),
    snd (delete' A ord a T) <= 1 + 2 * (1 + height A T).
Proof.
  unfold delete'. intros. apply delete_t_complex.
Qed.

Fact pow2_positive :
  forall n : nat, 1 <= 2 ^ n.
Proof.
  induction n; cbn.
  - trivial.
  - intuition.
Qed.

Theorem size'_complex :
  forall (A : Type) (T : BinTree A),
    snd (size' A T) <= 2 ^ (1 + height A T) - 1.
Proof.
  induction T; cbn.
  - apply Nat.le_trans with (S (2 ^ (1 + height A T1) + 2 ^ (1 + height A T2) - 2)).
    + apply le_n_S.
      rewrite <-Nat.add_1_l, Nat.sub_add_distr, Nat.add_1_l, <-Nat.add_sub_assoc.
      rewrite Nat.add_sub_swap. apply Nat.add_le_mono; assumption.
      1-2: apply pow2_positive.
    + rewrite <-Nat.sub_succ_l.
      * cbn. apply Nat.sub_le_mono_r. apply Nat.add_le_mono.
        -- apply Nat.add_le_mono.
          ++ apply Nat.pow_le_mono_r.
            ** intro. inversion H.
            ** apply Nat.le_max_l.
          ++ apply Nat.add_le_mono_r, Nat.pow_le_mono_r.
            ** intro. inversion H.
            ** apply Nat.le_max_l.
        -- rewrite Nat.add_0_r, Nat.add_0_r, Nat.add_0_r. apply Nat.add_le_mono.
          ++ apply Nat.pow_le_mono_r.
            ** intro. inversion H.
            ** apply Nat.le_max_r.
          ++ apply Nat.pow_le_mono_r.
            ** intro. inversion H.
            ** apply Nat.le_max_r.
      * rewrite <-Nat.add_1_l.
        apply Nat.add_le_mono; rewrite Nat.add_1_r; apply pow2_positive.
  - trivial.
Qed.


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

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              Nov 25th 1994                               *)
(*                                                                          *)
(****************************************************************************)
(*                                 groups.v                                 *)
(****************************************************************************)
Require Export Lci.
Require Export misc.

(*****************************************************************************)
Section groups.

Variable S : Set.
Variable G : S -> Prop.
Variable Add : S -> S -> S.
Variable O : S.
Variable Opp : S -> S.
(*****************************************************************************)

(*****************)
Definition is_group :=
  intern S G Add /\
  associativity S Add /\ neutral S G Add O /\ opposite S G Add O Opp.

(**************)
Lemma regular_l :
 is_group ->
 forall y z : S,
 G y -> G z -> forall x : S, G x -> Add x y = Add x z -> y = z.

Proof.
intros.
elim H; intros; elim H5; intros; elim H7; intros; elim H8; intros.
clear H4 H5 H7 H10.
(* use of neutral *)
elim (H11 y H0); intros; elim H5; clear H4 H5.
elim (H11 z H1); intros; elim H5; clear H4 H5 H8 H11.
(* use of opposite *)
elim (H9 x H2); intros; elim H5; intros; elim H8; intros; elim H11.
clear H4 H5 H7 H8 H9 H10 H11.
(* use of associativity *)
elim (H6 (Opp x) x y); elim (H6 (Opp x) x z).
elim H3; reflexivity.
Qed.

(************)
Lemma add_add :
 commutativity S Add ->
 associativity S Add ->
 forall x1 y1 x2 y2 : S,
 Add (Add x1 y1) (Add x2 y2) = Add (Add x1 x2) (Add y1 y2).

Proof.
intros com ass x1 y1 x2 y2.
rewrite (ass (Add x1 y1) x2 y2); elim (ass x1 y1 x2); elim (com x2 y1).
rewrite (ass x1 x2 y1); elim (ass (Add x1 x2) y1 y2); reflexivity.
Qed.

(****************)
Lemma opp_unicity :
 is_group -> forall x y : S, is_opposite S G Add O x y -> y = Opp x.

Proof.
intros.
(* G y *)
elim H0; intros; elim H2; intros.
(* y = 0+y *)
elim H; intros; elim H6; intros; elim H8; intros; elim H9; intros.
elim (H12 y H3); intros; elim H14; clear H H2 H3 H5 H6 H8 H11 H12 H13 H14.
(* 0=(-x)+x *)
elim (H10 x H1); intros; elim H2; intros; elim H5; intros; elim H8.
clear H H1 H2 H5 H6 H8 H10.
(* ((-x)+x)+y=(-x)+(x+y) *)
elim (H7 (Opp x) x y).
(* x+y = 0 *)
elim H4; intros; rewrite H; clear H H0 H1 H4 H7.
(* (-x)+0=(-x) *)
elim H9; intros; elim (H0 (Opp x) H3); intros. exact H1.
Qed.

(************)
Lemma opp_opp : is_group -> forall x : S, G x -> x = Opp (Opp x).

Proof.
intros.
apply (opp_unicity H (Opp x) x).
unfold is_opposite in |- *; split.
elim H; intros; elim H2; intros; elim H4; intros; elim (H6 x H0); intros.
elim H8; trivial.
elim H; intros; elim H2; intros; elim H4; intros; elim (H6 x H0); intros.
elim H8; intros; elim H10; auto.
Qed.

(************)
Lemma opp_add :
 is_group ->
 commutativity S Add ->
 forall x y : S, G x -> G y -> Opp (Add x y) = Add (Opp x) (Opp y).

Proof.
intros; symmetry  in |- *;
 apply (opp_unicity H (Add x y) (Add (Opp x) (Opp y))).
unfold is_opposite in |- *; split.
(* G (x+y) *)
elim H; intros; apply (H3 x y H1 H2).
split.
(* G ((-x)+(-y)) *)
elim H; intros; elim H4; intros; elim H6; intros; clear H4 H5 H6 H7.
elim (H8 x H1); intros; elim H5; intros; clear H4 H5 H7.
elim (H8 y H2); intros; elim H5; intros.
apply (H3 (Opp x) (Opp y) H6 H7).
(* (x+y)+((-x)+(-y)) = 0 & ((-x)+(-y))+(x+y) = 0 *)
elim H; intros; elim H4; intros; clear H3 H4 H6.
rewrite (add_add H0 H5 x y (Opp x) (Opp y)).
rewrite (add_add H0 H5 (Opp x) (Opp y) x y); clear H5.
elim H; intros; elim H4; intros; elim H6; intros.
  (* x+(-x) = 0 (-x)+x = 0 *)
elim (H8 x H1); intros; elim H10; intros; elim H12; intros.
rewrite H13; rewrite H14.
clear H H0 H1 H3 H4 H5 H6 H9 H10 H11 H12 H13 H14.
  (* y+(-y) = 0 (-y)+y = 0 *)
elim (H8 y H2); intros; elim H0; intros; elim H3; intros.
rewrite H4; rewrite H5.
clear H H0 H1 H2 H3 H4 H5 H8.
  (* 0+0 = 0 *)
elim H7; intros; exact (H0 O H).
Qed.

(****************)
Lemma opp_neutral : is_group -> Opp O = O.

Proof.
intros.
elim (opp_unicity H O O).
reflexivity.
unfold is_opposite in |- *.
elim H; intros; elim H1; intros; elim H3; intros; elim H4; intros.
elim (H7 O H6); auto.
Qed.

End groups.
(*****************************************************************************)


Require Export ZArith.
Require Export ZArithRing Extraction.
Require Import Lia.
Open Scope Z_scope.

(* The specification given in the exercise is rather cumbersome, because
  it requires formula that are outside Presburger arithmetic.  We make a
  detour using a more practical specification. *)

Definition sqrt_type2 :=
  fun v s r => (Zpos v) = s*s+r /\ 0 <= r <= 2*s.

Definition sqrt_type1 :=
  fun p s => {r:Z | sqrt_type2 p s r}.

Theorem th_sqrt1 : 1=1*1+0 /\ 0<= 0 <= 2*1.
Proof.
 simpl;auto with zarith.
Qed.

Theorem th_sqrt2 : 2=1*1+1 /\ 0 <= 1 <= 2*1.
Proof.
 simpl; auto with zarith.
Qed.

Theorem th_sqrt3 : 3=1*1+2 /\ 0 <= 2 <= 2*1.
Proof.
 simpl; auto with zarith.
Qed.

Theorem th_sqrt_4_0_le :
   forall p s r,
     Zpos p = s*s+r /\ 0<= r <= 2*s ->
     4*s+1 <= 4*r ->
     Zpos(xO (xO p)) = (2*s+1)*(2*s+1)+(4*r - (4*s+1)) /\
     0<= 4*r-(4*s+1) <= 2*(2*s+1).
Proof.
 intros p s r [Heq Hlt] Hle; rewrite Zpos_xO; rewrite (Zpos_xO p).
 rewrite Heq;  split.
 - ring.
 - split; lia.
Qed.

Theorem th_sqrt_4_0_gt :
   forall p s r,
     Zpos p = s*s+r /\ 0<= r <= 2*s ->
     4*s+1 > 4*r ->
     Zpos(xO (xO p)) = (2*s)*(2*s)+4*r /\
     0<= 4*r <= 2*(2*s).
Proof.
 intros p s r [Heq Hlt] Hle; rewrite Zpos_xO; rewrite (Zpos_xO p).
 rewrite Heq; split.
 -  ring.
 -  split; lia.
Qed.

Theorem th_sqrt_4_2_le :
   forall p s r,
     Zpos p = s*s+r /\ 0<= r <= 2*s ->
     4*s+1 <= 4*r+2 ->
     Zpos(xO (xI p)) = (2*s+1)*(2*s+1)+(4*r+2-(4*s+1)) /\
     0<= (4*r+2)-(4*s+1) <= 2*(2*s+1).
Proof.
 intros p s r [Heq Hlt] Hle; rewrite Zpos_xO; rewrite (Zpos_xI p).
 rewrite Heq; split.
 -  ring.
 -  split; lia.
Qed.

Theorem th_sqrt_4_2_gt :
   forall p s r,
     Zpos p = s*s+r /\ 0<= r <= 2*s ->
     4*s+1 > 4*r+2 ->
     Zpos(xO (xI p)) = (2*s)*(2*s)+(4*r+2) /\
     0<= 4*r+2 <= 2*(2*s).
Proof.
 intros p s r [Heq Hlt] Hle; rewrite Zpos_xO; rewrite (Zpos_xI p).
 rewrite Heq; split.
 -  ring.
 -  split; lia.
Qed.

Theorem th_sqrt_4_1_le :
   forall p s r,
     Zpos p = s*s+r /\ 0<= r <= 2*s ->
     4*s+1 <= 4*r+1 ->
     Zpos(xI (xO p)) = (2*s+1)*(2*s+1)+(4*r+1-(4*s+1)) /\
     0<= (4*r+1)-(4*s+1) <= 2*(2*s+1).
Proof.
 intros p s r [Heq Hlt] Hle; rewrite Zpos_xI; rewrite (Zpos_xO p).
 rewrite Heq; split.
 -  ring.
 -  split; lia.
Qed.

Theorem th_sqrt_4_1_gt :
   forall p s r,
     Zpos p = s*s+r /\ 0<= r <= 2*s ->
     4*s+1 > 4*r+1 ->
     Zpos(xI (xO p)) = (2*s)*(2*s)+(4*r+1) /\
     0<= 4*r+1 <= 2*(2*s).
Proof.
 intros p s r [Heq Hlt] Hle; rewrite Zpos_xI; rewrite (Zpos_xO p).
 rewrite Heq;  split.
 -  ring.
 -  split; lia.
Qed.

Theorem th_sqrt_4_3_le :
   forall p s r,
     Zpos p = s*s+r /\ 0<= r <= 2*s ->
     4*s+1 <= 4*r+3 ->
     Zpos(xI (xI p)) = (2*s+1)*(2*s+1)+(4*r+3-(4*s+1)) /\
     0<= (4*r+3)-(4*s+1) <= 2*(2*s+1).
Proof.
 intros p s r [Heq Hlt] Hle; rewrite Zpos_xI; rewrite (Zpos_xI p).
 rewrite Heq;  split.
 -  ring.
 -  split; lia.
Qed.

Theorem th_sqrt_4_3_gt :
   forall p s r,
     Zpos p = s*s+r /\ 0<= r <= 2*s ->
      4*s+1 > 4*r+3 ->
     Zpos(xI (xI p)) = (2*s)*(2*s)+(4*r+3) /\
     0<= 4*r+3 <= 2*(2*s).
Proof.
 intros p s r [Heq Hlt] Hle; rewrite Zpos_xI; rewrite (Zpos_xI p).
 rewrite Heq;  split.
 -  ring.
 -  split; lia.
Qed.

Fixpoint sqrt_aux (p:positive) :
  {s:Z &{r:Z | Zpos p = s*s+r /\ 0 <= r <= 2*s}} :=
match p return {s:Z & (sqrt_type1 p s)} with
  1%positive => existT (sqrt_type1 1) 1 (exist (sqrt_type2 1 1) 0 th_sqrt1)
| 2%positive => existT (sqrt_type1 2) 1 (exist (sqrt_type2 2 1) 1 th_sqrt2)
| 3%positive => existT (sqrt_type1 3) 1 (exist (sqrt_type2 3 1) 2 th_sqrt3)
| xO (xO p') =>
  match sqrt_aux p' with
    (existT _ s' (exist _ r' h)) =>
    match Z_le_gt_dec  (4*s'+1) (4*r') with
      left h' =>
        (existT  (sqrt_type1 (xO (xO p'))) (2*s'+1)
           (exist  (sqrt_type2 (xO (xO p')) (2*s'+1)) ((4*r')-(4*s'+1))
                (th_sqrt_4_0_le p' s' r' h h')))
    | right h' =>
        (existT (sqrt_type1 (xO (xO p'))) (2*s')
           (exist (sqrt_type2 (xO (xO p')) (2*s')) (4*r')
                (th_sqrt_4_0_gt p' s' r' h h')))
    end
  end
| xO (xI p') =>
  match sqrt_aux p' with
    (existT _ s' (exist _ r' h)) =>
    match Z_le_gt_dec  (4*s'+1) (4*r'+2) with
      left h' =>
        (existT (sqrt_type1 (xO (xI p'))) (2*s'+1)
           (exist (sqrt_type2 (xO (xI p')) (2*s'+1))
              ((4*r'+2)-(4*s'+1)) (th_sqrt_4_2_le p' s' r' h h')))
    | right h' =>
        (existT (sqrt_type1 (xO (xI p'))) (2*s')
           (exist (sqrt_type2 (xO (xI p')) (2*s'))
              (4*r'+2) (th_sqrt_4_2_gt p' s' r' h h')))
    end
  end
| xI (xO p') =>
  match sqrt_aux p' with
    (existT _ s' (exist _ r' h)) =>
    match Z_le_gt_dec  (4*s'+1) (4*r'+1) with
      left h' =>
        (existT (sqrt_type1 (xI (xO p'))) (2*s'+1)
           (exist (sqrt_type2 (xI (xO p')) (2*s'+1))
             ((4*r'+1)-(4*s'+1)) (th_sqrt_4_1_le p' s' r' h h')))
    | right h' =>
        (existT (sqrt_type1 (xI (xO p'))) (2*s')
           (exist (sqrt_type2 (xI (xO p')) (2*s')) (4*r'+1)
              (th_sqrt_4_1_gt p' s' r' h h')))
    end
  end
| xI (xI p') =>
  match sqrt_aux p' with
    (existT _ s' (exist _ r' h)) =>
    match Z_le_gt_dec  (4*s'+1) (4*r'+3) with
      left h' =>
        existT (sqrt_type1 (xI (xI p'))) (2*s'+1)
           (exist (sqrt_type2 (xI (xI p')) (2*s'+1))
               ((4*r'+3)-(4*s'+1)) (th_sqrt_4_3_le p' s' r' h h'))
    | right h' =>
        existT (sqrt_type1 (xI (xI p'))) (2*s')
           (exist (sqrt_type2 (xI (xI p')) (2*s'))
              (4*r'+3) (th_sqrt_4_3_gt p' s' r' h h'))
    end
  end
end.

(* We must now fulfill the required specification. *)

Definition sqrt :
  forall p, {s:Z &{r:Z | Zpos p = s*s+r /\ s*s <= Zpos p < (s+1)*(s+1)}}.
Proof.
 intros p; case (sqrt_aux p); intros s [r [Heq [H0_le_r Hr_le_2s]]].
 exists s; exists r;split.
 - exact Heq.
 - split.
   + lia.
   + replace ((s+1)*(s+1)) with (s*s + 2*s +1).
     * lia.
     * ring.
Defined.

Recursive Extraction sqrt.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Isomorphism.
Require Export Category.Theory.Functor.
Require Export Category.Structure.Cartesian.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section CartesianFunctor.

Context `{F : C ⟶ D}.
Context `{@Cartesian C}.
Context `{@Cartesian D}.

Class CartesianFunctor := {
  fobj_prod_iso {x y : C} : F (x × y) ≅ F x × F y;

  prod_in  := fun x y => from (@fobj_prod_iso x y);
  prod_out := fun x y => to   (@fobj_prod_iso x y);

  fmap_exl {x y : C} : fmap (@exl C _ x y) ≈ exl ∘ prod_out _ _;
  fmap_exr {x y : C} : fmap (@exr C _ x y) ≈ exr ∘ prod_out _ _;

  fmap_fork {x y z : C} (f : x ~> y) (g : x ~> z) :
    fmap (f △ g) ≈ prod_in _ _ ∘ fmap f △ fmap g
}.

Arguments prod_in {_ _ _} /.
Arguments prod_out {_ _ _} /.

Context `{@CartesianFunctor}.

Corollary prod_in_out (x y : C) :
  prod_in ∘ prod_out ≈ @id _ (F (x × y)).
Proof.
  intros.
  exact (iso_from_to fobj_prod_iso).
Qed.

Hint Rewrite @prod_in_out : functors.

Corollary prod_out_in (x y : C) :
  prod_out ∘ prod_in ≈ @id _ (F x × F y).
Proof.
  intros.
  exact (iso_to_from fobj_prod_iso).
Qed.

Hint Rewrite @prod_out_in : functors.

Corollary prod_in_inj {x y z : C} (f g : F x ~> F x × F y) :
  prod_in ∘ f ≈ prod_in ∘ g ↔ f ≈ g.
Proof.
  split; intros Hprod.
    rewrite <- id_left.
    rewrite <- prod_out_in.
    rewrite <- comp_assoc.
    rewrite Hprod.
    rewrite comp_assoc.
    autorewrite with functors; cat.
  subst.
  rewrite Hprod.
  reflexivity.
Qed.

Corollary prod_out_inj {x y z : C} (f g : F x ~> F (y × z)) :
  prod_out ∘ f ≈ prod_out ∘ g ↔ f ≈ g.
Proof.
  split; intros Hprod.
    rewrite <- id_left.
    rewrite <- prod_in_out.
    rewrite <- comp_assoc.
    rewrite Hprod.
    rewrite comp_assoc.
    autorewrite with functors; cat.
  subst.
  rewrite Hprod.
  reflexivity.
Qed.

End CartesianFunctor.

Arguments prod_in {_ _ _ _ _ _ _ _} /.
Arguments prod_out {_ _ _ _ _ _ _ _} /.

Hint Rewrite @prod_in_out : functors.
Hint Rewrite @prod_out_in : functors.

Require Import Category.Construction.Opposite.
Require Import Category.Functor.Opposite.
Require Import Category.Structure.Cocartesian.

Notation "'CocartesianFunctor' F" := (@CartesianFunctor _ _ (F^op) _ _)
  (at level 9) : category_theory_scope.
Notation "@CocartesianFunctor C D F" :=
  (@CartesianFunctor (C^op) (D^op) (F^op) _ _)
  (at level 9) : category_theory_scope.


Require Import Braun.monad.monad Braun.common.index Braun.insert.insert_log.
Require Import Braun.common.braun Braun.common.util Braun.common.big_oh.
Require Import Arith Arith.Even Arith.Div2 Omega.
Require Import Program.Wf.

Section copy_linear.

  Definition copy_linear_time (n:nat) := 17*n+3.

  Definition copy_linear_result (A:Set) (x:A) (n:nat) (b:@bin_tree A) (c:nat):=
    Braun b n /\
    (forall i y, IndexR b i y -> y = x) /\
    c = copy_linear_time (n).

  Load "copy_linear_gen.v".

  Next Obligation.
  Proof.
    repeat constructor;auto.
    intros i y IR.
    inversion IR.
  Qed.

  Next Obligation.
  Proof.
    clear H2 am0 H3 am.
    destruct H0 as [Br [IRr EQxn]].
    destruct H1 as [Bl [IRl EQxn0]].

    unfold copy_linear_result.
    subst.

    repeat split; auto.

    replace (S n') with (div2 (S n')+ div2(n') + 1).
    repeat constructor;auto.

    rewrite (div_ceil_floor_sum n') at 3.
    replace (n'+1) with (S n');[|omega].
    omega.

    intros i y IR. invclr IR; eauto.

    unfold copy_linear_time.
    replace (17 * div2 (S n') + 3 + (17 * div2 n' + 3 + 14))
    with (17 * (div2 n' + div2 (n'+1)) + 20).
    rewrite <- (div_ceil_floor_sum n').
    omega.

    rewrite mult_plus_distr_l.
    replace (S n') with (n'+1); omega.
  Qed.

  Theorem copy_linear_linear : big_oh copy_linear_time (fun n => n).
  Proof.
    unfold copy_linear_time; auto.
  Qed.

End copy_linear.


From stdpp Require Import numbers list.
From CoqCP Require Import Options ListRange SwapUpdate SelectionSort Foldl Comparator PickSmallestInRangeProperties ListDecomposition Sorted ListsEqual.

Definition partialSelectionSort {A : Type} (default : A) (compare : A -> A -> bool) (l : list A) (iterationCount : nat) := foldl (fun accumulated i => swap accumulated i (pickSmallestInRange default compare i (length l - 1) accumulated) default) l (range iterationCount).

Lemma partialSelectionSortZero {A : Type} (default : A) (compare : A -> A -> bool) (l : list A) : partialSelectionSort default compare l 0 = l.
Proof.
  unfold partialSelectionSort. rewrite rangeZero. easy.
Qed.

Lemma partialSelectionSortSucc {A : Type} (default : A) (compare : A -> A -> bool) (l : list A) (iterationCount : nat) : partialSelectionSort default compare l (S iterationCount) = swap (partialSelectionSort default compare l iterationCount) iterationCount (pickSmallestInRange default compare iterationCount (length l - 1) (partialSelectionSort default compare l iterationCount)) default.
Proof.
  unfold partialSelectionSort. rewrite rangeSucc, foldl_app. simpl. reflexivity.
Qed.

Lemma selectionSortComplete {A : Type} (default : A) (compare : A -> A -> bool) (l : list A) : partialSelectionSort default compare l (length l) = selectionSort default compare l.
Proof. easy. Qed.

Lemma selectionSortPreservesLength {A : Type} (default : A) (compare : A -> A -> bool) (l : list A) : length (selectionSort default compare l) = length l.
Proof.
  unfold selectionSort.
  remember (range _) as randomList eqn:HeqrandomList.
  clear HeqrandomList. revert l.
  induction randomList as [| a randomList IHrandomList].
  - easy.
  - intro l. simpl. pose proof IHrandomList (swap l a (pickSmallestInRange default compare a (length l - 1) l) default) as H.
    rewrite ?swapPreservesLength in H. assumption.
Qed.

Lemma partialSelectionSortPreservesLength {A : Type} (default : A) (compare : A -> A -> bool) (l : list A) (iterationCount : nat) : length (partialSelectionSort default compare l iterationCount) = length l.
Proof.
  unfold partialSelectionSort.
  remember (range _) as randomList eqn:HeqrandomList.
  clear HeqrandomList. revert l.
  induction randomList as [| a randomList IHrandomList].
  - easy.
  - intro l. simpl. pose proof IHrandomList (swap l a (pickSmallestInRange default compare a (length l - 1) l) default) as H.
    rewrite ?swapPreservesLength in H. assumption.
Qed.

Lemma partialSelectionSortInvariant {A : Type} (default : A) (comparator : Comparator A) (l : list A) (i : nat) (hLt : i < length l) : prefixSorted default (compare _ comparator) (partialSelectionSort default (compare _ comparator) l (S i)) (S i) /\ partitioned default (compare _ comparator) (partialSelectionSort default (compare _ comparator) l (S i)) i.
Proof.
  induction i as [| i IHi].
  - rewrite partialSelectionSortSucc, partialSelectionSortZero.
    split.
    + intros i j hIJ hJ. lia.
    + intros toTheLeft toTheRight hToTheLeft hToTheRight hLength.
      pose proof pickSmallestInRangeUpperBound default (compare A comparator) l 0 (length l - 1) as hUpperBound.
      rewrite Nat.add_0_l in hUpperBound.
      assert (hToTheLeftEq : toTheLeft = 0). { lia. }
      rewrite hToTheLeftEq. rewrite nthSwap; try lia.
      rewrite swapPreservesLength in hLength.
      pose proof pickSmallestInRangeCompare default comparator l 0 (length l - 1) toTheRight ltac:(lia) as H.
      rewrite Nat.add_0_l in H.
      assert (hCaseSplit : toTheRight = 0 \/ toTheRight <> 0). { lia. }
      destruct hCaseSplit as [hCaseSplit | hCaseSplit]; rewrite ?hCaseSplit; rewrite ?nthSwap; try lia; try apply irreflexive.
      assert (hCaseSplit' : toTheRight = pickSmallestInRange default (compare A comparator) 0 (length l - 1) l \/ toTheRight <> pickSmallestInRange default (compare A comparator) 0 (length l - 1) l). { lia. }
      destruct hCaseSplit' as [hCaseSplit' | hCaseSplit']; rewrite ?hCaseSplit', ?nthSwapVariant; try lia.
      * pose proof pickSmallestInRangeCompare default comparator l 0 (length l - 1) 0 ltac:(lia) as H0.
        rewrite ?Nat.add_0_l in H0. assumption.
      * rewrite nthSwapExcept; try lia. assumption.
  - rewrite partialSelectionSortSucc.
    remember (partialSelectionSort default (compare A comparator) l (S i)) as pastIteration eqn:HeqpastIteration.
    assert (hPastIterationSameLength : length pastIteration = length l).
    { rewrite HeqpastIteration, partialSelectionSortPreservesLength. reflexivity. }
    assert (hSimplify : S i + (length l - 1 - S i) = length l - 1). { lia. }
    pose proof pickSmallestInRangeUpperBound default (compare _ comparator) pastIteration (S i) (length l - 1 - S i) as hUpperBound.
    pose proof iLessEqualPickSmallestInRange default (compare _ comparator) pastIteration (S i) (length l - 1 - S i) as hLowerBound.
    rewrite hSimplify in *.
    split.
    + intros left right hLeftRight hRight.
      assert (hRightSuccI : right = S i \/ right < S i). { lia. }
      destruct hRightSuccI as [hRightSuccI | hRightSuccI].
      * rewrite hRightSuccI, nthSwap, nthSwapExcept; try lia.
        apply (proj2 (IHi ltac:(lia))); lia.
      * rewrite ?nthSwapExcept; try lia.
        exact (proj1 (IHi ltac:(lia)) left right ltac:(lia) ltac:(lia)).
    + intros left right hLeft hRight hRightLength.
      rewrite swapPreservesLength in hRightLength.
      assert (hLeftSplit : left = S i \/ left < S i). { lia. }
      destruct hLeftSplit as [hLeftSplit | hLeftSplit].
      * rewrite hLeftSplit, nthSwap; try lia.
        assert (hRightSplit : right = S i \/ right > S i). { lia. }
        destruct hRightSplit as [hRightSplit | hRightSplit].
        { rewrite hRightSplit, nthSwap; try lia; apply irreflexive. }
        { shelve. }
      * rewrite (nthSwapExcept _ _ _ _ left); try lia.
        assert (hRightSplit : right = S i \/ right > S i). { lia. }
        destruct hRightSplit as [hRightSplit | hRightSplit].
        { rewrite hRightSplit, nthSwap; try lia.
          apply (proj2 (IHi ltac:(lia))); lia. }
        { shelve. }
  Unshelve.
  { assert (hCaseSplit : right = pickSmallestInRange default (compare A comparator) (S i) (length l - 1) pastIteration \/ right <> pickSmallestInRange default (compare A comparator) (S i) (length l - 1) pastIteration). { lia. }
    destruct hCaseSplit as [hCaseSplit | hCaseSplit]; rewrite ?hCaseSplit.
    - rewrite nthSwapVariant; try lia.
      pose proof pickSmallestInRangeCompare default comparator pastIteration (S i) (length l - 1 - S i) 0 ltac:(lia) as H.
      rewrite hSimplify, Nat.add_0_r in H.
      assumption.
    - rewrite nthSwapExcept; try lia.
      pose proof pickSmallestInRangeCompare default comparator pastIteration (S i) (length l - 1 - S i) (right - S i) ltac:(lia) as H.
      assert (hSimplify' : S i + (right - S i) = right). { lia. }
      rewrite hSimplify, hSimplify' in H.
      assumption. }
  { assert (hCaseSplit : right = pickSmallestInRange default (compare A comparator) (S i) (length l - 1) pastIteration \/ right <> pickSmallestInRange default (compare A comparator) (S i) (length l - 1) pastIteration). { lia. }
    destruct hCaseSplit as [hCaseSplit | hCaseSplit]; rewrite ?hCaseSplit.
    - rewrite nthSwapVariant; try lia.
      apply (proj2 (IHi ltac:(lia))); lia.
    - rewrite nthSwapExcept; try lia.
      apply (proj2 (IHi ltac:(lia))); lia. }
Qed.

Lemma selectionSortCorrect {A : Type} (default : A) (comparator : Comparator A) (l : list A) : sorted default (compare _ comparator) (selectionSort default (compare _ comparator) l).
Proof.
  destruct l as [| a l].
  - intros a b h1 h2. simpl in *. lia.
  - pose proof proj1 (partialSelectionSortInvariant default comparator (a :: l) (length l) ltac:(simpl; lia)) as H.
    intros i j h1 h2.
    apply H.
    + assumption.
    + rewrite selectionSortPreservesLength in h2. simpl in h2. assumption.
Qed.

Lemma selectionSortPermutation {A : Type} (default : A) (compare : A -> A -> bool) (l : list A) : Permutation l (selectionSort default compare l).
Proof.
  rewrite <- selectionSortComplete.
  remember (length l) as iterationCount eqn:HeqiterationCount.
  assert (hIterationCount : iterationCount <= length l). { lia. }
  clear HeqiterationCount.
  induction iterationCount as [| iterationCount IHiterationCount].
  - easy.
  - rewrite partialSelectionSortSucc.
    remember (partialSelectionSort default compare l iterationCount) as pastIteration eqn:HeqpastIteration.
    remember (pickSmallestInRange default compare iterationCount (length l - 1) pastIteration) as j eqn:Heqj.
    assert (hSimplify : iterationCount + (length l - 1 - iterationCount) = length l - 1). { lia. }
    assert (hJUpperBound : j <= length l - 1).
    { pose proof pickSmallestInRangeUpperBound default compare pastIteration iterationCount (length l - 1 - iterationCount) as H.
      rewrite hSimplify in *. lia. }
    assert (hJLowerBound : iterationCount = j \/ iterationCount < j).
    { pose proof iLessEqualPickSmallestInRange default compare pastIteration iterationCount (length l - 1 - iterationCount) as H.
      rewrite hSimplify in *. lia. }
    destruct hJLowerBound as [hJLowerBound | hJLowerBound].
    + rewrite hJLowerBound, swapSelf. apply IHiterationCount. lia.
    + assert (hLeq1 : iterationCount < length pastIteration). { rewrite HeqpastIteration, partialSelectionSortPreservesLength in *; lia. }
      assert (hLeq2 : j < length pastIteration). { rewrite HeqpastIteration, partialSelectionSortPreservesLength in *; lia. }
      rewrite swapDecomposition, IHiterationCount; try lia.
      assert (hPartial : Permutation pastIteration (take iterationCount pastIteration ++ [nth iterationCount pastIteration default] ++ drop (S iterationCount) (take j pastIteration) ++ [nth j pastIteration default] ++ drop (j + 1) pastIteration)).
      { epose proof (listDecomposition pastIteration iterationCount j ltac:(lia) ltac:(rewrite HeqpastIteration in *; assumption) default) as H.
        rewrite <- H. reflexivity. }
      transitivity (take iterationCount pastIteration ++ [nth iterationCount pastIteration default] ++ drop (S iterationCount) (take j pastIteration) ++ [nth j pastIteration default] ++ drop (j + 1) pastIteration); try assumption.
      remember (take iterationCount pastIteration) as A1.
      remember ([nth iterationCount pastIteration default]) as A2.
      remember (drop (S iterationCount) (take j pastIteration)) as A3.
      remember ([nth j pastIteration default]) as A4.
      remember (drop (j + 1) pastIteration) as A5.
      assert (hRewriteInner : Permutation (A2 ++ A3 ++ A4) (A4 ++ A3 ++ A2)).
      { rewrite (Permutation_app_comm A3 A2), (app_assoc A4 A2 A3), (Permutation_app_comm A4 A2), (Permutation_app_comm A3 A4), <- app_assoc. reflexivity. }
      assert (rebracket1 : A1 ++ A2 ++ A3 ++ A4 ++ A5 = A1 ++ (A2 ++ A3 ++ A4) ++ A5). { listsEqual. }
      assert (rebracket2 : A1 ++ A4 ++ A3 ++ A2 ++ A5 = A1 ++ (A4 ++ A3 ++ A2) ++ A5). { listsEqual. }
      rewrite rebracket1, rebracket2, hRewriteInner. reflexivity.
Qed.


(* NotInSegMisc.v *)

Require Import Utf8 QArith Sorting.

Require Import Misc.
Require Import Slope_base.
Require Import ConvexHull.
Require Import ConvexHullMisc.

Theorem ad_hoc_lt_lt : ∀ i j k x y z,
  i < j ∧ i < k
  → (y - x) / (k - i) < (z - x) / (j - i)
    → x + i * ((x - y) / (k - i)) < z + j * ((x - y) / (k - i)).
Proof.
intros i j k x y z (Hij, Hjk) H.
apply Qlt_shift_mult_r in H; [ idtac | apply Qlt_minus; assumption ].
rewrite Qmult_comm, Qmult_div_assoc in H.
apply Qlt_shift_mult_l in H; [ idtac | apply Qlt_minus; assumption ].
rewrite Qmult_comm in H.
do 2 rewrite Qmult_minus_distr_l in H.
do 4 rewrite Qmult_minus_distr_r in H.
do 2 rewrite Qminus_minus_assoc in H.
rewrite <- Qplus_minus_swap in H.
apply Qminus_lt_lt_plus_r in H.
rewrite <- Qplus_minus_swap in H.
apply Qminus_lt_lt_plus_r in H.
do 2 rewrite <- Qplus_assoc in H.
rewrite <- Qplus_minus_swap in H.
apply Qlt_minus_plus_lt_r in H.
rewrite <- Qplus_minus_swap in H.
apply Qlt_minus_plus_lt_r in H.
do 2 rewrite Qplus_assoc in H.
do 2 rewrite Qmult_div_assoc.
rewrite Qplus_div; [ idtac | apply Qlt_not_0; assumption ].
rewrite Qplus_div; [ idtac | apply Qlt_not_0; assumption ].
apply Qdiv_lt_compat_r; [ apply Qlt_minus; assumption | idtac ].
rewrite Qmult_minus_distr_r.
rewrite Qplus_comm, Qmult_comm; apply Qnot_le_lt.
rewrite Qplus_comm, Qmult_comm; apply Qlt_not_le.
do 2 rewrite Qmult_minus_distr_l.
rewrite Qmult_minus_distr_r.
do 2 rewrite Qplus_minus_assoc.
apply Qlt_plus_minus_lt_r; rewrite <- Qplus_minus_swap.
apply Qlt_plus_minus_lt_r; rewrite Qplus_minus_swap.
do 2 rewrite <- Qplus_assoc; rewrite <- Qplus_minus_swap.
apply Qplus_lt_lt_minus_r; rewrite <- Qplus_minus_swap.
apply Qplus_lt_lt_minus_r; do 2 rewrite Qplus_assoc.
rewrite Qplus_comm, Qplus_assoc, Qplus_assoc; apply Qnot_le_lt.
rewrite <- Qplus_assoc, <- Qplus_assoc, Qplus_comm, Qplus_assoc.
rewrite Qplus_plus_swap; apply Qlt_not_le.
assumption.
Qed.

Theorem minimised_slope_le : ∀ pt₁ pt₂ pts ms,
  minimise_slope pt₁ pt₂ pts = ms
  → slope ms <= slope_expr pt₁ pt₂.
Proof.
intros pt₁ pt₂ pts ms Hms.
revert ms Hms.
induction pts as [| pt]; intros.
 simpl in Hms.
 subst ms; simpl.
 apply Qle_refl.

 simpl in Hms.
 remember (minimise_slope pt₁ pt pts) as ms₁.
 remember (slope_expr pt₁ pt₂ ?= slope ms₁) as c.
 destruct c; subst ms.
  simpl.
  symmetry in Heqc; apply Qeq_alt in Heqc.
  rewrite Heqc.
  unfold slope at 1; simpl.
  rewrite slope_slope_expr; [ idtac | symmetry; eassumption ].
  apply Qle_refl.

  simpl.
  apply Qle_refl.

  symmetry in Heqc; apply Qgt_alt in Heqc.
  apply Qlt_le_weak; eassumption.
Qed.

Theorem minimise_slope_pts_le : ∀ j αj pt pts ms,
  minimise_slope (j, αj) pt pts = ms
  → ∀ h αh,
     (h, αh) ∈ pts
     → slope ms <= slope_expr (j, αj) (h, αh).
Proof.
intros j αj pt pts ms Hms h αh Hαh.
revert pt ms Hms h αh Hαh.
induction pts as [| pt₁]; [ contradiction | intros ].
destruct Hαh as [Hαh| Hαh].
 subst pt₁.
 simpl in Hms.
 remember (minimise_slope (j, αj) (h, αh) pts) as ms₁.
 symmetry in Heqms₁.
 remember (slope_expr (j, αj) pt ?= slope ms₁) as c.
 destruct c; subst ms.
  unfold slope; simpl.
  rewrite <- minimised_slope; [ idtac | eassumption | reflexivity ].
  eapply minimised_slope_le; eassumption.

  simpl.
  eapply minimised_slope_le in Heqms₁.
  symmetry in Heqc; apply Qlt_alt in Heqc.
  apply Qlt_le_weak.
  eapply Qlt_le_trans; eassumption.

  eapply minimised_slope_le in Heqms₁.
  assumption.

 simpl in Hms.
 remember (minimise_slope (j, αj) pt₁ pts) as ms₁.
 symmetry in Heqms₁.
 remember (slope_expr (j, αj) pt ?= slope ms₁) as c.
 symmetry in Heqc.
 destruct c; subst ms.
  unfold slope; simpl.
  rewrite <- minimised_slope; [ idtac | eassumption | reflexivity ].
  eapply IHpts; eassumption.

  simpl.
  apply Qlt_alt in Heqc.
  apply Qlt_le_weak.
  eapply Qlt_le_trans; [ eassumption | idtac ].
  eapply IHpts; eassumption.

  eapply IHpts; eassumption.
Qed.

Theorem min_slope_lt_after_k : ∀ j αj k αk pt pts ms,
  Sorted fst_lt pts
  → minimise_slope (j, αj) pt pts = ms
    → fin_pt ms = (k, αk)
      → ∀ h αh, (h, αh) ∈ pts
        → k < h
          → slope ms < slope_expr (j, αj) (h, αh).
Proof.
intros j αj k αk pt pts ms Hsort Hms Hep h αh Hαh Hkh.
revert pt ms Hms Hep h Hαh Hkh.
induction pts as [| pt₁]; [ contradiction | intros ].
destruct Hαh as [Hαh| Hαh].
 subst pt₁.
 remember Hms as H; clear HeqH.
 apply end_pt_in in Hms.
 rewrite Hep in Hms.
 destruct Hms as [Hms| Hms].
  subst pt.
  simpl in H.
  remember (minimise_slope (j, αj) (h, αh) pts) as ms₁.
  symmetry in Heqms₁.
  remember (slope_expr (j, αj) (k, αk) ?= slope ms₁) as c.
  destruct c; subst ms.
   simpl in Hep |- *.
   apply minimise_slope_le in Heqms₁; [ idtac | assumption ].
   rewrite Hep in Heqms₁.
   apply Qle_not_lt in Heqms₁; contradiction.

   simpl in Hep |- *; clear Hep.
   symmetry in Heqc; apply Qlt_alt in Heqc.
   eapply Qlt_le_trans; [ eassumption | idtac ].
   eapply minimised_slope_le; eassumption.

   symmetry in Heqc; apply Qgt_alt in Heqc.
   apply minimise_slope_le in Heqms₁; [ idtac | assumption ].
   rewrite Hep in Heqms₁; simpl in Heqms₁.
   apply Qle_not_lt in Heqms₁.
   contradiction.

  destruct Hms as [Hms| Hms].
   injection Hms; clear Hms; intros; subst h αh.
   apply Qlt_irrefl in Hkh; contradiction.

   eapply Sorted_hd in Hsort; [ idtac | eassumption ].
   simpl in Hsort.
   eapply Qlt_trans in Hsort; [ idtac | eassumption ].
   apply Qlt_irrefl in Hsort; contradiction.

 simpl in Hms.
 remember (minimise_slope (j, αj) pt₁ pts) as ms₁.
 symmetry in Heqms₁.
 remember (slope_expr (j, αj) pt ?= slope ms₁) as c.
 destruct c; subst ms.
  simpl in Hep |- *.
  unfold slope; simpl.
  rewrite <- minimised_slope; [ idtac | eassumption | reflexivity ].
  eapply IHpts; try eassumption.
  destruct pts as [| pts₁]; [ constructor | idtac ].
  apply Sorted_inv_2 in Hsort; destruct Hsort; assumption.

  simpl in Hep |- *.
  subst pt.
  symmetry in Heqc; apply Qlt_alt in Heqc.
  eapply Qlt_le_trans; [ eassumption | idtac ].
  eapply minimise_slope_pts_le; eassumption.

  eapply IHpts; try eassumption.
  destruct pts as [| pts₁]; [ constructor | idtac ].
  apply Sorted_inv_2 in Hsort; destruct Hsort; assumption.
Qed.

Theorem points_after_k : ∀ pts j αj k αk seg γ β,
  Sorted fst_lt pts
  → j < k
    → γ = (αj - αk) / (k - j)
      → β = αj + j * γ
        → lower_convex_hull_points pts = Some (mkns (j, αj) (k, αk) seg)
          → ∀ h αh, k < h
            → (h, αh) ∈ pts
              → β < αh + h * γ.
Proof.
intros pts j αj k αk seg γ β.
intros Hsort Hjk Hγ Hβ Hnp h αh Hkh Hαh.
destruct pts as [| pt₁]; [ easy | ].
destruct pts as [| pt₂]; [ easy | ].
simpl in Hnp.
rewrite minimised_slope_beg_pt in Hnp.
injection Hnp; clear Hnp; intros Hseg Hep₁ Hp₁; subst seg pt₁.
remember (minimise_slope (j, αj) pt₂ pts) as ms₁.
destruct Hαh as [Hαh| Hαh].
 injection Hαh; clear Hαh; intros; subst h αh.
 eapply Qlt_trans in Hkh; [ idtac | eassumption ].
 apply Qlt_irrefl in Hkh; contradiction.

 destruct Hαh as [Hαh| Hαh]; [ exfalso | idtac ].
  subst pt₂.
  symmetry in Heqms₁.
  apply Sorted_inv_2 in Hsort; destruct Hsort as (Hlt₁, Hsort).
  apply minimise_slope_le in Heqms₁; [ idtac | assumption ].
  rewrite Hep₁ in Heqms₁.
  apply Qle_not_lt in Heqms₁.
  contradiction.

  symmetry in Heqms₁.
  symmetry in Hep₁.
  remember Heqms₁ as H; clear HeqH.
  eapply minimised_slope in H; [ idtac | eassumption ].
  symmetry in Hep₁.
  eapply min_slope_lt_after_k in Heqms₁; try eassumption.
   rewrite H in Heqms₁.
   subst β γ.
   apply ad_hoc_lt_lt.
    split; [ idtac | assumption ].
    eapply Qlt_trans; eassumption.

    unfold slope_expr in Heqms₁; simpl in Heqms₁.
    assumption.

   apply Sorted_inv_2 in Hsort; destruct Hsort as (Hlt, Hsort).
   apply Sorted_inv_1 in Hsort; assumption.
Qed.

Theorem not_seg_min_sl_lt : ∀ j αj k αk pt pts ms h αh,
  Sorted fst_lt [(j, αj); pt; (h, αh) … pts]
  → minimise_slope (j, αj) pt [(h, αh) … pts] = ms
    → j < h < k
      → (h, αh) ∉ oth_pts ms
        → fin_pt ms = (k, αk)
          → slope ms < slope_expr (j, αj) (h, αh).
Proof.
intros j αj k αk pt pts ms h αh Hsort Hms (Hjh, Hhk) Hseg Hep.
rewrite slope_slope_expr; [ idtac | eassumption ].
revert ms Hms Hseg Hep.
induction pts as [| pt₁]; intros.
 simpl in Hms.
 unfold slope in Hms; simpl in Hms.
 remember (slope_expr (j, αj) pt ?= slope_expr (j, αj) (h, αh)) as c.
 symmetry in Heqc.
 destruct c; subst ms; simpl.
  simpl in Hseg, Hep.
  injection Hep; clear Hep; intros; subst h αh.
  apply Qlt_irrefl in Hhk; contradiction.

  simpl in Hseg, Hep.
  subst pt.
  apply Qlt_alt in Heqc.
  assumption.

  simpl in Hseg, Hep.
  injection Hep; clear Hep; intros; subst h αh.
  apply Qlt_irrefl in Hhk; contradiction.

 remember [pt₁ … pts] as pts₁.
 simpl in Hms.
 remember (minimise_slope (j, αj) (h, αh) pts₁) as ms₁.
 symmetry in Heqms₁.
 remember (slope_expr (j, αj) pt ?= slope ms₁) as c₁.
 symmetry in Heqc₁.
 destruct c₁; subst ms; simpl.
  simpl in Hseg, Hep.
  apply Decidable.not_or in Hseg.
  destruct Hseg as (Hne, Hseg).
  subst pts₁.
  simpl in Heqms₁.
  remember (minimise_slope (j, αj) pt₁ pts) as ms₂.
  symmetry in Heqms₂.
  remember (slope_expr (j, αj) (h, αh) ?= slope ms₂) as c.
  symmetry in Heqc.
  destruct c; subst ms₁; simpl.
   simpl in Heqc₁, Hseg, Hep.
   apply Decidable.not_or in Hseg.
   destruct Hseg as (Hne₂, Hseg).
   negation Hne₂.

   simpl in Heqc₁, Hseg, Hep.
   injection Hep; clear Hep; intros; subst h αh.
   apply Qlt_irrefl in Hhk; contradiction.

   apply Qgt_alt in Heqc.
   rewrite slope_slope_expr in Heqc; [ idtac | eassumption ].
   assumption.

  simpl in Hseg, Hep.
  subst pt.
  apply Qlt_alt in Heqc₁.
  eapply Qlt_le_trans; [ eassumption | idtac ].
  eapply minimised_slope_le; eassumption.

  subst pts₁.
  apply Qgt_alt in Heqc₁.
  simpl in Heqms₁.
  remember (minimise_slope (j, αj) pt₁ pts) as ms₂.
  symmetry in Heqms₂.
  remember (slope_expr (j, αj) (h, αh) ?= slope ms₂) as c.
  symmetry in Heqc.
  destruct c; subst ms₁; simpl.
   simpl in Heqc₁, Hseg, Hep.
   apply Decidable.not_or in Hseg.
   destruct Hseg as (Hne₂, Hseg).
   negation Hne₂.

   simpl in Heqc₁, Hseg, Hep.
   injection Hep; clear Hep; intros; subst h αh.
   apply Qlt_irrefl in Hhk; contradiction.

   apply Qgt_alt in Heqc.
   rewrite slope_slope_expr in Heqc; [ idtac | eassumption ].
   assumption.
Qed.

Theorem points_between_j_and_k : ∀ pts j αj k αk oth γ β,
  Sorted fst_lt pts
  → γ = (αj - αk) / (k - j)
    → β = αj + j * γ
      → lower_convex_hull_points pts = Some (mkns (j, αj) (k, αk) oth)
        → ∀ h αh, j < h < k
          → (h, αh) ∈ pts
            → (h, αh) ∉ oth
              → β < αh + h * γ.
Proof.
intros pts j αj k αk oth γ β.
intros Hsort Hγ Hβ Hnp h αh (Hjh, Hhk) Hαh Hseg.
destruct pts as [| pt₁]; [ discriminate Hnp | idtac ].
remember Hnp as H; clear HeqH.
apply next_ch_points_hd in H.
subst pt₁; simpl in Hnp.
destruct pts as [| pt₁]; [ discriminate Hnp | idtac ].
remember (minimise_slope (j, αj) pt₁ pts) as ms₁.
injection Hnp; clear Hnp; intros Hop₁ Hep₁ Hbp₁; subst oth.
destruct Hαh as [Hαh| Hαh].
 injection Hαh; clear Hαh; intros; subst h αh.
 apply Qlt_irrefl in Hjh; contradiction.

 destruct Hαh as [Hαh| Hαh].
  subst pt₁.
  symmetry in Heqms₁.
  destruct pts as [| pt₁].
   simpl in Heqms₁.
   subst ms₁.
   simpl in Hep₁, Hseg, Hbp₁.
   injection Hep₁; clear Hep₁; intros; subst h αh.
   apply Qlt_irrefl in Hhk; contradiction.

   simpl in Heqms₁.
   remember (minimise_slope (j, αj) pt₁ pts) as ms₂.
   symmetry in Heqms₂.
   remember (slope_expr (j, αj) (h, αh) ?= slope ms₂) as c.
   destruct c; subst ms₁.
    simpl in Hep₁, Hseg, Hbp₁.
    apply Decidable.not_or in Hseg.
    destruct Hseg as (H, _); negation H.

    simpl in Hep₁, Hseg, Hbp₁.
    injection Hep₁; clear Hep₁; intros; subst h αh.
    apply Qlt_irrefl in Hhk; contradiction.

    symmetry in Hep₁.
    remember Heqms₂ as H; clear HeqH.
    eapply minimised_slope in H; [ idtac | eassumption ].
    symmetry in Heqc; apply Qgt_alt in Heqc.
    rewrite H in Heqc.
    subst β γ.
    apply ad_hoc_lt_lt.
     split; [ assumption | idtac ].
     eapply Qlt_trans; eassumption.

     unfold slope_expr in Heqc; simpl in Heqc.
     assumption.

  symmetry in Heqms₁.
  revert pt₁ ms₁ Hsort Heqms₁ Hep₁ Hseg Hbp₁.
  induction pts as [| pt₂]; intros.
   simpl in Heqms₁.
   subst ms₁.
   simpl in Hep₁, Hseg, Hbp₁.
   contradiction.

   destruct Hαh as [Hαh| Hαh].
    subst pt₂.
    symmetry in Hep₁.
    remember Heqms₁ as H; clear HeqH.
    eapply minimised_slope in H; [ idtac | eassumption ].
    symmetry in Hep₁.
    eapply not_seg_min_sl_lt in Heqms₁; try eassumption.
     rewrite H in Heqms₁.
     subst β γ.
     apply ad_hoc_lt_lt.
      split; [ assumption | idtac ].
      eapply Qlt_trans; eassumption.

      unfold slope_expr in Heqms₁; simpl in Heqms₁.
      assumption.

     split; assumption.

    simpl in Heqms₁.
    remember (minimise_slope (j, αj) pt₂ pts) as ms₂.
    symmetry in Heqms₂.
    remember (slope_expr (j, αj) pt₁ ?= slope ms₂) as c.
    symmetry in Heqc.
    destruct c; subst ms₁.
     simpl in Hep₁, Hseg, Hbp₁.
     apply Decidable.not_or in Hseg.
     destruct Hseg as (Hlt₁, Hseg).
     eapply IHpts; try eassumption.
      eapply Sorted_minus_2nd; [ idtac | eassumption ].
      intros x y z H₁ H₂; eapply Qlt_trans; eassumption.

      rewrite <- Heqms₂, minimised_slope_beg_pt; reflexivity.

     simpl in Hep₁, Hseg, Hbp₁.
     subst pt₁.
     apply Sorted_inv_2 in Hsort.
     destruct Hsort as (Hlt₂, Hsort).
     apply Sorted_inv_2 in Hsort.
     destruct Hsort as (Hlt₃, Hsort).
     eapply Sorted_hd in Hsort; [ idtac | eassumption ].
     unfold fst_lt in Hlt₃.
     simpl in Hlt₃, Hsort.
     clear Hlt₂.
     eapply Qlt_trans in Hlt₃; [ idtac | eassumption ].
     eapply Qlt_trans in Hlt₃; [ idtac | eassumption ].
     apply Qlt_irrefl in Hlt₃; contradiction.

     eapply IHpts; try eassumption.
     eapply Sorted_minus_2nd; [ idtac | eassumption ].
     intros x y z H₁ H₂; eapply Qlt_trans; eassumption.
Qed.

Theorem in_ch_in_pts : ∀ pts pt₁ pt₂ s,
  lower_convex_hull_points pts = Some (mkns pt₁ pt₂ s)
  → pt₁ ∈ pts ∧ pt₂ ∈ pts.
Proof.
intros pts pt₁ pt₂ s Hhs.
unfold lower_convex_hull_points in Hhs.
destruct pts as [| pt₃]; [ discriminate Hhs | idtac ].
destruct pts as [| pt₄]; [ discriminate Hhs | idtac ].
injection Hhs; clear Hhs; intros; subst pt₁ pt₂ s.
split; [ now rewrite minimised_slope_beg_pt; left | ].
remember (minimise_slope pt₃ pt₄ pts) as ms₁.
symmetry in Heqms₁.
apply end_pt_in in Heqms₁.
right; assumption.
Qed.

Theorem sorted_qeq_eq : ∀ pts j αj k αk,
  Sorted fst_lt pts
  → (j, αj) ∈ pts
    → (k, αk) ∈ pts
      → j == k
        → (j, αj) = (k, αk).
Proof.
intros pts j αj k αk Hsort Hj Hk Hjk.
induction pts as [| (l, αl)]; [ contradiction | idtac ].
destruct Hj as [Hj| Hj].
 destruct Hk as [Hk| Hk].
  rewrite Hj in Hk; assumption.

  injection Hj; clear Hj; intros; subst l αl.
  clear IHpts.
  exfalso.
  induction pts as [| (l, αl)]; [ contradiction | idtac ].
  destruct Hk as [Hk| Hk].
   injection Hk; clear Hk; intros; subst l αl.
   apply Sorted_inv_2 in Hsort; destruct Hsort as (Hlt, _).
   unfold fst_lt in Hlt; simpl in Hlt; rewrite Hjk in Hlt.
   apply Qlt_irrefl in Hlt; contradiction.

   apply IHpts; [ idtac | assumption ].
   eapply Sorted_minus_2nd; [ idtac | eassumption ].
   intros x y z H₁ H₂; eapply Qlt_trans; eassumption.

 destruct Hk as [Hk| Hk].
  injection Hk; clear Hk; intros; subst l αl.
  clear IHpts.
  exfalso.
  induction pts as [| (l, αl)]; [ contradiction | idtac ].
  destruct Hj as [Hj| Hj].
   injection Hj; clear Hj; intros; subst l αl.
   apply Sorted_inv_2 in Hsort; destruct Hsort as (Hlt, _).
   unfold fst_lt in Hlt; simpl in Hlt; rewrite Hjk in Hlt.
   apply Qlt_irrefl in Hlt; contradiction.

   apply IHpts; [ idtac | assumption ].
   eapply Sorted_minus_2nd; [ idtac | eassumption ].
   intros x y z H₁ H₂; eapply Qlt_trans; eassumption.

  apply Sorted_inv_1 in Hsort.
  apply IHpts; assumption.
Qed.

Theorem qeq_eq_ini : ∀ pts h αh j αj ptj s,
  Sorted fst_lt pts
  → lower_convex_hull_points pts = Some (mkns (j, αj) ptj s)
    → (h, αh) ∈ pts
      → h == j
        → h = j.
Proof.
intros pts h αh j αj ptj s Hpts Hhsl Hαh Hhk.
eapply sorted_qeq_eq with (αk := αj) in Hhk; try eassumption.
 injection Hhk; intros; subst; reflexivity.

 now apply in_ch_in_pts with (s := s) (pt₂ := ptj).
Qed.

Theorem qeq_eq_fin : ∀ pts h αh k αk ptk s,
  Sorted fst_lt pts
  → lower_convex_hull_points pts = Some (mkns ptk (k, αk) s)
    → (h, αh) ∈ pts
      → h == k
        → h = k.
Proof.
intros pts h αh k αk ptk s Hpts Hhsl Hαh Hhk.
eapply sorted_qeq_eq with (αk := αk) in Hhk; try eassumption.
 injection Hhk; intros; subst; reflexivity.

 now apply in_ch_in_pts with (s := s) (pt₁ := ptk).
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable ltA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defanglelessthan_1 : (forall A B C D E F : Universe, (exists U X V : Universe, (ltA_ A B C D E F -> (betS_ U X V /\ (out_ E D U /\ (out_ E F V /\ congA_ A B C D E X)))))).
Variable defanglelessthan2_2 : (forall A B C D E F U X V : Universe, ((betS_ U X V /\ (out_ E D U /\ (out_ E F V /\ congA_ A B C D E X))) -> ltA_ A B C D E F)).
Variable lemma_equalanglessymmetric_3 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable lemma_angledistinct_4 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> (A <> B /\ (B <> C /\ (A <> C /\ (Xa <> Xb /\ (Xb <> Xc /\ Xa <> Xc))))))).
Variable lemma_ray4_1_5 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_6 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_7 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable lemma_equalangleshelper_8 : (forall A B C Xa Xb Xc Xp Xq : Universe, ((congA_ A B C Xa Xb Xc /\ (out_ Xb Xa Xp /\ out_ Xb Xc Xq)) -> congA_ A B C Xp Xb Xq)).
Variable lemma_angleorderrespectscongruence_9 : (forall A B C D E F P Q R : Universe, ((ltA_ A B C D E F /\ congA_ P Q R D E F) -> ltA_ A B C P Q R)).
Variable lemma_ray5_10 : (forall A B C : Universe, (out_ A B C -> out_ A C B)).
Variable lemma_equalanglesNC_11 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> ~(col_ Xa Xb Xc))).
Variable lemma_ray2_12 : (forall A B C : Universe, (out_ A B C -> A <> B)).
Variable lemma_rayimpliescollinear_13 : (forall A B C : Universe, (out_ A B C -> col_ A B C)).
Variable lemma_collinearorder_14 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_raystrict_15 : (forall A B C : Universe, (out_ A B C -> A <> C)).
Variable lemma_inequalitysymmetric_16 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_collinear4_17 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable deftriangle_18 : (forall A B C : Universe, (triangle_ A B C -> ~(col_ A B C))).
Variable deftriangle2_19 : (forall A B C : Universe, (~(col_ A B C) -> triangle_ A B C)).
Variable lemma_crossbar_20 : (forall A B C E U V : Universe, (exists X : Universe, ((triangle_ A B C /\ (betS_ A E C /\ (out_ B A U /\ out_ B C V))) -> (out_ B E X /\ betS_ U X V)))).
Variable lemma_3_6b_21 : (forall A B C D : Universe, ((betS_ A B C /\ betS_ A C D) -> betS_ A B D)).

Theorem lemma_angleordertransitive_22 : (forall A B C D E F P Q R : Universe, ((ltA_ A B C D E F /\ ltA_ D E F P Q R) -> ltA_ A B C P Q R)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Lists.List.
Require Import Coq.Arith.PeanoNat.
Require Import Leapfrog.FinType.

Set Universe Polymorphism.
Section TypeNeq.
  Context (A B: Type).
  Context `{Finite A}.
  Context `{Finite B}.
  Lemma card_eq_raw:
    A = B ->
    forall (xs: list A) (ys: list B),
      (forall x, In x xs) ->
      (forall y, In y ys) ->
      NoDup xs ->
      NoDup ys ->
      length xs = length ys.
  Proof.
    intro eq.
    subst B.
    intros.
    eapply Nat.le_antisymm;
      eapply NoDup_incl_length;
      unfold incl;
      eauto.
  Qed.

  Lemma card_neq:
    card A <> card B ->
    A <> B.
  Proof.
    unfold "<>".
    unfold card.
    destruct H0, H2.
    eauto using card_eq_raw.
  Qed.

End TypeNeq.


(**********************************************************************)
(* Equations                                                          *)
(* Copyright (c) 2009-2020 Matthieu Sozeau <matthieu.sozeau@inria.fr> *)
(**********************************************************************)
(* This file is distributed under the terms of the                    *)
(* GNU Lesser General Public License Version 2.1                      *)
(**********************************************************************)

Set Warnings "-notation-overridden".

Require Import Equations.Init.
Require Import Equations.Type.Logic.
Require Import Equations.Type.Classes.

(** Decidable equality.

   We redevelop the derivation of [K] from decidable equality on [A] making
   everything transparent and moving to [Type] so that programs using this
   will actually be computable inside Coq. *)

Set Universe Polymorphism.

Import Id_Notations.
Import Sigma_Notations.
Local Open Scope equations_scope.

(** We rederive the UIP shifting proof transparently, and on type.
    Taken from Coq's stdlib.
 *)

Definition UIP_refl_on_ X (x : X) := forall p : x = x, p = 1.
Definition UIP_refl_ X := forall (x : X) (p : x = x), p = 1.

Lemma Id_trans_r {A} (x y z : A) : x = y -> z = y -> x = z.
Proof.
  destruct 1. destruct 1. exact 1.
Defined.

(** We rederive the UIP shifting proof transparently. *)
Theorem UIP_shift_on@{i} (X : Type@{i}) (x : X) :
  UIP_refl_on_ X x -> forall y : x = x, UIP_refl_on_ (x = x) y.
Proof.
  intros UIP_refl y.
  rewrite (UIP_refl y).
  intros z.
  assert (UIP:forall y' y'' : x = x, y' = y'').
  { intros. apply Id_trans_r with 1; apply UIP_refl. }
  transitivity (id_trans (id_trans (UIP 1 1) z)
                         (id_sym (UIP 1 1))).
  - destruct z. destruct (UIP _ _). reflexivity.
  - change
      (match 1 as y' in _ = x' return y' = y' -> Type@{i} with
       | 1 => fun z => z = 1
       end (id_trans (id_trans (UIP 1 1) z)
                     (id_sym (UIP (1) (1))))).
    destruct z. destruct (UIP _ _). reflexivity.
Defined.

Theorem UIP_shift@{i} : forall {U : Type@{i}}, UIP_refl_@{i} U -> forall x:U, UIP_refl_@{i} (x = x).
Proof. exact (fun U UIP_refl x => @UIP_shift_on U x (UIP_refl x)). Defined.

(** This is the reduction rule of UIP. *)
Lemma uip_refl_refl@{i} {A : Type@{i}} {E : UIP@{i} A} (x : A) : uip (x:=x) 1 1 = 1.
Proof.
  apply UIP_shift@{i}.
  intros y e. apply uip@{i}.
Defined.

Theorem UIP_K@{i j} {A : Type@{i}} {U : UIP A} (x : A) :
  forall P : x = x -> Type@{j},
    P 1 -> forall p : x = x, P p.
Proof.
  intros P peq e. now elim (uip 1 e).
Defined.

(** Tactic to solve EqDec goals, destructing recursive calls for the recursive
  structure of the type and calling instances of eq_dec on other types. *)

Ltac eqdec_loop t u :=
  (left; reflexivity) ||
  (solve [right; intro He; inversion He]) ||
  (let x := match t with
             | context C [ _ ?x ] => constr:(x)
             end
    in
    let y := match u with
             | context C [ _ ?y ] => constr:(y)
             end
    in
    let contrad := let Hn := fresh in
                   intro Hn; right; intro He; apply Hn; inversion He; reflexivity in
    let good := intros ->;
      let t' := match t with
                | context C [ ?x _ ] => constr:(x)
                end
      in
      let u' := match u with
                | context C [ ?y _ ] => constr:(y)
                end
      in
      (* idtac "there" t' u'; *)  try (eqdec_loop t' u')
    in
    (* idtac "here" x y; *)
    match goal with
    | [ H : forall z, sum (Id _ z) _ |- _ ] =>
      case (H y); [good|contrad]
    | _ => case (eq_dec x y); [good|contrad]
    end) || idtac.

Ltac eqdec_proof := try red; intros;
  match goal with
   | |- sum (Id ?x ?y) _ =>
    revert y; induction x; intros until y; depelim y;
    match goal with
      |- sum (Id ?x ?y) _ => eqdec_loop x y
    end
  end.

(** Derivation of principles on sigma types whose domain is decidable. *)

Section EqdepDec.
  Universe  i.
  Context {A : Type@{i}} `{EqDec A}.

  Let comp {x y y':A} (eq1:x = y) (eq2:x = y') : y = y' :=
    Id_rect _ _ (fun a _ => a = y') eq2 _ eq1.

  Remark trans_sym_eq : forall (x y:A) (u:x = y), comp u u = id_refl y.
  Proof.
    intros.
    case u; compute. apply id_refl.
  Defined.

  Variable x : A.

  Let nu {y:A} (u:x = y) : x = y :=
    match eq_dec x y with
      | inl eqxy => eqxy
      | inr neqxy => Empty_rect (fun _ => _) (neqxy u)
    end.

  Let nu_constant : forall (y:A) (u v:x = y), nu u = nu v.
    intros.
    unfold nu in |- *.
    case (eq_dec x y); intros.
    reflexivity.

    case e; trivial.
  Defined.

  Let nu_inv {y:A} (v:x = y) : x = y := comp (nu (id_refl x)) v.

  Remark nu_left_inv : forall (y:A) (u:x = y), nu_inv (nu u) = u.
  Proof.
    intros.
    case u; unfold nu_inv in |- *.
    apply trans_sym_eq.
  Defined.

  Theorem eq_proofs_unicity : forall (y:A) (p1 p2:x = y), p1 = p2.
  Proof.
    intros.
    elim nu_left_inv with (u := p1).
    elim nu_left_inv with (u := p2).
    elim nu_constant with y p1 p2.
    reflexivity.
  Defined.

  Theorem K_dec :
    forall P:x = x -> Type@{i}, P (id_refl x) -> forall p:x = x, P p.
  Proof.
    intros.
    elim eq_proofs_unicity with x (id_refl x) p.
    trivial.
  Defined.

  Lemma eq_dec_refl : eq_dec x x = inl (id_refl x).
  Proof.
    case eq_dec; intros. apply ap. apply eq_proofs_unicity.
    elim e. apply id_refl.
  Defined.

  (** The corollary *)
  (* On [sigma] *)

  Let projs {P:A -> Type@{i}} (exP:sigma P) (def:P x) : P x :=
    match exP with
      | sigmaI _ x' prf =>
        match eq_dec x' x with
          | inl eqprf => Id_rect _ x' (fun x _ => P x) prf x eqprf
          | _ => def
        end
    end.

  Theorem inj_right_sigma {P : A -> Type@{i}} {y y':P x} :
      (x, y) = (x, y') -> y = y'.
  Proof.
    intros.
    cut (projs (x, y) y = projs (sigmaI P x y') y).
    unfold projs.
    case (eq_dec x x).
    intro e.
    elim e using K_dec. trivial.

    intros.
    case e; reflexivity.

    case X; reflexivity.
  Defined.

  Lemma inj_right_sigma_refl (P : A -> Type@{i}) (y : P x) :
    inj_right_sigma (y:=y) (y':=y) 1 = (id_refl _).
  Proof.
    unfold inj_right_sigma. intros.
    unfold eq_rect. unfold projs.
    destruct (id_sym@{i} eq_dec_refl).
    unfold K_dec. simpl.
    unfold eq_proofs_unicity. subst projs.
    simpl. unfold nu_inv, comp, nu. simpl.
    unfold eq_ind, nu_left_inv, trans_sym_eq, eq_rect, nu_constant.
    destruct (id_sym@{i} eq_dec_refl). reflexivity.
  Defined.

End EqdepDec.

Definition transport {A : Type} {P : A -> Type} {x y : A} (p : x = y) : P x -> P y :=
  match p with id_refl => fun h => h end.

Lemma sigma_eq@{i} (A : Type@{i}) (P : A -> Type@{i}) (x y : sigma P) :
  x = y -> Σ p : (x.1 = y.1), transport p x.2 = y.2.
Proof.
  intros H; destruct H.
  destruct x as [x px]. simpl.
  refine (id_refl, id_refl).
Defined.

Theorem inj_sigma_r@{i} {A : Type@{i}} `{H : HSet A} {P : A -> Type@{i}} {x} {y y':P x} :
    sigmaI P x y = sigmaI P x y' -> y = y'.
Proof.
  intros [H' H'']%sigma_eq. cbn in *.
  pose (is_hset H' id_refl).
  apply (transport (P:=fun h => transport h y = y') i H'').
Defined.

Definition apd {A} {B : A -> Type} (f : forall x : A, B x) {x y : A} (p : x = y) :
  transport p (f x) = f y.
Proof. now destruct p. Defined.

Definition apd_eq {A} {x y : A} (p : x = y) {z} (q : z = x) :
  transport (P:=@Id A z) p q = id_trans q p.
Proof. now destruct p, q. Defined.

Lemma id_trans_sym {A} (x y z : A) (p : x = y) (q : y = z) (r : x = z) :
  id_trans p q = r -> q = id_trans (id_sym p) r.
Proof. destruct p, q. destruct 1. exact 1. Defined.

Lemma hprop_hset {A} (h : HProp A) : HSet A.
Proof.
  intro x.
  set (g y := h x y).
  intros y z w.
  assert (forall y z (p : y = z), p = id_trans (id_sym (g y)) (g z)).
  intros. apply id_trans_sym. destruct (apd_eq p (g y0)). apply apd.
  rewrite X. now rewrite (X _ _ z).
Defined.

(** Proof that equality proofs in 0-truncated types are connected *)
Lemma hset_pi {A} `{HSet A} (x y : A) (p q : x = y) (r : p = q) : is_hset p q = r.
Proof.
  red in H.
  pose (hprop_hset (H x y)).
  apply h.
Defined.

Lemma is_hset_refl {A} `{HSet A} (x : A) : is_hset (id_refl x) id_refl = id_refl.
Proof.
  apply hset_pi.
Defined.

Lemma inj_sigma_r_refl@{i} (A : Type@{i}) (H : HSet A) (P : A -> Type@{i}) x (y : P x) :
  inj_sigma_r (y:=y) (y':=y) 1 = (id_refl _).
Proof.
  unfold inj_sigma_r. intros.
  simpl. now rewrite is_hset_refl.
Defined.

Theorem K {A} `{HSet A} (x : A) (P : x = x -> Type) :
  P (id_refl x) -> forall p : x = x, P p.
Proof.
  intros. exact (transport (is_hset id_refl p) X).
Defined.