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

Require Import Arith List Lia.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import php.

From Undecidability.Shared.Libs.DLW.Wf
  Require Import wf_chains.

Set Implicit Arguments.

Local Infix "∊" := In (at level 70, no associativity).
Local Infix "⊆" := incl (at level 70, no associativity).

Section wf_strict_order_list.

  Variable (X : Type) (R : X -> X -> Prop).
  Hypothesis (Rirrefl : forall x, ~ R x x)
             (Rtrans : forall x y z, R x y -> R y z -> R x z).

  Implicit Type l : list X.

  Fact chain_trans n x y : chain R n x y -> n = 0 /\ x = y \/ R x y.
  Proof using Rtrans. induction 1 as [ | ? ? ? ? ? ? [ [] | ] ]; subst; eauto. Qed.

  Corollary chain_irrefl n x :~ chain R (S n) x x.
  Proof using Rirrefl Rtrans.
    intros H.
    apply chain_trans in H as [ (? & _) | H ]; try easy.
    revert H; apply Rirrefl.
  Qed.

  (* Assume a list over approximating the domain of R *)

  Variable (m : list X) (Hm : forall x y, R x y -> x ∊ m).

  Hint Resolve incl_nil_l incl_cons : core.

  Fact chain_list_incl l x y : chain_list R l x y -> l ⊆ m.
  Proof using Hm. induction 1; simpl; eauto. Qed.

  (* Any chain of length above length m contains a duplicated
      value (by the PHP) hence a non nil sub-chain with identical
      endpoints, contradicting chain_irrefl *)

  Lemma chain_bounded n x y : chain R n x y -> n <= length m.
  Proof using Hm Rirrefl Rtrans.
    intros H.
    destruct (le_lt_dec n (length m)) as [ | C ]; auto.
    destruct chain_chain_list with (1 := H)
      as (ll & H1 & H2).
    cut (list_has_dup ll).
    + intros H3.
      apply list_has_dup_equiv in H3 as (z & l & u & r & ->).
      apply chain_list_app_inv in H1 as (a & _ & H1).
      apply chain_list_cons_inv in H1 as (<- & k & H3 & H1).
      apply chain_list_app_inv in H1 as (p & H4 & H1).
      apply chain_list_cons_inv in H1 as (<- & _ & _ & _).
      apply chain_list_chain in H4.
      destruct (@chain_irrefl (length u) z).
      constructor 2 with k; auto.
    + apply chain_list_incl in H1.
      apply finite_php_dup with (2 := H1); lia.
  Qed.

  (* Since chains have bounded length, we get WF *)

  Hint Resolve chain_bounded : core.

  Theorem wf_strict_order_list : well_founded R.
  Proof using Hm Rirrefl Rtrans. apply wf_chains; eauto. Qed.

End wf_strict_order_list.

Section wf_strict_order_finite.

  Variable (X : Type) (HX : exists l, forall x : X, x ∊ l)
           (R : X -> X -> Prop)
           (Rirrefl : forall x, ~ R x x)
           (Rtrans : forall x y z, R x y -> R y z -> R x z).

  Theorem wf_strict_order_finite : well_founded R.
  Proof using HX Rirrefl Rtrans.
    destruct HX as (m & Hm).
    apply wf_strict_order_list with (m := m); auto.
  Qed.

End wf_strict_order_finite.


Require Import Reals.
Local Open Scope R_scope.
From ValidSDP Require Import validsdp.

Let p (x0 x1 x2 x3 x4 x5 : R) :=
  0
  - ((0 - x1) * x2 - x0 * x3 + x1 * x4 + x2 * x5 - x4 * x5
     + x0 * (0 - x0 + x1 + x2 - x3 + x4 + x5)).

Let b1 (x0 x1 x2 x3 x4 x5 : R) :=
  (x0 - 4/1) * (3969/625 - x0).

Let b2 (x0 x1 x2 x3 x4 x5 : R) :=
  (x1 - 4/1) * (3969/625 - x1).

Let b3 (x0 x1 x2 x3 x4 x5 : R) :=
  (x2 - 4/1) * (4/1 - x2).

Let b4 (x0 x1 x2 x3 x4 x5 : R) :=
  (x3 - 90601/10000) * (90601/10000 - x3).

Let b5 (x0 x1 x2 x3 x4 x5 : R) :=
  (x4 - 4/1) * (3969/625 - x4).

Let b6 (x0 x1 x2 x3 x4 x5 : R) :=
  (x5 - 4/1) * (4/1 - x5).

Theorem p_nonneg (x0 x1 x2 x3 x4 x5 : R) :
  b1 x0 x1 x2 x3 x4 x5 >= 0 ->
  b2 x0 x1 x2 x3 x4 x5 >= 0 ->
  b3 x0 x1 x2 x3 x4 x5 >= 0 ->
  b4 x0 x1 x2 x3 x4 x5 >= 0 ->
  b5 x0 x1 x2 x3 x4 x5 >= 0 ->
  b6 x0 x1 x2 x3 x4 x5 >= 0 ->
  p x0 x1 x2 x3 x4 x5 >= 0.
Proof.
unfold b1, b2, b3, b4, b5, b6, p.
validsdp.
Qed.


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

Require Import Arith Max Omega List Permutation.

Require Import tacs rel_utils list_utils.
Require Import finite.

Require Import tree proof.

Require Import list_contract formula sequent_rules.

Set Implicit Arguments.

Local Notation " g '|--' a " := ((g,a):Seq) (at level 70, no associativity).
Local Notation " l 'c>>' m " := (list_contract Form_eq_dec l m) (at level 70, no associativity).

Section LI1.

  Definition LI1_rules    :=     rule_id
                            cup2 LR_rule_r
                            cup2 LR_rule_l
                            cup2 rule_cntr
                            cup2 rule_weak.

  Definition LI1_rules_wc :=     LI1_rules
                            cup2 rule_cut.

  (* LI1 rules are decidable and thus can be reified *)

  Fact LI1_rules_reif c h : LI1_rules c h -> { rule_id   c h }
                                           + { LR_rule_r c h }
                                           + { LR_rule_l c h }
                                           + { rule_cntr c h }
                                           + { rule_weak c h }.
  Proof.
    intros H.
    unfold LI1_rules in H.
    destruct (rule_id_dec c h);
    destruct (LR_rule_r_dec c h);
    destruct (LR_rule_l_dec c h);
    destruct (rule_cntr_dec c h);
    destruct (rule_weak_dec c h); tauto.
  Qed.

  Fact LI1_rules_wc_reif c h : LI1_rules_wc c h -> { rule_id    c h }
                                                 + { LR_rule_r  c h }
                                                 + { LR_rule_l  c h }
                                                 + { rule_cntr  c h }
                                                 + { rule_weak  c h }
                                                 + { rule_cut   c h }.
  Proof.
    intros H.
    unfold LI1_rules_wc, LI1_rules in H.
    destruct (rule_id_dec c h);
    destruct (LR_rule_r_dec c h);
    destruct (LR_rule_l_dec c h);
    destruct (rule_cntr_dec c h);
    destruct (rule_weak_dec c h);
    destruct (rule_cut_dec c h); tauto.
  Qed.

  Definition LI1_cf_bprovable n s := exists t, bproof LI1_rules n s t.

  Definition LI1_proof s := { n : _ & { t | bproof LI1_rules_wc n s t } }.
  Definition LI1_cf_proof s := { n : _ & { t | bproof LI1_rules n s t } }.

  Definition LI1_provable s := inhabited (LI1_proof s).
  Definition LI1_cf_provable s := exists n t, bproof LI1_rules n s t.

  Fact LI1_rule_b_id n a : LI1_cf_bprovable (S n) (a :: nil |-- a).
  Proof.
    exists (in_tree ( (a :: nil) |-- a ) nil).
    apply rules_id.
    intros ? ?; cbv; tauto.
  Qed.

  Fact LI1_rule_id a : LI1_proof (a :: nil |-- a).
  Proof.
    exists 1, (in_tree ( (a :: nil) |-- a ) nil).
    apply rules_id.
    intros ? ?; cbv; tauto.
  Qed.

  Fact LI1_cf_provable_id a : LI1_cf_provable (a :: nil |-- a).
  Proof. exists 1; apply LI1_rule_b_id. Qed.

  Fact LI1_provable_id a : LI1_provable (a :: nil |-- a).
  Proof. exists; apply LI1_rule_id. Qed.

  Fact LI1_rule_b_r n ga a b : LI1_cf_bprovable n     (a::ga |-- b)
                            -> LI1_cf_bprovable (S n) (ga |-- a %> b).
  Proof.
    intros (t & H).
    exists (in_tree (ga |-- a %> b) (t::nil)).
    apply LR_rules_imp_r; auto.
    intros ? ?; cbv; tauto.
  Qed.

  Fact LI1_rule_r ga a b : LI1_proof (a::ga |-- b)
                        -> LI1_proof (ga |-- a %> b).
  Proof.
    intros (n & t & H).
    exists (S n), (in_tree (ga |-- a %> b) (t::nil)).
    apply LR_rules_imp_r; auto.
    intros ? ?; cbv; tauto.
  Qed.

  Fact LI1_cf_provable_r ga a b : LI1_cf_provable (a::ga |-- b)
                               -> LI1_cf_provable (ga |-- a %> b).
  Proof. intros (n & Hn); exists (S n); revert Hn; apply LI1_rule_b_r. Qed.

  Fact LI1_provable_r ga a b : LI1_provable (a::ga |-- b)
                            -> LI1_provable (ga |-- a %> b).
  Proof. intros [H]; exists; revert H; apply LI1_rule_r. Qed.

  Fact LI1_rule_b_l n ga de th a b d :
         th ~p (a %> b) :: ga ++ de
      -> LI1_cf_bprovable n (ga  |-- a)
      -> LI1_cf_bprovable n (b::de |-- d)
      -> LI1_cf_bprovable (S n) (th  |-- d).
  Proof.
    intros H1 (tg & Htg) (td & Htd).
    exists (in_tree (th |-- d) (tg :: td :: nil)).
    apply LR_rules_imp_l with ga de a b; auto.
    intros ? ?; cbv; tauto.
  Qed.

  Fact LI1_rule_l ga de th a b d :
         th ~p (a %> b) :: ga ++ de
      -> LI1_proof (ga  |-- a)
      -> LI1_proof (b::de |-- d)
      -> LI1_proof (th  |-- d).
  Proof.
    intros H1 (ng & tg & Htg) (nd & td & Htd).
    exists (S (max ng nd)), (in_tree (th |-- d) (tg :: td :: nil)).
    apply LR_rules_imp_l with ga de a b; auto.
    intros ? ?; cbv; tauto.
    revert Htg; apply bproof_mono, le_max_l.
    revert Htd; apply bproof_mono, le_max_r.
  Qed.

  Fact LI1_cf_provable_l ga de th a b d :
         th ~p (a %> b) :: ga ++ de
      -> LI1_cf_provable (ga  |-- a)
      -> LI1_cf_provable (b::de |-- d)
      -> LI1_cf_provable (th  |-- d).
  Proof.
    intros H1 (n & tn & Hn) (p & tp & Hp); exists (S (max n p)).
    apply LI1_rule_b_l with (1 := H1).
    exists tn; revert Hn; apply bproof_mono, le_max_l.
    exists tp; revert Hp; apply bproof_mono, le_max_r.
  Qed.

  Fact LI1_provable_l ga de th a b d :
         th ~p (a %> b) :: ga ++ de
      -> LI1_provable (ga  |-- a)
      -> LI1_provable (b::de |-- d)
      -> LI1_provable (th  |-- d).
  Proof.
    intros H1 [H2] [H3]; exists; revert H1 H2 H3; apply LI1_rule_l.
  Qed.

  Fact LI1_rule_b_cntr n ga th x a :
         ga ~p x :: th
      -> LI1_cf_bprovable n (x :: x :: th |-- a)
      -> LI1_cf_bprovable (S n) (ga |-- a).
  Proof.
    intros H2 (t & Ht).
    exists (in_tree (ga |-- a) (t::nil)).
    apply rules_cntr with th x; auto.
    intros ? ?; cbv; tauto.
  Qed.

  Fact LI1_rule_cntr ga th x a :
         ga ~p x :: th
      -> LI1_proof (x :: x :: th |-- a)
      -> LI1_proof (ga |-- a).
  Proof.
    intros H2 (n & t & Ht).
    exists (S n), (in_tree (ga |-- a) (t::nil)).
    apply rules_cntr with th x; auto.
    intros ? ?; cbv; tauto.
  Qed.

  Fact LI1_cf_provable_cntr ga th x a :
         ga ~p x :: th
      -> LI1_cf_provable (x :: x :: th |-- a)
      -> LI1_cf_provable (ga |-- a).
  Proof. intros H1 (n & Hn); exists (S n); revert Hn; apply LI1_rule_b_cntr; auto. Qed.

  Fact LI1_provable_cntr ga th x a :
         ga ~p x :: th
      -> LI1_provable (x :: x :: th |-- a)
      -> LI1_provable (ga |-- a).
  Proof.
    intros H1 [H2]; exists; revert H1 H2; apply LI1_rule_cntr.
  Qed.

  Fact LI1_rule_b_weak n ga th x a :
         ga ~p x :: th
      -> LI1_cf_bprovable n (th |-- a)
      -> LI1_cf_bprovable (S n) (ga |-- a).
  Proof.
    intros H2 (t & Ht).
    exists (in_tree (ga |-- a) (t::nil)).
    apply rules_weak with th x; auto.
    intros ? ?; cbv; tauto.
  Qed.

  Fact LI1_rule_weak ga th x a :
         ga ~p x :: th
      -> LI1_proof (th |-- a)
      -> LI1_proof (ga |-- a).
  Proof.
    intros H2 (n & t & Ht).
    exists (S n), (in_tree (ga |-- a) (t::nil)).
    apply rules_weak with th x; auto.
    intros ? ?; cbv; tauto.
  Qed.

  Fact LI1_cf_provable_weak ga th x a :
         ga ~p x :: th
      -> LI1_cf_provable (th |-- a)
      -> LI1_cf_provable (ga |-- a).
  Proof. intros H1 (n & Hn); exists (S n); revert Hn; apply LI1_rule_b_weak with x; auto. Qed.

  Fact LI1_provable_weak ga th x a :
         ga ~p x :: th
      -> LI1_provable (th |-- a)
      -> LI1_provable (ga |-- a).
  Proof.
    intros H1 [H2]; exists; revert H1 H2; apply LI1_rule_weak.
  Qed.

  Fact LI1_rule_cut ga de th a b :
         th ~p ga ++ de
      -> LI1_proof (ga |-- a)
      -> LI1_proof (a::de |-- b)
      -> LI1_proof (th |-- b).
  Proof.
    intros H1 (na & ta & Hta) (nd & td & Htd).
    exists (S (max na nd)), (in_tree (th |-- b) (ta::td::nil)).
    apply rules_cut with ga de a; auto.
    intros ? ?; cbv; tauto.
    revert Hta; apply bproof_mono, le_max_l.
    revert Htd; apply bproof_mono, le_max_r.
  Qed.

  Fact LI1_provable_cut ga de th a b :
         th ~p ga ++ de
      -> LI1_provable (ga |-- a)
      -> LI1_provable (a::de |-- b)
      -> LI1_provable (th |-- b).
  Proof. intros H1 [H2] [H3]; exists; revert H1 H2 H3; apply LI1_rule_cut. Qed.

  (* Induction principles for LI1 bounded proofs, LI1 proofs,
     LI1 bounded provability, LI1 provability *)

  Section LI1_bproof_rect.

    Variable P : nat -> Seq -> Type.

    Hypothesis HP1 : forall n A, P (S n) (A :: nil |-- A).

    Hypothesis HP2 : forall n ga A B,   P n (A :: ga |-- B)
                                     -> P (S n) (ga |-- A %> B).

    Hypothesis HP3 : forall n ga de th A B C,
                                        th ~p (A %> B) :: ga ++ de
                                     -> P n (ga |-- A)
                                     -> P n (B :: de |-- C)
                                     -> P (S n) (th |-- C).

    Hypothesis HP4 : forall n de th A B,
                                        de ~p A :: th
                                     -> P n (A :: A :: th |-- B)
                                     -> P (S n) (de |-- B).

    Hypothesis HP5 : forall n de th A B,
                                        de ~p A :: th
                                     -> P n (th |-- B)
                                     -> P (S n) (de |-- B).

    Hypothesis HP6 : forall n ga de th A B,
                                        th ~p ga ++ de
                                     -> P n (ga |-- A)
                                     -> P n (A :: de |-- B)
                                     -> P (S n) (th |-- B).

    Theorem LI1_bproof_rect n s t : bproof LI1_rules_wc n s t -> P n s.
    Proof.
      induction 1 as [ n x ll tt H2 H3 H4 ] using bproof_rect.

      apply LI1_rules_wc_reif in H2.
      destruct H2 as [ [ [ [ [ H2 | H2 ] | H2 ] | H2 ] | H2 ] | H2 ].

      apply rule_id_reif in H2.
      destruct H2 as (a & Ha); cbv in Ha.
      inversion Ha; subst x ll; apply HP1.

      apply LR_rule_r_reif in H2.
      destruct H2 as ( ((ga,a),b) & E).
      cbv in E; inversion E; subst x ll; apply HP2.
      apply Forall2_cons_inv_l in H3.
      destruct H3 as (t' & mm & H3 & H5 & H6).
      apply Forall2_nil_inv_l in H6; subst mm.
      apply H4 with t'; auto.

      apply LR_rule_l_reif in H2.
      destruct H2 as ( ((((((ga,de),th),a),b),d) & H) & E).
      cbv in E; inversion E; subst x ll.
      apply Forall2_cons_inv_l in H3.
      destruct H3 as (ta & mma & H3 & H5 & H6).
      apply Forall2_cons_inv_l in H6.
      destruct H6 as (tb & mmb & H6 & H7 & H8).
      apply Forall2_nil_inv_l in H8; subst mmb.
      subst.
      apply HP3 with ga de a b; auto.
      apply H4 with ta; auto.
      apply H4 with tb; auto.

      apply rule_cntr_reif in H2.
      destruct H2 as ( ((((ga,th),a),b) & H) & E).
      cbv in E; inversion E; subst x ll.
      apply Forall2_cons_inv_l in H3.
      destruct H3 as (t' & mm & H3 & H7 & H8).
      apply Forall2_nil_inv_l in H8; subst.
      apply HP4 with th a; auto.
      apply H4 with t'; auto.

      apply rule_weak_reif in H2.
      destruct H2 as ( ((((ga,th),a),b) & H) & E).
      cbv in E; inversion E; subst x ll.
      apply Forall2_cons_inv_l in H3.
      destruct H3 as (t' & mm & H3 & H7 & H8).
      apply Forall2_nil_inv_l in H8; subst.
      apply HP5 with th a; auto.
      apply H4 with t'; auto.

      apply rule_cut_reif in H2.
      destruct H2 as ( (((((ga,de),th),a),b) & H) & E).
      cbv in E; inversion E; subst x ll.
      apply Forall2_cons_inv_l in H3.
      destruct H3 as (ta & mm & H3 & H7 & H8).
      apply Forall2_cons_inv_l in H8.
      destruct H8 as (tb & mmb & H8 & H9 & H10).
      apply Forall2_nil_inv_l in H10; subst.
      apply HP6 with ga de a; auto.
      apply H4 with ta; auto.
      apply H4 with tb; auto.
    Qed.

  End LI1_bproof_rect.

  Section LI1_cf_bproof_rect.

    Variable P : nat -> Seq -> Type.

    Hypothesis HP1 : forall n A, P (S n) (A :: nil |-- A).

    Hypothesis HP2 : forall n ga A B,   P n (A :: ga |-- B)
                                     -> P (S n) (ga |-- A %> B).

    Hypothesis HP3 : forall n ga de th A B C,
                                        th ~p (A %> B) :: ga ++ de
                                     -> P n (ga |-- A)
                                     -> P n (B :: de |-- C)
                                     -> P (S n) (th |-- C).

    Hypothesis HP4 : forall n de th A B,
                                        de ~p A :: th
                                     -> P n (A :: A :: th |-- B)
                                     -> P (S n) (de |-- B).

    Hypothesis HP5 : forall n de th A B,
                                        de ~p A :: th
                                     -> P n (th |-- B)
                                     -> P (S n) (de |-- B).

    Theorem LI1_cf_bproof_rect n s t : bproof LI1_rules n s t -> P n s.
    Proof.
      induction 1 as [ n x ll tt H2 H3 H4 ] using bproof_rect.

      apply LI1_rules_reif in H2.
      destruct H2 as [ [ [ [ H2 | H2 ] | H2 ] | H2 ] | H2 ].

      apply rule_id_reif in H2.
      destruct H2 as (a & Ha); cbv in Ha.
      inversion Ha; subst x ll; apply HP1.

      apply LR_rule_r_reif in H2.
      destruct H2 as ( ((ga,a),b) & E).
      cbv in E; inversion E; subst x ll; apply HP2.
      apply Forall2_cons_inv_l in H3.
      destruct H3 as (t' & mm & H3 & H5 & H6).
      apply Forall2_nil_inv_l in H6; subst mm.
      apply H4 with t'; auto.

      apply LR_rule_l_reif in H2.
      destruct H2 as ( ((((((ga,de),th),a),b),d) & H) & E).
      cbv in E; inversion E; subst x ll.
      apply Forall2_cons_inv_l in H3.
      destruct H3 as (ta & mma & H3 & H5 & H6).
      apply Forall2_cons_inv_l in H6.
      destruct H6 as (tb & mmb & H6 & H7 & H8).
      apply Forall2_nil_inv_l in H8; subst mmb.
      subst.
      apply HP3 with ga de a b; auto.
      apply H4 with ta; auto.
      apply H4 with tb; auto.

      apply rule_cntr_reif in H2.
      destruct H2 as ( ((((ga,th),a),b) & H) & E).
      cbv in E; inversion E; subst x ll.
      apply Forall2_cons_inv_l in H3.
      destruct H3 as (t' & mm & H3 & H7 & H8).
      apply Forall2_nil_inv_l in H8; subst.
      apply HP4 with th a; auto.
      apply H4 with t'; auto.

      apply rule_weak_reif in H2.
      destruct H2 as ( ((((ga,th),a),b) & H) & E).
      cbv in E; inversion E; subst x ll.
      apply Forall2_cons_inv_l in H3.
      destruct H3 as (t' & mm & H3 & H7 & H8).
      apply Forall2_nil_inv_l in H8; subst.
      apply HP5 with th a; auto.
      apply H4 with t'; auto.
    Qed.

  End LI1_cf_bproof_rect.

  Definition LI1_bproof_ind (P : _ -> _ -> Prop) := LI1_bproof_rect P.

  Section LI1_cf_bprovable_ind.

    Variable P : nat -> Seq -> Prop.

    Hypothesis HP1 : forall n A, P (S n) (A :: nil |-- A).

    Hypothesis HP2 : forall n ga A B,   P n (A :: ga |-- B)
                                     -> P (S n) (ga |-- A %> B).

    Hypothesis HP3 : forall n ga de th A B C,
                                        th ~p (A %> B) :: ga ++ de
                                     -> P n (ga |-- A)
                                     -> P n (B :: de |-- C)
                                     -> P (S n) (th |-- C).

    Hypothesis HP4 : forall n de th A B,
                                        de ~p A :: th
                                     -> P n (A :: A :: th |-- B)
                                     -> P (S n) (de |-- B).

    Hypothesis HP5 : forall n de th A B,
                                        de ~p A :: th
                                     -> P n (th |-- B)
                                     -> P (S n) (de |-- B).

    Theorem LI1_cf_bprovable_ind n s : LI1_cf_bprovable n s -> P n s.
    Proof.
      intros (t & Ht); revert Ht.
      apply LI1_cf_bproof_rect; auto.
    Qed.

  End LI1_cf_bprovable_ind.

  Section LI1_proof_rect.

    Variable P : Seq -> Type.

    Hypothesis HP1 : forall A, P (A :: nil |-- A).

    Hypothesis HP2 : forall ga A B,     P (A :: ga |-- B)
                                     -> P (ga |-- A %> B).

    Hypothesis HP3 : forall ga de th A B C,
                                        th ~p (A %> B) :: ga ++ de
                                     -> P (ga |-- A)
                                     -> P (B :: de |-- C)
                                     -> P (th |-- C).

    Hypothesis HP4 : forall de th A B,
                                        de ~p A :: th
                                     -> P (A :: A :: th |-- B)
                                     -> P (de |-- B).

    Hypothesis HP5 : forall de th A B,
                                        de ~p A :: th
                                     -> P (th |-- B)
                                     -> P (de |-- B).

    Hypothesis HP6 : forall ga de th A B,
                                        th ~p ga ++ de
                                     -> P (ga |-- A)
                                     -> P (A :: de |-- B)
                                     -> P (th |-- B).

    Theorem LI1_proof_rect s : LI1_proof s -> P s.
    Proof.
      intros (n & t & Ht); revert n s t Ht.
      apply LI1_bproof_rect with (P := fun _ s => P s); auto.
    Qed.

  End LI1_proof_rect.

  Section LI1_provable_ind.

    Variable P : Seq -> Prop.

    Hypothesis HP1 : forall A, P (A :: nil |-- A).

    Hypothesis HP2 : forall ga A B,     P (A :: ga |-- B)
                                     -> P (ga |-- A %> B).

    Hypothesis HP3 : forall ga de th A B C,
                                        th ~p (A %> B) :: ga ++ de
                                     -> P (ga |-- A)
                                     -> P (B :: de |-- C)
                                     -> P (th |-- C).

    Hypothesis HP4 : forall de th A B,
                                        de ~p A :: th
                                     -> P (A :: A :: th |-- B)
                                     -> P (de |-- B).

    Hypothesis HP5 : forall de th A B,
                                        de ~p A :: th
                                     -> P (th |-- B)
                                     -> P (de |-- B).

    Hypothesis HP6 : forall ga de th A B,
                                        th ~p ga ++ de
                                     -> P (ga |-- A)
                                     -> P (A :: de |-- B)
                                     -> P (th |-- B).

    Theorem LI1_provable_ind s : LI1_provable s -> P s.
    Proof.
      intros [ H ]; revert H.
      apply LI1_proof_rect; assumption.
    Qed.

  End LI1_provable_ind.

  Section LI1_cf_proof_rect.

    Variable P : Seq -> Type.

    Hypothesis HP1 : forall A, P (A :: nil |-- A).

    Hypothesis HP2 : forall ga A B,     P (A :: ga |-- B)
                                     -> P (ga |-- A %> B).

    Hypothesis HP3 : forall ga de th A B C,
                                        th ~p (A %> B) :: ga ++ de
                                     -> P (ga |-- A)
                                     -> P (B :: de |-- C)
                                     -> P (th |-- C).

    Hypothesis HP4 : forall de th A B,
                                        de ~p A :: th
                                     -> P (A :: A :: th |-- B)
                                     -> P (de |-- B).

    Hypothesis HP5 : forall de th A B,
                                        de ~p A :: th
                                     -> P (th |-- B)
                                     -> P (de |-- B).

    Theorem LI1_cf_proof_rect s : LI1_cf_proof s -> P s.
    Proof.
      intros (n & t & Ht); revert Ht.
      apply LI1_cf_bproof_rect with (P := fun _ s => P s) (n := n); auto.
    Qed.

  End LI1_cf_proof_rect.

  Section LI1_cf_provable_ind.

    Variable P : Seq -> Prop.

    Hypothesis HP1 : forall A, P (A :: nil |-- A).

    Hypothesis HP2 : forall ga A B,     P (A :: ga |-- B)
                                     -> P (ga |-- A %> B).

    Hypothesis HP3 : forall ga de th A B C,
                                        th ~p (A %> B) :: ga ++ de
                                     -> P (ga |-- A)
                                     -> P (B :: de |-- C)
                                     -> P (th |-- C).

    Hypothesis HP4 : forall de th A B,
                                        de ~p A :: th
                                     -> P (A :: A :: th |-- B)
                                     -> P (de |-- B).

    Hypothesis HP5 : forall de th A B,
                                        de ~p A :: th
                                     -> P (th |-- B)
                                     -> P (de |-- B).

    Theorem LI1_cf_provable_ind s : LI1_cf_provable s -> P s.
    Proof.
      intros (n & Hn).
      apply LI1_cf_bprovable_ind with (P := fun _ s => P s) (n := n); auto.
    Qed.

  End LI1_cf_provable_ind.

  Section LI1_cf_perm.

    Let bproof_perm_rec n c d : LI1_cf_bprovable n c
                             -> fst c ~p fst d
                             -> snd c = snd d
                             -> LI1_cf_bprovable n d.
    Proof.
      intros H; revert H d.
      induction 1 as [ n a
                     | n ga a b IH
                     | n ga de th a b x G1 G3 G4
                     | n de th a x G2 G3
                     | n de th a x G2 G3 ] using LI1_cf_bprovable_ind;
        intros (ka,d); simpl; intros E1 E2; subst d.

      apply Permutation_length_1_inv in E1; subst ka.
      apply LI1_rule_b_id.

      apply LI1_rule_b_r, IH; simpl; auto.

      apply LI1_rule_b_l with ga de a b.
      apply perm_trans with (2 := G1), Permutation_sym; auto.
      apply G3; auto.
      apply G4; auto.

      apply LI1_rule_b_cntr with th a; auto.
      apply perm_trans with (2 := G2), Permutation_sym; auto.

      apply LI1_rule_b_weak with th a; auto.
      apply perm_trans with (2 := G2), Permutation_sym; auto.
    Qed.

    Lemma LI1_cf_bprovable_perm n ga de a :
            ga ~p de
         -> LI1_cf_bprovable n (ga |-- a)
         -> LI1_cf_bprovable n (de |-- a).
    Proof.
      intros H1 H2.
      apply bproof_perm_rec with (1 := H2); auto.
    Qed.

    Lemma LI1_cf_provable_perm ga de a :
            ga ~p de
         -> LI1_cf_provable (ga |-- a)
         -> LI1_cf_provable (de |-- a).
    Proof.
      intros H1 (n & H2); exists n; revert H2; apply LI1_cf_bprovable_perm; auto.
    Qed.

  End LI1_cf_perm.

  Lemma LI1_cf_provable_contract ga de x :
            ga c>> de
         -> LI1_cf_provable (ga |-- x)
         -> LI1_cf_provable (de |-- x).
  Proof.
    intros H; revert x.
    apply list_contract_one_rect with (eqX_dec := Form_eq_dec) (4 := H);
      clear ga de H.
    intros ga de ? ?; apply LI1_cf_provable_perm; auto.
    intros ? ? ?; apply LI1_cf_provable_cntr; auto.
    auto.
  Qed.

  Lemma LI1_cf_provable_weakening ga de x :
         LI1_cf_provable (ga |-- x)
      -> LI1_cf_provable (ga ++ de |-- x).
  Proof.
    intros H.
    induction de as [ | a de IHde ].
    rewrite <- app_nil_end; auto.
    apply LI1_cf_provable_weak with (ga++de) a; auto.
    apply Permutation_sym, Permutation_cons_app; auto.
  Qed.

  Section LI1_perm.

    Let provable_perm_rec c :
                         LI1_provable c
                      -> forall d,
                         fst c ~p fst d
                      -> snd c = snd d
                      -> LI1_provable d.
    Proof.
      induction 1 as [ A
                     | ga A B IH
                     | ga de th A B C H1 IH1 IH2
                     | ga de A B IH
                     | ga de A B IH
                     | ga de th A B IH1 IH2 ] using LI1_provable_ind;
        intros (rho,D); simpl; intros E1 E2; subst D.

      apply Permutation_length_1_inv in E1; subst rho.
      apply LI1_provable_id.

      apply LI1_provable_r, IH; simpl; auto.

      apply LI1_provable_l with ga de A B; auto.
      apply perm_trans with (1 := Permutation_sym E1); auto.

      apply LI1_provable_cntr with de A; auto.
      apply perm_trans with (1 := Permutation_sym E1); auto.

      apply LI1_provable_weak with de A; auto.
      apply perm_trans with (1 := Permutation_sym E1); auto.

      apply LI1_provable_cut with ga de A; auto.
      apply perm_trans with (1 := Permutation_sym E1); auto.
    Qed.

    Lemma LI1_provable_perm ga de a :
           ga ~p de
        -> LI1_provable (ga |-- a)
        -> LI1_provable (de |-- a).
    Proof.
      intros H1 H2.
      apply provable_perm_rec with (1 := H2); auto.
    Qed.

  End LI1_perm.

  Lemma LI1_provable_contract ga de x :
         ga c>> de
      -> LI1_provable (ga |-- x)
      -> LI1_provable (de |-- x).
  Proof.
    intros H; revert x.
    apply list_contract_one_rect with (eqX_dec := Form_eq_dec) (4 := H);
      clear ga de H.
    intros ga de ? ?; apply LI1_provable_perm; auto.
    intros ? ? ?; apply LI1_provable_cntr; auto.
    auto.
  Qed.

End LI1.


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

Require Import List.

Require Import basics.
Require Import preord.
Require Import categories.
Require Import sets.
Require Import finsets.
Require Import esets.
Require Import effective.
Require Import directed.
Require Import plotkin.

Definition is_lub (A:preord) (x y z:A) :=
  x ≤ z /\ y ≤ z /\ forall z', x ≤ z' -> y ≤ z' -> z ≤ z'.
Arguments is_lub [A] x y z.

Record cusl (A:preord) :=
  { cusl_lub : forall x y:A,
                 { z | is_lub x y z } +
                 { forall z, x ≤ z -> y ≤ z -> False }
  }.

Lemma cusl_finset (A:preord) (C:cusl A) (X:finset A) (HX:inh true X) :
  { z | least_upper_bound z X } + { forall z, upper_bound z X -> False }.
Proof.
  revert HX. induction X; intros.
  elimtype False. hnf in HX.
  destruct HX. apply nil_elem in H. auto.
  destruct X.
  left. exists a.
  split.
  hnf; intros. apply cons_elem in H. destruct H.
  rewrite H. auto. apply nil_elem in H. elim H.
  intros. apply H. apply cons_elem; auto.
  destruct IHX.
  exists c. apply cons_elem. auto.
  destruct s.
  destruct (cusl_lub A C x a).
  destruct s as [z [?[??]]].
  left. exists z.
  split. hnf; intros.
  apply cons_elem in H2. destruct H2.
  rewrite H2. auto.
  rewrite <- H. apply l. auto.
  intros. apply H1.
  destruct l. apply H4.
  red; intros.
  apply H2. apply cons_elem; auto.
  apply H2. apply cons_elem; auto.
  right; intros.
  apply (f z).
  destruct l. apply H1.
  red; intros. apply H. apply cons_elem; auto.
  apply H. apply cons_elem; auto.
  right; intros.
  apply (f z).
  red; intros. apply H. apply cons_elem; auto.
Qed.

Fixpoint calc_lubs A (C:cusl A) (l:list (finset A)) : finset A :=
  match l with
  | nil => nil
  | x::l' =>
      match inh_dec A true x with
      | left Hx =>
        match cusl_finset A C x Hx with
        | inleft (exist z Hz) => z::nil
        | inright _ => nil
        end
      | right Hx => nil
      end ++ calc_lubs A C l'
  end.

Lemma calc_lubs_correct A C l z :
  z ∈ calc_lubs A C l <-> exists x, In x l /\ inh true x /\ least_upper_bound z x.
Proof.
  induction l; simpl.
  split; intros.
  apply nil_elem in H; elim H.
  destruct H as [?[??]]. elim H.
  destruct (inh_dec A true a).
  destruct (cusl_finset A C a i).
  destruct s as [q Hz].
  simpl.
  split; intros.
  apply cons_elem in H. destruct H.
  exists a. split; auto. split; auto.
  rewrite H. auto.
  apply IHl in H.
  destruct H as [x [?[??]]]. exists x; split; auto.
  destruct H as [x [?[??]]]. destruct H. subst x.
  apply cons_elem. left.
  destruct Hz; destruct H1.
  split; auto.
  apply cons_elem; right.  apply IHl. eauto.
  simpl.
  rewrite IHl.
  split; intros [x [?[??]]]; exists x; split; auto.
  destruct H. subst a.
  elim (f z). destruct H1; auto. auto.
  simpl.
  rewrite IHl.
  split; intros [x [?[??]]]; exists x; split; auto.
  destruct H. subst a.
  elim n. hnf; eauto.
  auto.
Qed.

Definition sub_lubs A (C:cusl A) (X:finset A) : finset A :=
  calc_lubs A C (list_finsubsets X).

Lemma sub_lubs_correct A C X lub (HA:ord_dec A) :
  lub ∈ sub_lubs A C X <-> exists Y:finset A, Y ⊆ X /\ inh true Y /\ least_upper_bound lub Y.
Proof.
  unfold sub_lubs.
  rewrite calc_lubs_correct.
  split; intros [Y [?[??]]].
  exists Y. split; auto.
  apply list_finsubsets_correct. exists Y; split; auto.
  apply list_finsubsets_complete in H; auto.
  destruct H as [Y' [??]].
  exists Y'. split; auto.
  split.
  destruct H0 as [q ?]. exists q. rewrite <- H2; auto.
  rewrite <- H2. auto.
Qed.

Lemma cusl_has_normals (A:preord) (Heff:effective_order A) (C:cusl A) : has_normals A Heff true.
Proof.
  red; intros.
  exists (X ++ sub_lubs A C X).
  split.
  red; intros. apply app_elem; auto.
  split.
  destruct Hinh as [q ?]. exists q. apply app_elem. auto.
  intros. apply prove_directed. auto.
  intros.
  apply finsubset_elem in H.
  apply finsubset_elem in H0.
  destruct H. destruct H0.
  destruct (cusl_lub A C x y) as [[q ?]|Hq].
  2: elim (Hq z); auto.
  destruct i as [?[??]].
  exists q. split; auto. split; auto.
  apply finsubset_elem.
  intros. destruct H6. rewrite H8. auto.
  split.
  apply app_elem. right.
  apply sub_lubs_correct.
  constructor. apply (eff_ord_dec A Heff).
  apply app_elem in H.
  apply app_elem in H0.
  destruct H. destruct H0.
  exists (x::y::nil).
    split. apply cons_subset; auto. apply cons_subset; auto. apply nil_subset.
    split. exists x. apply cons_elem; auto.
    split. apply ub_cons; auto. apply ub_cons; auto. apply ub_nil.
    intros. apply H5. apply H6. apply cons_elem; auto.
    apply H6. apply cons_elem. right. apply cons_elem. auto.

  apply sub_lubs_correct in H0.
  destruct H0 as [Y2 [?[??]]].
  exists (x::Y2).
    split.
    red; intros. apply cons_elem in H8. destruct H8.
    rewrite H8; auto. auto.
    split. exists x. apply cons_elem; auto.
    split. red; intros.
    apply cons_elem in H8. destruct H8; auto.
    rewrite H8. auto.
    destruct H7. rewrite <- H4. apply H7; auto.
    intros. apply H5.
    apply H8. apply cons_elem; auto.
    destruct H7. apply H9. red; intros. apply H8.
    apply cons_elem; auto.

  constructor. apply (eff_ord_dec A Heff).
  apply sub_lubs_correct in H.
  destruct H as [Y1 [?[??]]].
  destruct H0.
  exists (y::Y1).
    split.
    red; intros. apply cons_elem in H8. destruct H8.
    rewrite H8; auto. auto.
    split. exists y. apply cons_elem; auto.
    split. red; intros.
    apply cons_elem in H8. destruct H8; auto.
    rewrite H8. auto.
    destruct H7. rewrite <- H3. apply H7; auto.
    intros. apply H5.
    destruct H7. apply H9. red; intros. apply H8.
    apply cons_elem; auto.
    apply H8. apply cons_elem; auto.

  apply sub_lubs_correct in H0.
  destruct H0 as [Y2 [?[??]]].
  exists (Y1++Y2).
    split.
    red; intros. apply app_elem in H10. destruct H10; auto.
    split.
    destruct H6 as [n ?]. exists n. apply app_elem; auto.
    split.
    hnf; intros. apply app_elem in H10. destruct H10.
    destruct H7.
    rewrite <- H3. apply H7; auto.
    destruct H9.
    rewrite <- H4. apply H9; auto.
    intros.
    apply H5.
    destruct H7. apply H11.
    red; intros. apply H10. apply app_elem; auto.
    destruct H9. apply H11.
    red; intros. apply H10. apply app_elem; auto.

  constructor. apply (eff_ord_dec A Heff).
  constructor. apply (eff_ord_dec A Heff).
  apply H5; auto.
  intros. destruct H1. transitivity x0; auto.
  intros. destruct H1. transitivity x0; auto.
Qed.

Definition cusl_plotkin (A:preord) (Heff:effective_order A) (C:cusl A)
  : plotkin_order true A
  :=  norm_plt A Heff true (cusl_has_normals A Heff C).


Require Import Coq.ZArith.ZArith Coq.micromega.Lia.

Local Open Scope Z_scope.
Module Z2Nat.
  Definition inj_nonpos n : n <= 0 -> Z.to_nat n = 0%nat.
  Proof.
    destruct n; try reflexivity; lia.
  Qed.
End Z2Nat.


Require Export Point.Core2D Point.NatPoint1D Point.NatPointCore2D CommonDefinitions.

Module NatPoint2D <: Point2D.
  Definition t := point.
  Definition distT := nat.
  (*Definition min_dist := min.*)
  Definition get_dist (x y : point) := ∥ x -- y ∥².
  Definition x_le p1 p2 := le p1.(x) p2.(x).
  Definition y_le p1 p2 := le p1.(y) p2.(y).
  Definition x_le_dec : forall x y, {x_le x y} + {~x_le x y}
    := fun _ _ => le_dec _ _.
  Definition y_le_dec : forall x y, {y_le x y} + {~y_le x y}
    := fun _ _ => le_dec _ _.
  Definition point_in_strip_close_enough (pt1 : t) (max_square_distance : distT) (pt2 : t) : bool
    := if ((Nat.max (pt1.(y) - pt2.(y)) (pt2.(y) - pt1.(y))) ^ 2 <= 2 * max_square_distance)%dec
       then true
       else false.

  Definition dist_le : distT -> distT -> Prop := le.

  Definition dist_le_dec := le_dec.
  Instance x_le_preo : PreOrder x_le := _.
  Admitted.
  Instance dist_le_preo : PreOrder dist_le := _.
  Instance x_le_paro : @PartialOrder _ eq _ x_le x_le_preo := _.
  Admitted.
  Instance dist_le_paro : @PartialOrder _ eq _ dist_le dist_le_preo := _.
  Instance x_le_total : Total x_le := _.
  Admitted.
  Instance dist_le_total : Total dist_le := _.

  Definition min_dist (x y : distT) : distT
    := if dist_le_dec x y then x else y.

  Module Notations.
  End Notations.
End NatPoint2D.


Require Import List.

Fixpoint rev (x : list nat) (y : list nat) {struct x} : list nat :=
  match x with
    | nil => y
    | cons xh xt => rev xt (cons xh y)
  end.

Eval compute in (rev (cons 1 (cons 2 (cons 3 nil)))) nil.


Require Import Problem Omega.

Lemma diag : forall j, visit j j.
Proof.
  induction j; [constructor|].
  apply visit_down; [omega|].
  assert (forall i, visit i j -> visit i (S j)).
  - induction i; intros.
    * apply (visit_right j); [omega|auto].
    * apply visit_down.
      + inversion_clear H.
        omega.
      + apply IHi.
        inversion_clear H.
        auto.
  - apply H.
    auto.
Qed.

Theorem solution : task.
Proof.
  unfold task.
  induction i; intros.
  - induction j; [constructor|].
    apply (visit_right j); [auto|apply diag].
  - assert (i < j \/ i = j \/ S i = j) by omega.
    destruct H0; [|destruct H0].
    * refine (visit_down _ _ H0 _).
      apply IHi.
      omega.
    * apply visit_down; [|apply IHi]; omega.
    * subst j.
      apply diag.
Qed.


(* Set Printing All imi fuctiona doar cu optiunea "Display all basic low-level contents" (Shift + Alt + A) *)

(* EX 1 : *)

Inductive State :=
| state : nat -> nat -> State.

Notation "{ nr1 , nr2 }" := (state nr1 nr2) (at level 0).

Definition fst (nr : State) : nat :=
  match nr with
  | state nr1 nr2 => nr1
end.

Definition snd (nr : State) : nat :=
  match nr with
  | state nr1 nr2 => nr2
end.

Check {12, 15}.         (* {12, 15}  : State *)
Check fst.              (* fst  : State -> nat *)
Compute fst ({12,15}).  (* = 12   : nat *)
Check snd.              (* snd   : State -> nat *)
Compute snd ({12,15}).  (* = 15  : nat *)

(* EX 2 : *)

(*
A transitiv sistem is defined by : a set of states, a set of initial states, a set of final states and a transition relation

The transitiv sistem is composed off of 2 states s and s', it returns a Prop (a multitude of properties - type, predefined in Coq);
  - comp from s to s' is a relation
  - s and s' are 2 states, we modify the state of s', based off of the state of s
  - "s ~~> s'" is the transitiv relation

The transitiv sistem must have 3 transitiv relations :

  - When the first component is larger than the second     if (comp1 s > comp2 s) it returns (through : ~~>) s'=(comp2 - comp1, comp2)
  - When the second component is larger than the first     if (comp1 s > comp2 s) it returns (through : ~~>) s'=(comp1-comp2, comp2)
  - And when they are equal                                if (comp1 s > comp2 s) it returns (through : ~~>) s'=(=nil)

In the case of a repetitiv change, we just have to processes the outputs;
 - if comp1 > comp2 or comp2 > comp1, we take s'-output and put it into s-input
 - If comp1 = comp2, we exit the comp() with return nil
*)

(* EX 3 : *)

 Reserved Notation "S1 ~~> S2" (at level 31).

 Inductive step (s s' : State) : Prop :=
 | left_gt : (fst s) > (snd s) ->
         s' = {fst s - snd s, snd s} ->              (* <---- Modification *)
         s ~~> s'
 | right_gt : (fst s) < (snd s) ->
         s' = {fst s, snd s - fst s} ->              (* <---- Modification *)
         s ~~> s'
 where "s ~~> s'" := (step s s').

(* EX 4 : *)

Require Import Omega.

Example ex0_step : {6, 3} ~~> {3, 3}.
Proof.
     apply left_gt.
      - simpl. omega.
      - simpl. reflexivity.
Qed.

Example ex1_step : {12, 15} ~~> {12, 3}.
Proof.
    apply right_gt.
     - simpl. omega.
     - simpl. reflexivity.
Qed.

(* EX 5 : *)

 Reserved Notation "A ==> B" (at level 32).
 Inductive steps(s s' : State) : Prop :=
 | refl : s = s' -> s ==> s'
 | tran : forall t,s ~~> t -> t ==> s' -> s ==> s'
 where "s ==> s'" := (steps s s').

 Example ex0_steps : {3, 3} ==> {3, 3}.
 Proof.
     apply refl.
      - reflexivity.
 Qed.

(* EX 6 : *)

 Example ex1_steps: {12, 15} ==> {3, 3}.
 Proof.
     apply tran with (t := {12, 3}).
      - apply ex1_step.
      - apply tran with (t := {9, 3}).
        -- apply left_gt.
          --- simpl. simpl. omega.
          --- simpl. reflexivity.
        -- apply tran with (t := {6,3}).
          --- apply left_gt.
            ---- simpl. simpl. omega.
            ---- simpl. reflexivity.
          --- apply tran with (t := {3, 3}).
            ---- apply left_gt.
                  ----- simpl. simpl. omega.
                  ----- simpl. reflexivity.
            ---- apply refl.
            ----- reflexivity.

Qed.


Require Import Ltacs.
Require Import String.

(* Set Typeclasses Debug. *)

Class Dec (P : Prop) := { dec : P + ~ P }.

Theorem dec_impl_excluded_middle: forall P,
  Dec P ->
  (P \/ ~ P).
Proof.
  intros.
  destruct H; destruct dec0; eauto.
Qed.

Theorem dec_impl_equiv_bool : forall (P : Prop),
  Dec P ->
  exists f, (P <-> f = true) /\ (~ P <-> f = false).
Proof.
  intros.
  dest H.
  dest dec0; eauto.
  - exists true; split; split; eauto; qcon.
  - exists false; split; split; eauto; qcon.
Qed.

Lemma dec_le_nat : forall (a b : nat),
  Dec (a <= b).
Proof.
  induction a; dest b; econstructor; eauto.
  - left. ind b; eauto.
  - right. qcon.
  - specialize IHa with b. dest IHa.
    dest dec0.
    * left. eapply le_n_S. eauto.
    * right. intros HC. eapply le_S_n in HC. cong.
Defined.

#[global]
Instance dec_le_nat_inst (a b : nat) : Dec (a <= b).
eapply dec_le_nat. Defined.

Class DecEq (A : Type) :=
{
  decEq : forall x1 x2 : A, { x1 = x2 } + {x1 <> x2}
}.

Lemma nat_eq_dec' : forall n1 n2 : nat,
    {n1 = n2} + {n1 <> n2}.
Proof with eauto.
  ind n1; destruct n2...
  destruct (IHn1 n2)...
Qed.

(** Setting up some baseline Decidable props related to equality
    - This should allow for the other classes to be easily built
*)

#[global]
Instance nat_eq_dec (n1 n2 : nat) : Dec (n1 = n2).
destruct (nat_eq_dec' n1 n2); constructor; eauto.
Defined.

#[global]
Instance decEq_nat : DecEq nat.
constructor. ind x1; destruct x2; eauto.
specialize IHx1 with x2.
destruct IHx1; eauto. Defined.

#[global]
Instance decEq_string : DecEq string.
constructor. apply string_dec. Defined.

#[global]
Instance decEq_list (A : Type) `{DA : DecEq A} : DecEq (list A).
constructor.
ind x1; dest x2; eauto; try (right; qcon; fail).
(* Checking for list head equality *)
dest DA. dest (decEq0 a a0);
specialize IHx1 with x2;
dest IHx1; subst; eauto; try (right; qcon; congruence).
Defined.

#[global]
Instance decEq_pair (A B : Type) `{DA : DecEq A} `{DB : DecEq B} : DecEq (A * B).
constructor.
ind x1; dest x2; eauto; try (right; qcon; fail).
dest DA; dest DB; dest (decEq0 a a0); dest (decEq1 b b0);
subst; eauto; try (right; qcon; congruence).
Defined.

Class EqClass (A : Type) `{DE : DecEq A} :=
{
  eqb : A -> A -> bool ;
  eqb_leibniz   : forall x y, eqb x y = true <-> x = y  ;
  neqb_leibniz  : forall x y, eqb x y = false <-> x <> y;
}.

Theorem eqb_refl_all : forall {A : Type} `{H : EqClass A} (a : A),
  eqb a a = true.
Proof.
  destruct H; intros.
  rewrite eqb_leibniz0. auto.
Qed.

Definition gen_deceq_eqb {A : Type} `{DE : DecEq A} (a1 a2 : A) : bool :=
  match (decEq a1 a2) with
  | left e => true
  | right e => false
  end.

Theorem gen_deceq_eqb_refl: forall {A : Type} `{DE : DecEq A} (a : A),
  gen_deceq_eqb a a = true.
Proof.
  intros.
  unfold gen_deceq_eqb.
  destruct DE. simpl.
  destruct (decEq0 a a).
  - refl.
  - cong.
Qed.

Lemma gen_eqb_impl_eqb_leibniz : forall {A : Type} `{Eq : DecEq A} (x y : A),
  gen_deceq_eqb x y = true <-> x = y.
Proof.
  unfold gen_deceq_eqb.
  intros.
  destruct (decEq x y); split; eauto; try qcon.
Defined.

Lemma gen_eqb_impl_neqb_leibniz : forall {A : Type} `{Eq : DecEq A} (x y : A),
  gen_deceq_eqb x y = false <-> x <> y.
Proof.
  unfold gen_deceq_eqb.
  intros.
  destruct (decEq x y); split; eauto; try qcon.
Defined.

#[global]
Instance deceq_impl_eqb (A : Type) `{DE : DecEq A} : EqClass A :=
{
  eqb := gen_deceq_eqb ;
  eqb_leibniz := gen_eqb_impl_eqb_leibniz ;
  neqb_leibniz := gen_eqb_impl_neqb_leibniz
}.

Class Partial_Order {A : Type} `{Eq : EqClass A} (R : A -> A -> Prop) :=
{
  po_reflexive : forall (a : A), R a a ;
  po_antiSym : forall (a b : A), R a b -> R b a -> eqb a b = true ;
  po_transitivity : forall (a b c : A),
      R a b ->
      R b c ->
      R a c
}.

Lemma nat_eqb_sn : forall (a b : nat),
  eqb a b = true <->
  eqb (S a) (S b) = true.
Proof.
  ind a; dest b; eauto; split; eauto; intros.
  - unfold eqb, deceq_impl_eqb, gen_deceq_eqb, decEq, decEq_nat, nat_rec, nat_rect in *.
    destruct (match
        (fix F (n : nat) : forall x2 : nat, {n = x2} + {n <> x2} :=
           match n as n0 return (forall x2 : nat, {n0 = x2} + {n0 <> x2}) with
           | 0 =>
               fun x2 : nat =>
               match x2 as n0 return ({0 = n0} + {0 <> n0}) with
               | 0 => left eq_refl
               | S n0 => right (O_S n0)
               end
           | S n0 =>
               fun x2 : nat =>
               match x2 as n1 return ({S n0 = n1} + {S n0 <> n1}) with
               | 0 => right (not_eq_sym (O_S n0))
               | S n1 =>
                   match F n0 n1 with
                   | left a => left (f_equal_nat nat S n0 n1 a)
                   | right b => right (not_eq_S n0 n1 b)
                   end
               end
           end) a b
      with
      | left a0 => left (f_equal_nat nat S a b a0)
      | right b0 => right (not_eq_S a b b0)
      end); eauto.
  - unfold eqb, deceq_impl_eqb, gen_deceq_eqb, decEq, decEq_nat, nat_rec, nat_rect in *.
    destruct (match
          (fix F (n : nat) : forall x2 : nat, {n = x2} + {n <> x2} :=
             match n as n0 return (forall x2 : nat, {n0 = x2} + {n0 <> x2}) with
             | 0 =>
                 fun x2 : nat =>
                 match x2 as n0 return ({0 = n0} + {0 <> n0}) with
                 | 0 => left eq_refl
                 | S n0 => right (O_S n0)
                 end
             | S n0 =>
                 fun x2 : nat =>
                 match x2 as n1 return ({S n0 = n1} + {S n0 <> n1}) with
                 | 0 => right (not_eq_sym (O_S n0))
                 | S n1 =>
                     match F n0 n1 with
                     | left a => left (f_equal_nat nat S n0 n1 a)
                     | right b => right (not_eq_S n0 n1 b)
                     end
                 end
             end) a b
        with
        | left a0 => left (f_equal_nat nat S a b a0)
        | right b0 => right (not_eq_S a b b0)
        end); eauto.
Qed.

#[global]
Instance partial_order_nats : Partial_Order le.
constructor.
- induction a; eauto.
- induction a; destruct b; intros; eauto.
  * inv H0.
  * inv H.
  * eapply le_S_n in H, H0. assert (eqb a b = true). eauto.
    rewrite <- nat_eqb_sn; eauto.
- induction a; dest b; dest c; intros; eauto;
  eapply PeanoNat.Nat.le_trans; eauto.
Defined.

Class Total_Order {A : Type} (R : A -> A -> Prop) `{PO : Partial_Order A R} :=
{
  dec_t_order : forall (a b : A), R a b + R b a
}.

Theorem total_order_invertible : forall {A : Type} {R : A -> A -> Prop}
  `{HT : Total_Order A R} (a b : A),
    a <> b ->
    R a b <-> ~ R b a.
Proof.
  split; intros.
  - dest PO. intros HC.
    pose proof (po_antiSym0 _ _ H0 HC).
    rewrite eqb_leibniz in H1. cong.
  - dest (dec_t_order a b); eauto.
    cong.
Qed.

Require Import List.

#[global]
Instance dec_in {A : Type} `{Heq : EqClass A} (a : A) (l : list A) : Dec (In a l).
constructor.
induction l; smp; eauto.
destruct IHl.
- (* In a l *)
  eauto.
- (* ~ In a l *)
  destruct (eqb a0 a) eqn:E.
  * (* a0 = a *)
    rewrite eqb_leibniz in E. eauto.
  * (* a0 <> a *)
    rewrite neqb_leibniz in E.
    right. qcon.
Defined.

Require Import Lia.

Fixpoint t_order_max_in_list {A : Type} (l : list A)
  (R : A -> A -> Prop) `{TO : Total_Order A R} : option A.
destruct l eqn:L'.
- apply None.
- destruct (t_order_max_in_list A l0 R DE Eq0 PO TO) eqn:Rec.
  * (* rec = Some a0 *)
    destruct (dec_t_order a a0).
    ** (* R a a0 - so a0 max *)
      apply (Some a0).
    ** (* R a0 a - so a max *)
      apply (Some a).
  * (* rec = None *)
    apply (Some a).
Defined.

Class WeakMaximal {A : Type} (R : A -> A -> Prop) :=
{
  weakMaxElemProof : forall (l : list A), l <> nil -> exists (max : A),
      (forall (elem : A), In elem l -> R elem max)
}.

Class Maximal {A : Type} (R : A -> A -> Prop) :=
{
  maxElemProof : forall (l : list A), l <> nil -> exists (max : A),
      ((forall (elem : A), In elem l -> R elem max) /\ In max l)
}.

#[global]
Instance weak_maximal_nats : WeakMaximal le.
constructor.
induction l.
- intros. cong.
- intros.
  destruct l; smp.
  * (* l = nil *)
    exists a; intros; eauto.
    destruct H0; subst; eauto; try exfalso; eauto.
  * (* l = n :: l *)
    assert (n :: l <> nil). {
      clearAll.
      induction l; eauto; try qcon.
    }
    pose proof (IHl H0) as IHl.
    clear H. clear H0.
    destruct IHl as [max' H].
    assert (n < max' \/ n = max' \/ max' < n). lia.
    destruct H0.
    **  (* n < max' *)
        assert (a < max' \/ a = max' \/ max' < a). lia.
        destruct H1.
      *** (* a < max' => max' is greatest *)
          exists max'; intros; eauto.
          destruct H2; eauto; subst; eauto; try lia.
      *** destruct H1.
        ****  (* a = max' => a/max' is greatest *)
              subst.
              exists max'; intros; eauto.
              destruct H1; eauto; subst; eauto; try lia.
        ****  (* max' < a => a is greatest *)
              exists a; intros; eauto.
              destruct H2; eauto; subst; eauto; try lia;
              destruct H2; subst; eauto; try lia.
              eapply PeanoNat.Nat.le_trans.
              eapply H; eauto. lia.
    **  (* n = max' \/ max' < n*)
        destruct H0.
      *** (* n = max' *)
          subst.
          assert (a < max' \/ a = max' \/ max' < a). lia.
          destruct H0.
        ****  exists max'; intros; eauto.
              destruct H1; eauto; subst; eauto; try lia.
        ****  destruct H0.
          ***** subst. (* a = max' *)
                exists max'; intros; eauto.
                destruct H0; eauto.
          ***** (* max' < a *)
                exists a; intros; eauto.
                destruct H1; subst; eauto.
                destruct H1; subst; eauto; try lia.
                eapply PeanoNat.Nat.le_trans.
                eapply H; eauto. lia.
      *** (* max' < n *)
          assert (a < n \/ a = n \/ n < a). lia.
          destruct H1; eauto.
        ****  (* max' < n, a < n -> n greatest *)
              exists n; intros; eauto.
              destruct H2; subst; eauto; try lia.
              destruct H2; subst; eauto; try lia.
              eapply PeanoNat.Nat.le_trans.
              eapply H; eauto. lia.
        ****  (* a = n \/ n < a *)
              destruct H1; subst; eauto.
          ***** (* a = n -> n greatest *)
                exists n; intros; eauto.
                destruct H1; subst; eauto; try lia.
                destruct H1; subst; eauto; try lia.
                eapply PeanoNat.Nat.le_trans.
                eapply H; eauto. lia.
          ***** (* n < a -> a greatest *)
                exists a; intros; eauto.
                destruct H2; subst; eauto; try lia.
                destruct H2; subst; eauto; try lia.
                eapply PeanoNat.Nat.le_trans.
                eapply H; eauto. lia.
Defined.

#[global]
Instance maximal_nats : Maximal le.
constructor.
induction l; intros.
- cong.
- destruct l.
  * (* only a in list, so a = max *)
    exists a; split; smp; eauto.
    intros. destruct H0; try lia.
  * (* a :: n :: l = list *)
    assert (n :: l <> nil). qcon.
    pose proof (IHl H0) as IHl.
    clear H. clear H0.
    destruct IHl as [max' [Hel Hmax]].
    smp.
    destruct Hmax.
    **  (* n = max' *)
        subst.
        assert (a <= max' \/ max' <= a). lia.
        destruct H.
      *** (* a <= max' *)
          exists max'; split; intros; eauto.
          destruct H0 as [H0 | [H1 | H2]]; subst; eauto.
      *** (* max' <= a *)
          exists a; split; intros; eauto.
          destruct H0 as [H0 | [H0 | H0]]; subst; eauto.
          eapply PeanoNat.Nat.le_trans.
          eapply Hel; eauto. lia.
    **  (* In max' l, n <> max also *)
        assert (a <= max' \/ max' <= a). lia.
        destruct H0.
      *** (* a <= max' *)
          exists max'; split; intros; eauto.
          destruct H1 as [H1 | [H1 | H2]]; subst; eauto.
      *** (* max' <= a *)
          exists a; split; intros; eauto.
          destruct H1 as [H1 | [H1 | H1]]; subst; eauto.
        ****  eapply PeanoNat.Nat.le_trans.
              eapply Hel; eauto. lia.
        ****  eapply PeanoNat.Nat.le_trans.
              eapply Hel; eauto. lia.
Defined.

Lemma nat_0_le_sn : forall (n : nat),
  0 <= S n.
Proof.
  induction n; eauto.
Qed.

#[global]
Instance total_order_nat : Total_Order le.
constructor.
induction a; destruct b; eauto.
- left. lia.
- right. lia.
- specialize IHa with b. dest IHa.
  * (* a <= b *)
    left. apply le_n_S; eauto.
  * (* ~ a <= b *)
    right. lia.
Defined.

Class WellFounded {A : Type} (R : A -> A -> Prop) `{PO : Partial_Order A R} :=
{
  min : A ;
  minElemProof :
    (forall (a : A), (R min a)) /\
    (forall (a : A), a <> min -> ~ (R a min))
}.

#[global]
Instance wf_nat : WellFounded le.
pose proof (Build_WellFounded _ le _ _ _ 0).
apply H. clear H.
intros. split.
- induction a; eauto.
- induction a; eauto.
  intros; qcon.
Defined.

Class Defaultable (A : Type) :=
{
  defVal : A
}.

#[global]
Instance nat_defaultable : Defaultable nat :=
{
  defVal := 0
}.

#[global]
Instance string_defaultable : Defaultable string :=
{
  defVal := ""
}.

#[global]
Instance list_defaultable {A : Type} : Defaultable (list A) :=
{
  defVal := nil
}.

#[global]
Instance pair_defaultable {A B : Type} `{HA : Defaultable A} `{HB : Defaultable B} : Defaultable(A * B) :=
{
  defVal := (defVal, defVal)
}.


Require Import A1_Plan A2_Orientation A7_Tactics.
Require Import B1_ClockwiseProp B2_CollinearProp.

Section EQUIORIENTED_PROP.

Lemma EquiOrientedAABC : forall A B C : Point,
	EquiOriented A A B C.
Proof.
	canonize1.
	elim (NotClockwiseAAB _ _ H).
Qed.

Lemma  EquiOrientedNotClockwiseABC : forall A B C D, EquiOriented A B C D -> ~Clockwise A B C.
Proof.
	canonize1.
	elim (NotClockwiseABA C D); auto.
Qed.

Lemma  EquiOrientedNotClockwiseABD : forall A B C D, EquiOriented A B C D -> ~Clockwise A B D.
Proof.
	canonize1.
	elim (NotClockwiseABB C D); auto.
Qed.

Lemma ChangeAllABC : forall A B C D : Point,
	EquiOriented A B C D ->
	A <> B ->
	Collinear A B C ->
	EquiOriented C D A B.
Proof.
	intros; apply ChangeSide.
	 apply ChangeSense; trivial.
	 auto.
Qed.

Lemma ChangeAllBCD : forall A B C D : Point,
	EquiOriented A B C D ->
	A <> B ->
	Collinear B C D ->
	EquiOriented C D A B.
Proof.
	intros; apply ChangeSense.
	 apply ChangeSide; auto.
	 apply (CollinearCBA _ _ _ H1).
Qed.

Lemma ChangeAll : forall A B C D : Point,
	EquiOriented A B C D ->
	A <> B ->
	Collinear A B C \/ Collinear B C D ->
	EquiOriented C D A B.
Proof.
	intros A B C D H H0 H1; destruct H1.
	 apply ChangeAllABC; trivial.
	 apply ChangeAllBCD; trivial.
Qed.

Lemma ChangeSenseABAC : forall A B C : Point,
	EquiOriented A B A C -> EquiOriented B A C A.
Proof.
	intros; apply (ChangeSense _ _ _ _ H).
	apply CollinearABA.
Qed.

Lemma EquiOrientedCollinearCA : forall A B C : Point,
	EquiOriented A B C A -> Collinear A B C.
Proof.
	canonize1.
	 elim (NotClockwiseABA C A); auto.
	 elim (NotClockwiseABA B A); apply (ChangeSide _ _ _ _ H).
	  apply sym_not_eq; apply (ClockwiseDistinctAB _ _ _ H0).
	  apply (ClockwiseBCA _ _ _ H0).
Qed.

Lemma ChangeSenseABCA : forall A B C : Point,
	EquiOriented A B C A -> EquiOriented B A A C.
Proof.
	intros; apply ChangeSense.
	 trivial.
	 apply EquiOrientedCollinearCA; trivial.
Qed.

Lemma ChangeSenseABBC : forall A B C : Point,
	EquiOriented A B B C -> EquiOriented B A C B.
Proof.
	intros; apply ChangeSense.
	 trivial.
	 apply CollinearABB.
Qed.

Lemma EquiOrientedCollinearCB : forall A B C : Point,
	EquiOriented A B C B -> Collinear A B C.
Proof.
	canonize1.
	 elim (NotClockwiseABA C B); auto.
	 elim (NotClockwiseABA A B); apply (ChangeAllBCD _ _ _ _ H).
	  apply sym_not_eq; apply (ClockwiseDistinctAB _ _ _ H0).
	  apply CollinearABA.
	  apply (ClockwiseCAB _ _ _ H0).
Qed.

Lemma EquiOrientedCollinearAC : forall A B C : Point,
	EquiOriented A B A C -> Collinear A B C.
Proof.
	intros; apply CollinearBAC.
	apply EquiOrientedCollinearCB.
	apply ChangeSenseABAC; trivial.
Qed.

Lemma EquiOrientedCollinearBC : forall A B C : Point,
	EquiOriented A B B C -> Collinear A B C.
Proof.
	intros; apply CollinearBAC.
	apply EquiOrientedCollinearCA.
	apply ChangeSenseABBC; trivial.
Qed.

Lemma ChangeSenseABCB : forall A B C : Point,
	EquiOriented A B C B -> EquiOriented B A B C.
Proof.
	intros; apply (ChangeSense _ _ _ _ H).
	apply (EquiOrientedCollinearCB _ _ _ H).
Qed.

Lemma ChangeAllABAC : forall A B C : Point,
	EquiOriented A B A C -> A <> B ->
	EquiOriented A C A B.
Proof.
	intros; apply ChangeSenseABCB.
	apply ChangeSide; trivial.
Qed.

Lemma ChangeAllABCA : forall A B C : Point,
	EquiOriented A B C A -> A <> B ->
	EquiOriented C A A B.
Proof.
	intros; apply ChangeSenseABCA.
	apply ChangeSide; trivial.
Qed.

Lemma ChangeAllABBC : forall A B C : Point,
	EquiOriented A B B C -> A <> B ->
	EquiOriented B C A B.
Proof.
	intros; apply ChangeSenseABBC.
	apply ChangeSide; trivial.
Qed.

Lemma ChangeAllABCB : forall A B C : Point,
	EquiOriented A B C B -> A <> B ->
	EquiOriented C B A B.
Proof.
	intros; apply ChangeSenseABAC.
	apply ChangeSide; trivial.
Qed.

Lemma SegmentEquiOriented : forall A B C : Point,
	B <> C -> Segment A C B ->
	EquiOriented A B B C.
Proof.
	canonize1.
	apply (ChangeSide _ _ _ _ H2); auto.
Qed.

Lemma EquiOrientedTrans : forall A B C D E F : Point,
	EquiOriented A B C D -> EquiOriented C D E F ->
	EquiOriented A B E F.
Proof.
	canonize1.
Qed.

Lemma EquiOrientedTransCollinear : forall A B C D E : Point,
	Collinear B C D ->
	EquiOriented A B D E ->
	EquiOriented B C D E ->
	EquiOriented A C D E.
Proof.
	canonize1.
	decompose [or] (FourthPoint A C M B H).
	 elim (NotClockwiseABB B A).
	   apply (ChangeSide _ _ _ _ H0).
	  apply sym_not_eq; apply (ClockwiseDistinctCA _ _ _ H4).
	  apply (ChangeSense _ _ _ _ H1).
	   canonize1.
	   apply (ClockwiseBCA _ _ _ H4).
	 auto.
	 auto.
Qed.

Lemma EquiOrientedABCDNotCollinearABC : forall A B C D : Point,
	EquiOriented A B C D ->
	 (A<>B /\ Clockwise C D A) \/ (A<>B /\ Clockwise C D B) \/ Clockwise B A D ->
	~Collinear A B C.
Proof.
	intuition.
	 elim (NotClockwiseABA A B).
	   apply (ChangeAll _ _ _ _ H); intuition.
	 elim (NotClockwiseABB A B).
	   apply (ChangeAll _ _ _ _ H); intuition.
	 elim (NotClockwiseABA D C).
	   apply (ChangeSense _ _ _ _ H); intuition.
Qed.

Lemma EquiOrientedABCDNotCollinearBCD : forall A B C D : Point,
	EquiOriented A B C D ->
	A <> B ->
	Clockwise C D A ->
	~Collinear B C D .
Proof.
	intuition.
	elim (NotClockwiseABA A B).
	apply (ChangeAll _ _ _ _ H); intuition.
Qed.

Lemma EquiOrientedABCDNotClockwiseCDA : forall A B C D : Point,
	EquiOriented A B C D ->
	A <> B ->
	Collinear A B C \/ Collinear B C D ->
	~Clockwise C D A.
Proof.
	intuition.
	 elim (NotClockwiseABA A B).
	   apply (ChangeAll _ _ _ _ H); intuition.
	 elim (NotClockwiseABA A B).
	   apply (ChangeAll _ _ _ _ H); intuition.
Qed.

Lemma EquiOrientedABCDNotClockwiseDCA : forall A B C D : Point,
	EquiOriented A B C D ->
	A <> B ->
	~Clockwise D C A.
Proof.
	intuition.
	elim (NotClockwiseABB B A).
	apply (ChangeSide _ _ _ _ H); intuition.
Qed.

Lemma EquiOrientedABCDNotClockwiseCDB : forall A B C D : Point,
	EquiOriented A B C D ->
	A <> B ->
	Collinear A B C->
	~Clockwise C D B.
Proof.
	intuition.
	elim (NotClockwiseABB A B).
	apply (ChangeAll _ _ _ _ H); intuition.
Qed.

Lemma EquiOrientedABCDNotClockwiseDCB : forall A B C D : Point,
	EquiOriented A B C D ->
	A <> B ->
	~Clockwise D C B.
Proof.
	intuition.
	elim (NotClockwiseABA B A).
	apply (ChangeSide _ _ _ _ H); intuition.
Qed.

Lemma EquiOrientedABCDNotClockwiseBAD : forall A B C D : Point,
	EquiOriented A B C D ->
	Collinear A B C ->
	~Clockwise B A D.
Proof.
	intuition.
	elim (NotClockwiseABA D C).
	apply (ChangeSense _ _ _ _ H); intuition.
Qed.

Lemma EquiOrientedABCDNotClockwiseBAC : forall A B C D : Point,
	EquiOriented A B C D ->
	C <> D ->
	Collinear B C D ->
	~Clockwise B A C.
Proof.
	intuition.
	generalize H2; apply (EquiOrientedABCDNotClockwiseCDB D C B A).
	 apply (ChangeSide _ _ _ _ H).
	   apply sym_not_eq; apply (ClockwiseDistinctAB _ _ _ H2).
	 auto.
	 apply CollinearCBA; trivial.
Qed.

Lemma OpenRaysClockwise : forall A B C D E : Point,
	Clockwise A B C ->
	OpenRay A B D  ->
	OpenRay A C E ->
	Clockwise A D E.
Proof.
	canonize1.
	apply H0.
	apply ClockwiseBCA.
	apply (ChangeSense A C A E H1).
	 apply CollinearABA.
	 apply ClockwiseCAB; trivial.
Qed.

End EQUIORIENTED_PROP.


Require Export XR_lt_0_INR.
Require Export XR_Rplus_lt_compat_r.

Local Open Scope R_scope.

Lemma lt_INR : forall n m:nat,
  (n < m)%nat ->
  INR n < INR m.
Proof.
  intros n.
  induction n as [ | n hn ].
  {
    intros m hm.
    apply lt_0_INR.
    exact hm.
  }
  {
    intros m hsnm.
    destruct m as [ | m ].
    { inversion hsnm. }
    {
      rewrite S_INR.
      rewrite S_INR.
      apply Rplus_lt_compat_r.
      apply hn.
      apply lt_S_n.
      exact hsnm.
    }
  }
Qed.


Require Import ZArith.

Module NaiveLang.
  Definition expr := (nat -> option Z) -> Prop.
  Definition context := expr -> Prop.
  Definition impp (e1 e2 : expr) : expr := fun st => e1 st -> e2 st.
  Definition andp (e1 e2 : expr) : expr := fun st => e1 st /\ e2 st.
  Definition orp  (e1 e2 : expr) : expr := fun st => e1 st \/ e2 st.
  Definition falsep : expr := fun st => False.
  Definition coq_prop (P: Prop): expr := fun _ => P.

  Definition join : (nat -> option Z) -> (nat -> option Z) -> (nat -> option Z) -> Prop :=
    fun x y z =>
      forall p: nat,
       (exists v, x p = Some v /\ y p = None /\ z p = Some v) \/
       (exists v, x p = None /\ y p = Some v /\ z p = Some v) \/
       (x p = None /\ y p = None /\ z p = None).
  Definition sepcon (e1 e2 : expr) : expr := fun st =>
    exists st1 st2, join st1 st2 st /\ e1 st1 /\ e2 st2.
  Definition emp : expr := fun st =>
    forall p, st p = None.
  Definition corable (e: expr): Prop := forall s1 s2, e s1 <-> e s2.

  Definition provable (e : expr) : Prop := forall st, e st.
End NaiveLang.

Require Import interface_4.

Module NaiveRule.
  Include DerivedNames (NaiveLang).
  Lemma modus_ponens :
    forall x y : expr, provable (impp x y) -> provable x -> provable y.
  Proof. unfold provable, impp. auto. Qed.

  Lemma axiom1 : forall x y : expr, provable (impp x (impp y x)).
  Proof. unfold provable, impp. auto. Qed.

  Lemma axiom2 : forall x y z : expr,
      provable (impp (impp x (impp y z)) (impp (impp x y) (impp x z))).
  Proof. unfold provable, impp. auto. Qed.

  Lemma andp_intros :
    forall x y : expr, provable (impp x (impp y (andp x y))).
  Proof. unfold provable, impp, andp. auto. Qed.

  Lemma andp_elim1 : forall x y : expr, provable (impp (andp x y) x).
  Proof. unfold provable, impp, andp. tauto. Qed.

  Lemma andp_elim2 : forall x y : expr, provable (impp (andp x y) y).
  Proof. unfold provable, impp, andp. tauto. Qed.

  Lemma orp_intros1 : forall x y : expr, provable (impp x (orp x y)).
  Proof. unfold provable, impp, orp. auto. Qed.

  Lemma orp_intros2 : forall x y : expr, provable (impp y (orp x y)).
  Proof. unfold provable, impp, orp. auto. Qed.

  Lemma orp_elim : forall x y z : expr,
      provable (impp (impp x z) (impp (impp y z) (impp (orp x y) z))).
  Proof. unfold provable, impp, orp. tauto. Qed.

  Lemma falsep_elim : forall x : expr, provable (impp falsep x).
  Proof. unfold provable, impp, falsep. destruct 1. Qed.

  Lemma peirce_law : forall x y: expr, provable (impp (impp (impp x y) x) x).
  Proof. unfold provable, impp. intros; tauto. Qed.

  Axiom sepcon_comm: forall x y, provable (iffp (sepcon x y) (sepcon y x)).
  Axiom sepcon_assoc: forall x y z,
      provable (iffp (sepcon x (sepcon y z)) (sepcon (sepcon x y) z)).
  Axiom sepcon_mono : (forall x1 x2 y1 y2 : expr, provable (impp x1 x2) -> provable (impp y1 y2) -> provable (impp (sepcon x1 y1) (sepcon x2 y2))) .
  Axiom sepcon_emp : (forall x : expr, provable (iffp (sepcon x emp) x)) .
  Axiom falsep_sepcon_impp : (forall x : expr, provable (impp (sepcon falsep x) falsep)) .
  Axiom orp_sepcon_impp : (forall x y z : expr, provable (impp (sepcon (orp x y) z) (orp (sepcon x z) (sepcon y z)))) .
  Axiom corable_coq_prop : (forall P : Prop, corable (coq_prop P)) .
  Axiom corable_preserved' : (forall x y : expr, provable (iffp x y) -> corable x -> corable y) .
  Axiom corable_andp_sepcon1 : (forall x y z : expr, corable x -> provable (iffp (sepcon (andp x y) z) (andp x (sepcon y z)))) .
End NaiveRule.

Module T := LogicTheorem NaiveLang NaiveRule.
Module Solver := IPSolver NaiveLang.
Import T.
Import Solver.


Require Export P01.

(** **** Exercise: 3 stars (fold_constants_com_sound)  *)
(** Complete the [WHILE] case of the following proof. *)

Theorem WHILE_false : forall b c,
   bequiv b BFalse ->
    cequiv (WHILE b DO c END) SKIP.
Proof. intros. split.
  Case "->". intros. inversion H0; subst. apply E_Skip. unfold bequiv in H. rewrite H in H3. inversion H3.
  Case "<-". intros. inversion H0; subst. apply E_WhileEnd. unfold bequiv in H. rewrite H. reflexivity. Qed.

Theorem fold_constants_com_sound :
  ctrans_sound fold_constants_com.
Proof.
  unfold ctrans_sound. intros c.
  com_cases (induction c) Case; simpl.
  Case "SKIP". apply refl_cequiv.
  Case "::=". apply CAss_congruence. apply fold_constants_aexp_sound.
  Case ";;".
    (***
     Note how we use the tactic [eauto].
     ***)
   destruct c1; destruct c2; try (apply CSeq_congruence; assumption)
;  eauto using skip_left, skip_right.
  Case "IFB".
    assert (bequiv b (fold_constants_bexp b)).
      SCase "Pf of assertion". apply fold_constants_bexp_sound.
    destruct (fold_constants_bexp b) eqn:Heqb;
      (* If the optimization doesn't eliminate the if, then the result
         is easy to prove from the IH and fold_constants_bexp_sound *)
      try (apply CIf_congruence; assumption).
    SCase "b always true".
      apply trans_cequiv with c1; try assumption.
      apply IFB_true; assumption.
    SCase "b always false".
      apply trans_cequiv with c2; try assumption.
      apply IFB_false; assumption.
  Case "WHILE".
    assert (bequiv b (fold_constants_bexp b)). apply fold_constants_bexp_sound.
    destruct (fold_constants_bexp b) eqn:Heqb; eauto using  WHILE_true, WHILE_false, CWhile_congruence; assumption.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelNC.
Require Export GeoCoq.Elements.OriginalProofs.lemma_NCdistinct.
Require Export GeoCoq.Elements.OriginalProofs.lemma_NCorder.
Require Export GeoCoq.Elements.OriginalProofs.lemma_NChelper.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_parallelbetween :
   forall B H K L M,
   BetS H B K -> Par M B H L -> Col L M K ->
   BetS L M K.
Proof.
intros.
assert (~ Meet M B H L) by (conclude_def Par ).
assert (nCol M B H) by (forward_using lemma_parallelNC).
assert (nCol M H L) by (forward_using lemma_parallelNC).
assert (neq M B) by (forward_using lemma_NCdistinct).
assert (neq H L) by (forward_using lemma_NCdistinct).
assert (nCol M L H) by (forward_using lemma_NCorder).
assert (Col M L K) by (forward_using lemma_collinearorder).
assert (Col H B K) by (conclude_def Col ).
assert (eq M M) by (conclude cn_equalityreflexive).
assert (eq L L) by (conclude cn_equalityreflexive).
assert (eq B B) by (conclude cn_equalityreflexive).
assert (eq H H) by (conclude cn_equalityreflexive).
assert (~ eq M K).
 {
 intro.
 assert (Col H B M) by (conclude cn_equalitysub).
 assert (Col M B H) by (forward_using lemma_collinearorder).
 assert (Col H L H) by (conclude_def Col ).
 assert (Meet M B H L) by (conclude_def Meet ).
 contradict.
 }
assert (nCol M L H) by (forward_using lemma_NCorder).
assert (Col M L M) by (conclude_def Col ).
assert (nCol M K H) by (conclude lemma_NChelper).
assert (nCol H M K) by (forward_using lemma_NCorder).
assert ((eq L M \/ eq L K \/ eq M K \/ BetS M L K \/ BetS L M K \/ BetS L K M)) by (conclude_def Col ).
assert (BetS L M K).
by cases on (eq L M \/ eq L K \/ eq M K \/ BetS M L K \/ BetS L M K \/ BetS L K M).
{
 assert (~ ~ BetS L M K).
  {
  intro.
  assert (Col M B M) by (conclude_def Col ).
  assert (Col H L L) by (conclude_def Col ).
  assert (Col H L M) by (conclude cn_equalitysub).
  assert (Meet M B H L) by (conclude_def Meet ).
  contradict.
  }
 close.
 }
{
 assert (~ ~ BetS L M K).
  {
  intro.
  assert (Col H B L) by (conclude cn_equalitysub).
  assert (Col H L B) by (forward_using lemma_collinearorder).
  assert (Col M B B) by (conclude_def Col ).
  assert (Meet M B H L) by (conclude_def Meet ).
  contradict.
  }
 close.
 }
{
 assert (~ ~ BetS L M K).
  {
  intro.
  contradict.
  }
 close.
 }
{
 assert (~ ~ BetS L M K).
  {
  intro.
  assert (nCol H K M) by (forward_using lemma_NCorder).
  let Tf:=fresh in
  assert (Tf:exists E, (BetS H E L /\ BetS M E B)) by (conclude postulate_Pasch_inner);destruct Tf as [E];spliter.
  assert (Col H E L) by (conclude_def Col ).
  assert (Col M E B) by (conclude_def Col ).
  assert (Col H L E) by (forward_using lemma_collinearorder).
  assert (Col M B E) by (forward_using lemma_collinearorder).
  assert (Meet M B H L) by (conclude_def Meet ).
  contradict.
  }
 close.
 }
{
 close.
 }
{
 assert (~ ~ BetS L M K).
  {
  intro.
  assert (BetS M K L) by (conclude axiom_betweennesssymmetry).
  let Tf:=fresh in
  assert (Tf:exists E, (BetS H E L /\ BetS M B E)) by (conclude postulate_Pasch_outer);destruct Tf as [E];spliter.
  assert (Col H E L) by (conclude_def Col ).
  assert (Col M B E) by (conclude_def Col ).
  assert (Col H L E) by (forward_using lemma_collinearorder).
  assert (Meet M B H L) by (conclude_def Meet ).
  contradict.
  }
 close.
 }
(** cases *)
close.
Qed.

End Euclid.


(** Calculation for arithmetic + exceptions + global state. Instead of
a [Put] operator with two arguments the source language has a unary
[Put] operator and an explicit sequencing operator [Seq]. *)

Require Import List.
Require Import Tactics.

(** * Syntax *)

Inductive Expr : Set :=
| Val : nat -> Expr
| Add : Expr -> Expr -> Expr
| Throw : Expr
| Catch : Expr -> Expr -> Expr
| Seq : Expr -> Expr -> Expr
| Get : Expr
| Put : Expr -> Expr.

(** * Semantics *)

Definition State := nat.

Fixpoint eval (x: Expr) (q : State) : (option nat * State) :=
  match x with
    | Val n => (Some n , q)
    | Add x1 x2 => match eval x1 q with
                   | (Some n, q') => match eval x2 q' with
                                       | (Some m, q'') => (Some (n + m), q'')
                                       | (None, q'') => (None, q'')
                                     end
                   | (None, q') => (None, q')
                   end
    | Throw => (None, q)
    | Catch x1 x2 => match eval x1 q with
                     | (Some n, q') => (Some n, q')
                     | (None, q') => eval x2 q'
                     end
    | Seq x1 x2 => match eval x1 q with
                   | (Some _, q') => eval x2 q'
                   | (None, q') => (None, q')
                   end
    | Get => (Some q,q)
    | Put x' => match eval x' q with
                | (Some n, q') => (Some n, n)
                | (None, q') => (None, q')
                end
  end.

(** * Compiler *)

Inductive Code : Set :=
| HALT : Code
| PUSH : nat -> Code -> Code
| ADD : Code -> Code
| FAIL : Code
| MARK : Code -> Code -> Code
| UNMARK : Code -> Code
| LOAD : Code -> Code
| POP : Code -> Code
| SAVE : Code -> Code
.

Fixpoint comp' (x : Expr) (c : Code) : Code :=
  match x with
    | Val n => PUSH n c
    | Add x1 x2 => comp' x1 (comp' x2 (ADD c))
    | Throw => FAIL
    | Catch x1 x2 => MARK (comp' x2 c) (comp' x1 (UNMARK c))
    | Seq x1 x2 => comp' x1 (POP (comp' x2 c))
    | Get => LOAD c
    | Put x' => comp' x' (SAVE c)
  end.

(* Put x y => comp' x (SAVE (comp' y c)) *)

Definition comp (x : Expr) : Code := comp' x HALT.

(** * Virtual Machine *)

Inductive Elem : Set :=
| VAL : nat -> Elem
| HAN : Code -> Elem
.
Definition Stack : Set := list Elem.

Inductive Conf : Set :=
| conf : Code -> Stack -> State -> Conf
| fail : Stack -> State -> Conf.

Notation "⟨ c , s , q ⟩" := (conf c s q).
Notation "⟪ s , q ⟫" := (fail s q ).

Reserved Notation "x ==> y" (at level 80, no associativity).
Inductive VM : Conf -> Conf -> Prop :=
| vm_push n c s q : ⟨PUSH n c, s, q⟩ ==> ⟨ c , VAL n :: s, q ⟩
| vm_add c s q m n : ⟨ADD c, VAL m :: VAL n :: s, q⟩ ==> ⟨c, VAL (n + m) :: s, q⟩
| vm_fail s q : ⟨ FAIL, s, q⟩ ==> ⟪s,q⟫
| vm_mark c h s q : ⟨MARK h c, s, q⟩ ==> ⟨c, HAN h :: s, q⟩
| vm_unmark c n h s q : ⟨UNMARK c, VAL n :: HAN h :: s, q⟩ ==> ⟨c, VAL n :: s, q⟩
| vm_load c s q : ⟨LOAD c, s, q⟩ ==> ⟨c, VAL q :: s, q⟩
| vm_pop c n s q : ⟨POP c, VAL n :: s, q⟩ ==> ⟨c, s, q⟩
| vm_save c n s q : ⟨SAVE c, VAL n :: s, q⟩ ==> ⟨c, VAL n :: s, n⟩
| vm_fail_val n s q : ⟪VAL n :: s, q ⟫ ==> ⟪s, q⟫
| vm_fail_han c s q : ⟪HAN c :: s, q ⟫ ==> ⟨c, s, q⟩
where "x ==> y" := (VM x y).

Hint Constructors VM : core.

(** * Calculation *)

(** Boilerplate to import calculation tactics *)

Module VM <: Preorder.
Definition Conf := Conf.
Definition VM := VM.
End VM.
Module VMCalc := Calculation VM.
Import VMCalc.

(** Specification of the compiler *)

Theorem spec x c s q : ⟨comp' x c, s, q⟩
                       =>> match eval x q with
                            | (Some n, q') => ⟨c , VAL n :: s, q'⟩
                            | (None, q') => ⟪ s, q' ⟫
                           end.

(** Setup the induction proof *)

Proof.
  intros.
  generalize dependent c.
  generalize dependent s.
  generalize dependent q.
  induction x;intros.

(** Calculation of the compiler *)

(** - [x = Val n]: *)

  begin
  ⟨c, VAL n :: s, q⟩.
  <== { apply vm_push }
  ⟨PUSH n c, s, q⟩.
  [].

(** - [x = Add x1 x2]: *)

  begin
   (match eval x1 q with
     | (Some m, q') => match eval x2 q' with
                         | (Some n, q'') => ⟨ c, VAL (m + n) :: s, q'' ⟩
                         | (None, q'') => ⟪ s, q'' ⟫
                  end
     | (None, q') => ⟪ s, q' ⟫
     end).
  <<= { apply vm_add }
   (match eval x1 q with
     | (Some m, q') => match eval x2 q' with
                         | (Some n, q'') => ⟨ ADD c, VAL n :: VAL m :: s, q'' ⟩
                         | (None, q'') => ⟪ s, q'' ⟫
                  end
     | (None, q') => ⟪ s, q' ⟫
     end).
  <<= { apply vm_fail_val }
   (match eval x1 q with
     | (Some m, q') => match eval x2 q' with
                         | (Some n, q'') => ⟨ ADD c, VAL n :: VAL m :: s, q'' ⟩
                         | (None, q'') => ⟪ VAL m :: s, q'' ⟫
                  end
     | (None, q') => ⟪ s, q' ⟫
     end).
  <<= { apply IHx2 }
   (match eval x1 q with
     | (Some m, q') =>  ⟨ comp' x2 (ADD c), VAL m :: s, q' ⟩
     | (None, q') => ⟪ s, q' ⟫
     end).
  <<= { apply IHx1 }
      ⟨ comp' x1 (comp' x2 (ADD c)), s, q ⟩.
  [].

(** - [x = Throw]: *)

  begin
    ⟪s, q⟫.
  <== { apply vm_fail }
    ⟨ FAIL, s, q⟩.
  [].

(** - [x = Catch x1 x2]: *)

  begin
    (match eval x1 q with
         | (Some m, q') => ⟨ c, VAL m :: s, q'⟩
         | (None, q') => match eval x2 q' with
                           | (Some n, q'') => ⟨c, VAL n :: s, q''⟩
                           | (None, q'') => ⟪s, q''⟫
                         end
    end).
   <<= { apply IHx2 }
    (match eval x1 q with
         | (Some m, q') => ⟨ c, VAL m :: s, q'⟩
         | (None, q') => ⟨comp' x2 c, s, q'⟩
    end).
   <<= { apply vm_fail_han }
    (match eval x1 q with
         | (Some m, q') => ⟨ c, VAL m :: s, q'⟩
         | (None, q') => ⟪ HAN (comp' x2 c) :: s, q'⟫
    end).
   <<= { apply vm_unmark }
    (match eval x1 q with
         | (Some m, q') => ⟨ UNMARK c, VAL m :: HAN (comp' x2 c) :: s, q'⟩
         | (None, q') => ⟪ HAN (comp' x2 c) :: s, q'⟫
    end).
   <<= { apply IHx1 }
       ⟨ comp' x1 (UNMARK c), HAN (comp' x2 c) :: s, q⟩.
   <<= { apply vm_mark }
       ⟨ MARK (comp' x2 c) (comp' x1 (UNMARK c)),  s, q⟩.
   [].

(** - [x = Seq x1 x2]: *)

   begin
     (match eval x1 q with
        | (Some n, q') => match eval x2 q' with
                            | (Some m, q'') => ⟨c, VAL m :: s, q''⟩
                            | (None, q'') => ⟪s, q''⟫
                          end
        | (None, q') => ⟪s, q'⟫
      end).
   <<= { apply IHx2 }
       (match eval x1 q with
          | (Some n, q') => ⟨comp' x2 c, s, q'⟩
          | (None, q') => ⟪s, q'⟫
        end).
   <<= { apply vm_pop }
       (match eval x1 q with
          | (Some n, q') => ⟨POP (comp' x2 c), VAL n :: s, q'⟩
          | (None, q') => ⟪s, q'⟫
        end).
   <<= { apply IHx1 }
       ⟨comp' x1 (POP (comp' x2 c)), s, q⟩.
   [].

(** - [x = Get]: *)

   begin
     ⟨ c, VAL q :: s, q⟩.
   <== { apply vm_load }
     ⟨ LOAD c, s, q⟩.
   [].

(** - [x = Put x]: *)

   begin
     (match eval x q with
          | (Some n, q') =>  ⟨c, VAL n :: s, n⟩
          | (None, q') => ⟪s, q'⟫
      end).
   <<= { apply vm_save }
       (match eval x q with
          | (Some n, q') => ⟨SAVE c, VAL n :: s, q'⟩
          | (None, q') => ⟪s, q'⟫
        end).
   <<= { apply IHx }
       ⟨comp' x (SAVE c), s, q⟩.
   [].
Qed.

(** * Soundness *)

(** Since the VM is defined as a small step operational semantics, we
have to prove that the VM is deterministic and does not get stuck in
order to derive soundness from the above theorem. *)

Lemma determ_vm : determ VM.
  intros C C1 C2 V. induction V; intro V'; inversion V'; subst; reflexivity.
Qed.

Lemma term_vm x :  ~ (exists C, match x with
                             | (Some n, q) => ⟨HALT , VAL n :: nil, q⟩
                             | (None, q) =>  ⟪nil, q⟫
                           end  ==> C).
Proof.
  destruct x; destruct o; intro Contra; destruct Contra; subst; inversion H.
Qed.

Theorem sound x C q : ⟨comp x, nil, q⟩ =>>! C -> C = match eval x q with
                                                  | (Some n, q') => ⟨HALT , VAL n :: nil, q'⟩
                                                  | (None, q') =>  ⟪nil, q'⟫
                                                end.
Proof.
  intros.
  pose (spec x HALT nil) as H'. unfold comp in *. pose (determ_trc determ_vm) as D.
  unfold determ in D. eapply D. apply H. split. apply H'. apply term_vm.
Qed.


(** V teh vajah se bomo učili uporabljati standardno knjižnico
    v Coqu (http://www.lix.polytechnique.fr/coq/stdlib/).
    Knjižnica ima veliko koristnih izrekov in definicij. Ponavadi
    je glavna težava v tem, da je težko najti izrek, ki ga v
    danem trenutku potrebujemo. Coq ima nekaj ukazov, s katerim
    lahko prgledujemo knjižnico in iščemo potencialno koristne
    izreke.

    Najprej bomo vadili uporabo knjižnice za realna števila, zato jo
    najprej zahtevamo z ukazom [Require Import].
*)

Require Import Reals.

(** Večinoma bomo uporabljali notacijo za realna števila. Na primer,
    želimo, da bi "x + y" pomenilo seštevanje realnih števil, ne naravnih.
    Lahko bi vsakič pisali "(x + y)%R", a je bolj praktično, da vključimo
    notacijo za realna števila z ukazom [Local Open Scope]. *)

Local Open Scope R_scope.

(* Če bomo potrebovali operacije na naravnih številih, lahko še vedno
   pišemo "(x + y)%nat". *)

(** Dokažimo preprosto neenačbo. *)
Theorem vaja_1 (x y : R) :  x^2 + y^2 >= 2 * x * y.
Proof.
  (* Postopek dokaza je naslednji:

     - prenesemo vse na eno stran: x^2 - 2 * x * y + y^2 >= 0
     - faktoriziramo: (x - y)^2 >= 0
     - opazimo, da je kvadrat števila nenegativen

     Prva težava: kako prenesemo [2 * y * x] na drugo stran neenačbe?
     Verjetno obstaja ustrezna lema v knjižnici. Treba je malo brskati.
     Poskusite in če ne najdete odgovora v 5 minutah, poglejte rešitev
     v tej datoteki. Iščite v knižnici [RIneq],
     http://www.lix.polytechnique.fr/coq/stdlib/Coq.Reals.RIneq.html

     Rešitev je nižje spodaj.

              |
              |
              V

     Lenoba lena, malo bolj se potrudi!

    Lema, ki jo iščemo je [Rminus_ge]. O njej izvemo več z ukazom
    [Check Rminus_ge.], ki pove:

      Rminus_ge : forall r1 r2 : R, r1 - r2 >= 0 -> r1 >= r2
 *)
 apply Rminus_ge.
 (** Sedaj bi radi faktorizirali. To je najlažje narediti tako,
     da Coq-u povemo, naj zamenja [x^2 + y^2 - 2 * x * y] s
     kvadratom [(x - y)^2]. Če bi to naredili, bi se nam kasneje
     zataknilo: v knjižnici je kvadrat realnega števila definiran
     kot [Rsqr x]. Zato je bolje, da [Rsqr] uporabimo tudi mi.

     Lahko pa bi tudi v knjižnici poiskali lemo [Rsqr_plus],
     vendar tega zdaj ne bomo naredili, da vidimo, kako se dela
     na roke.
 *)
  replace (x^2 + y^2 - 2 * x * y) with (Rsqr (x - y)).
  - (* Spet iščemo lemo, tokrat, da je kvadrat nenegativen.
       Hitro najdemo

         Lemma Rle_0_sqr : forall r, 0 <= Rsqr r.

       Na žalost gre v napačno smer, mi potrebujemo Rsqr r >= 0.
       Najprej moramo svojo neenačbo obrniti. Torej potrebujemo
       lemo, ki pravi [x <= y -> y >= x]. Spet malo pogledamo in
       najdemo [Rle_ge]. *)
    apply Rle_ge.
    apply Rle_0_sqr.
    (* Kot vidimo, je vse skupaj ena nočna mora. Hej, bomo vsaj imeli dokaz z vsemi
       podrobnostmi. *)
    - (* Tu bi bilo najbolj logično, če bi uporabili poenostavljanje
       izrazov. To se lahko v splošnem naredi s [simpl] in s [compute]. Za delo s
       kolobarji (realna števila tvorijo kolobar, saj tvorijo obseg) imamo taktiki
       [ring_simplify] in [ring]. Z nekaj poskušanja ugotovimo, da je pravo
       zaporedje [compute] in [ring]. *)
       compute.
       ring.
Qed.

(** Naslednjo vajo naredite sami. Ideja: x^4 je treba napisati kot Rsqr (x^2). *)
Theorem vaja_2 : forall x : R, 0 <= x^4.
Proof.
  admit.
Qed.

(** Iskanje po spletnih straneh je lahko precej zamudno. V Coq-u lahko
    iščemo tudi z ukazi:

    - [SearchAbout Rsqr] poišče vse izreke, ki omenjajo [Rsqr].
    - [SearchAbout "+"] poišče vse izreke, ki omenjajo "+" (tu podamo kar notacijo,
      lahko bi tudi rekli [SearchAbout Rplus]).
    - [SearchAbout (Rsqr (?x - ?y))] poišče vse izreke, v katerih se pojavi izraz
       oblike "Rsqr (?x - ?y)", kjer sta ?x in ?y poljubna. V splošnem lahko
       napišemo poljuben vzorec, kjer z ?x, ?y, ... označimo tiste dele vzorca,
       ki so poljubni.

    Polna dokumentacija za [SearchAbout] in [SearchPattern] je na
    http://coq.inria.fr/V8.2pl1/refman/Reference-Manual009.html#@command105

    Ukaz [SearchPattern vzorec] sprejme vzorec in vrne vse izreke, katerih
    *sklep* ustreza danemu vzorcu.
*)
(** Naslednje vaje reši s pomočjo ukaza [SearchAbout]. Vsaka od vaj je rešljiva
    s preprosto uporabo [apply] izreka iz knjižnice. *)

Theorem vaja_3 (x : R) : 0 < Rsqr x -> x <> 0.
Proof.
  (* Uporabi: SearchAbout Rsqr. *)
  admit.
Qed.

Theorem vaja_4 (x : R) : x < x + 1.
Proof.
  (* Uporabi: SearchPattern (?x < ?x + 1). *)
  admit.
Qed.

Theorem vaja_5 (x : R) : sin (2 * x) = 2 * sin x * cos x.
Proof.
  (* SearchAbout (sin (2 * ?x)). *)
  admit.
Qed.

(** Tu je še nekaj bolj zanimivih vaj. Pomagajte si s [SearchAbout]
    in [SearchPattern]. *)

Theorem vaja_6 : forall x : R, 0 < x -> 0 < x * x * x.
Proof.
  admit.
Qed.

Theorem vaja_7 (x : R) : sin (3 * x) = 3 * (cos x)^2 * sin x - (sin x)^3.
Proof.
  admit.
Qed.

Theorem vaja_8 (x y : R) :
  0 <= x -> 0 <= y -> Rabs (x + y) = Rabs x + Rabs y.
Proof.
  admit.
Qed.

Theorem vaja_9 : forall x : R, x <= 0 -> x * x * x <= 0.
Proof.
  admit.
Qed.

Theorem vaja_10 : forall x : R, 0 < x * x * x -> 0 < x.
Proof.
  admit.
Qed.


Definition nandb (b1:bool) (b2:bool) : bool :=
  match b1, b2 with
  | true, true => false
  | _, _ => true
  end.

(* “Proof. reflexivity. Qed.” *)
Example test_nandb1: (nandb true false) = true.
Proof. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. reflexivity. Qed.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
  match b1, b2, b3 with
  | true, true, true => true
  | _, _, _ => false
  end.

Example test_andb31: (andb3 true true true) = true.
Proof. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. reflexivity. Qed.


(** Feitiços **)
Definition lem : Prop := forall (P: Prop), P \/ (~ P).
Definition raa : Prop := forall (P : Prop), (~P -> False) -> P.

Theorem lem_implies_raa : lem -> raa.
Proof.
  intros Hlem P HnP_imp_F.
  destruct (Hlem P) as [HP | HnP].
  - exact HP.
  - apply HnP_imp_F in HnP as Hbot.
    contradiction.
Qed.

(** 1. Proposições de dupla negação **)

Theorem doubleneg_intro : forall (p : Prop), p -> ~ ~ p.
Proof.
  intros p.
  unfold not.
  intros Hp.
  intros p_implies_f.
  apply (p_implies_f Hp).
Qed.

Theorem doubleneg_elim_with_raa : raa -> forall (p: Prop), ~ ~ p -> p.
Proof.
  intros Hraa p HnnP.
  apply Hraa.
  exact HnnP.
Qed.

(** 2. A irrefutabilidade do LEM **)

Theorem irrefutabilidade_lem_with_lem : lem -> forall (P : Prop), ~ ~(P \/ ~P).
Proof.
  intros Hlem P Hn_P_or_nP.
  apply Hn_P_or_nP in Hlem as Hfalse.
  assumption.
Qed.

(** 3. A lei de Peirce e sua versão "fraca" **)

Theorem lei_de_Peirce_with_raa : raa -> forall (P Q: Prop), ((P -> Q) -> P) -> P.
Proof.
  intros Hraa P Q HP_imp_Q__imp_P.
  apply Hraa.
  intros HnP.
  assert(HP_imp_Q: P -> Q).
    { intro HP. apply HnP in HP as Hbot. contradiction. }
  apply HP_imp_Q__imp_P in HP_imp_Q as HP.
  apply HnP in HP as Hbot.
  exact Hbot.
Qed.

Theorem lei_de_Peirce_fraca : forall (P Q : Prop), ((P -> Q) -> P) -> ~~P.
Proof.
  intros P Q HP_imp_Q__imp_P HnP.
  assert(HP_imp_Q: P -> Q).
  * intro HP. apply HnP in HP. contradiction.
  * apply HP_imp_Q__imp_P in HP_imp_Q as HP. apply HnP in HP. assumption.
Qed.

(** 4. Proposições de interdefinabilidade dos ⇒,∨: **)

Theorem implies_or1_with_lem : lem -> forall (P Q : Prop), (P -> Q) -> (~P \/ Q).
Proof.
  intros Hlem P Q HP_imp_Q.
  destruct (Hlem P) as [Hp | Hnp].
  - apply HP_imp_Q in Hp as HQ. right. assumption.
  - left. assumption.
Qed.

Theorem implies_or2 : forall (P Q : Prop), (~P \/ Q) -> (P -> Q).
Proof.
  intros P Q HnP_or_Q HP.
  destruct (HnP_or_Q) as [HnP | HQ].
  - apply HnP in HP as Hfalse. contradiction.
  - assumption.
Qed.

Theorem implies_or3 : forall (P Q : Prop), (P \/ Q) -> (~P -> Q).
Proof.
  intros P Q HP_or_Q HnP.
  destruct (HP_or_Q) as [HP | HQ].
  - apply HnP in HP as Hfalse. contradiction.
  - assumption.
Qed.

Theorem implies_or4_with_lem : lem -> forall (P Q : Prop), (~P -> Q) -> (P \/ Q).
Proof.
  intros Hlem P Q HnP_imp_Q.
  destruct (Hlem P) as [Hp | Hnp].
  - left. assumption.
  - apply HnP_imp_Q in Hnp as HQ. right. assumption.
Qed.

(** 5. Proposições de interdefinabilidade dos ∨,∧: **)

Theorem interdefinabilidade_e_ou1 : forall (P Q : Prop), P \/ Q -> ~(~P /\ ~Q).
Proof.
  intros P Q HP_or_Q HnP_and_nQ. destruct HnP_and_nQ as [HnP HnQ].
  destruct (HP_or_Q) as [HP | HQ].
  - apply HnP in HP as Hfalse. assumption.
  - apply HnQ in HQ as Hfalse. assumption.
Qed.

Theorem interdefinabilidade_e_ou2_with_lem : lem -> forall (P Q : Prop), ~(~P /\ ~Q) -> P \/ Q.
Proof.
  intros Hlem P Q Hn_nP_and_nQ.
  destruct (Hlem P) as [HP | HnP].
  - left. assumption.
  - destruct (Hlem Q) as [HQ | HnQ].
    * right. assumption.
    * assert(HnP_and_nQ: ~P /\ ~Q).
      + split.
        -- assumption.
        -- assumption.
      + apply Hn_nP_and_nQ in HnP_and_nQ. contradiction.
Qed.

Theorem interdefinabilidade_e_ou3 : forall (P Q : Prop), P /\ Q -> ~(~P \/ ~Q).
Proof.
  intros P Q HP_and_Q HnP_or_nQ. destruct HP_and_Q as [HP HQ].
  destruct (HnP_or_nQ) as [HnP | HnQ].
  - apply HnP in HP as Hfalse. assumption.
  - apply HnQ in HQ as Hfalse. assumption.
Qed.

Theorem interdefinabilidade_e_ou4_with_raa : raa -> forall (P Q : Prop), ~(~P \/ ~Q) -> P /\ Q.
Proof.
  intros Hraa P Q Hn_nP_or_nQ. split.
  - apply Hraa.
    intros HnP.
    assert(HnP_or_nQ: ~P \/ ~Q).
      { left. exact HnP. }
    apply Hn_nP_or_nQ in HnP_or_nQ. contradiction.
  - apply Hraa.
    intros HnQ.
    assert(HnP_or_nQ: ~P \/ ~Q).
      { right. exact HnQ. }
    apply Hn_nP_or_nQ in HnP_or_nQ. contradiction.
Qed.

(** 6. As leis de De Morgan **)

Theorem de_morgan1 : forall (P Q : Prop), ~(P \/ Q) -> (~P /\ ~Q).
Proof.
  intros P Q Hn_P_or_Q.
  split.
  - intro HP.
    assert(HP_or_Q: P \/ Q).
      { left. exact HP. }
    apply Hn_P_or_Q in HP_or_Q as Hbot.
    contradiction.
  - intro HQ.
    assert(HP_or_Q: P \/ Q).
      { right. exact HQ. }
    apply Hn_P_or_Q in HP_or_Q as Hbot.
    contradiction.
Qed.

Theorem de_morgan2 : forall (P Q : Prop), (~P /\ ~Q) -> ~(P \/ Q).
Proof.
  intros P Q HnP_and_nQ HP_or_Q. destruct HnP_and_nQ as [HnP HnQ].
  destruct HP_or_Q as [HP | HQ].
  - contradiction.
  - contradiction.
Qed.

Theorem de_morgan3_with_raa : raa -> forall (P Q : Prop), ~(P /\ Q) -> (~P \/ ~Q).
Proof.
  intros Hraa P Q Hn_P_and_Q.
  apply Hraa.
  intros Hn_nP_or_nQ.
  apply (de_morgan1 (~P) (~Q)) in Hn_nP_or_nQ as HnnP_and_nnQ.
  destruct HnnP_and_nnQ as (HnnP, HnnQ).
  assert(HP_or_Q: P /\ Q).
    { split.
      - exact (doubleneg_elim_with_raa Hraa P HnnP).
      - exact (doubleneg_elim_with_raa Hraa Q HnnQ). }
  apply Hn_P_and_Q in HP_or_Q as Hbot.
  contradiction.
Qed.

Theorem de_morgan4 : forall (P Q : Prop), (~P \/ ~Q) -> ~(P /\ Q).
Proof.
  intros P Q HnP_or_nQ HP_and_Q. destruct HP_and_Q as [HP HQ].
  destruct HnP_or_nQ as [HnP | HnQ].
  - contradiction.
  - contradiction.
Qed.

(** 7. Proposições de distributividade dos ∨,∧: **)

Theorem distributividade_e_ou1 : forall (P Q R : Prop), P /\ (Q \/ R) -> (P /\ Q) \/ (P /\ R).
Proof.
  intros P Q R HP_and__Q_or_R. destruct HP_and__Q_or_R as [HP HQ_or_R].
  destruct HQ_or_R as [HQ | HR].
  - left. split.
    * assumption.
    * assumption.
  - right. split.
    * assumption.
    * assumption.
Qed.

Theorem distributividade_e_ou2 : forall (P Q R : Prop), (P /\ Q) \/ (P /\ R) -> P /\ (Q \/ R).
Proof.
  intros P Q R HP_and_Q__or__P_and_R.
  destruct HP_and_Q__or__P_and_R as [HP_and_Q | HP_and_R].
  - destruct HP_and_Q as [HP HQ]. split.
    * assumption.
    * left. assumption.
  - destruct HP_and_R as [HP HR]. split.
    * assumption.
    * right. assumption.
Qed.

Theorem distributividade_ou_e1 : forall (P Q R : Prop), P \/ (Q /\ R) -> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R HP_or__Q_and_R.
  destruct HP_or__Q_and_R as [HP | HQ_and_R].
  - split.
    * left. assumption.
    * left. assumption.
  - destruct HQ_and_R as [HQ HR]. split.
    * right. assumption.
    * right. assumption.
Qed.

Theorem distributividade_ou_e2 : forall (P Q R : Prop), (P \/ Q) /\ (P \/ R) -> P \/ (Q /\ R).
Proof.
  intros P Q R HP_or_Q__and__P_or_R. destruct HP_or_Q__and__P_or_R as [HP_or_Q HP_or_R].
  destruct HP_or_Q as [HP | HQ].
  - left. assumption.
  - destruct HP_or_R as [HP | HR].
    * left. assumption.
    * right. split.
      + assumption.
      + assumption.
Qed.

(** 8. As leis de De Morgan para ∃,∀ **)

Theorem neg_exists : forall (A : Type)(phi : A -> Prop), ~(exists (x: A), phi x) -> (forall (x : A), ~phi x).
Proof.
  intros A phi Hnex_px a Hpa.
  assert (Hex_px: exists (x : A), phi x).
  - exists a. assumption.
  - apply Hnex_px in Hex_px as Hfalse. assumption.
Qed.

Theorem neg_exists_inverse : forall (A : Type)(phi : A -> Prop), (forall (x : A), ~phi x) -> ~(exists (x: A), phi x).
Proof.
  intros A phi Hfx_npx Hex_px. destruct Hex_px as (a, Hpa).
  apply (Hfx_npx a) in Hpa as Hfalse. assumption.
Qed.

Theorem neg_exists2 : forall (A : Type)(phi : A -> Prop)(psi : A -> Prop), ~(exists (x: A), phi x /\ psi x) -> (forall (x : A), phi x -> ~psi x).
Proof.
  intros A phi psi Hnex_phx_and_psx a Hpha Hpsa.
  assert (Hex_phx_and_psx: exists (x : A), phi x /\ psi x).
    { exists a. split; assumption. }
  apply Hnex_phx_and_psx in Hex_phx_and_psx as Hbot.
  exact Hbot.
Qed.

Theorem neg_forall :
  raa -> forall (A: Type)(phi : A -> Prop), ~(forall (x : A), phi x) -> (exists (x : A), ~phi x).
Proof.
  intros Hraa A phi Hnfx_px.
  apply Hraa.
  intros Hnex_npx.
  assert (Hfx_px: forall x : A, phi x).
    { intros x.
      apply (doubleneg_elim_with_raa Hraa).
      apply (neg_exists A _ Hnex_npx x). }
  apply Hnfx_px in Hfx_px as Hbot.
  exact Hbot.
Qed.

Theorem neg_forall_inverse : forall (A : Type)(phi : A -> Prop), (exists (x : A), ~phi x) -> ~(forall ( x: A ), phi x).
Proof.
  intros A phi Hex_npx Hfx_px. destruct Hex_npx as (a, Hnpa).
  apply Hnpa in Hfx_px as Hfalse. assumption.
Qed.

(** 9. Proposições de interdefinabilidade dos ∃,∀ **)

Theorem exists_forall1 : forall (A : Type)(phi : A -> Prop), (exists ( x: A ), phi x) -> ~(forall (x : A), ~phi x).
Proof.
  intros A phi Hex_px Hfx_npx. destruct Hex_px as (a, Hpa).
  apply (Hfx_npx a) in Hpa as Hfalse. assumption.
Qed.

Theorem exists_forall2_with_raa : raa -> forall (A : Type)(phi : A -> Prop), ~(forall (x : A), ~phi x) -> (exists ( x: A ), phi x).
Proof.
  intros Hraa A phi Hnfx_npx.
  apply Hraa.
  intros Hnex_px.
  assert (Hfx_npx: forall x : A, ~phi x).
    { intros x.
      apply (neg_exists A _ Hnex_px x). }
  apply Hnfx_npx in Hfx_npx as Hbot.
  exact Hbot.
Qed.

Theorem exists_forall3 : forall (A : Type)(phi : A -> Prop), (forall ( x: A ), phi x) -> ~(exists (x : A), ~phi x).
Proof.
  intros A phi Hfx_px Hex_npx. destruct Hex_npx as (a, Hnpa).
  apply Hnpa in Hfx_px as Hfalse. assumption.
Qed.

Theorem exists_forall4_with_raa : raa -> forall (A : Type)(phi : A -> Prop), ~(exists (x : A), ~phi x) -> (forall ( x: A ), phi x).
Proof.
  intros Hraa A phi Hnex_npx a.
  apply Hraa. intros Hnpa.
  assert (Hex_npx: exists (x : A), ~phi x).
  - exists a. assumption.
  - apply Hnex_npx in Hex_npx as Hfalse. contradiction.
Qed.

(** 10. Proposições de distributividade de quantificadores **)

Theorem distirbutividade_quantificadores1 : forall (A : Type)(phi psi : A -> Prop),
  (exists (x : A), phi x /\ psi x) -> (exists (x : A), phi x) /\ (exists (x : A), psi x).
Proof.
  intros A phi psi Hex__phx_and_psx. destruct Hex__phx_and_psx as (a, Hpha_and_psa).
  destruct Hpha_and_psa as (Hpha, Hpsa).
  split.
  - exists a. assumption.
  - exists a. assumption.
Qed.

Theorem distirbutividade_quantificadores3 : forall (A : Type)(phi psi : A -> Prop),
  (exists (x : A), phi x \/ psi x) -> (exists (x : A), phi x) \/ (exists (x : A), psi x).
Proof.
  intros A phi psi Hex_phx_or_psx.
  destruct Hex_phx_or_psx as (a, Hpha_or_psa).
  destruct Hpha_or_psa as [Hpha | Hpsa].
  - left. exists a. exact Hpha.
  - right. exists a. exact Hpsa.
Qed.

Theorem distirbutividade_quantificadores4 : forall (A : Type)(phi psi : A -> Prop),
  (exists (x : A), phi x) \/ (exists (x : A), psi x) -> (exists (x : A), phi x \/ psi x).
Proof.
  intros A phi psi Hex_phx__or__ex_psx.
  destruct Hex_phx__or__ex_psx as [Hex_phx | Hex_psx].
  - destruct Hex_phx as (a, Hpha).
    exists a. left. exact Hpha.
  - destruct Hex_psx as (a, Hpsa).
    exists a. right. exact Hpsa.
Qed.

Theorem distirbutividade_quantificadores5 : forall (A : Type)(phi psi : A -> Prop),
  (forall (x : A), phi x /\ psi x) -> (forall (x : A), phi x) /\ (forall (x : A), psi x).
Proof.
  intros A phi psi Hfx_phx_and_psix.
  split.
  - intros a. destruct (Hfx_phx_and_psix a) as (Hpha, Hpsa).
    exact Hpha.
  - intros a. destruct (Hfx_phx_and_psix a) as (Hpha, Hpsa).
    exact Hpsa.
Qed.

Theorem distirbutividade_quantificadores6 : forall (A : Type)(phi psi : A -> Prop),
  (forall (x : A), phi x) /\ (forall (x : A), psi x) -> (forall (x : A), phi x /\ psi x).
Proof.
  intros A phi psi Hfx_phx__and__fx_psx x.
  destruct Hfx_phx__and__fx_psx as (Hfx_phx, Hfx_psx).
  split.
  - exact (Hfx_phx x).
  - exact (Hfx_psx x).
Qed.

Theorem distirbutividade_quantificadores8 : forall (A : Type)(phi psi : A -> Prop),
  (forall (x : A), phi x) \/ (forall (x : A), psi x) -> (forall (x : A), phi x \/ psi x).
Proof.
  intros A phi psi Hfx_phx__or__fx_psx x.
  destruct Hfx_phx__or__fx_psx as [Hfx_phx | Hfx_psx].
  - left. exact (Hfx_phx x).
  - right. exact (Hfx_psx x).
Qed.

(** 1. (Cont) Proposições de contraposição **)

Theorem contraopositiva1 : forall (P Q : Prop), (P -> Q) -> (~Q -> ~P).
Proof.
  intros P Q HP_imp_Q HnQ HP. apply HP_imp_Q in HP as HQ.
  apply HnQ in HQ as Hfalse. assumption.
Qed.

Theorem contrapositiva2_with_raa : raa -> forall (P Q : Prop), (~Q -> ~P) -> (P -> Q).
Proof.
  intros Hraa P Q HnQ_imp_nP HP.
  apply Hraa.
  intros HnQ. apply HnQ_imp_nP in HnQ as HnP.
  apply HnP in HP as Hfalse. contradiction.
Qed.