Require Import ords ssreflect ssrfun ssrbool pg3x_spec pg33_ind.
Require Import wlog.

Module PS : ProjectiveSpace.

  Definition Point := Point.
  Definition Line := Line.

  Definition incid_lp := incid_lp.
  Definition eqP := eqP.
  Definition eqL := eqL.

  (** a1_exists : existence of a line generated from 2 points *)

  Check l_from_points.

  Ltac prove_a1_exists :=
    let A:=fresh in
    let B:=fresh in
    intros A B;  pose (l:=(l_from_points A B));
                   revert l;case A; case B; intros l; exists l; exact (erefl true).

  Lemma a1_exists : forall A B : Point,
      {l : Line | incid_lp A l && incid_lp B l}.
  Proof.
    idtac "-> proving a1_exists".
    time (prove_a1_exists).
    Time Qed.
  Check a1_exists.

  (** a3_1 : every line has at least three distinct points *)

  Ltac exists_p3 t u v :=
    exact (existT _ t
                  (existT _  u
                          (exist _   v (erefl true)))).

  Ltac prove_a3_1 := let l := fresh "l" in
                     let x := fresh "x" in
                     intros l; pose (x:= points_from_line l); revert x;
                     case l; intros x;
                     exists_p3 (fst (fst (fst x))) (snd (fst (fst x))) (snd (fst x)).

  Definition dist_3p  (A B C :Point) : bool := (negb (eqP A B)) && (negb (eqP A C)) && (negb (eqP B C)).

  Lemma a3_1 :
    forall l:Line,{A:Point &{B:Point &{ C:Point|
            dist_3p A B C && (incid_lp A l && incid_lp B l && incid_lp C l)}}}.
    Proof.
    idtac "-> proving a3_1".
    time (prove_a3_1).
    Time Qed.

    Check a3_1.

  (** a1_unique : unicity of the line generated from 2 points *)
  (** l_from_points is actually a1_exists *)
  Check l_from_points.
  Check a1_exists.

  Lemma points_line : forall T Z:Point, forall x:Line,
        incid_lp T x -> incid_lp Z x -> (T<>Z) -> x = (l_from_points T Z).
  Proof.
    idtac "-> proving points_line".
    time (intros T Z x;
          case x; case T; intros HTx;
          first [ discriminate |
                 case Z; intros HZx HTZ;
                 solve  [ discriminate |  exact (@erefl Line _) | apply False_rect; auto ] ]).
    Time Qed.

  Check points_line.

  Ltac handle x :=
    match goal with Ht  : is_true (incid_lp ?T x),
                    Hz  : is_true (incid_lp ?Z x),
                    Htz : (not (@eq Point ?T ?Z))  |- _ =>
                    let HP := fresh in pose proof (points_line T Z x Ht Hz Htz) as HP;
                                       clear Ht Hz; rewrite HP(*; subst*)  end.

  Ltac prove_a1_unique :=
    let A:=fresh in
    let B:= fresh in
    let HAB' := fresh in
    let l1:=fresh in
    let l2:=fresh in
    let HAB:=fresh in
    let HAl1:=fresh in
    let HBl1:= fresh in
    let HAl2 := fresh in
    let HBl2 := fresh in
    intros A B l1 l2 HAB HAl1 HBl1 HAl2 HBl2;
    revert A B HAB l1 HAl1 HBl1 l2 HAl2 HBl2;
    intros  X; case X;
    intros Y;case Y; intros HAB;
    solve [apply False_rect; auto
          | discriminate
          | intros l1 HAl1 HBl1; handle l1; intros l2 HAl2 HBl2; handle l2; exact (@erefl Line _)].

  Lemma a1_unique:forall (A B :Point)(l1 l2:Line),
      ~A=B -> incid_lp A l1 -> incid_lp B l1  -> incid_lp A l2 -> incid_lp B l2 -> l1=l2.
  Proof.
    idtac "-> proving a1_unique".
    time(prove_a1_unique).
    Time Qed.

  Check a1_unique.

  Lemma Point_dec : forall T U:Point, {T=U}+{~T=U}.
  Proof.
    intros T U; case T; case U;
      solve [left; exact (@erefl Point _) | right; discriminate].
  Qed.

  Ltac prove_uniqueness :=
    let P:= fresh in
    let Q:= fresh in
    let hypP := fresh in
    let HPQdiff := fresh in
    let hypQ := fresh in
    let HPQ := fresh in
    let l := fresh in
    let m := fresh in
    let Hl := fresh in
    let Hl' := fresh in
    let Hm := fresh in
    let Hm' := fresh in
    intros P Q l m Hl Hl' Hm Hm';
    revert l Hl Hl' m Hm Hm';
    destruct (Point_dec P Q) as [HPQdiff | HPQdiff];
    [left; rewrite HPQdiff; exact (@erefl Point _) | idtac]; revert HPQdiff;
    case P; case Q; intros HPQdiff;
    solve [discriminate |
      intros  l Hl Hl';handle l; intros m Hm Hm'; handle m; right; exact (@erefl Line _)].

  Lemma uniqueness : forall (A B :Point)(l1 l2:Line),
      incid_lp A l1 -> incid_lp B l1  -> incid_lp A l2 -> incid_lp B l2 -> A = B \/ l1 = l2.
  Proof.
    idtac "-> proving uniqueness".
    time(prove_uniqueness).
    Time Qed.
  Check uniqueness.

  (** a3_2 : there exists 2 lines which do not intersect, i.e. dim >= 3  *)

  Ltac solve_a3_2 := let p:= fresh in
                     intros p; case p;
                     let hypp:=fresh in let t := fresh in intros hypp t; discriminate.

  (*Ltac prove_a3_2 := try_all_l ltac:(fun l1 => exists l1; try_all_l ltac:(fun l2 => exists l2; solve_a3_2)).*)

  Lemma a3_2 : exists l1:Line, exists l2:Line, forall p:Point, ~(incid_lp p l1 && incid_lp p l2).
  Proof.
    idtac "-> proving a3_2".
    exists L0; exists L34;intros p; case p;
      let hypp:=fresh in let t := fresh in intros t; discriminate.
    (*Time (prove_a3_2).*) (* we could have chosen GKL and EHM for instance:  exists (o 35 0); exists (o 35 34)).*)
    Time Qed.
  Check a3_2.

(* a3_3 : given 3 lines, there exists a line which intersects these 3 lines *)

  Definition Intersect_In (l1 l2 :Line) (P:Point) := incid_lp P l1 && incid_lp P l2.

  (** points_from_l is actually a3_1 *)

  Definition points_from_l (l:Line) := points_from_line l.

  Ltac exists_lppp l t u v :=
    exact (ex_intro _  l
                 (ex_intro _  t
                  (ex_intro _ u
                          (ex_intro _  v  (erefl true))))).

  Definition dist_3l (A B C :Line) : bool :=
    (negb (eqL A B)) && (negb (eqL A C)) && (negb (eqL B C)).

  Lemma a3_3_simple :
    forall v1 v2 v3:Line,
      leL v1 v2-> leL v2 v3 ->
      dist_3l v1 v2 v3 ->
      exists v4 :Line, exists T1:Point, exists T2:Point, exists T3:Point,
              (Intersect_In v1 v4 T1) && (Intersect_In v2 v4 T2) && (Intersect_In v3 v4 T3).
   Proof.
     idtac "-> proving a3_3_simple".
     unfold dist_3l; intros v1 v2 v3 Hv1v2 Hv2v3 Hd;
       pose (t:=f_a3_3 v1 v2 v3) ;
pose(l:=fst t); pose (x:= fst (fst (snd t))); pose (y:= snd (fst (snd t))); pose (z:=snd (snd t));
       revert Hv1v2 Hv2v3 Hd t l x y z.

     case v1.

(*case v2;
                  intros hp1p2;try exact (degen_bool _ hp1p2) .

case v3;intros hp1p3 hdist l x y z.*)

    par: abstract
           (time (case v2;
                  intros hp1p2;
                  first [exact (degen_bool _ hp1p2) |
                         (case v3;
                          intros hp1p3 hdist t l x y z;
                          solve [ (exact (degen_bool _ hp1p3))
                                | (exact (degen_bool _ hdist))
                                | exists_lppp l x y z ])])).

      Time Qed.
(*233s*)
   Lemma eqL_sym : forall x y:Line, eqL x y = eqL y x.
    Proof.
      idtac "proving eqL_sym".
      time (intros; apply PeanoNat.Nat.eqb_sym).
    Time Qed.
    Check eqL_sym.

    Lemma eqP_sym : forall x y:Point, eqP x y = eqP y x.
    Proof.
      idtac "proving eqP_sym".
      time (intros;apply PeanoNat.Nat.eqb_sym).
    Time Qed.
    Check eqP_sym.

    Lemma exchL: forall x y B C, ~~eqL y x && B &&C-> ~~eqL x y && B && C.
    Proof.
      intros x y b c H.
      apply ab_bool in H.
      destruct H as [Hx Hy].
      apply ab_bool in Hx.
      destruct Hx.
      apply ab_bool; split.
      apply ab_bool; split.
      rewrite eqL_sym.
      assumption.
      assumption.
      assumption.
    Qed.

    Lemma exchP: forall x y B C D E F,
        ~~eqP y x && B &&C &&D &&E &&F-> ~~eqP x y && B && C && D && E &&F.
    Proof.
      intros x y b c d e f H.
      apply ab_bool in H.
      destruct H as [Ha Hf]; apply ab_bool in Ha;
        destruct Ha as [Ha He]; apply ab_bool in Ha;
          destruct Ha as [Ha Hd]; apply ab_bool in Ha;
            destruct Ha as [Ha Hc]; apply ab_bool in Ha;
              destruct Ha as [Ha Hb].
      apply ab_bool; split.
      apply ab_bool; split.
      apply ab_bool; split.
      apply ab_bool; split.
      apply ab_bool; split.
      rewrite eqP_sym.
      assumption.
      assumption.
      assumption.
      assumption.
      assumption.
      assumption.
    Qed.

   Lemma a3_3 : forall v1 v2 v3:Line,
      dist_3l v1 v2 v3 -> exists v4 :Line,  exists T1:Point, exists T2:Point, exists T3:Point,
             (Intersect_In v1 v4 T1) && (Intersect_In v2 v4 T2) && (Intersect_In v3 v4 T3).
  Proof.
    idtac "-> proving a3_3".
    intros v1 v2 v3.
    wlog3 v1 v2 v3 leL leL_total idtac idtac.

    intros; apply a3_3_simple.
    destruct (ab_bool_lr _ _  H) as [Ha1 Ha2]; exact Ha1.
    destruct (ab_bool_lr _ _  H) as [Ha1 Ha2]; exact Ha2.
    assumption.

    intros.
    assert (Hd: dist_3l x z y).
    unfold dist_3l in *;
      apply circ3;apply circ3;apply exchL;apply circ3; apply comm12L; assumption.
    destruct (H Hd) as [v4 [t1 [t2 [t3 Hv4t1t2t3]]]].
    exists v4; exists t1; exists t3; exists t2.
    apply circ3; apply circ3; apply comm12L; assumption.

    intros.
    assert (Hd: dist_3l y x z).
    unfold dist_3l in *; apply exchL; apply circ3; apply circ3; apply comm12L; assumption.
    destruct (H Hd) as [v4 [t1 [t2 [t3 Hv4t1t2t3]]]].
    exists v4; exists t2; exists t1; exists t3.
    apply comm12L; assumption.

    intros.
    assert (Hd: dist_3l y z x).
    unfold dist_3l in *.
    apply circ3; apply exchL; apply circ3; apply exchL; apply circ3; apply circ3; assumption.
    destruct (H Hd) as [v4 [t1 [t2 [t3 Hv4t1t2t3]]]].
    exists v4; exists t3; exists t1; exists t2.
    apply circ3; assumption.

    intros.
    assert (Hd: dist_3l z x y).
    unfold dist_3l in *.
    apply exchL; apply circ3; apply exchL; apply circ3; assumption.
    destruct (H Hd) as [v4 [t1 [t2 [t3 Hv4t1t2t3]]]].
    exists v4; exists t2; exists t3; exists t1.
    apply circ3; apply circ3; assumption.

    intros.
    assert (Hd: dist_3l z y x).
    unfold dist_3l in *.
    apply exchL; apply circ3; apply exchL; apply circ3; apply exchL;
      apply circ3; apply circ3; apply comm12L; assumption.
    destruct  (H Hd) as [v4 [t1 [t2 [t3 Hv4t1t2t3]]]].
    exists v4; exists t3; exists t2; exists t1.
    apply comm12L; apply circ3;apply circ3; assumption.
    Time Qed.

  (** a2 : Pasch's axiom *)

  Definition dist_4p  (A B C D:Point) : bool :=
    (negb (eqP A B)) && (negb (eqP A C)) && (negb (eqP A D))
                     && (negb (eqP B C)) && (negb (eqP B D)) && (negb (eqP C D)).

  Ltac findp' := match goal with
                  |-  (@ex Point (fun J:Point =>
                                       is_true (andb (incid_lp J ?m)
                                                     (incid_lp J ?p))))
                  /\ (@ex Point (fun K:Point =>
                                       is_true (andb (incid_lp K ?q)
                                                     (incid_lp K ?r))))=>
                  exact (conj (ex_intro _  ((*pg33_ind.*)f_a2 m p) (erefl true))
                              (ex_intro _  ((*pg33_ind.*)f_a2 q r) (erefl true)))
                 end.

  Lemma a2_conj_specific :
    forall A B C D:Point, leP A B -> leP C D ->
        let lAB := l_from_points A B in
        let lCD := l_from_points C D in
        let lAC := l_from_points A C in
        let lBD := l_from_points B D in
        let lAD := l_from_points A D in
        let lBC := l_from_points B C in

        dist_4p A B C D ->
        incid_lp A lAB && incid_lp B lAB ->
        incid_lp C lCD && incid_lp D lCD ->
        incid_lp A lAC && incid_lp C lAC ->
        incid_lp B lBD && incid_lp D lBD ->
        incid_lp A lAD && incid_lp D lAD ->
        incid_lp B lBC && incid_lp C lBC ->

        (exists I:Point, incid_lp I lAB && incid_lp I lCD) ->
        (exists J:Point, (incid_lp J lAC && incid_lp J lBD)) /\
        (exists K:Point, (incid_lp K lAD && incid_lp K lBC)).
  Proof.
  idtac "-> proving a2_conj_specific".
     intros A B C D HleAB HleCD lAB lCD lAC lBD lAD lBC Hdist HlAB HlCD HlAC HlBD HlAD HlBC Hex;
       destruct (ab_bool_lr _ _ Hdist) as [Hdist1 HCD]; clear Hdist;
         destruct (ab_bool_lr _ _ Hdist1) as [Hdist2 HBD]; clear Hdist1;
           destruct (ab_bool_lr _ _ Hdist2) as [Hdist3 HBC]; clear Hdist2;
             destruct (ab_bool_lr _ _ Hdist3) as [Hdist4 HAD]; clear Hdist3;
               destruct (ab_bool_lr _ _ Hdist4) as [HAB HAC]; clear Hdist4;
        revert A B HleAB HAB lAB HlAB C HBC HAC lBC HlBC lAC HlAC D HleCD HAD HBD HCD lAD HlAD lBD HlBD lCD HlCD Hex.

     time (intros A B; case A; case B; intros HlePAB HAB lAB HlAB).
     par: abstract (time (first [exact (degen_bool _ HlePAB) |exact (degen_bool _ HAB) | exact (degen_bool _ HlAB)|

      (intros C; case C; intros HBC HAC lBC HlBC lAC HlAC;
           first [  exact (degen_bool _ HBC) | exact (degen_bool _ HAC)
                        |

                        (intros D; case D; intros HleCD HAD HBD HCD lAD HlAD lBD HlBD lCD HlCD Hex;

                         first [ exact (degen_bool _ HleCD) | exact (degen_bool _ HAD)
                                 | exact (degen_bool _ HBD) | exact (degen_bool _ HCD)

                                 | case Hex; intros t; case t; intros Ht;
                                 first [exact (degen_bool _ Ht) | findp'] ])])])).
  Qed.
  Check a2_conj_specific.

  Lemma l_from_points_sym : forall x y:Point, l_from_points x y = l_from_points y x.
  Proof.
    intros x y; case x; case y; reflexivity.
  Qed.

Lemma a2_conj :
    forall A B C D:Point, dist_4p A B C D ->
         let lAB := l_from_points A B in
         let lCD := l_from_points C D in
         let lAC := l_from_points A C in
         let lBD := l_from_points B D in
         let lAD := l_from_points A D in
         let lBC := l_from_points B C in

         incid_lp A lAB && incid_lp B lAB ->
         incid_lp C lCD && incid_lp D lCD ->
         incid_lp A lAC && incid_lp C lAC ->
         incid_lp B lBD && incid_lp D lBD ->
         incid_lp A lAD && incid_lp D lAD ->
         incid_lp B lBC && incid_lp C lBC ->

         (exists I:Point, incid_lp I lAB && incid_lp I lCD) ->
         (exists J:Point, (incid_lp J lAC && incid_lp J lBD)) /\
         (exists J:Point, (incid_lp J lAD && incid_lp J lBC)).
  Proof.
    intros A B.
    wlog2 A B leP leP_total idtac idtac.
    intros A B HleAB.
    intros C D.
    wlog2 C D leP leP_total idtac ltac:(intros; apply a2_conj_specific; assumption || exact I).
    (* other cases *)

    intros C D Hr.

    intros lAB lCD lAC lBD lAD lBC Hdist HlAB HlCD HlAC HlBD HlAD HlBC Hex.
    assert (Hd' : dist_4p A B D C).
    unfold dist_4p in *.
    apply circ6; apply comm12P; apply circ6; apply circ6 ; apply comm12P; apply circ6;
    apply circ6; apply exchP; apply circ6; assumption.

    assert (HlDC:(incid_lp D (l_from_points D C) && incid_lp C (l_from_points D C))).
    apply circ2; rewrite l_from_points_sym; assumption.
    assert (Hex': (exists I : Point, incid_lp I (l_from_points A B) && incid_lp I (l_from_points D C))).
    rewrite (l_from_points_sym D C); assumption.
    generalize (Hr Hd' HlAB HlDC HlAD HlBC HlAC HlBD Hex').
    solve [intuition].

    intros A B Hr C D.
    intros Hd lAB lCD lAC lBD lAD lBC HlAB HlCD HlAC HlBD HlAD HlBC Hex.
    assert (Hd':  dist_4p B A C D).
    unfold dist_4p in *.
    apply exchP; apply circ6; apply circ6; apply comm12P; apply circ6; apply comm12P;
      apply circ6; apply circ6; apply circ6; apply circ6; apply comm12P; apply circ6;
        apply comm12P; apply circ6; apply circ6; apply circ6; apply circ6; assumption.

    assert (HlBA:incid_lp B (l_from_points B A) && incid_lp A (l_from_points B A)).
    apply circ2; rewrite l_from_points_sym; assumption.
    assert (HlDB:(incid_lp D (l_from_points D B) && incid_lp B (l_from_points D B))).
    apply circ2; rewrite l_from_points_sym; assumption.
    assert (Hex':(exists I : Point, incid_lp I (l_from_points B A) && incid_lp I (l_from_points C D))).
    rewrite (l_from_points_sym B A); assumption.

    generalize (Hr C D Hd' HlBA HlCD HlBC HlAD HlBD HlAC Hex').
    intros (He1,He2).
    split.
    destruct He2 as [e2 He2]; apply circ2 in He2; exists e2; assumption.
    destruct He1 as [e1 He1]; apply circ2 in He1; exists e1; assumption.
  Qed.

  Check a2_conj.

  Lemma points_line' : forall T Z:Point, forall x:Line,
        incid_lp T x -> incid_lp Z x -> ~~ eqP T Z -> x = (l_from_points T Z).
  Proof.
    idtac "-> proving points_line".
    time (intros T Z x;
           case x ;
           case T; intros  HTx;
           first [ discriminate |
                   case Z; intros  HZx HTZ;
                   solve [discriminate | apply False_rect; auto | exact (@erefl Line _)]]).
    Time Qed.

  Ltac handle' x :=
    match goal with Ht  : is_true (incid_lp ?T x),
                          Hz  : is_true (incid_lp ?Z x),
                                Htz : is_true (negb (eqP ?T ?Z)) |- _ =>
                    let HP := fresh in pose proof (points_line' T Z x Ht Hz Htz) as HP;
                                       clear Ht Hz; rewrite HP(*; subst*)  end.

  Ltac handle_eff l P Q HlAB:= assert (l=l_from_points P Q);[
                                 assert (incid_lp P l) by ( solve [intuition]);
                                 assert (incid_lp Q l) by ( solve [intuition]);
                                 handle' l; reflexivity | idtac].

  Lemma incid_lp_l_from_point1 : forall x y, incid_lp x (l_from_points x y).
  Proof.
    intros x y; case x; case y; trivial.
  Qed.

  Lemma incid_lp_l_from_point2 : forall x y, incid_lp y (l_from_points x y).
  Proof.
    intros x y; case x; case y; trivial.
  Qed.

  Lemma a2 : forall A B C D:Point, forall lAB lCD lAC lBD :Line,
        dist_4p A B C D ->
        incid_lp A lAB && incid_lp B lAB ->
        incid_lp C lCD && incid_lp D lCD ->
        incid_lp A lAC && incid_lp C lAC ->
        incid_lp B lBD && incid_lp D lBD ->
        (exists I:Point, incid_lp I lAB && incid_lp I lCD) ->
        exists J:Point, incid_lp J lAC && incid_lp J lBD.
  Proof.
    intros A B C D lAB lCD lAC lBD Hdist HlAB HlCD HlAC HlBD Hex.
    destruct (ab_bool_lr _ _ HlAB) as [HlAB1 HlAB2];
      destruct (ab_bool_lr _ _ HlCD) as [HlCD1 HlCD2];
      destruct (ab_bool_lr _ _ HlAC) as [HlAC1 HlAC2];
      destruct (ab_bool_lr _ _ HlBD) as [HlBD1 HlBD2];
      destruct (ab_bool_lr _ _ Hdist) as [Hdist1 HCD];
      destruct (ab_bool_lr _ _ Hdist1) as [Hdist2 HBD];
      destruct (ab_bool_lr _ _ Hdist2) as [Hdist3 HBC];
      destruct (ab_bool_lr _ _ Hdist3) as [Hdist4 HAD];
      destruct (ab_bool_lr _ _ Hdist4) as [HAB HAC].

    handle_eff lAB A B HlAB.
    handle_eff lCD C D HlCD.
    handle_eff lAC A C HlAC.
    handle_eff lBD B D HlBD.
    rewrite H in HlAB.
    rewrite H0 in HlCD.
    rewrite H1 in HlAC.
    rewrite H2 in HlBD.
    rewrite H in Hex.
    rewrite H0 in Hex.
    assert (HlAD:(incid_lp A (l_from_points A D) && incid_lp D (l_from_points A D))).
    apply Bool.andb_true_iff; split;
      [apply incid_lp_l_from_point1 | apply incid_lp_l_from_point2].

    assert (HlBC: (incid_lp B (l_from_points B C) && incid_lp C (l_from_points B C))).
    apply Bool.andb_true_iff; split;
      [apply incid_lp_l_from_point1 | apply incid_lp_l_from_point2].

    rewrite H1.
    rewrite H2.
    elim (a2_conj A B C D Hdist HlAB HlCD HlAC HlBD HlAD HlBC Hex).
    intros; assumption.
  Qed.
  Check a2.

End PS.

(* Local Variables: *)
(* coq-prog-name: "/Users/magaud/.opam/4.07.0/bin/coqtop" *)
(* coq-load-path: (("." "Top") ) *)
(* suffixes: .v *)
(* End: *)


Require Import Coq.Program.Equality.
Require Import Coq.btauto.Btauto.
From Coq.ssr Require Import ssreflect ssrfun ssrbool.
From mathcomp.ssreflect Require Import seq eqtype.

Set Boolean Equality Schemes.
Set Decidable Equality Schemes.

Module Syntax1.
Inductive syntax := Zero | One
 | Tensor (Left : syntax) (Right : syntax)
 | With (Left : syntax) (Right : syntax)
 | Implication (Left : syntax) (Right : syntax)
 | Bang (Right : syntax).

Declare Scope syntax_scope.
Delimit Scope syntax_scope with syntax. (* allows writing foo%syntax to mean that foo is in syntax_scope *)
Bind Scope syntax_scope with syntax. (* means that functions taking variables of type syntax will
automatically parse those variables in syntax_scope *)
Print Grammar constr.
Notation "A * B" := (Tensor A B) : syntax_scope.
Notation "A && B" := (With A B) : syntax_scope.
Notation "A '-o' B" := (Implication A B) (at level 99) : syntax_scope.
Notation "! A" := (Bang A) (at level 9, format "! A") : syntax_scope.
Notation "0" := Zero : syntax_scope.
Notation "1" := One : syntax_scope.
Reserved Notation "Ctx ||- A" (at level 100, no associativity).

(* ssreflect magic to use decidable membership *)
Lemma syntax_eqbP : Equality.axiom syntax_beq.
Proof.
  intros A B; pose proof (internal_syntax_dec_bl A B); pose proof (internal_syntax_dec_lb A B).
  destruct (syntax_beq A B); constructor.
  all: intuition congruence.
Qed.

Canonical syntax_eqMixin := EqMixin syntax_eqbP.
Canonical syntax_eqType := Eval hnf in EqType syntax syntax_eqMixin.
Inductive provable : seq syntax -> syntax -> Type :=
| idA A

(*------------------------------*)
:          [:: A] ||- A

| permute_context Ctx1 Ctx2 P

(a : perm_eq Ctx1 Ctx2)     (b : Ctx1 ||- P)
(*---------------------------------------------*)
:                  Ctx2 ||- P

| tensor_left Ctx A B P

    (a : A :: B :: Ctx ||- P)
(*------------------------------*)
:     A * B :: Ctx ||- P

| tensor_right Ctx1 Ctx2 A B
 (a : Ctx1 ||- A)    (b : Ctx2 ||- B)
(*------------------------------------*)
:     Ctx1 ++ Ctx2 ||- A * B

| with_left_1 Ctx A B P

      (a : A :: Ctx ||- P)
(*------------------------------*)
:      A && B :: Ctx ||- P

| with_left_2 Ctx A B P

      (a : B :: Ctx ||- P)
(*------------------------------*)
:      A && B :: Ctx ||- P

| with_right Ctx A B

(a : Ctx ||- A)    (b : Ctx ||- B)
(*------------------------------*)
:       Ctx ||- A && B

| one_left Ctx P

          (a : Ctx ||- P)
(*------------------------------*)
:         1 :: Ctx ||- P

| one_right

(*------------------------------*)
:           [::] ||- 1

| zero_left Ctx P

(*------------------------------*)
:     0 :: Ctx ||- P

| implication_left Ctx1 Ctx2 A B P

      (a : Ctx1 ||- A)    (b : B :: Ctx2 ||- P)
(*--------------------------------------------------*)
:         (A -o B) :: Ctx1 ++ Ctx2 ||- P

| implication_right Ctx A B

     (a : A :: Ctx ||- B)
(*------------------------------*)
:      Ctx ||- (A -o B)

where "Ctx ||- A" := (provable Ctx%syntax A).

Lemma catss0 : forall [T : Type] (s1 s2 : seq T),
  s1 ++ s2 = [::] -> s1 = [::] /\ s2 = [::].
Proof.
  destruct s1.
  {
    simpl.
    intros.
    split.
    {
      reflexivity.
    }
    {
      exact H.
    }
  }
  {
    simpl.
    intros.
    discriminate.
  }
Qed.

(** Previously, we were copy-pasting
<<<
    exfalso.
    clear -x.
    apply catss0 in x.
    destruct x as [a b].
    apply catss0 in b.
    destruct b as [c d].
    discriminate.
>>>
to prove goals like
>>>
1 subgoal
Ctx1, Ctx2 : seq syntax
Left, Right : syntax
proof : Ctx1 ++ [:: Left; Right] ++ Ctx2 ||- False
IHproof : Ctx1 ++ [:: Left; Right] ++ Ctx2 = [::] ->
          False = False -> Logic.False
x : Ctx1 ++ [:: (Left /\ Right)%syntax] ++ Ctx2 = [::]
______________________________________(1/1)
Logic.False
>>>

Now we write a tactic to handle all goals which have a hypothesis which says that some concatenation of lists is empty.
*)
Ltac absurd_from_empty_cat :=
  repeat match goal with
         | [ H : _ ++ _ = [::] |- _ ] => apply catss0 in H
         | [ H : _ /\ _        |- _ ] => destruct H
         | [ H : _ :: _ = [::] |- _ ] => exfalso; discriminate
         end.

Fixpoint truth_value (x : syntax) : bool
  := match x with
     | One => true
     | Zero => false
     | Tensor l r => truth_value l && truth_value r
     | With l r => truth_value l && truth_value r
     | Implication l r => if truth_value l then truth_value r else true
     | Bang r => truth_value r
     end.

Definition truth_value_of_context (ctx : seq syntax) : bool
  := foldr andb true (map truth_value ctx).

Lemma truth_value_of_context_cons x ctx : truth_value_of_context (x :: ctx) = truth_value x && truth_value_of_context ctx.
Proof.
  reflexivity.
Qed.

Lemma foldr_cat_assoc A (s1 s2 : seq A) (init : A) (op : A -> A -> A)
  (init_idl : forall x, op init x = x)
  (op_assoc : forall a b c, op a (op b c) = op (op a b) c)
: foldr op init (s1 ++ s2) = op (foldr op init s1) (foldr op init s2).
Proof.
  induction s1.
  {
    simpl.
    rewrite init_idl.
    reflexivity.
  }
  {
    simpl.
    rewrite IHs1.
    rewrite op_assoc.
    reflexivity.
  }
Qed.

Search "assoc" andb.

Lemma truth_value_of_context_cat Ctx1 Ctx2
: truth_value_of_context (Ctx1 ++ Ctx2) = truth_value_of_context Ctx1 && truth_value_of_context Ctx2.
Proof.
  unfold truth_value_of_context.
  Search map cat.
  rewrite map_cat.
  Search foldr cat.
  Search foldr.
  rewrite foldr_cat_assoc//.
  apply Bool.andb_assoc.
Qed.

Lemma truth_value_of_context_nil
: truth_value_of_context [::] = true.
Proof.
  reflexivity.
Qed.

Search perm_eq.
Check catCA_perm_ind.

Lemma truth_value_of_context_perm Ctx1 Ctx2 : perm_eq Ctx1 Ctx2 -> truth_value_of_context Ctx1 = truth_value_of_context Ctx2.
Proof.
  Search perm_eq.
  Check catCA_perm_ind.
  intros A.
  pose proof (@catCA_perm_ind _
    (fun Ctx2 => truth_value_of_context Ctx1 = truth_value_of_context Ctx2)) as H.
  cbv beta in H.
  apply H with (s1 := Ctx1).
  {
    clear.
    intros s1 s2 s3 A.
    rewrite A.
    clear.
    rewrite !truth_value_of_context_cat.
    Search (?A && ?B = ?B && ?A).
    Search (_ && _ = _ && _).
    rewrite !Bool.andb_assoc.
    rewrite (Bool.andb_comm (truth_value_of_context s1) (truth_value_of_context s2)).
    reflexivity.
  }
  {
    exact A.
  }
  {
    reflexivity.
  }
Qed.

Theorem boolean_consistency : forall Ctx P, (Ctx ||- P) ->  truth_value_of_context Ctx = true -> truth_value P = true.
Proof.
  intros Ctx P H T.
  induction H;
  rewrite -> ?truth_value_of_context_cat, -> ?truth_value_of_context_cons, -> ?truth_value_of_context_nil, -> ?Bool.andb_true_r in *.
  all: simpl in *; auto.
  all: rewrite -> ?truth_value_of_context_cat, -> ?truth_value_of_context_cons, -> ?truth_value_of_context_nil, -> ?Bool.andb_true_r in *.
  all: simpl in *; auto.
  {
    apply truth_value_of_context_perm in a.
    rewrite -a // in T.
  }
  {
    rewrite -> ?Bool.andb_assoc in *.
    assert (X : truth_value A = true) by auto.
    rewrite -> X in *.
    auto.
  }
  {
    rewrite T in IHprovable.
    Search (_ && true).
    rewrite -> Bool.andb_true_r in *.
    destruct (truth_value A); auto.
  }
Qed.

Inductive extended_nat := negative_infinity | positive_infinity | non_negative (_:nat).
Coercion non_negative : nat >-> extended_nat.
Declare Scope extended_nat_scope.
Delimit Scope extended_nat_scope with extended_nat.
Bind Scope extended_nat_scope with extended_nat.
Notation "-oo" := negative_infinity : extended_nat_scope.
Notation "+oo" := positive_infinity : extended_nat_scope.

Definition extended_plus (A B : extended_nat) : extended_nat
  := match A, B with
     | -oo, -oo => -oo
     | -oo, non_negative _ => -oo
     | non_negative _, -oo => -oo
     | non_negative A, non_negative B => non_negative (A + B)
     end%extended_nat.
Infix "+" := extended_plus : extended_nat_scope.

Definition extended_minus (A B : extended_nat) : extended_nat
  := match A, B with
     | -oo, -oo => -oo
     | -oo, non_negative _ => -oo
     | non_negative _, -oo => -oo
     | non_negative A, non_negative B => non_negative (A + B)
     end%extended_nat.
Infix "-" := extended_minus : extended_nat_scope.

Fixpoint resource_count (x : syntax) : extended_nat
  := match x with
     | One => 0
     | Zero => -oo
     | Tensor l r => resource_count l + resource_count r
     | With l _ =>  resource_count l
     | Implication l r => resource_count r - resource_count a
     | Bang r => truth_value r
     end%extended_nat.

Definition truth_value_of_context (ctx : seq syntax) : bool
  := foldr andb true (map truth_value ctx).

Lemma truth_value_of_context_cons x ctx : truth_value_of_context (x :: ctx) = truth_value x && truth_value_of_context ctx.
Proof.
  reflexivity.
Qed.

Lemma foldr_cat_assoc A (s1 s2 : seq A) (init : A) (op : A -> A -> A)
  (init_idl : forall x, op init x = x)
  (op_assoc : forall a b c, op a (op b c) = op (op a b) c)
: foldr op init (s1 ++ s2) = op (foldr op init s1) (foldr op init s2).
Proof.
  induction s1.
  {
    simpl.
    rewrite init_idl.
    reflexivity.
  }
  {
    simpl.
    rewrite IHs1.
    rewrite op_assoc.
    reflexivity.
  }
Qed.

Search "assoc" andb.

Lemma truth_value_of_context_cat Ctx1 Ctx2
: truth_value_of_context (Ctx1 ++ Ctx2) = truth_value_of_context Ctx1 && truth_value_of_context Ctx2.
Proof.
  unfold truth_value_of_context.
  Search map cat.
  rewrite map_cat.
  Search foldr cat.
  Search foldr.
  rewrite foldr_cat_assoc//.
  apply Bool.andb_assoc.
Qed.

Lemma truth_value_of_context_nil
: truth_value_of_context [::] = true.
Proof.
  reflexivity.
Qed.

Search perm_eq.
Check catCA_perm_ind.

Lemma truth_value_of_context_perm Ctx1 Ctx2 : perm_eq Ctx1 Ctx2 -> truth_value_of_context Ctx1 = truth_value_of_context Ctx2.
Proof.
  Search perm_eq.
  Check catCA_perm_ind.
  intros A.
  pose proof (@catCA_perm_ind _
    (fun Ctx2 => truth_value_of_context Ctx1 = truth_value_of_context Ctx2)) as H.
  cbv beta in H.
  apply H with (s1 := Ctx1).
  {
    clear.
    intros s1 s2 s3 A.
    rewrite A.
    clear.
    rewrite !truth_value_of_context_cat.
    Search (?A && ?B = ?B && ?A).
    Search (_ && _ = _ && _).
    rewrite !Bool.andb_assoc.
    rewrite (Bool.andb_comm (truth_value_of_context s1) (truth_value_of_context s2)).
    reflexivity.
  }
  {
    exact A.
  }
  {
    reflexivity.
  }
Qed.

Theorem boolean_consistency : forall Ctx P, (Ctx ||- P) ->  truth_value_of_context Ctx = true -> truth_value P = true.
Proof.
  intros Ctx P H T.
  induction H;
  rewrite -> ?truth_value_of_context_cat, -> ?truth_value_of_context_cons, -> ?truth_value_of_context_nil, -> ?Bool.andb_true_r in *.
  all: simpl in *; auto.
  all: rewrite -> ?truth_value_of_context_cat, -> ?truth_value_of_context_cons, -> ?truth_value_of_context_nil, -> ?Bool.andb_true_r in *.
  all: simpl in *; auto.
  {
    apply truth_value_of_context_perm in a.
    rewrite -a // in T.
  }
  {
    rewrite -> ?Bool.andb_assoc in *.
    assert (X : truth_value A = true) by auto.
    rewrite -> X in *.
    auto.
  }
  {
    rewrite T in IHprovable.
    Search (_ && true).
    rewrite -> Bool.andb_true_r in *.
    destruct (truth_value A); auto.
  }
Qed.


Require Import Reals.
Require Import Interval.Tactic.

Open Scope R_scope.

Goal
  forall x, -1 <= x <= 1 ->
  sqrt (1 - x) <= 3/2.
Proof.
  intros.
  interval.
Qed.

Goal
  forall x, -1 <= x <= 1 ->
  sqrt (1 - x) <= 141422/100000.
Proof.
  intros.
  interval.
Qed.

Goal
  forall x, -1 <= x <= 1 ->
  sqrt (1 - x) <= 141422/100000.
Proof.
  intros.
  interval_intro (sqrt (1 - x)) upper as H'.
  apply Rle_trans with (1 := H').
  interval.
Qed.

Goal
  forall x, 3/2 <= x <= 2 ->
  forall y, 1 <= y <= 33/32 ->
  Rabs (sqrt(1 + x/sqrt(x+y)) - 144/1000*x - 118/100) <= 71/32768.
Proof.
  intros.
  interval with (i_prec 19, i_bisect x).
Qed.

Goal
  forall x, 1/2 <= x <= 2 ->
  Rabs (sqrt x - (((((122 / 7397 * x + (-1733) / 13547) * x
                   + 529 / 1274) * x + (-767) / 999) * x
                   + 407 / 334) * x + 227 / 925))
    <= 5/65536.
Proof.
  intros.
  interval with (i_bisect_taylor x 3).
Qed.

Goal
  forall x, -1 <= x ->
  x < 1 + powerRZ x 3.
Proof.
  intros.
  interval with (i_bisect_diff x).
Qed.

Require Import Coquelicot.Coquelicot.

Goal
  Rabs (RInt (fun x => atan (sqrt (x*x + 2)) / (sqrt (x*x + 2) * (x*x + 1))) 0 1
        - 5/96*PI*PI) <= 1/1000.
Proof.
  interval with (i_integral_prec 9, i_integral_depth 1, i_integral_deg 5).
Qed.

Goal
  RInt_gen (fun x => 1 * (powerRZ x 3 * ln x^2))
           (at_right 0) (at_point 1) = 1/32.
Proof.
  refine ((fun H => Rle_antisym _ _ (proj2 H) (proj1 H)) _).
  interval.
Qed.

Goal
  Rabs (RInt_gen (fun t => 1/sqrt t * exp (-(1*t)))
                 (at_point 1) (Rbar_locally p_infty)
        - 2788/10000) <= 1/1000.
Proof.
  interval.
Qed.


Require Import Coq.ZArith.ZArith.
Require Export Fiat.Common.Coq__8_4__8_5__Compat.

#[global]
Hint Rewrite <- nat_compare_lt : hints.
#[global]
Hint Rewrite <- nat_compare_gt : hints.
#[global]
Hint Rewrite Nat.compare_eq_iff : hints.
#[global]
Hint Rewrite <- Nat.compare_eq_iff : hints.

Ltac autorewrite_nat_compare :=
  autorewrite with hints.

Lemma nat_compare_eq_refl : forall x, Nat.compare x x = Eq.
  intros; apply Nat.compare_eq_iff; trivial.
Qed.

Lemma nat_compare_consistent :
  forall n0 n1,
    { Nat.compare n0 n1 = Lt /\ Nat.compare n1 n0 = Gt }
    + { Nat.compare n0 n1 = Eq /\ Nat.compare n1 n0 = Eq }
    + { Nat.compare n0 n1 = Gt /\ Nat.compare n1 n0 = Lt }.
Proof.
  intros n0 n1;
  destruct (lt_eq_lt_dec n0 n1) as [ [_lt | _eq] | _lt ];
  [ constructor 1; constructor 1  | constructor 1; constructor 2 | constructor 2 ];
  split;
  autorewrite_nat_compare;
  intuition.
Qed.