Require Import Imp.
Require Import Hoare.

Inductive hoare_proof : Assertion -> com -> Assertion -> Type :=
| H_Skip : forall P,
             hoare_proof P (SKIP) P
| H_Asgn : forall Q V a,
             hoare_proof (assn_sub V a Q) (V::= a) Q
| H_Seq : forall P c Q d R,
            hoare_proof P c Q ->
            hoare_proof Q d R ->
            hoare_proof P (c;;d) R
| H_If : forall P Q b c1 c2,
           hoare_proof (fun st => P st /\ bassn b st) c1 Q ->
           hoare_proof (fun st => P st /\ ~(bassn b st)) c2 Q ->
           hoare_proof P (IFB b THEN c1 ELSE c2 FI) Q
| H_While: forall P b c,
             hoare_proof (fun st => P st /\ bassn b st) c P ->
             hoare_proof P (WHILE b DO c END) (fun st => P st /\ ~(bassn b st))
| H_Consequence : forall (P Q P' Q' :Assertion) c,
                    hoare_proof P' c Q' ->
                    (forall st, P st -> P' st) ->
                    (forall st, Q' st -> Q st) ->
                    hoare_proof P c Q.

Lemma H_Consequence_pre :
  forall (P P' Q:Assertion) c,
    hoare_proof P' c Q ->
    (forall st, P st -> P' st) ->
    hoare_proof P c Q.
  intros. eapply H_Consequence. apply X. auto. auto.
Qed.

Lemma H_Consequence_post :
  forall (P Q Q':Assertion) c,
    hoare_proof P c Q' ->
    (forall st, Q' st -> Q st) ->
    hoare_proof P c Q.

  intros; eapply H_Consequence; eauto.
Qed.

Example same_proof:
  hoare_proof
    (assn_sub X (APlus (AId X) (ANum 1))
              (assn_sub X (APlus (AId X) (ANum 2))
                        (fun st => st X = 3)))
    (X ::= APlus (AId X) (ANum 1);; (X::= APlus (AId X) (ANum 2)))
    (fun st => st X = 3).
Proof.
  eapply H_Consequence_pre.
  eapply H_Seq.
  apply H_Asgn.
  apply H_Asgn. auto.
Qed.

Theorem hoare_proof_sound :
  forall P c Q,
    hoare_proof P c Q -> {{P}} c {{Q}}.

  intros.
  elim X.
  apply hoare_skip. apply hoare_asgn.
  intros. eapply hoare_seq; eauto.
  intros. eapply hoare_if; eauto.
  intros. eapply hoare_while; eauto.
  intros. eapply hoare_consequence; eauto.
Qed.

Theorem H_Post_True_deriv :
  forall c P,
    hoare_proof P c (fun _ => True).

  intro. elim c; intros.
  eapply H_Consequence_post. eapply H_Skip. auto.
  eapply H_Consequence_pre. eapply H_Asgn. unfold assn_sub. auto.
  eapply H_Seq; eauto.
  eapply H_If; eauto.
  eapply H_Consequence. apply (H_While (fun st=> True)). apply X. simpl. auto. auto.
Qed.

Theorem H_Pre_False_deriv:
  forall c P,
    hoare_proof (fun st => False) c P.
  intro. elim c.
  intros. eapply H_Consequence_pre. apply H_Skip. intros. elim H.
  intros. eapply H_Consequence_pre. apply H_Asgn. intros. elim H.
  intros. eapply H_Seq. eapply H_Consequence_pre. apply X. intros. elim H. auto.
  intros. eapply H_If. eapply H_Consequence_pre; eauto. intros. inversion H. elim H0.
  eapply H_Consequence_pre; eauto. intros. elim H. auto.
  intros. eapply H_Consequence. apply (H_While (fun st=>False)). eapply H_Consequence_pre. apply X.
  intros. inversion H. elim H0. intros ? x; elim x. simpl. intros ? x; inversion x. elim H.
Qed.

Definition wp (c:com) (Q:Assertion) :Assertion :=
  fun st => (forall st' , c/ st \\ st' -> Q st').

Lemma wp_is_precondition :
  forall c Q,
    {{wp c Q}} c {{Q}}.

  unfold wp. unfold hoare_triple. intros. auto.
Qed.

Lemma wp_is_weakest:
  forall c Q P',
    {{P'}} c {{Q}} -> forall st, P' st -> wp c Q st.
  unfold wp. unfold hoare_triple.
  intros. eauto.
Qed.

Theorem hoare_proof_complete :
  forall P c Q,
    {{P}} c {{Q}} -> hoare_proof P c Q.

  intros P c. generalize dependent P. unfold hoare_triple.
  elim c; intros. eapply H_Consequence_pre. apply H_Skip. intro. apply (H st st (E_Skip _)).
  eapply H_Consequence_pre. apply H_Asgn. unfold assn_sub. intro. apply (H st (t_update st i (aeval st a)) (E_Ass st a (aeval st a) i eq_refl)).
  eapply H_Consequence_pre.  pose (X0 (wp c1 Q) Q (wp_is_precondition _ _)).
  pose (X (wp c0 (wp c1 Q)) (wp c1 Q) (wp_is_precondition _ _)).
  pose (wp_is_weakest _ _ _ H). eapply H_Seq. apply h0. auto.
  pose (wp_is_weakest _ _ _ H).
  assert (forall st, wp (c0;;c1) Q st -> wp c0 (wp c1 Q) st).
  unfold wp. intros. apply H0. eapply (E_Seq); eauto. auto.
  pose (wp (IFB b THEN c0 ELSE c1 FI) Q) as p.
  cut (hoare_proof p (IFB b THEN c0 ELSE c1 FI) Q).
  intro. eapply H_Consequence_pre. apply X1. unfold p. intro. apply wp_is_weakest. auto.
  assert (forall st, p st -> ((beval st b = true) -> wp c0 Q st) /\ ((beval st b = false) -> wp c1 Q st)).
  split; intros. unfold wp in p. unfold p in H0. unfold wp. intros. apply H0. apply E_IfTrue; auto.
  unfold wp in p. unfold p in H0. unfold wp. intros. apply H0. apply E_IfFalse; auto.
  eapply H_If; pose wp_is_precondition as h; unfold hoare_triple in h. apply X. unfold bassn. intros. destruct H2. eapply h; eauto. destruct (H0 st H2). auto.
  apply X0. unfold bassn. intros. destruct H2. eapply h; eauto. destruct (H0 st H2). destruct (beval st b). elim (H3 eq_refl). auto.
  apply (H_Consequence _ _ (wp (WHILE b DO c0 END) Q) (fun st => (wp (WHILE b DO c0 END) Q) st /\ ~(bassn b st))).  apply H_While. apply X. unfold wp; unfold bassn. intros. destruct H1. apply H1. eapply E_WhileLoop; eauto.
  eapply wp_is_weakest. unfold hoare_triple. auto. unfold wp; unfold bassn. intros. destruct H0. apply H0. apply E_WhileEnd. destruct (beval st b). elim (H1 eq_refl). auto.
Qed.


(**
----
_This file is part of_

----
*** A Formal Definition of JML in Coq #
# and its Application to Runtime Assertion Checking
Ph.D. Thesis by Hermann Lehner
----
Online available at #jmlcoq.info#

Authors:
  - Hermann Lehner
  - David Pichardie (Bicolano)
  - Andreas Kaegi (Syntax Rewritings, Implementation of ADTs)

Copyright 2011 Hermann Lehner

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

----
*)

Lemma eqb_true (A:Type) (x y:A) (eqb:A->A->bool) (eqb_spec : forall x y, if eqb x y then x = y else x <> y) (P:eqb x y = true) : x = y.
Proof.
  generalize (eqb_spec x y); intro H.
  destruct (eqb x y).
  assumption.
  discriminate P.
Qed.

Lemma eqb_false (A:Type) (x y:A) (eqb:A->A->bool) (eqb_spec : forall x y, if eqb x y then x = y else x <> y) (P:eqb x y = false) : x <> y.
Proof.
  generalize (eqb_spec x y); intro H.
  destruct (eqb x y).
  discriminate P.
  assumption.
Qed.


Require Import ords all_ssreflect pg3x_spec pg32_ind pg32_spec.

Module PS : ProjectiveSpace.

  Definition Point := Point. (*[eqType of Point].*)
  Definition Line := Line. (*[eqType of Line].*)

  Definition incid_lp (x:Point) (l:Line) : bool := incid_lp x l.

  Definition eqP (x y:Point) := x==y.
  Definition eqL (l m :Line) := l==m.

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

  Lemma symAB : forall A B:Point,
      {l : Line |  incid_lp A l && incid_lp B l} ->
      {l : Line |  incid_lp B l && incid_lp A l}.
  Proof.
    intros A B X.
    exists (projT1 X).
    abstract (destruct X; rewrite Bool.andb_comm; assumption).
  Defined.

  Lemma wrapAB : forall A B:Point,forall P:Point-> Point-> Type,
        (forall x y:Point, x <= y -> P x y) -> (forall x y:Point,  y<=x -> P x y) -> P A B.
  Proof.
    intros A B;
      destruct (Bool.orb_true_elim _ _ (leq_total A B)) as [i | i];
    [intros P X1 X2; exact (X1 _ _ i) | intros P X1 X2; exact (X2 _ _ i)].
  Defined.

  Lemma wraplm : forall A B:Line,forall P:Line -> Line -> Type,
        (forall x y:Line, x<=y -> P x y) -> (forall x y:Line,  y<=x -> P x y) -> P A B.
  Proof.
     intros A B;
       destruct (Bool.orb_true_elim _ _ (leq_total A B)) as [i | i];
     [intros P X1 X2; exact (X1 _ _ i) | intros P X1 X2; exact (X2 _ _ i)].
  Defined.

  Ltac wrap_it_completely tac :=
    let A:= fresh "A" in
    let B:= fresh "B" in
    let Xsym := fresh "Xsym" in
    let Xle := fresh "Xle" in
    intros A B;
    pattern A,B;
    match goal with A:?ty |- (?P A B) =>
                    cbv beta;
                    revert A B;
                    assert (Xle:forall A B:ty, A<=B -> P A B) ; [tac |
                    assert (Xsym:forall x y:ty, P x y -> P y x);
                    [idtac |
                     intros A B; apply (wrapAB A B) || apply (wraplm A B);
                     [ (exact Xle)
                     | repeat (intro; try solve [ apply Xsym; apply Xle; assumption])
                     ]
                    ]]
    end.

  Ltac prove_a1_exists :=
    let P:=fresh in
    let Q:=fresh in
    intros P Q; elim P using Point_rect; elim Q using Point_rect;intros hypp hypq;
    try_all_l ltac:(fun L => (solve [apply (exist _ L); exact (@erefl bool 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 Defined.
  Check a1_exists.

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

  Ltac final_a3_1 := abstract (exact (@erefl bool true)).

  Ltac prove_a3_1 :=
    let l:= fresh in
    intros l; elim l using Line_rect; intros hi;
    try_all_p ltac:(fun A => apply (existT _ A);
    try_all_p ltac:(fun B => apply (existT _ B);
    try_all_p ltac:(fun C => apply (exist _ C); final_a3_1))).

  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 Defined.

  (** a1_unique : unicity of the line generated from 2 points *)

  (** l_from_points is actually a1_exists *)

  Definition l_from_points (Z : Point * Point) := proj1_sig (a1_exists (fst Z) (snd Z)).

  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;
            elim x using Line_rect; intros hypx;
              elim T using Point_rect; intros hypt HTx;
                solve [ remove_cases |
                        elim Z using Point_rect; intros hypz HZx HTZ;
                          solve [ remove_cases
                                | apply val_inj; exact (@erefl nat _)]]).
    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: is_true (?T!=?Z) |- _ =>
                    pose proof (points_line T Z x Ht Hz Htz); clear Ht Hz; 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 HAB' l1 l2 HAB HAl1 HBl1 HAl2 HBl2;
    revert A B HAB' HAB l1 HAl1 HBl1 l2 HAl2 HBl2;
    intros  X; elim X using Point_rect;
    intros hypx Y;elim Y using Point_rect; intros hypy HAB' HAB;
    solve [remove_cases |
           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 (
        wrap_it_completely prove_a1_unique';
    intros; apply H; try assumption; rewrite eq_sym; assumption).
    Time Qed.
  Check a1_unique.

  Lemma Point_dec : forall T U:Point, {T=U}+{T!=U}.
  Proof.
    intros T U; elim T using Point_rect; intros hypT; elim U using Point_rect;
      intros hypU; solve [left; apply:val_inj; exact (@erefl _ _) |
                          right;apply/negP; intro H; inversion H].
  Defined.

  Ltac prove_uniqueness :=
    let P:= fresh in
    let hypP := fresh in
    let HPQdiff := fresh in
    let Q:= fresh in
    let hypQ := fresh in
    let HPQ := fresh in
    let l := fresh in
    let m := fresh in
    intros P Q;
    destruct (Point_dec P Q) as [HPQdiff | HPQdiff];
    [left; subst P; exact (@erefl Point _) | idtac];
    revert P Q HPQdiff;
    intros P; elim P using Point_rect;
    intros hypP Q; elim Q using Point_rect; intros hypQ HPQdiff HPQ;
    solve [remove_cases |
    intros l m Hl Hl'; revert m; 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(wrap_it_completely (prove_uniqueness);
    intros; assert (foo:x=y\/l1=l2->y=x\/l1=l2) by (intros; solve [intuition]);
      apply foo; apply H; assumption).
    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; elim p using Point_rect;
                     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".
    time (prove_a3_2). (* we could have chosen (o 35 0) and (o 35 34). *)
    Time Qed.
  Check a3_2.

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

  (** points_from_l is actually a3_1 *)

  Definition points_from_l (l:Line) :=
    let t:= (a3_1 l) in (projT1 t, projT1 (projT2 t), proj1_sig (projT2 (projT2  t))).

  Definition inter (l1 l2:Line) : option Point :=
    match (points_from_l l1) with (X,Y,Z) =>
      match (points_from_l l2) with (X',Y',Z') =>
              if (Point_dec X X') then Some (X) else
                if (Point_dec X Y') then Some (X) else
                  if (Point_dec X Z') then Some (X) else
                    if (Point_dec Y X') then Some (Y) else
                      if (Point_dec Y Y') then Some (Y) else
                        if (Point_dec Y Z') then (Some Y) else
                          if (Point_dec Z X') then (Some Z) else
                            if (Point_dec Z Y') then (Some Z) else
                              if (Point_dec Z Z') then (Some Z) else None end end.

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

   Ltac solve_l l l1 l2 l3 :=
    let sP1 := eval compute in (inter l l1) in
    let sP2 := eval compute in (inter l l2) in
    let sP3 := eval compute in (inter l l3) in
    match sP1 with
    | None => fail
    | Some ?P1 => match sP2 with
           | None => fail
           | Some ?P2 => match sP3 with
                  | None => fail
                  | Some ?P3 => solve [apply (ex_intro _ l); apply (ex_intro _ P1);
                                       apply (ex_intro _ P2); apply (ex_intro _ P3);
                                       exact (@erefl bool true)]
                                              end end end.

  Ltac solve_ex_ll :=
    match goal with |- exists (l4 : _) (J1 J2 J3 : _),
        is_true (Intersect_In ?l1 l4 J1 &&
        Intersect_In ?l2 l4 J2 && Intersect_In ?l3 l4 J3) => try_all_l ltac:(fun L => solve_l L l1 l2 l3) end.

  Lemma wrapABC : forall (A B C: Point) (P : Point -> Point -> Point -> Type),
      (forall x y z : Point, x <= y <= z -> P x y z) ->
      (forall x y z : Point, x <= z <= y -> P x y z) ->
      (forall x y z : Point, y <= x <= z -> P x y z) ->
      (forall x y z : Point, y <= z <= x -> P x y z) ->
      (forall x y z : Point, z <= x <= y -> P x y z) ->
      (forall x y z : Point, z <= y <= x -> P x y z) ->
      P A B C.
  Proof.
    intros A B C;
      destruct (Bool.orb_true_elim _ _ (leq_total A B)) as [i | i];
      destruct (Bool.orb_true_elim _ _ (leq_total A C)) as [j | j];
      destruct (Bool.orb_true_elim _ _ (leq_total B C)) as [k | k];
      [ intros P X1 X2 X3 X4 X5 X6;apply X1; apply andb_true_intro; split; assumption
      | intros P X1 X2 X3 X4 X5 X6;apply X2; apply andb_true_intro; split; assumption
      | intros P X1 X2 X3 X4 X5 X6;apply X4; apply andb_true_intro; split; assumption
      | intros P X1 X2 X3 X4 X5 X6;apply X5; apply andb_true_intro; split; assumption
      | intros P X1 X2 X3 X4 X5 X6;apply X3; apply andb_true_intro; split; assumption
      | intros P X1 X2 X3 X4 X5 X6;apply X6; apply andb_true_intro; split; assumption
      | intros P X1 X2 X3 X4 X5 X6;apply X4; apply andb_true_intro; split; assumption
      | intros P X1 X2 X3 X4 X5 X6;apply X6; apply andb_true_intro; split; assumption].
  Qed.

  Lemma wraplmp : forall (A B C: Line) (P : Line -> Line -> Line -> Type),
      (forall x y z : Line, x <= y <= z -> P x y z) ->
      (forall x y z : Line, x <= z <= y -> P x y z) ->
      (forall x y z : Line, y <= x <= z -> P x y z) ->
      (forall x y z : Line, y <= z <= x -> P x y z) ->
      (forall x y z : Line, z <= x <= y -> P x y z) ->
      (forall x y z : Line, z <= y <= x -> P x y z) ->
      P A B C.
  Proof.
    intros A B C;
      destruct (Bool.orb_true_elim _ _ (leq_total A B)) as [i | i];
      destruct (Bool.orb_true_elim _ _ (leq_total A C)) as [j | j];
      destruct (Bool.orb_true_elim _ _ (leq_total B C)) as [k | k];
      [ intros P X1 X2 X3 X4 X5 X6;apply X1; apply andb_true_intro; split; assumption
      | intros P X1 X2 X3 X4 X5 X6;apply X2; apply andb_true_intro; split; assumption
      | intros P X1 X2 X3 X4 X5 X6;apply X4; apply andb_true_intro; split; assumption
      | intros P X1 X2 X3 X4 X5 X6;apply X5; apply andb_true_intro; split; assumption
      | intros P X1 X2 X3 X4 X5 X6;apply X3; apply andb_true_intro; split; assumption
      | intros P X1 X2 X3 X4 X5 X6;apply X6; apply andb_true_intro; split; assumption
      | intros P X1 X2 X3 X4 X5 X6;apply X4; apply andb_true_intro; split; assumption
      | intros P X1 X2 X3 X4 X5 X6;apply X6; apply andb_true_intro; split; assumption].
  Qed.

  Ltac wrap_it_completely3 tac :=
    let A:= fresh "A" in
    let B:= fresh "B" in
    let C:= fresh "C" in
    let Xsym := fresh "Xsym" in
    let Xsym1 := fresh "Xsym1" in
    let Xsym2 := fresh "Xsym2" in
    let Xle := fresh "Xle" in
    intros A B C;
    pattern A,B,C;
    match goal with A:?ty |- (?P A B C) =>
                    cbv beta;
                    revert A B C;
                    assert (Xle:forall A B C:ty, A<=B<=C -> P A B C) ;
                    [ tac
                    | intros A B C; apply (wrapABC A B C) || apply (wraplmp A B C);idtac]
    end.

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

   Ltac prove_a3_3' :=
    let v1 := fresh in
    let v2 := fresh in
    let v3 := fresh in
    let Hv1v2v3 := fresh in
    let hd:= fresh in
    let hd12:=fresh in
    let hd1 :=fresh in
    let hd2 :=fresh in
    let hd3 :=fresh in
    let hypv1 := fresh in
    let hypv2 := fresh in
    let Hv1v2diff := fresh in
    let hypv3 := fresh in
    let Hv1v3 := fresh in
    let Hv2v3 := fresh in
    unfold dist_3l; intros v1 v2 v3 Hv1v2v3 hd;
    destruct (ab_bool_lr _ _ hd) as [hd12 hd3];
    destruct (ab_bool_lr _ _ hd12) as [hd1 hd2];
    revert Hv1v2v3 hd1 hd2 hd3;
    elim v1 using Line_rect; intros hypv1;
    abstract (elim v2 using Line_rect; intros hypv2 Hv1v2v3 Hv1v2diff;
              solve [remove_cases |
                     clear Hv1v2v3 Hv1v2diff;
                     (elim v3 using Line_rect; intros hypv3 Hv1v3 Hv2v3;
              solve [remove_cases | clear Hv1v3 Hv2v3; solve_ex_ll])]).

   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".
    wrap_it_completely3 idtac.
    time(prove_a3_3').

    exact Xle.

    intros.
    assert (Hd: dist_3l x z y).
    unfold dist_3l, eqL in * ; rewrite (eq_sym z y); apply comm12L; assumption.
    generalize (Xle x z y H Hd).
    intros Hex; destruct Hex as [v4 [t1 [t2 [t3 Hv4t1t2t3]]]].
    exists v4; exists t1; exists t3; exists t2.
    apply comm12L; apply circ3; assumption.

    intros.
    assert (Hd: dist_3l y x z).
    unfold dist_3l, eqL in * ; rewrite (eq_sym y x).
    apply circ3; apply comm12L; apply circ3; apply circ3; assumption.
    generalize (Xle y x z H Hd).
    intros Hex; destruct Hex 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,eqL in *.
    rewrite (eq_sym z x); rewrite (eq_sym y x); apply circ3; assumption.
    generalize (Xle y z x H Hd).
    intros Hex; destruct Hex as [v4 [t1 [t2 [t3 Hv4t1t2t3]]]].
    exists v4; exists t3; exists t1; exists t2.
    apply comm12L; apply circ3; apply comm12L; apply circ3; apply circ3; assumption.

    intros.
    assert (Hd: dist_3l z x y).
    unfold dist_3l,eqL in *; rewrite (eq_sym z x); rewrite (eq_sym z y);
      apply circ3; apply circ3; assumption.
    generalize (Xle z x y H Hd).
    intros Hex; destruct Hex as [v4 [t1 [t2 [t3 Hv4t1t2t3]]]].
    exists v4; exists t2; exists t3; exists t1.
    apply circ3; apply comm12L; apply circ3; apply circ3; apply comm12L; assumption.

    intros.
    assert (Hd: dist_3l z y x).
    unfold dist_3l,eqL in *; rewrite (eq_sym z y); rewrite (eq_sym z x); rewrite (eq_sym y x).
    apply comm12L; apply circ3; apply circ3; assumption.
    generalize (Xle z y x H Hd).
    intros Hex; destruct Hex as [v4 [t1 [t2 [t3 Hv4t1t2t3]]]].
    exists v4; exists t3; exists t2; exists t1.
    apply circ3; apply comm12L; assumption.

    (*Optimize Heap. Optimize Proof.*)
    Time Qed.
  Check a3_3.

  (** a2 : Pasch's axiom *)

  Definition proj t := match t with Some t' => t' | None => (o 15 0) end.

  Ltac findp := match goal with
                  |-  (@ex Point (fun J:Point =>
                                       is_true (andb (incid_lp J ?m)
                                                     (incid_lp J ?p))))
                         => exists (proj (inter m p)); exact (@erefl bool true) end.

  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)).

  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;
            elim x using Line_rect; intros hypx;
            elim T using Point_rect; intros hypt HTx;
            solve [remove_cases |
                   elim Z using Point_rect; intros hypz HZx HTZ;
                   solve [ remove_cases | apply val_inj; exact (@erefl nat _)]]).
    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.

  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.
    idtac "-> proving a2".
    wrap_it_completely idtac.

    time(unfold dist_4p;
            intros P Q HPQle R S l1 l2 l3 l4 hd hp1q1 hr2s2 hp3r3 hq4s4 Ht;

    destruct (ab_bool_lr _ _ hd) as [hd12345 hd6];
    destruct (ab_bool_lr _ _ hd12345) as [hd1234 hd5];
    destruct (ab_bool_lr _ _ hd1234) as [hd123 hd4];
    destruct (ab_bool_lr _ _ hd123) as [hd12 hd3];
    destruct (ab_bool_lr _ _ hd12) as [hd1 hd2]; clear hd hd12345 hd1234 hd123 hd12;
    destruct (ab_bool_lr _ _ hp1q1) as [hp1 hq1];
    destruct (ab_bool_lr _ _ hr2s2) as [hr2 hs2];
    destruct (ab_bool_lr _ _ hp3r3) as [hp3 hr3];
    destruct (ab_bool_lr _ _ hq4s4) as [hq4 hs4]; clear hp1q1 hr2s2 hp3r3 hq4s4;

    revert HPQle hd1 hp1 hq1 hd2 hd4 hp3 hr3 hd3 hd5 hd6 hr2 hs2 hq4 hs4 Ht;
    elim P using Point_rect; intros hypP;

    abstract (
        elim Q using Point_rect;
        intros hypQ hd1 HPQdiff;
        solve [ remove_cases |
        intros hp1 hq1; handle' l1; clear hd1;
        abstract (
            elim R using Point_rect;
            intros hypR hd2 hd4;
            solve [remove_cases |
                   intros hp3 hr3; handle' l3; clear hd2 hd4;
                   abstract (elim S using Point_rect; intros hypS hd3 hd5 hd6;
                             solve [ remove_cases |
                                     intros  hr2 hs2;
                                     handle' l2;
                                     intros  hq4 hs4;
                                     handle' l4;
                                     clear hd5 hd6;
                                     abstract (intros Ht; destruct Ht as [t Ht]; revert Ht;
                                               elim t using Point_rect; intros hypt Ht;
                                               solve [remove_cases |  findp ])])])])).
(* 377s *)
      clear Xle; intros.
      assert (dist: dist_4p x y D C).

      unfold dist_4p,eqP in H0; unfold dist_4p,eqP;
        rewrite (eq_sym x y); rewrite (eq_sym D C); apply bool6; assumption.
      assert (exists J : Point, (incid_lp J) lBD && (incid_lp J) lAC).
      apply (H D C lAB lCD lBD lAC dist);
      [ apply circ2; assumption | apply circ2; assumption | assumption | assumption | assumption].
      destruct H6 as [J HJ]; exists J; apply circ2; assumption.
      Time Qed.

End PS.

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


(*
    This file have five theorems indicating the correctness theorems on complete graph preserve downward
    Top level theorem is "correctness_preservation"
*)

From mathcomp Require Import all_ssreflect.
Require Import Coq.Strings.String Coq.Bool.Bool Coq.Lists.List.
Import ListNotations.
From Coq.Arith Require Import Arith EqNat.
Open Scope string_scope.
Open Scope list_scope.
Require Import Coq.Program.Equality.
Require Import Arith.
Require Import Coq.Program.Tactics.
From Taxiway Require Import To_naive To_complete.
From Taxiway Require Import Find_path.
From Taxiway Require Import Correctness.

From Hammer Require Import Hammer.

(* ======== start correct =========*)

Definition naive_path_starts_with_vertex (path : list Edge_type) (start_v : Vertex) : Prop :=
    exists taxiway_name, exists l, path = ((start_v, input), taxiway_name) :: l.

Theorem naive_start_correct:
    forall start_v end_v ATC D (path : list Arc_type) (paths : list (list Arc_type)),
    Some paths = (find_path (start_v : Vertex) (end_v : Vertex) (ATC : list string) (D : C_Graph_type)) ->
    In path paths ->
    naive_path_starts_with_vertex (to_N path) start_v.
Proof.
    (* Hint Resolve output_path_start_correct. *)
    intros. unfold naive_path_starts_with_vertex.
    assert (
        (exists taxiway_name l_c, to_N path = to_N ( (((start_v, input), (start_v, input)), taxiway_name)::l_c ) )->
        exists taxiway_name l, to_N path = (start_v, input, taxiway_name)::l). hammer.
    apply H1. clear H1.
    assert (
        (exists taxiway_name l_c,
            path = ((start_v, input), (start_v, input), taxiway_name) :: l_c ) ->
        exists taxiway_name l_c,
            to_N path = to_N ((start_v, input, (start_v, input), taxiway_name) :: l_c)
    ). hammer. apply H1. clear H1.
    apply output_path_start_correct with (start_v := start_v) (end_v := end_v) (ATC := ATC) (D := D) (paths := paths).
    apply H. apply H0.
Qed.

(* ========== end correct ===========*)

Lemma hd_error_f :
    forall (f:Arc_type -> Edge_type) a l,
    hd_error l = Some a -> hd_error (map f l) = Some (f a).
Proof.
    intros. hammer.
Qed.

Definition naive_ends_with_vertex (path : list Edge_type) (end_v : Vertex) : Prop :=
    exists end_Edge,
    ((hd_error (rev path)) = Some end_Edge) /\ end_Edge.1.1 = end_v.

Theorem naive_end_correct:
    forall start_v end_v ATC D (path : list Arc_type) (paths : list (list Arc_type)),
    Some paths = (find_path (start_v : Vertex) (end_v : Vertex) (ATC : list string) (D : C_Graph_type)) ->
    In path paths ->
    naive_ends_with_vertex (to_N path) end_v.
Proof.
    intros. unfold naive_ends_with_vertex.
    assert (
        rev (to_N path) = to_N (rev path)
    ). unfold to_N. hammer.  rewrite -> H1.

    assert (
        exists end_arc,
            hd_error (rev path) = Some end_arc /\ end_arc.1.2.1 = end_v
    ) as H_original.
    apply output_path_end_correct with (start_v := start_v) (ATC := ATC) (D:=D) (path:=path) (paths:=paths). assumption. assumption.

    destruct H_original as [v H_2]. destruct H_2 as [H_l H_r].
    exists (c_to_n v). split.
    - unfold to_N. apply hd_error_f with (l:=rev path). assumption.
    - unfold c_to_n. simpl. assumption.
Qed.

(* ============ in graph ============*)

Lemma to_N_downward :
    forall x path, In x path ->
    forall a, a = c_to_n x -> In a (to_N path).
Proof.
    intros. unfold to_N. hammer.
Qed.

(* here we only prove (tl path) is in graph;
   naive_path_starts_with_vertex states that (hd path) is the start vertex, so it must also be in the graph. *)
Definition naive_path_in_graph (path : list Edge_type) (G : list Edge_type) : Prop :=
    forall a, In a (tl (path)) -> In a G.

Theorem naive_in_graph :
    forall start_v end_v ATC D (path : list Arc_type) (paths : list (list Arc_type)),
    Some paths = (find_path (start_v : Vertex) (end_v : Vertex) (ATC : list string) (D : C_Graph_type)) ->
    In path paths ->
    naive_path_in_graph (to_N path) (to_N D).
Proof.
    intros. unfold naive_path_in_graph.

    assert (
        path_in_graph path D
    ) as H_original. hammer. unfold path_in_graph in H_original.

    assert (
        forall a, In a (tl (to_N path)) <-> In a (to_N (tl path))
    ) as H_tl. intros. split. hammer. hammer.

    assert (
        (forall a : Edge_type,
        (In a (to_N (tl path)) -> In a (to_N D))) ->
        (forall a : Edge_type,
        (In a (tl (to_N path)) -> In a (to_N D)))
    ). hammer. apply H1. clear H1. clear H_tl.

    unfold to_N.
    hammer.
Qed.

(* ============ connected ===========*)

(* From Taxiway Require Import Example.
Example path_conn_eg1 : path_conn (rev [(((Ch, input), (BC, Ch)), C);
(((BC, Ch), (AA3, A3r)), A3)]).
Proof. simpl. unfold Arc_conn. easy. Qed.  *)

(* an arc is legal if it has the form (from AB to BC), i.e. ((B, A), (C, B)) *)
Definition is_legal_arc (e1 : Arc_type)  : Prop :=
   (e1.1.1.1 = e1.1.2.2).

(* Example is_legal_arc_eg : is_legal_arc (((BC, Ch), (AA3, BC)), ""). *)
(* Proof. unfold is_legal_arc. easy. Qed. *)

(* TWO edges are connected if e1.from = e2.to *)
Definition Edge_conn (e1 : Edge_type) (e2 : Edge_type) : Prop :=
    e1.1.2 = e2.1.1.

(* NOTE the first edge is the later edge, i.e. the path is CH -> BC -> AA3 *)
(* Example Edge_conn_eg: Edge_conn ((AA3, BC), "") ((BC, Ch), "") .
Proof. simpl. unfold Edge_conn. easy. Qed. *)

(*  The function to check whether path(edge) is connected
    Since the edge doesn't contains the "from" information, we need to refer to the neighbor
*)
Fixpoint naive_path_conn (path : list Edge_type): Prop :=
    match path with
    | path_f::path_r => match path_r with
        | path_s::path_r_r => (Edge_conn path_f path_s) /\ (naive_path_conn path_r)
        | [] => True
        end
    | [] => True
    end.

(*
    The first element in the path is the initial arc assigned by Find_path, which is (((start_v, input), (start_v, input)), t), will violate the property
    We drop the first element in this property

    We further introduce an assumption of the path, however the find_path on generated complete graph will always satisfy the assumption. We leave this part to partial identity.
*)
Theorem naive_conn:
    forall (path : list Arc_type) start_v end_v ATC D  (paths : list (list Arc_type)),
    Some paths = (find_path (start_v : Vertex) (end_v : Vertex) (ATC : list string) (D : C_Graph_type)) ->
    In path paths ->
    ((forall arc, In arc (tl path) -> is_legal_arc arc) -> naive_path_conn (rev (to_N path))).
Proof.
intros.
        assert (
            path_conn (rev path)
        ) as H_original by hammer.

        (* TODO put this below to_N *)
        assert (forall path, (rev (to_N path)) = to_N (rev path)) as lemma. {
            intros.
            unfold to_N. unfold c_to_n. rewrite map_rev. reflexivity.
        }

        (* this assertion should be unrelated to find_path, and quantify over path to make it strong enough *)
        assert (forall rev_path,
            path_conn (rev_path) ->
            (forall arc, In arc (tl (rev rev_path))%SEQ -> is_legal_arc arc) ->
             naive_path_conn ((to_N (rev_path)))).
        {
            intro p. dependent induction p.
                + easy.
                + intros. simpl.
                destruct p eqn:Hp.
                    * easy.
                    * assert (path_conn (a0 :: l)). {
                        hammer.
                    }
                    simpl.
                    assert (rev [:: a, a0 & l] = rev (a0::l) ++ (rev [a])). {
                        rewrite <- rev_app_distr. reflexivity.
                    }
                    split.
                    {
                        assert(H_a_legal: is_legal_arc a). {
                            apply H3.

                            rewrite -> H5. destruct (rev (a0 :: l)) eqn:H7.
                            - assert ((a0 :: l) = rev []). hammer. simpl in H6. discriminate H6.
                            - simpl. intuition.
                        }
                        unfold Edge_conn, c_to_n; simpl.
                        simpl in H2. destruct H2.
                        unfold Arc_conn in H2. rewrite <- H2.
                        (* assert (path' = rev  [:: a, a0 & l]  ). hammer. *)

                        unfold is_legal_arc in H_a_legal. hammer.
                    }

                    {
                    apply IHp in H4.
                    - simpl in H4. assumption.
                    - intros. apply H3. rewrite -> H5.
                    simpl. simpl in H6.
                    remember ((rev l ++ [a0])%list) as l1.
                    destruct l1 eqn: Hl1.
                        + simpl in H6. contradiction.
                        +  simpl in H6. simpl. apply in_rev. apply in_rev in H6.
                        rewrite rev_app_distr. simpl. right. assumption.
                    }
        }

        rewrite -> lemma.
        apply H2. assumption. rewrite rev_involutive. assumption.
Qed.

(* ========== follow ATC =========*)

Fixpoint naive_path_coresp_atc (path : list Edge_type) : list string :=
    match path with
    | [] => []
    | a::b => match b with
        | []   => [a.2]
        | c::l => if (a.2 =? c.2)
        then (naive_path_coresp_atc b)
        else a.2::(naive_path_coresp_atc b)
        end
    end.

Definition naive_path_follow_atc (path : list Edge_type) (atc : list string) : Prop :=
    atc = naive_path_coresp_atc path.

Theorem naive_follow_atc:
    forall start_v end_v ATC D (path : list Arc_type) (paths : list (list Arc_type)),
    Some paths = (find_path (start_v : Vertex) (end_v : Vertex) (ATC : list string) (D : C_Graph_type)) ->
    In path paths ->
    naive_path_follow_atc (to_N path) ATC.
Proof.
intros. unfold naive_path_follow_atc.

assert (
    path_follow_atc path ATC
) as H_original. hammer. unfold path_follow_atc in H_original.

assert (
    forall path, path_coresp_atc path = naive_path_coresp_atc (to_N path)
) as H_tl. {
    intros.
    induction path0.
    - easy.
    - unfold to_N. clear H H0 H_original. hammer.
    (* simpl. hammer. *)
}
hammer.
Qed.

(* ========== Correctness Preserve ========== *)

(* collection of correctness properties *)
Theorem correctness_preservation:
    forall start_v end_v ATC D (path : list Arc_type) (paths : list (list Arc_type)),
    Some paths = (find_path (start_v : Vertex) (end_v : Vertex) (ATC : list string) (D : C_Graph_type)) ->
    In path paths ->
    (* if find_path return some paths, then every path has the following properties: *)
    naive_path_follow_atc (to_N path) ATC /\
    naive_path_in_graph (to_N path) (to_N D) /\
    naive_path_starts_with_vertex (to_N path) start_v /\
    naive_ends_with_vertex (to_N path) end_v /\
    (* The assumption always hold for D = to_C G, the complete theorem is in Lifting.v *)
    ((forall arc, In arc (tl path) -> is_legal_arc arc) -> naive_path_conn (rev (to_N path))).
Proof. intros.
(* this tactic applys thm to current goal and
   finds hypothesis from assumption for the theorem *)
Ltac temp_tac thm start_v end_v ATC D path paths :=
    let app_thm := (apply (thm start_v end_v ATC D path paths); (repeat assumption)) in
        match goal with
        | [ |- _ /\ _] => split; [app_thm | ]
        | _ =>  app_thm
        end.

temp_tac naive_follow_atc start_v end_v ATC D path paths.
temp_tac naive_in_graph start_v end_v ATC D path paths.
temp_tac naive_start_correct start_v end_v ATC D path paths.
temp_tac naive_end_correct start_v end_v ATC D path paths.
temp_tac naive_conn path start_v end_v ATC D paths.
Qed.

(* ========= Make-up for naive_conn ========== *)

(*
    This is a makeup theorem for downward connection property hold for a complete graph generated by to_C
*)

(*  A lemma to ensure that the arc in complete graph follows a consistency
    i.e. in the form ((x, _), (_, x), taxiway)
*)
Lemma to_C_legal:
    forall (NG: N_Graph_type),
    (forall arc, In arc (to_C NG) -> is_legal_arc arc).
Proof.
    intros. unfold to_C in H. remember (undirect_to_bidirect NG) as BG.
    unfold generate_edges in H. unfold previous_edges in H.
    apply in_flat_map in H. destruct H as [e H]. destruct H.
    apply in_map_iff in H0. destruct H0 as [a H0]. destruct H0.
    apply filter_In in H1. destruct H1. unfold is_legal_arc.
    unfold undirect_to_bidirect in HeqBG. simpl in HeqBG.
    assert(a.1.1 =v= e.1.2). hammer. clear H2.
    hammer.
Qed.

(* a makeup for naive_conn *)
Theorem naive_conn_complete:
    forall (path : list Arc_type) start_v end_v ATC (G : N_Graph_type)  (paths : list (list Arc_type)),
    Some paths = (find_path (start_v : Vertex) (end_v : Vertex) (ATC : list string) (to_C G)) ->
    In path paths ->
    (naive_path_conn (rev (to_N path))).
Proof.
    intros. apply naive_conn with (start_v:=start_v) (end_v:=end_v) (ATC:=ATC) (D:=to_C G) (paths:=paths).
    assumption. assumption.
    assert ((forall arc : Arc_type, In arc (to_C G) -> is_legal_arc arc) -> (forall arc : Arc_type, In arc (tl path) -> is_legal_arc arc)). intros. apply H1.
    assert (forall start_v end_v ATC D (path : list Arc_type) (paths : list (list Arc_type)),
    Some paths = (find_path (start_v : Vertex) (end_v : Vertex) (ATC : list string) (D : C_Graph_type)) ->
    In path paths ->
    path_in_graph path D). apply output_path_in_graph. unfold path_in_graph in H3.
    apply H3 with (start_v:=start_v) (end_v:=end_v) (ATC:=ATC) (path:=path) (paths:=paths). assumption. assumption.
    assumption.
    apply H1. apply to_C_legal with (NG:=G).
Qed.


Require Import Basics Pointed.
Require Import Truncations.

(** ** Encode-decode method of characterizing identity types *)

(** See PathAny.v for a related characterization of identity types. *)

Definition encode_decode
  (A : Type) (a0 : A) (code : A -> Type)
  (c0 : code a0) (decode : forall x, code x -> a0 = x)
  (s : forall (c : code a0), decode _ c # c0 = c)
  (r : decode _ c0 = idpath) (a1 : A)
  : a0 = a1 <~> code a1.
Proof.
  srapply equiv_adjointify.
  - exact (fun p => p # c0).
  - apply decode.
  - intro p.
    destruct (decode _ p) in p.
    apply s.
  - intros [].
    exact r.
Defined.

(** Encode-decode for truncated identity-types *)
Definition encode_decode_trunc n
  (A : Type) (a0 : A) (code : A -> Type) `{forall a, IsTrunc n (code a)}
  (c0 : code a0) (decode : forall x, code x -> Tr n (a0 = x))
  (s : forall (c : code a0), Trunc_rec (fun p => p # c0) (decode _ c) = c)
  (r : decode _ c0 = tr idpath) (a1 : A)
  : Tr n (a0 = a1) <~> code a1.
Proof.
  srapply equiv_adjointify.
  - apply (Trunc_rec (fun p => p # c0)).
  - apply decode.
  - intro p.
    pose (decode _ p) as p'.
    clearbody p'.
    strip_truncations.
    destruct p' in p.
    apply s.
  - intros p.
    strip_truncations.
    destruct p.
    exact r.
Defined.

(** Encode-decode for loop spaces *)
Definition encode_decode_loops
  (A : pType) (code : pFam A)
  (decode : forall x, code x -> point A = x)
  (s : forall (c : code (point A)), decode _ c # (dpoint code) = c)
  (r : decode _ (dpoint code) = idpath)
  : loops A <~> code (point A)
  := encode_decode _ _ code (dpoint code) decode s r _.

(** Encode-decode for truncated loop spaces *)
Definition encode_decode_trunc_loops n
  (A : pType) (code : pFam A) `{forall a, IsTrunc n (code a)}
  (decode : forall x, code x -> Tr n (point A = x))
  (s : forall (c : code (point A)),
    Trunc_rec (fun (p : loops A) => p # (dpoint code)) (decode _ c) = c)
  (r : decode _ (dpoint code) = tr idpath)
  : pTr n (loops A) <~> code (point A)
  := encode_decode_trunc _ _ _ code (dpoint code) decode s r _.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Constructions of semi-lattices. *)

Require Import Coqlib.
Require Import Maps.
Require Import FSets.

(** * Signatures of semi-lattices *)

(** A semi-lattice is a type [t] equipped with an equivalence relation [eq],
  a boolean equivalence test [beq], a partial order [ge], a smallest element
  [bot], and an upper bound operation [lub].
  Note that we do not demand that [lub] computes the least upper bound. *)

Module Type SEMILATTICE.

  Variable t: Type.
  Variable eq: t -> t -> Prop.
  Hypothesis eq_refl: forall x, eq x x.
  Hypothesis eq_sym: forall x y, eq x y -> eq y x.
  Hypothesis eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
  Variable beq: t -> t -> bool.
  Hypothesis beq_correct: forall x y, beq x y = true -> eq x y.
  Variable ge: t -> t -> Prop.
  Hypothesis ge_refl: forall x y, eq x y -> ge x y.
  Hypothesis ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Variable bot: t.
  Hypothesis ge_bot: forall x, ge x bot.
  Variable lub: t -> t -> t.
  Hypothesis ge_lub_left: forall x y, ge (lub x y) x.
  Hypothesis ge_lub_right: forall x y, ge (lub x y) y.

End SEMILATTICE.

(** A semi-lattice ``with top'' is similar, but also has a greatest
  element [top]. *)

Module Type SEMILATTICE_WITH_TOP.

  Include Type SEMILATTICE.
  Variable top: t.
  Hypothesis ge_top: forall x, ge top x.

End SEMILATTICE_WITH_TOP.

(** * Semi-lattice over maps *)

Set Implicit Arguments.

(** Given a semi-lattice with top [L], the following functor implements
  a semi-lattice structure over finite maps from positive numbers to [L.t].
  The default value for these maps is either [L.top] or [L.bot]. *)

Module LPMap(L: SEMILATTICE_WITH_TOP) <: SEMILATTICE_WITH_TOP.

Inductive t' : Type :=
  | Bot_except: PTree.t L.t -> t'
  | Top_except: PTree.t L.t -> t'.

Definition t: Type := t'.

Definition get (p: positive) (x: t) : L.t :=
  match x with
  | Bot_except m =>
      match m!p with None => L.bot | Some x => x end
  | Top_except m =>
      match m!p with None => L.top | Some x => x end
  end.

Definition set (p: positive) (v: L.t) (x: t) : t :=
  match x with
  | Bot_except m =>
      Bot_except (if L.beq v L.bot then PTree.remove p m else PTree.set p v m)
  | Top_except m =>
      Top_except (if L.beq v L.top then PTree.remove p m else PTree.set p v m)
  end.

Lemma gss:
  forall p v x,
  L.eq (get p (set p v x)) v.
Proof.
  intros. destruct x; simpl.
  case_eq (L.beq v L.bot); intros.
  rewrite PTree.grs. apply L.eq_sym. apply L.beq_correct; auto.
  rewrite PTree.gss. apply L.eq_refl.
  case_eq (L.beq v L.top); intros.
  rewrite PTree.grs. apply L.eq_sym. apply L.beq_correct; auto.
  rewrite PTree.gss. apply L.eq_refl.
Qed.

Lemma gso:
  forall p q v x,
  p <> q -> get p (set q v x) = get p x.
Proof.
  intros. destruct x; simpl.
  destruct (L.beq v L.bot). rewrite PTree.gro; auto. rewrite PTree.gso; auto.
  destruct (L.beq v L.top). rewrite PTree.gro; auto. rewrite PTree.gso; auto.
Qed.

Definition eq (x y: t) : Prop :=
  forall p, L.eq (get p x) (get p y).

Lemma eq_refl: forall x, eq x x.
Proof.
  unfold eq; intros. apply L.eq_refl.
Qed.

Lemma eq_sym: forall x y, eq x y -> eq y x.
Proof.
  unfold eq; intros. apply L.eq_sym; auto.
Qed.

Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
Proof.
  unfold eq; intros. eapply L.eq_trans; eauto.
Qed.

Definition beq (x y: t) : bool :=
  match x, y with
  | Bot_except m, Bot_except n => PTree.beq L.beq m n
  | Top_except m, Top_except n => PTree.beq L.beq m n
  | _, _ => false
  end.

Lemma beq_correct: forall x y, beq x y = true -> eq x y.
Proof.
  destruct x; destruct y; simpl; intro; try congruence.
  red; intro; simpl.
  generalize (PTree.beq_correct L.eq L.beq L.beq_correct t0 t1 H p).
  destruct (t0!p); destruct (t1!p); intuition. apply L.eq_refl.
  red; intro; simpl.
  generalize (PTree.beq_correct L.eq L.beq L.beq_correct t0 t1 H p).
  destruct (t0!p); destruct (t1!p); intuition. apply L.eq_refl.
Qed.

Definition ge (x y: t) : Prop :=
  forall p, L.ge (get p x) (get p y).

Lemma ge_refl: forall x y, eq x y -> ge x y.
Proof.
  unfold ge, eq; intros. apply L.ge_refl. auto.
Qed.

Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
Proof.
  unfold ge; intros. apply L.ge_trans with (get p y); auto.
Qed.

Definition bot := Bot_except (PTree.empty L.t).

Lemma get_bot: forall p, get p bot = L.bot.
Proof.
  unfold bot; intros; simpl. rewrite PTree.gempty. auto.
Qed.

Lemma ge_bot: forall x, ge x bot.
Proof.
  unfold ge; intros. rewrite get_bot. apply L.ge_bot.
Qed.

Definition top := Top_except (PTree.empty L.t).

Lemma get_top: forall p, get p top = L.top.
Proof.
  unfold top; intros; simpl. rewrite PTree.gempty. auto.
Qed.

Lemma ge_top: forall x, ge top x.
Proof.
  unfold ge; intros. rewrite get_top. apply L.ge_top.
Qed.

(** A [combine] operation over the type [PTree.t L.t] that attempts
  to share its result with its arguments. *)

Section COMBINE.

Variable f: option L.t -> option L.t -> option L.t.
Hypothesis f_none_none: f None None = None.

Definition opt_eq (ox oy: option L.t) : Prop :=
  match ox, oy with
  | None, None => True
  | Some x, Some y => L.eq x y
  | _, _ => False
  end.

Lemma opt_eq_refl: forall ox, opt_eq ox ox.
Proof.
  intros. unfold opt_eq. destruct ox. apply L.eq_refl. auto.
Qed.

Lemma opt_eq_sym: forall ox oy, opt_eq ox oy -> opt_eq oy ox.
Proof.
  unfold opt_eq. destruct ox; destruct oy; auto. apply L.eq_sym.
Qed.

Lemma opt_eq_trans: forall ox oy oz, opt_eq ox oy -> opt_eq oy oz -> opt_eq ox oz.
Proof.
  unfold opt_eq. destruct ox; destruct oy; destruct oz; intuition.
  eapply L.eq_trans; eauto.
Qed.

Definition opt_beq (ox oy: option L.t) : bool :=
  match ox, oy with
  | None, None => true
  | Some x, Some y => L.beq x y
  | _, _ => false
  end.

Lemma opt_beq_correct:
  forall ox oy, opt_beq ox oy = true -> opt_eq ox oy.
Proof.
  unfold opt_beq, opt_eq. destruct ox; destruct oy; try congruence.
  intros. apply L.beq_correct; auto.
  auto.
Qed.

Definition tree_eq (m1 m2: PTree.t L.t) : Prop :=
  forall i, opt_eq (PTree.get i m1) (PTree.get i m2).

Lemma tree_eq_refl: forall m, tree_eq m m.
Proof. intros; red; intros; apply opt_eq_refl. Qed.

Lemma tree_eq_sym: forall m1 m2, tree_eq m1 m2 -> tree_eq m2 m1.
Proof. intros; red; intros; apply opt_eq_sym; auto. Qed.

Lemma tree_eq_trans: forall m1 m2 m3, tree_eq m1 m2 -> tree_eq m2 m3 -> tree_eq m1 m3.
Proof. intros; red; intros; apply opt_eq_trans with (PTree.get i m2); auto. Qed.

Lemma tree_eq_node:
  forall l1 o1 r1 l2 o2 r2,
  tree_eq l1 l2 -> tree_eq r1 r2 -> opt_eq o1 o2 ->
  tree_eq (PTree.Node l1 o1 r1) (PTree.Node l2 o2 r2).
Proof.
  intros; red; intros. destruct i; simpl; auto.
Qed.

Lemma tree_eq_node':
  forall l1 o1 r1 l2 o2 r2,
  tree_eq l1 l2 -> tree_eq r1 r2 -> opt_eq o1 o2 ->
  tree_eq (PTree.Node l1 o1 r1) (PTree.Node' l2 o2 r2).
Proof.
  intros; red; intros. rewrite PTree.gnode'. apply tree_eq_node; auto.
Qed.

Lemma tree_eq_node'':
  forall l1 o1 r1 l2 o2 r2,
  tree_eq l1 l2 -> tree_eq r1 r2 -> opt_eq o1 o2 ->
  tree_eq (PTree.Node' l1 o1 r1) (PTree.Node' l2 o2 r2).
Proof.
  intros; red; intros. repeat rewrite PTree.gnode'. apply tree_eq_node; auto.
Qed.

Hint Resolve opt_beq_correct opt_eq_refl opt_eq_sym
             tree_eq_refl tree_eq_sym
             tree_eq_node tree_eq_node' tree_eq_node'' : combine.

Inductive changed: Type := Unchanged | Changed (m: PTree.t L.t).

Fixpoint combine_l (m : PTree.t L.t) {struct m} : changed :=
  match m with
  | PTree.Leaf =>
      Unchanged
  | PTree.Node l o r =>
      let o' := f o None in
      match combine_l l, combine_l r with
      | Unchanged, Unchanged => if opt_beq o' o then Unchanged else Changed (PTree.Node' l o' r)
      | Unchanged, Changed r' => Changed (PTree.Node' l o' r')
      | Changed l', Unchanged => Changed (PTree.Node' l' o' r)
      | Changed l', Changed r' => Changed (PTree.Node' l' o' r')
      end
  end.

Lemma combine_l_eq:
  forall m,
  tree_eq (match combine_l m with Unchanged => m | Changed m' => m' end)
          (PTree.xcombine_l f m).
Proof.
  induction m; simpl.
  auto with combine.
  destruct (combine_l m1) as [ | l']; destruct (combine_l m2) as [ | r'];
  auto with combine.
  case_eq (opt_beq (f o None) o); auto with combine.
Qed.

Fixpoint combine_r (m : PTree.t L.t) {struct m} : changed :=
  match m with
  | PTree.Leaf =>
      Unchanged
  | PTree.Node l o r =>
      let o' := f None o in
      match combine_r l, combine_r r with
      | Unchanged, Unchanged => if opt_beq o' o then Unchanged else Changed (PTree.Node' l o' r)
      | Unchanged, Changed r' => Changed (PTree.Node' l o' r')
      | Changed l', Unchanged => Changed (PTree.Node' l' o' r)
      | Changed l', Changed r' => Changed (PTree.Node' l' o' r')
      end
  end.

Lemma combine_r_eq:
  forall m,
  tree_eq (match combine_r m with Unchanged => m | Changed m' => m' end)
          (PTree.xcombine_r f m).
Proof.
  induction m; simpl.
  auto with combine.
  destruct (combine_r m1) as [ | l']; destruct (combine_r m2) as [ | r'];
  auto with combine.
  case_eq (opt_beq (f None o) o); auto with combine.
Qed.

Inductive changed2 : Type :=
  | Same
  | Same1
  | Same2
  | CC(m: PTree.t L.t).

Fixpoint xcombine (m1 m2 : PTree.t L.t) {struct m1} : changed2 :=
    match m1, m2 with
    | PTree.Leaf, PTree.Leaf =>
        Same
    | PTree.Leaf, _ =>
        match combine_r m2 with
        | Unchanged => Same2
        | Changed m => CC m
        end
    | _, PTree.Leaf =>
        match combine_l m1 with
        | Unchanged => Same1
        | Changed m => CC m
        end
    | PTree.Node l1 o1 r1, PTree.Node l2 o2 r2 =>
        let o := f o1 o2 in
        match xcombine l1 l2, xcombine r1 r2 with
        | Same, Same =>
            match opt_beq o o1, opt_beq o o2 with
            | true, true => Same
            | true, false => Same1
            | false, true => Same2
            | false, false => CC(PTree.Node' l1 o r1)
            end
        | Same1, Same | Same, Same1 | Same1, Same1 =>
            if opt_beq o o1 then Same1 else CC(PTree.Node' l1 o r1)
        | Same2, Same | Same, Same2 | Same2, Same2 =>
            if opt_beq o o2 then Same2 else CC(PTree.Node' l2 o r2)
        | Same1, Same2 => CC(PTree.Node' l1 o r2)
        | (Same|Same1), CC r => CC(PTree.Node' l1 o r)
        | Same2, Same1 => CC(PTree.Node' l2 o r1)
        | Same2, CC r => CC(PTree.Node' l2 o r)
        | CC l, (Same|Same1) => CC(PTree.Node' l o r1)
        | CC l, Same2 => CC(PTree.Node' l o r2)
        | CC l, CC r => CC(PTree.Node' l o r)
        end
    end.

Lemma xcombine_eq:
  forall m1 m2,
  match xcombine m1 m2 with
  | Same => tree_eq m1 (PTree.combine f m1 m2) /\ tree_eq m2 (PTree.combine f m1 m2)
  | Same1 => tree_eq m1 (PTree.combine f m1 m2)
  | Same2 => tree_eq m2 (PTree.combine f m1 m2)
  | CC m => tree_eq m (PTree.combine f m1 m2)
  end.
Proof.
Opaque combine_l combine_r PTree.xcombine_l PTree.xcombine_r.
  induction m1; destruct m2; simpl.
  split; apply tree_eq_refl.
  generalize (combine_r_eq (PTree.Node m2_1 o m2_2)).
  destruct (combine_r (PTree.Node m2_1 o m2_2)); auto.
  generalize (combine_l_eq (PTree.Node m1_1 o m1_2)).
  destruct (combine_l (PTree.Node m1_1 o m1_2)); auto.
  generalize (IHm1_1 m2_1) (IHm1_2 m2_2).
  destruct (xcombine m1_1 m2_1);
  destruct (xcombine m1_2 m2_2); auto with combine;
  intuition; case_eq (opt_beq (f o o0) o); case_eq (opt_beq (f o o0) o0); auto with combine.
Qed.

Definition combine (m1 m2: PTree.t L.t) : PTree.t L.t :=
  match xcombine m1 m2 with
  | Same|Same1 => m1
  | Same2 => m2
  | CC m => m
  end.

Lemma gcombine:
  forall m1 m2 i, opt_eq (PTree.get i (combine m1 m2)) (f (PTree.get i m1) (PTree.get i m2)).
Proof.
  intros.
  assert (tree_eq (combine m1 m2) (PTree.combine f m1 m2)).
  unfold combine.
  generalize (xcombine_eq m1 m2).
  destruct (xcombine m1 m2); tauto.
  eapply opt_eq_trans. apply H. rewrite PTree.gcombine; auto. apply opt_eq_refl.
Qed.

End COMBINE.

Definition opt_lub (x y: L.t) : option L.t :=
  let z := L.lub x y in
  if L.beq z L.top then None else Some z.

Definition lub (x y: t) : t :=
  match x, y with
  | Bot_except m, Bot_except n =>
      Bot_except
        (combine
           (fun a b =>
              match a, b with
              | Some u, Some v => Some (L.lub u v)
              | None, _ => b
              | _, None => a
              end)
           m n)
  | Bot_except m, Top_except n =>
      Top_except
        (combine
           (fun a b =>
              match a, b with
              | Some u, Some v => opt_lub u v
              | None, _ => b
              | _, None => None
              end)
        m n)
  | Top_except m, Bot_except n =>
      Top_except
        (combine
           (fun a b =>
              match a, b with
              | Some u, Some v => opt_lub u v
              | None, _ => None
              | _, None => a
              end)
        m n)
  | Top_except m, Top_except n =>
      Top_except
        (combine
           (fun a b =>
              match a, b with
              | Some u, Some v => opt_lub u v
              | _, _ => None
              end)
           m n)
  end.

Lemma gcombine_top:
  forall f t1 t2 p,
  f None None = None ->
  L.eq (get p (Top_except (combine f t1 t2)))
       (match f t1!p t2!p with Some x => x | None => L.top end).
Proof.
  intros. simpl. generalize (gcombine f H t1 t2 p). unfold opt_eq.
  destruct ((combine f t1 t2)!p); destruct (f t1!p t2!p).
  auto. contradiction. contradiction. intros; apply L.eq_refl.
Qed.

Lemma gcombine_bot:
  forall f t1 t2 p,
  f None None = None ->
  L.eq (get p (Bot_except (combine f t1 t2)))
       (match f t1!p t2!p with Some x => x | None => L.bot end).
Proof.
  intros. simpl. generalize (gcombine f H t1 t2 p). unfold opt_eq.
  destruct ((combine f t1 t2)!p); destruct (f t1!p t2!p).
  auto. contradiction. contradiction. intros; apply L.eq_refl.
Qed.

Lemma ge_lub_left:
  forall x y, ge (lub x y) x.
Proof.
  assert (forall u v,
    L.ge (match opt_lub u v with Some x => x | None => L.top end) u).
  intros; unfold opt_lub.
  case_eq (L.beq (L.lub u v) L.top); intros. apply L.ge_top. apply L.ge_lub_left.

  unfold ge, lub; intros. destruct x; destruct y.

  eapply L.ge_trans. apply L.ge_refl. apply gcombine_bot. auto.
  simpl. destruct t0!p; destruct t1!p.
  apply L.ge_lub_left.
  apply L.ge_refl. apply L.eq_refl.
  apply L.ge_bot.
  apply L.ge_refl. apply L.eq_refl.

  eapply L.ge_trans. apply L.ge_refl. apply gcombine_top. auto.
  simpl. destruct t0!p; destruct t1!p.
  auto.
  apply L.ge_top.
  apply L.ge_bot.
  apply L.ge_top.

  eapply L.ge_trans. apply L.ge_refl. apply gcombine_top. auto.
  simpl. destruct t0!p; destruct t1!p.
  auto.
  apply L.ge_refl. apply L.eq_refl.
  apply L.ge_top.
  apply L.ge_top.

  eapply L.ge_trans. apply L.ge_refl. apply gcombine_top. auto.
  simpl. destruct t0!p; destruct t1!p.
  auto.
  apply L.ge_top.
  apply L.ge_top.
  apply L.ge_top.
Qed.

Lemma ge_lub_right:
  forall x y, ge (lub x y) y.
Proof.
  assert (forall u v,
    L.ge (match opt_lub u v with Some x => x | None => L.top end) v).
  intros; unfold opt_lub.
  case_eq (L.beq (L.lub u v) L.top); intros. apply L.ge_top. apply L.ge_lub_right.

  unfold ge, lub; intros. destruct x; destruct y.

  eapply L.ge_trans. apply L.ge_refl. apply gcombine_bot. auto.
  simpl. destruct t0!p; destruct t1!p.
  apply L.ge_lub_right.
  apply L.ge_bot.
  apply L.ge_refl. apply L.eq_refl.
  apply L.ge_refl. apply L.eq_refl.

  eapply L.ge_trans. apply L.ge_refl. apply gcombine_top. auto.
  simpl. destruct t0!p; destruct t1!p.
  auto.
  apply L.ge_top.
  apply L.ge_refl. apply L.eq_refl.
  apply L.ge_top.

  eapply L.ge_trans. apply L.ge_refl. apply gcombine_top. auto.
  simpl. destruct t0!p; destruct t1!p.
  auto.
  apply L.ge_bot.
  apply L.ge_top.
  apply L.ge_top.

  eapply L.ge_trans. apply L.ge_refl. apply gcombine_top. auto.
  simpl. destruct t0!p; destruct t1!p.
  auto.
  apply L.ge_top.
  apply L.ge_top.
  apply L.ge_top.
Qed.

End LPMap.

(** * Semi-lattice over a set. *)

(** Given a set [S: FSetInterface.S], the following functor
    implements a semi-lattice over these sets, ordered by inclusion. *)

Module LFSet (S: FSetInterface.WS) <: SEMILATTICE.

  Definition t := S.t.

  Definition eq (x y: t) := S.Equal x y.
  Definition eq_refl: forall x, eq x x := S.eq_refl.
  Definition eq_sym: forall x y, eq x y -> eq y x := S.eq_sym.
  Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := S.eq_trans.
  Definition beq: t -> t -> bool := S.equal.
  Definition beq_correct: forall x y, beq x y = true -> eq x y := S.equal_2.

  Definition ge (x y: t) := S.Subset y x.
  Lemma ge_refl: forall x y, eq x y -> ge x y.
  Proof.
    unfold eq, ge, S.Equal, S.Subset; intros. firstorder.
  Qed.
  Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Proof.
    unfold ge, S.Subset; intros. eauto.
  Qed.

  Definition  bot: t := S.empty.
  Lemma ge_bot: forall x, ge x bot.
  Proof.
    unfold ge, bot, S.Subset; intros. elim (S.empty_1 H).
  Qed.

  Definition lub: t -> t -> t := S.union.

  Lemma ge_lub_left: forall x y, ge (lub x y) x.
  Proof.
    unfold lub, ge, S.Subset; intros. apply S.union_2; auto.
  Qed.

  Lemma ge_lub_right: forall x y, ge (lub x y) y.
  Proof.
    unfold lub, ge, S.Subset; intros. apply S.union_3; auto.
  Qed.

End LFSet.

(** * Flat semi-lattice *)

(** Given a type with decidable equality [X], the following functor
  returns a semi-lattice structure over [X.t] complemented with
  a top and a bottom element.  The ordering is the flat ordering
  [Bot < Inj x < Top]. *)

Module LFlat(X: EQUALITY_TYPE) <: SEMILATTICE_WITH_TOP.

Inductive t' : Type :=
  | Bot: t'
  | Inj: X.t -> t'
  | Top: t'.

Definition t : Type := t'.

Definition eq (x y: t) := (x = y).
Definition eq_refl: forall x, eq x x := (@refl_equal t).
Definition eq_sym: forall x y, eq x y -> eq y x := (@sym_equal t).
Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@trans_equal t).

Definition beq (x y: t) : bool :=
  match x, y with
  | Bot, Bot => true
  | Inj u, Inj v => if X.eq u v then true else false
  | Top, Top => true
  | _, _ => false
  end.

Lemma beq_correct: forall x y, beq x y = true -> eq x y.
Proof.
  unfold eq; destruct x; destruct y; simpl; try congruence; intro.
  destruct (X.eq t0 t1); congruence.
Qed.

Definition ge (x y: t) : Prop :=
  match x, y with
  | Top, _ => True
  | _, Bot => True
  | Inj a, Inj b => a = b
  | _, _ => False
  end.

Lemma ge_refl: forall x y, eq x y -> ge x y.
Proof.
  unfold eq, ge; intros; subst y; destruct x; auto.
Qed.

Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
Proof.
  unfold ge; destruct x; destruct y; try destruct z; intuition.
  transitivity t1; auto.
Qed.

Definition bot: t := Bot.

Lemma ge_bot: forall x, ge x bot.
Proof.
  destruct x; simpl; auto.
Qed.

Definition top: t := Top.

Lemma ge_top: forall x, ge top x.
Proof.
  destruct x; simpl; auto.
Qed.

Definition lub (x y: t) : t :=
  match x, y with
  | Bot, _ => y
  | _, Bot => x
  | Top, _ => Top
  | _, Top => Top
  | Inj a, Inj b => if X.eq a b then Inj a else Top
  end.

Lemma ge_lub_left: forall x y, ge (lub x y) x.
Proof.
  destruct x; destruct y; simpl; auto.
  case (X.eq t0 t1); simpl; auto.
Qed.

Lemma ge_lub_right: forall x y, ge (lub x y) y.
Proof.
  destruct x; destruct y; simpl; auto.
  case (X.eq t0 t1); simpl; auto.
Qed.

End LFlat.

(** * Boolean semi-lattice *)

(** This semi-lattice has only two elements, [bot] and [top], trivially
  ordered. *)

Module LBoolean <: SEMILATTICE_WITH_TOP.

Definition t := bool.

Definition eq (x y: t) := (x = y).
Definition eq_refl: forall x, eq x x := (@refl_equal t).
Definition eq_sym: forall x y, eq x y -> eq y x := (@sym_equal t).
Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@trans_equal t).

Definition beq : t -> t -> bool := eqb.

Lemma beq_correct: forall x y, beq x y = true -> eq x y.
Proof eqb_prop.

Definition ge (x y: t) : Prop := x = y \/ x = true.

Lemma ge_refl: forall x y, eq x y -> ge x y.
Proof. unfold ge; tauto. Qed.

Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
Proof. unfold ge; intuition congruence. Qed.

Definition bot := false.

Lemma ge_bot: forall x, ge x bot.
Proof. destruct x; compute; tauto. Qed.

Definition top := true.

Lemma ge_top: forall x, ge top x.
Proof. unfold ge, top; tauto. Qed.

Definition lub (x y: t) := x || y.

Lemma ge_lub_left: forall x y, ge (lub x y) x.
Proof. destruct x; destruct y; compute; tauto. Qed.

Lemma ge_lub_right: forall x y, ge (lub x y) y.
Proof. destruct x; destruct y; compute; tauto. Qed.

End LBoolean.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

Require Import NZAxioms.
Require Import NZAddOrder.

Module Type NZMulOrderProp (Import NZ : NZOrdAxiomsSig').
Include NZAddOrderProp NZ.

Theorem mul_lt_pred :
  forall p q n m, S p == q -> (p * n < p * m <-> q * n + m < q * m + n).
Proof.
intros p q n m H. rewrite <- H. nzsimpl.
rewrite <- ! add_assoc, (add_comm n m).
now rewrite <- add_lt_mono_r.
Qed.

Theorem mul_lt_mono_pos_l : forall p n m, 0 < p -> (n < m <-> p * n < p * m).
Proof.
intros p n m Hp. revert n m. apply lt_ind with (4:=Hp). solve_proper.
intros. now nzsimpl.
clear p Hp. intros p Hp IH n m. nzsimpl.
assert (LR : forall n m, n < m -> p * n + n < p * m + m)
 by (intros n1 m1 H; apply add_lt_mono; trivial; now rewrite <- IH).
split; intros H.
now apply LR.
destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial.
rewrite EQ in H. order.
apply LR in GT. order.
Qed.

Theorem mul_lt_mono_pos_r : forall p n m, 0 < p -> (n < m <-> n * p < m * p).
Proof.
intros p n m.
rewrite (mul_comm n p), (mul_comm m p). now apply mul_lt_mono_pos_l.
Qed.

Theorem mul_lt_mono_neg_l : forall p n m, p < 0 -> (n < m <-> p * m < p * n).
Proof.
nzord_induct p.
order.
intros p Hp _ n m Hp'. apply lt_succ_l in Hp'. order.
intros p Hp IH n m _. apply le_succ_l in Hp.
le_elim Hp.
assert (LR : forall n m, n < m -> p * m < p * n).
 intros n1 m1 H. apply (le_lt_add_lt n1 m1).
 now apply lt_le_incl. rewrite <- 2 mul_succ_l. now rewrite <- IH.
split; intros H.
now apply LR.
destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial.
rewrite EQ in H. order.
apply LR in GT. order.
rewrite (mul_lt_pred p (S p)), Hp; now nzsimpl.
Qed.

Theorem mul_lt_mono_neg_r : forall p n m, p < 0 -> (n < m <-> m * p < n * p).
Proof.
intros p n m.
rewrite (mul_comm n p), (mul_comm m p). now apply mul_lt_mono_neg_l.
Qed.

Theorem mul_le_mono_nonneg_l : forall n m p, 0 <= p -> n <= m -> p * n <= p * m.
Proof.
intros n m p H1 H2. le_elim H1.
le_elim H2. apply lt_le_incl. now apply mul_lt_mono_pos_l.
apply eq_le_incl; now rewrite H2.
apply eq_le_incl; rewrite <- H1; now do 2 rewrite mul_0_l.
Qed.

Theorem mul_le_mono_nonpos_l : forall n m p, p <= 0 -> n <= m -> p * m <= p * n.
Proof.
intros n m p H1 H2. le_elim H1.
le_elim H2. apply lt_le_incl. now apply mul_lt_mono_neg_l.
apply eq_le_incl; now rewrite H2.
apply eq_le_incl; rewrite H1; now do 2 rewrite mul_0_l.
Qed.

Theorem mul_le_mono_nonneg_r : forall n m p, 0 <= p -> n <= m -> n * p <= m * p.
Proof.
intros n m p H1 H2;
rewrite (mul_comm n p), (mul_comm m p); now apply mul_le_mono_nonneg_l.
Qed.

Theorem mul_le_mono_nonpos_r : forall n m p, p <= 0 -> n <= m -> m * p <= n * p.
Proof.
intros n m p H1 H2;
rewrite (mul_comm n p), (mul_comm m p); now apply mul_le_mono_nonpos_l.
Qed.

Theorem mul_cancel_l : forall n m p, p ~= 0 -> (p * n == p * m <-> n == m).
Proof.
intros n m p Hp; split; intro H; [|now f_equiv].
apply lt_gt_cases in Hp; destruct Hp as [Hp|Hp];
 destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial.
apply (mul_lt_mono_neg_l p) in LT; order.
apply (mul_lt_mono_neg_l p) in GT; order.
apply (mul_lt_mono_pos_l p) in LT; order.
apply (mul_lt_mono_pos_l p) in GT; order.
Qed.

Theorem mul_cancel_r : forall n m p, p ~= 0 -> (n * p == m * p <-> n == m).
Proof.
intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_cancel_l.
Qed.

Theorem mul_id_l : forall n m, m ~= 0 -> (n * m == m <-> n == 1).
Proof.
intros n m H.
stepl (n * m == 1 * m) by now rewrite mul_1_l. now apply mul_cancel_r.
Qed.

Theorem mul_id_r : forall n m, n ~= 0 -> (n * m == n <-> m == 1).
Proof.
intros n m; rewrite mul_comm; apply mul_id_l.
Qed.

Theorem mul_le_mono_pos_l : forall n m p, 0 < p -> (n <= m <-> p * n <= p * m).
Proof.
intros n m p H; do 2 rewrite lt_eq_cases.
rewrite (mul_lt_mono_pos_l p n m) by assumption.
now rewrite -> (mul_cancel_l n m p) by
(intro H1; rewrite H1 in H; false_hyp H lt_irrefl).
Qed.

Theorem mul_le_mono_pos_r : forall n m p, 0 < p -> (n <= m <-> n * p <= m * p).
Proof.
intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_le_mono_pos_l.
Qed.

Theorem mul_le_mono_neg_l : forall n m p, p < 0 -> (n <= m <-> p * m <= p * n).
Proof.
intros n m p H; do 2 rewrite lt_eq_cases.
rewrite (mul_lt_mono_neg_l p n m); [| assumption].
rewrite -> (mul_cancel_l m n p)
 by (intro H1; rewrite H1 in H; false_hyp H lt_irrefl).
now setoid_replace (n == m) with (m == n) by (split; now intro).
Qed.

Theorem mul_le_mono_neg_r : forall n m p, p < 0 -> (n <= m <-> m * p <= n * p).
Proof.
intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_le_mono_neg_l.
Qed.

Theorem mul_lt_mono_nonneg :
  forall n m p q, 0 <= n -> n < m -> 0 <= p -> p < q -> n * p < m * q.
Proof.
intros n m p q H1 H2 H3 H4.
apply le_lt_trans with (m * p).
apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl].
apply -> mul_lt_mono_pos_l; [assumption | now apply le_lt_trans with n].
Qed.

(* There are still many variants of the theorem above. One can assume 0 < n
or 0 < p or n <= m or p <= q. *)

Theorem mul_le_mono_nonneg :
  forall n m p q, 0 <= n -> n <= m -> 0 <= p -> p <= q -> n * p <= m * q.
Proof.
intros n m p q H1 H2 H3 H4.
le_elim H2; le_elim H4.
apply lt_le_incl; now apply mul_lt_mono_nonneg.
rewrite <- H4; apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl].
rewrite <- H2; apply mul_le_mono_nonneg_l; [assumption | now apply lt_le_incl].
rewrite H2; rewrite H4; now apply eq_le_incl.
Qed.

Theorem mul_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n * m.
Proof.
intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_pos_r.
Qed.

Theorem mul_neg_neg : forall n m, n < 0 -> m < 0 -> 0 < n * m.
Proof.
intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_neg_r.
Qed.

Theorem mul_pos_neg : forall n m, 0 < n -> m < 0 -> n * m < 0.
Proof.
intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_neg_r.
Qed.

Theorem mul_neg_pos : forall n m, n < 0 -> 0 < m -> n * m < 0.
Proof.
intros; rewrite mul_comm; now apply mul_pos_neg.
Qed.

Theorem mul_nonneg_nonneg : forall n m, 0 <= n -> 0 <= m -> 0 <= n*m.
Proof.
intros. rewrite <- (mul_0_l m). apply mul_le_mono_nonneg; order.
Qed.

Theorem mul_pos_cancel_l : forall n m, 0 < n -> (0 < n*m <-> 0 < m).
Proof.
intros n m Hn. rewrite <- (mul_0_r n) at 1.
 symmetry. now apply mul_lt_mono_pos_l.
Qed.

Theorem mul_pos_cancel_r : forall n m, 0 < m -> (0 < n*m <-> 0 < n).
Proof.
intros n m Hn. rewrite <- (mul_0_l m) at 1.
 symmetry. now apply mul_lt_mono_pos_r.
Qed.

Theorem mul_nonneg_cancel_l : forall n m, 0 < n -> (0 <= n*m <-> 0 <= m).
Proof.
intros n m Hn. rewrite <- (mul_0_r n) at 1.
 symmetry. now apply mul_le_mono_pos_l.
Qed.

Theorem mul_nonneg_cancel_r : forall n m, 0 < m -> (0 <= n*m <-> 0 <= n).
Proof.
intros n m Hn. rewrite <- (mul_0_l m) at 1.
 symmetry. now apply mul_le_mono_pos_r.
Qed.

Theorem lt_1_mul_pos : forall n m, 1 < n -> 0 < m -> 1 < n * m.
Proof.
intros n m H1 H2. apply (mul_lt_mono_pos_r m) in H1.
rewrite mul_1_l in H1. now apply lt_1_l with m.
assumption.
Qed.

Theorem eq_mul_0 : forall n m, n * m == 0 <-> n == 0 \/ m == 0.
Proof.
intros n m; split.
intro H; destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]];
destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]];
try (now right); try (now left).
exfalso; now apply (lt_neq 0 (n * m)); [apply mul_neg_neg |].
exfalso; now apply (lt_neq (n * m) 0); [apply mul_neg_pos |].
exfalso; now apply (lt_neq (n * m) 0); [apply mul_pos_neg |].
exfalso; now apply (lt_neq 0 (n * m)); [apply mul_pos_pos |].
intros [H | H]. now rewrite H, mul_0_l. now rewrite H, mul_0_r.
Qed.

Theorem neq_mul_0 : forall n m, n ~= 0 /\ m ~= 0 <-> n * m ~= 0.
Proof.
intros n m; split; intro H.
intro H1; apply eq_mul_0 in H1. tauto.
split; intro H1; rewrite H1 in H;
(rewrite mul_0_l in H || rewrite mul_0_r in H); now apply H.
Qed.

Theorem eq_square_0 : forall n, n * n == 0 <-> n == 0.
Proof.
intro n; rewrite eq_mul_0; tauto.
Qed.

Theorem eq_mul_0_l : forall n m, n * m == 0 -> m ~= 0 -> n == 0.
Proof.
intros n m H1 H2. apply eq_mul_0 in H1. destruct H1 as [H1 | H1].
assumption. false_hyp H1 H2.
Qed.

Theorem eq_mul_0_r : forall n m, n * m == 0 -> n ~= 0 -> m == 0.
Proof.
intros n m H1 H2; apply eq_mul_0 in H1. destruct H1 as [H1 | H1].
false_hyp H1 H2. assumption.
Qed.

(** Some alternative names: *)

Definition mul_eq_0 := eq_mul_0.
Definition mul_eq_0_l := eq_mul_0_l.
Definition mul_eq_0_r := eq_mul_0_r.

Theorem lt_0_mul n m : 0 < n * m <-> (0 < n /\ 0 < m) \/ (m < 0 /\ n < 0).
Proof.
split; [intro H | intros [[H1 H2] | [H1 H2]]].
destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]];
[| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |];
(destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]];
[| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]);
try (left; now split); try (right; now split).
assert (H3 : n * m < 0) by now apply mul_neg_pos.
exfalso; now apply (lt_asymm (n * m) 0).
assert (H3 : n * m < 0) by now apply mul_pos_neg.
exfalso; now apply (lt_asymm (n * m) 0).
now apply mul_pos_pos. now apply mul_neg_neg.
Qed.

Theorem square_lt_mono_nonneg : forall n m, 0 <= n -> n < m -> n * n < m * m.
Proof.
intros n m H1 H2. now apply mul_lt_mono_nonneg.
Qed.

Theorem square_le_mono_nonneg : forall n m, 0 <= n -> n <= m -> n * n <= m * m.
Proof.
intros n m H1 H2. now apply mul_le_mono_nonneg.
Qed.

(* The converse theorems require nonnegativity (or nonpositivity) of the
other variable *)

Theorem square_lt_simpl_nonneg : forall n m, 0 <= m -> n * n < m * m -> n < m.
Proof.
intros n m H1 H2. destruct (lt_ge_cases n 0).
now apply lt_le_trans with 0.
destruct (lt_ge_cases n m) as [LT|LE]; trivial.
apply square_le_mono_nonneg in LE; order.
Qed.

Theorem square_le_simpl_nonneg : forall n m, 0 <= m -> n * n <= m * m -> n <= m.
Proof.
intros n m H1 H2. destruct (lt_ge_cases n 0).
apply lt_le_incl; now apply lt_le_trans with 0.
destruct (le_gt_cases n m) as [LE|LT]; trivial.
apply square_lt_mono_nonneg in LT; order.
Qed.

Theorem mul_2_mono_l : forall n m, n < m -> 1 + 2 * n < 2 * m.
Proof.
intros n m. rewrite <- le_succ_l, (mul_le_mono_pos_l (S n) m two).
rewrite two_succ. nzsimpl. now rewrite le_succ_l.
order'.
Qed.

Lemma add_le_mul : forall a b, 1<a -> 1<b -> a+b <= a*b.
Proof.
 assert (AUX : forall a b, 0<a -> 0<b -> (S a)+(S b) <= (S a)*(S b)).
  intros a b Ha Hb.
  nzsimpl. rewrite <- succ_le_mono. apply le_succ_l.
  rewrite <- add_assoc, <- (add_0_l (a+b)), (add_comm b).
  apply add_lt_mono_r.
  now apply mul_pos_pos.
 intros a b Ha Hb.
 assert (Ha' := lt_succ_pred 1 a Ha).
 assert (Hb' := lt_succ_pred 1 b Hb).
 rewrite <- Ha', <- Hb'. apply AUX; rewrite succ_lt_mono, <- one_succ; order.
Qed.

(** A few results about squares *)

Lemma square_nonneg : forall a, 0 <= a * a.
Proof.
 intros. rewrite <- (mul_0_r a). destruct (le_gt_cases a 0).
 now apply mul_le_mono_nonpos_l.
 apply mul_le_mono_nonneg_l; order.
Qed.

Lemma crossmul_le_addsquare : forall a b, 0<=a -> 0<=b -> b*a+a*b <= a*a+b*b.
Proof.
 assert (AUX : forall a b, 0<=a<=b -> b*a+a*b <= a*a+b*b).
  intros a b (Ha,H).
  destruct (le_exists_sub _ _ H) as (d & EQ & Hd).
  rewrite EQ.
  rewrite 2 mul_add_distr_r.
  rewrite !add_assoc. apply add_le_mono_r.
  rewrite add_comm. apply add_le_mono_l.
  apply mul_le_mono_nonneg_l; trivial. order.
 intros a b Ha Hb.
 destruct (le_gt_cases a b).
 apply AUX; split; order.
 rewrite (add_comm (b*a)), (add_comm (a*a)).
 apply AUX; split; order.
Qed.

Lemma add_square_le : forall a b, 0<=a -> 0<=b ->
 a*a + b*b <= (a+b)*(a+b).
Proof.
 intros a b Ha Hb.
 rewrite mul_add_distr_r, !mul_add_distr_l.
 rewrite add_assoc.
 apply add_le_mono_r.
 rewrite <- add_assoc.
 rewrite <- (add_0_r (a*a)) at 1.
 apply add_le_mono_l.
 apply add_nonneg_nonneg; now apply mul_nonneg_nonneg.
Qed.

Lemma square_add_le : forall a b, 0<=a -> 0<=b ->
 (a+b)*(a+b) <= 2*(a*a + b*b).
Proof.
 intros a b Ha Hb.
 rewrite !mul_add_distr_l, !mul_add_distr_r. nzsimpl'.
 rewrite <- !add_assoc. apply add_le_mono_l.
 rewrite !add_assoc. apply add_le_mono_r.
 apply crossmul_le_addsquare; order.
Qed.

Lemma quadmul_le_squareadd : forall a b, 0<=a -> 0<=b ->
 2*2*a*b <= (a+b)*(a+b).
Proof.
 intros.
 nzsimpl'.
 rewrite !mul_add_distr_l, !mul_add_distr_r.
 rewrite (add_comm _ (b*b)), add_assoc.
 apply add_le_mono_r.
 rewrite (add_shuffle0 (a*a)), (mul_comm b a).
 apply add_le_mono_r.
 rewrite (mul_comm a b) at 1.
 now apply crossmul_le_addsquare.
Qed.

End NZMulOrderProp.


Require Import Iron.Language.SystemF2.SubstTypeType.
Require Import Iron.Language.SystemF2.SubstTypeExp.
Require Import Iron.Language.SystemF2.TyJudge.

(* Substitution of exps in exps preserves typing *)
Theorem subst_exp_exp_ix
 :  forall ix ke te x1 t1 x2 t2
 ,  get  ix te = Some t2
 -> TYPE ke te           x1 t1
 -> TYPE ke (delete ix te) x2 t2
 -> TYPE ke (delete ix te) (substXX ix x2 x1) t1.
Proof.
 intros. gen ix ke te t1 x2 t2.
 induction x1; intros; inverts_type; simpl; eauto.

 Case "XVar".
  fbreak_nat_compare.
  SCase "n = ix".
   rewrite H in H3. inverts H3. auto.

  SCase "n < ix".
   apply TYVar; auto.

  SCase "n > ix".
   apply TYVar; auto.
   rewrite <- H3.
   destruct n.
    burn.
    simpl. nnat. apply get_delete_below; burn.

 Case "XLAM".
  eapply (IHx1 ix) in H5.
  apply TYLAM.
   unfold liftTE. rewrite map_delete. eauto.
   eapply get_map. eauto.
   unfold liftTE. rewrite <- map_delete.
    rrwrite (map (liftTT 1 0) (delete ix te) = liftTE 0 (delete ix te)).
    apply type_kienv_weaken. auto.

 Case "XLam".
  apply TYLam; auto.
   rewrite delete_rewind.
   eauto using type_tyenv_weaken.
Qed.

Theorem subst_exp_exp
 :  forall ke te x1 t1 x2 t2
 ,  TYPE ke (te :> t2) x1 t1
 -> TYPE ke te x2 t2
 -> TYPE ke te (substXX 0 x2 x1) t1.
Proof.
 intros.
 rrwrite (te = delete 0 (te :> t2)).
 eapply subst_exp_exp_ix; burn.
Qed.


From Coq Require Import List Lia Arith.
Require Import Monads.Computation.
Require Import Monads.Delay.

(** * Untyped l-calculus with De Brujin indices *)
Definition const :=nat.

Inductive term: Type :=
| Var: nat -> term
| Const: const -> term
| Fun: term -> term
| App: term -> term -> term.

Inductive value: Type :=
| Int: const -> value
| Clos: term -> list value -> value.

Definition env := list value.
Definition ret {A} (x:A) := Return (Some x).

(** * BSOS using [Computation] *)
(** The following [CoFixpoint] function [bs] implements the big-step operational semantics
for the untyped l-calculus with constants, where we can have three different scenarios:
- successful computation
- stuck computation
- non terminating computation
By composing [Computation] with [option] (which is also a [Monad]) we can account for all these behaviours at once *)
Definition Fail {A} := Return (@None A).
CoFixpoint bs (t: term) (e:env): Computation (option value) :=
match t with
 | Const i => ret (Int i)
 | Var n   => match (nth_error e n) with
           | Some v => ret v
           | None   => Fail end
 | Fun a => ret (Clos a e)
 | App a b => v1 <- bs a e ; v2 <- bs b e ; match v1 with
                                    | None            => Fail
                                    | Some (Int n)    => Fail
                                    | Some (Clos x y) => match v2 with
                                                          | None   => Fail
                                                          | Some t => Step (bs x (t::y)) end end end .

(** * Examples*)
Lemma successful_computation: forall e, Eqp (interp ( bs (Const 2) e)) (rtrn (Some (Int 2))).
Proof. intros. eval_ (interp (bs (Const 2) e)). Qed.

Definition fail {A} := rtrn (@None A).

Lemma interp_fail: forall {A}, (interp (@Fail A)) = @fail A.
Proof. intros. eval_ (interp (@Fail A)). reflexivity. Qed.

Lemma stuck_computation: forall e, Eqp (interp (bs (App (Const 1) (Const 2)) e)) fail.
Proof.
intros. eval_ (interp (bs (App (Const 1) (Const 2)) e)).
eval_ (interp (_ <- bs (Const 2) e; (@Fail value))).
rewrite interp_fail. apply eqp_value with (a:=None).
- constructor. constructor. constructor.
- constructor. Qed.

CoFixpoint Never := @step (option value) Never.

Definition delta := Fun (App (Var 0) (Var 0)).
Definition omega := App delta delta.

Lemma infinite_computation: forall e, Eqp (interp (bs omega e)) Never.
Proof.
intros. eval_ (interp (bs omega e)).
eval_ (interp
(v2 <- bs delta e;
 match v2 with
 | Some t => Step (bs (App (Var 0) (Var 0)) (t :: e))
 | None => Fail
 end)).
eval_ (Never). constructor. cofix CIH.
eval_ (interp
(Step (bs (App (Var 0) (Var 0)) (Clos (App (Var 0) (Var 0)) e :: e)))).
eval_ (Never). constructor.
eval_ (interp (bs (App (Var 0) (Var 0)) (Clos (App (Var 0) (Var 0)) e :: e))).
eval_ (interp
(v2 <- bs (Var 0) (Clos (App (Var 0) (Var 0)) e :: e);
 match v2 with
 | Some t => Step (bs (App (Var 0) (Var 0)) (t :: e))
 | None => Fail
 end)). eval_ (Never). eval_ (Never). repeat constructor. apply CIH. Qed.


Require Export Iron.Language.SystemF2.TyBase.

(*******************************************************************)
(* Lift type indices that are at least a certain depth. *)
Fixpoint liftTT (n: nat) (d: nat) (tt: ty) : ty :=
  match tt with
  |  TVar ix
  => if le_gt_dec d ix
      then TVar (ix + n)
      else tt

  |  TCon _     => tt

  |  TForall t
  => TForall (liftTT n (S d) t)

  |  TApp t1 t2
  => TApp    (liftTT n d t1) (liftTT n d t2)
  end.
Hint Unfold liftTT.

(********************************************************************)
(* Lifting and well-formedness *)
Lemma liftTT_wfT
 :  forall kn t d
 ,  wfT kn t
 -> wfT (S kn) (liftTT 1 d t).
Proof.
 intros. gen kn d.
 lift_burn t; inverts H; try burn.

 Case "TVar".
  repeat (simpl; lift_cases).
   eapply WfT_TVar. burn.
   eapply WfT_TVar. burn.
Qed.
Hint Resolve liftTT_wfT.

(********************************************************************)
(* Lifting and type utils *)
Lemma liftTT_getCtorOfType
 :  forall d ix t
 ,  getCtorOfType (liftTT d ix t) = getCtorOfType t.
Proof.
 lift_burn t.
Qed.
Hint Rewrite liftTT_getCtorOfType : global.

Lemma liftTT_takeTCon
 :  forall tt d ix
 ,  liftTT d ix (takeTCon tt) = takeTCon (liftTT d ix tt).
Proof.
 intros; lift_burn tt.
Qed.
Hint Rewrite liftTT_takeTCon : global.

Lemma liftTT_takeTCon'
 :  forall n d tt tCon
 ,  takeTCon tt = tCon
 -> takeTCon (liftTT n d tt) = liftTT n d tCon.
Proof.
 intros. gen n d.
 induction tt; intros; rewrite <- H; burn.
Qed.
Hint Resolve liftTT_takeTCon'.

Lemma liftTT_takeTArgs
 : forall tt d ix
 , map (liftTT d ix) (takeTArgs tt) = takeTArgs (liftTT d ix tt).
Proof.
 intros.
 induction tt; intros; simpl; auto.
  lift_cases; auto.
  rr. burn.
Qed.
Hint Rewrite liftTT_takeTArgs : global.

Lemma liftTT_takeTArgs'
 :  forall n d tt tsArgs
 ,  takeTArgs tt = tsArgs
 -> takeTArgs (liftTT n d tt) = map (liftTT n d) tsArgs.
Proof.
 intros.
 induction tt; intros; rewrite <- H; try burn.
Qed.
Hint Resolve liftTT_takeTArgs'.

Lemma liftTT_makeTApps
 :  forall n d t1 ts
 ,  liftTT n d (makeTApps t1 ts)
 =  makeTApps (liftTT n d t1) (map (liftTT n d) ts).
Proof.
 intros. gen t1.
 induction ts; burn.
Qed.
Hint Rewrite liftTT_makeTApps : global.

(********************************************************************)
Lemma liftTT_zero
 :  forall d t
 ,  liftTT 0 d t = t.
Proof.
 intros. gen d. lift_burn t.
Qed.
Hint Rewrite liftTT_zero : global.

Lemma liftTT_comm
 :  forall n m d t
 ,  liftTT n d (liftTT m d t)
 =  liftTT m d (liftTT n d t).
Proof.
 intros. gen d. lift_burn t.
Qed.

Lemma liftTT_succ
 :  forall n m d t
 ,  liftTT (S n) d (liftTT m     d t)
 =  liftTT n     d (liftTT (S m) d t).
Proof.
 intros. gen d m n. lift_burn t.
Qed.
Hint Rewrite liftTT_succ : global.

Lemma liftTT_plus
 : forall n m d t
 , liftTT n d (liftTT m d t) = liftTT (n + m) d t.
Proof.
 intros. gen n d.
 induction m; intros.
 rewrite liftTT_zero; burn.

 rw (n + S m = S n + m).
  rewrite liftTT_comm.
  rewrite <- IHm.
  rewrite liftTT_comm.
  burn.
Qed.
Hint Rewrite <- liftTT_plus : global.

(******************************************************************************)
Lemma liftTT_wfT_1
 :  forall t n ix
 ,  wfT n t
 -> liftTT 1 (n + ix) t = t.
Proof.
 intros. gen n ix.
 induction t; intros; inverts H; simpl; auto.

  Case "TVar".
   lift_cases; burn.

  Case "TForall".
   f_equal. spec IHt H1.
   rw (S (n + ix) = S n + ix).
   burn.

  Case "TApp".
   rs. burn.
Qed.
Hint Resolve liftTT_wfT_1.

Lemma liftTT_closedT_id_1
 :  forall t d
 ,  closedT t
 -> liftTT 1 d t = t.
Proof.
 intros.
 rw (d = d + 0). eauto.
Qed.
Hint Resolve liftTT_closedT_id_1.

Lemma liftTT_closedT_10
 :  forall t
 ,  closedT t
 -> closedT (liftTT 1 0 t).
Proof.
 intros. red.
 rw (0 = 0 + 0).
 rewrite liftTT_wfT_1; auto.
Qed.
Hint Resolve liftTT_closedT_10.

(********************************************************************)
(* Changing the order of lifting.
   We build this up in stages.
   Start out by only allow lifting by a single place for both
   applications. Then allow lifting by multiple places in the first
   application, then multiple places in both.
*)
Lemma liftTT_liftTT_11
 :  forall d d' t
 ,  liftTT 1 d              (liftTT 1 (d + d') t)
 =  liftTT 1 (1 + (d + d')) (liftTT 1 d t).
Proof.
 intros. gen d d'.
 induction t; intros; simpl; try burn.

 Case "TVar".
  repeat (lift_cases; unfold liftTT); burn.

 Case "TForall".
  rw (S (d + d') = (S d) + d').
  burn.
Qed.

Lemma liftTT_liftTT_1
 :  forall n1 m1 n2 t
 ,  liftTT m1   n1 (liftTT 1 (n2 + n1) t)
 =  liftTT 1 (m1 + n2 + n1) (liftTT m1 n1 t).
Proof.
 intros. gen n1 m1 n2 t.
 induction m1; intros; simpl.
  burn.

  rw (S m1 = 1 + m1).
  rewrite <- liftTT_plus.
  rs.
  rw (m1 + n2 + n1 = n1 + (m1 + n2)).
  rewrite liftTT_liftTT_11.
  burn.
Qed.

Lemma liftTT_liftTT
 :  forall m1 n1 m2 n2 t
 ,  liftTT m1 n1 (liftTT m2 (n2 + n1) t)
 =  liftTT m2 (m1 + n2 + n1) (liftTT m1 n1 t).
Proof.
 intros. gen n1 m1 n2 t.
 induction m2; intros.
  burn.

  rw (S m2 = 1 + m2).
  rewrite <- liftTT_plus.
  rewrite liftTT_liftTT_1.
  rewrite IHm2.
  burn.
Qed.
Hint Rewrite liftTT_liftTT : global.

Lemma liftTT_map_liftTT
 :  forall m1 n1 m2 n2 ts
 ,  map (liftTT m1 n1) (map (liftTT m2 (n2 + n1)) ts)
 =  map (liftTT m2 (m1 + n2 + n1)) (map (liftTT m1 n1) ts).
Proof.
 induction ts; simpl; burn.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List. Import ListNotations.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.Notations.
Local Open Scope Z_scope.

(* Condition code flags *)
Module CC.
  Inductive code : Type :=
  | C : code
  | M : code
  | L : code
  | Z : code
  .

  Record state :=
    { cc_c : bool; cc_m : bool; cc_l : bool; cc_z : bool }.

  Definition code_dec (x y : code) : {x = y} + {x <> y}.
  Proof. destruct x, y; try apply (left eq_refl); right; congruence. Defined.

  Definition update (to_write : list code) (result : BinInt.Z) (cc_spec : code -> BinInt.Z -> bool) (old_state : state)
    : state :=
    {|
      cc_c := if (In_dec code_dec C to_write)
              then cc_spec C result
              else old_state.(cc_c);
      cc_m := if (In_dec code_dec M to_write)
              then cc_spec M result
              else old_state.(cc_m);
      cc_l := if (In_dec code_dec L to_write)
              then cc_spec L result
              else old_state.(cc_l);
      cc_z := if (In_dec code_dec Z to_write)
              then cc_spec Z result
              else old_state.(cc_z)
    |}.

End CC.

Section Language.
  Record instruction :=
    {
      num_source_regs : nat;
      writes_conditions : list CC.code;
      spec : tuple Z num_source_regs -> CC.state -> Z
    }.

  Section expr.
    Context {name : Type} (name_eqb : name -> name -> bool) (wordmax : Z) (cc_spec : CC.code -> Z -> bool).

    Inductive expr :=
    | Ret : name -> expr
    | Instr (i : instruction)
            (rd : name) (* destination register *)
            (args : tuple name i.(num_source_regs)) (* source registers *)
            (cont : expr) (* next line *)
      : expr
    .

    Fixpoint interp (e : expr) (cc : CC.state) (ctx : name -> Z) : Z :=
      match e with
      | Ret n => ctx n
      | Instr i rd args cont =>
        let result := i.(spec) (Tuple.map ctx args) cc in
        let new_cc := CC.update i.(writes_conditions) result cc_spec cc in
        let new_ctx := (fun n => if name_eqb n rd then result mod wordmax else ctx n) in
        interp cont new_cc new_ctx
      end.
  End expr.
End Language.

Section Instructions.
  Import CC.

  Definition cc_spec (x : CC.code) (result : BinInt.Z) : bool :=
    match x with
    | C => Z.testbit result 256 (* carry bit *)
    | M => Z.testbit result 255 (* most significant bit *)
    | L => Z.testbit result 0   (* least significant bit *)
    | Z => result =? 0          (* whether equal to zero *)
    end.

  Definition lower128 x := (Z.land x (Z.ones 128)).
  Definition upper128 x := (Z.shiftr x 128).
  Local Notation "x '[C]'" := (if x.(cc_c) then 1 else 0) (at level 20).
  Local Notation "x '[M]'" := (if x.(cc_m) then 1 else 0) (at level 20).
  Local Notation "x '[L]'" := (if x.(cc_l) then 1 else 0) (at level 20).
  Local Notation "x '[Z]'" := (if x.(cc_z) then 1 else 0) (at level 20).
  Local Notation "'int'" := (BinInt.Z).
  Local Notation "x << y" := ((Z.shiftl x y) mod (2^256)) : Z_scope. (* truncating left shift *)
  Local Notation "x >> y" := (Z.shiftr x y) : Z_scope.

  (* Note: In the specification document, argument order gets a bit
    confusing. Like here, r0 is always the first argument "source 0"
    and r1 the second. But the specification of MUL128LU is:
            (R[RS1][127:0] * R[RS0][255:128])

    while the specification of SUB is:
          (R[RS0] - shift(R[RS1], imm))

    In the SUB case, r0 is really treated the first argument, but in
    MUL128LU the order seems to be reversed; rather than low-high, we
    take the high part of the first argument r0 and the low parts of
    r1. This is also true for MUL128UL. *)

  Definition ADD (imm : int) : instruction :=
    {|
      num_source_regs := 2;
      writes_conditions := [C; M; L; Z];
      spec := (fun '(r0, r1) cc =>
                 r0 + (r1 << imm))
    |}.

  Definition ADDC (imm : int) : instruction :=
    {|
      num_source_regs := 2;
      writes_conditions := [C; M; L; Z];
      spec := (fun '(r0, r1) cc =>
                 r0 + (r1 << imm) + cc[C])
    |}.

  Definition SUB (imm : int) : instruction :=
    {|
      num_source_regs := 2;
      writes_conditions := [C; M; L; Z];
      spec := (fun '(r0, r1) cc =>
                 r0 - (r1 << imm))
    |}.

  Definition SUBC (imm : int) : instruction :=
    {|
      num_source_regs := 2;
      writes_conditions := [C; M; L; Z];
      spec := (fun '(r0, r1) cc =>
                 r0 - (r1 << imm) - cc[C])
    |}.

  Definition MUL128LL : instruction :=
    {|
      num_source_regs := 2;
      writes_conditions := [M; L; Z];
      spec := (fun '(r0, r1) cc =>
                 (lower128 r0) * (lower128 r1))
    |}.

  Definition MUL128LU : instruction :=
    {|
      num_source_regs := 2;
      writes_conditions := [M; L; Z];
      spec := (fun '(r0, r1) cc =>
                 (lower128 r1) * (upper128 r0)) (* see note *)
    |}.

  Definition MUL128UL : instruction :=
    {|
      num_source_regs := 2;
      writes_conditions := [M; L; Z];
      spec := (fun '(r0, r1) cc =>
                 (upper128 r1) * (lower128 r0)) (* see note *)
    |}.

  Definition MUL128UU : instruction :=
    {|
      num_source_regs := 2;
      writes_conditions := [M; L; Z];
      spec := (fun '(r0, r1) cc =>
                 (upper128 r0) * (upper128 r1))
    |}.

  (* Note : Unlike the other operations, the output of RSHI is
    truncated in the specification. This is not strictly necessary,
    since the interpretation function truncates the output
    anyway. However, it is useful to make the definition line up
    exactly with Z.rshi. *)
  Definition RSHI (imm : int) : instruction :=
    {|
      num_source_regs := 2;
      writes_conditions := [M; L; Z];
      spec := (fun '(r0, r1) cc =>
                 (((2^256 * r0) + r1) >> imm) mod (2^256))
    |}.

  Definition SELC : instruction :=
    {|
      num_source_regs := 2;
      writes_conditions := [];
      spec := (fun '(r0, r1) cc =>
                 if cc[C] =? 1 then r0 else r1)
    |}.

  Definition SELM : instruction :=
    {|
      num_source_regs := 2;
      writes_conditions := [];
      spec := (fun '(r0, r1) cc =>
                 if cc[M] =? 1 then r0 else r1)
    |}.

  Definition SELL : instruction :=
    {|
      num_source_regs := 2;
      writes_conditions := [];
      spec := (fun '(r0, r1) cc =>
                 if cc[L] =? 1 then r0 else r1)
    |}.

  (* TODO : treat the MOD register specially, like CC *)
  Definition ADDM : instruction :=
    {|
      num_source_regs := 3;
      writes_conditions := [M; L; Z];
      spec := (fun '(r0, r1, MOD) cc =>
                 let ra := r0 + r1 in
                 if ra >=? MOD
                 then ra - MOD
                 else ra)
    |}.

End Instructions.

Module Registers.
  Inductive register : Type :=
  | r0 : register
  | r1 : register
  | r2 : register
  | r3 : register
  | r4 : register
  | r5 : register
  | r6 : register
  | r7 : register
  | r8 : register
  | r9 : register
  | r10 : register
  | r11 : register
  | r12 : register
  | r13 : register
  | r14 : register
  | r15 : register
  | r16 : register
  | r17 : register
  | r18 : register
  | r19 : register
  | r20 : register
  | r21 : register
  | r22 : register
  | r23 : register
  | r24 : register
  | r25 : register
  | r26 : register
  | r27 : register
  | r28 : register
  | r29 : register
  | r30 : register
  | RegZero : register (* r31 *)
  | RegMod : register
  .

  Definition reg_dec (x y : register) : {x = y} + {x <> y}.
  Proof. destruct x, y; try (apply left; congruence); right; congruence. Defined.
  Definition reg_eqb x y := if reg_dec x y then true else false.

  Lemma reg_eqb_neq x y : x <> y -> reg_eqb x y = false.
  Proof. cbv [reg_eqb]; break_match; congruence. Qed.
  Lemma reg_eqb_refl x : reg_eqb x x = true.
  Proof. cbv [reg_eqb]; break_match; congruence. Qed.
End Registers.


Require Import stdpp.list.
Require Import ssreflect.
From Tweetnacl Require Import Libs.Export.

Ltac ind_destr_destr n a b :=
  induction n ; destruct a ; destruct b ; boum.

(* Some definitions relating to the functional spec of this particular program.  *)
Fixpoint Zipp (f:Z -> Z -> Z) (a b : list Z) : list Z := match a,b with
  | [], [] => []
  | [], q => map (f 0%Z) q
  | q, [] => map (fun x => (f x 0%Z)) q
  | h1::q1,h2::q2 => (f h1 h2) :: Zipp f q1 q2
end.

Notation "F ( A , B )" := (Zipp F A B) (at level 60, right associativity).

Lemma Zipp_nil1: forall f h q, Zipp f (h :: q) [] = (f h 0%Z) :: (Zipp f q []).
Proof. ind_boum q. Qed.

Lemma Zipp_nil2: forall f h q, Zipp f [] (h :: q) = (f 0%Z h) :: (Zipp f [] q).
Proof. ind_boum q. Qed.

Open Scope Z.

Lemma Zipp_map_l: forall f a, Zipp f a [] = map (fun x : Z => f x 0%Z) a.
Proof. ind_boum a. Qed.

Lemma Zipp_map_r: forall f a, Zipp f [] a = map (f 0%Z) a.
Proof. ind_boum a. Qed.

Lemma Zipp_take : forall f n a b, take n (Zipp f a b) = Zipp f (take n a) (take n b).
Proof. ind_destr_destr n a b => //=; rewrite -?Zipp_map_l -?Zipp_map_r IHn; destruct n; go. Qed.

Lemma Zipp_length_max : forall f a b, length (Zipp f a b) = max (length a) (length b).
Proof. induction a ; destruct b ; go => //= ; rewrite map_length ; reflexivity. Qed.

Lemma Zipp_Zlength_max : forall f a b, Zlength (Zipp f a b) = Z.max (Zlength a) (Zlength b).
Proof.
  induction a as [|h a IHl]; destruct b ; go ; simpl;
  try assert(Ha := Zlength_pos a);
  try assert(Hb := Zlength_pos b).

  rewrite ?Zlength_cons Zlength_map Z.max_r; try reflexivity.
  rewrite Zlength_nil; omega.

  rewrite ?Zlength_cons Zlength_map Z.max_l ; try reflexivity.
  rewrite Zlength_nil; omega.

  rewrite ?Zlength_cons IHl.
  apply Z.succ_max_distr.
Qed.

Lemma Zipp_length : forall f a b, length (Zipp f a b) = length a \/ length (Zipp f a b) = length b.
Proof.
  intros f a b.
  rewrite Zipp_length_max.
  assert(Hl: length a < length b \/ length a = length b \/ length a > length b) by omega.
  repeat match goal with
    | [ H : _ \/ _ |- _ ] => destruct H
    | _ => right; apply Max.max_r ; go ; fail
    | _ => left; apply Max.max_l ; go ; fail
  end.
Qed.

Lemma Zipp_Zlength : forall f a b, Zlength (Zipp f a b) = Zlength a \/ Zlength (Zipp f a b) = Zlength b.
Proof.
  intros f a b.
  rewrite Zipp_Zlength_max.
  assert(Hl: Zlength a < Zlength b \/ Zlength a = Zlength b \/ Zlength a > Zlength b) by omega.
  repeat match goal with
    | [ H : _ \/ _ |- _ ] => destruct H
    | _ => right; apply Z.max_r ; go ; fail
    | _ => left; apply Z.max_l ; go ; fail
  end.
Qed.

Lemma Zipp_nth_length : forall f (n : nat) (a b : list Z),
  length a = length b ->
  (n < length a)%nat ->
  nth n (Zipp f a b) (f 0 0) = f (nth n a 0) (nth n b 0).
Proof. induction n; destruct a,b ; simpl ; intros ; flatten ; go. Qed.

Lemma Zipp_nth_Zlength : forall f (n : Z) (a b : list Z),
  0 <= n ->
  Zlength a = Zlength b ->
  n < Zlength a ->
  nth (Z.to_nat n) (Zipp f a b) (f 0 0) = f (nth (Z.to_nat n) a 0) (nth (Z.to_nat n) b 0).
Proof. intros f n a b Hn Hab Hna ; apply Zipp_nth_length ; auto.
rewrite ?Zlength_correct in Hab; omega.
rewrite ?Zlength_correct in Hna.
apply Z2Nat.inj_lt in Hna.
rewrite Nat2Z.id in Hna.
assumption.
omega.
omega.
Qed.

Definition f_comm (f: Z -> Z -> Z) := forall x y, f x y = f y x.
Definition f_0_neutral (f: Z -> Z -> Z) := forall x, f x 0%Z = x.
Definition f_neutral_0 (f: Z -> Z -> Z) := forall x, f 0%Z x = x.
Definition f_assoc (f: Z -> Z -> Z) := forall x y z, f (f x y) z = f x (f y z).

Lemma Zipp_comm: forall f a b, f_comm f -> Zipp f a b = Zipp f b a.
Proof.
  induction a, b ;
  repeat match goal with
    | _ => progress intros
    | _ => reflexivity
    | _ => simpl ; f_equal ; go ; apply map_ext
    | [ H : f_comm _ |- _ ] => rewrite H
  end.
Qed.

Lemma Zipp_nil_r: forall f a, f_0_neutral f -> Zipp f a [] = a.
Proof.
  intros ; go.
  rewrite Zipp_map_l.
  replace (map (fun x : ℤ => f x 0%Z) a) with (map (fun x : ℤ => x) a).
  apply map_id.
  apply map_ext ; go.
Qed.

Lemma Zipp_nil_l: forall f a, f_neutral_0 f ->  Zipp f [] a = a.
Proof.
  intros ; go.
  rewrite Zipp_map_r ; go.
  replace (map (f 0%Z) a) with (map (fun x : ℤ => x) a) ; go.
  rewrite map_id ; go.
  apply map_ext ; go.
Qed.

Lemma Zipp_assoc : forall f a b c, f_assoc f -> f_neutral_0 f ->  f_0_neutral f ->  Zipp f (Zipp f a b) c = Zipp f a (Zipp f b c).
Proof.
  induction a, b, c ;
  repeat match goal with
   | _ => progress intros
   | _ => progress go
   | _ => rewrite Zipp_nil_r
   | _ => rewrite Zipp_nil_l
   | _ => simpl ; f_equal
   end.
Qed.

Lemma Zipp_drop : forall f n a b, drop n (Zipp f a b) = Zipp f (drop n a) (drop n b).
Proof.
  ind_destr_destr n a b; simpl drop ; [rewrite Zipp_map_r | rewrite Zipp_map_l] ; auto ; rewrite map_drop ; reflexivity.
Qed.

Close Scope Z.