(*From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat div seq.
From mathcomp Require Import choice fintype finfun bigop finset.
*)
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import ssralg  (*zmodp*) matrix (* mxalgebra poly (* polydiv *)
  mxpoly *)       .
From mathcomp Require Import bigop.

From mathcomp Require Import algC.

From Hammer Require Import Tactics .
From Hammer Require Import Hammer .

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

Require Import Friendship.adj2_matrix.
Require Import Friendship.divisibility.
Require Import Friendship.matrix_casts.

Section friendship_sec.

  Context (T: finType) (T_nonempty :  [set: T] != set0)
    (F: rel T) (Fsym: symmetric F) (Firr: irreflexive F)
    (* I first tried with  "Co: forall (m n: T), m != n -> T"
       but gave up when I wanted a total version, and couldn't prove that
       it was equal to 'Co' whenever m != n *)
    (Co: forall (m n: T), T)

  (Col : forall m n (mNn: m != n), F m (Co m n))
  (Cor : forall m n (mNn: m != n), F n (Co m n))
  (CoUnique : forall m n l (mNn: m != n), F m l -> F n l -> l = Co m n).

  Definition T_elem:  T := (xchoose (set0Pn _ T_nonempty)).

  Definition n := #|[set: T]|.
  Lemma nge1 : n >= 1.
  Proof.
    by move: T_nonempty; rewrite card_gt0.
  Qed.

  Lemma Co_sym m n (mNn: m != n) (nNm: n != m): Co m n = Co n m.
  Proof.
    firstorder.
  Qed.

  Lemma andWl a b : a && b -> a.
  Proof.
    move=> /andP; firstorder.
  Qed.
  Lemma andWr a b : a && b -> b.
  Proof.
    move=> /andP; firstorder.
  Qed.

  Definition adj u := [set w | F u w].
  Definition deg u := #|adj u|.
  Definition k := deg T_elem.

  Lemma v_not_in_adj_u u v w:
    w \in adj u -> ~~(F u v) -> v != w.
  Proof.
    rewrite in_set.
    move=> Fuw nFuv.
    apply/negP.
    move=> /eqP vW.
    rewrite -vW in Fuw.
    move: nFuv => /negP.
    firstorder.
  Qed.

  (*Definition map_adj (u v w: T) := Co v w.*)

  (*Definition map_adj' u v
    (uNv: u != v) (nFuv: ~~(F u v)) w (wAdjU: w \in adj u)
    := (Co (v_not_in_adj_u  wAdjU nFuv)).*)

  Lemma map_adj_im u v (*(uNv: u != v) *)
    (nFuv: ~~(F u v)) w (wAdjU: w \in adj u) :
    Co v w \in adj v.
  Proof.
    rewrite in_set.
    apply: Col; apply: (@v_not_in_adj_u u); by [].
  Qed.

  Lemma Feq u v: F u v -> u != v.
  Proof.
    by case: (@eqP _ u v); [move => ->; rewrite Firr|].
  Qed.

  Lemma map_adj_inj u v (uNv: u != v) (nFuv: ~~(F u v)):
    {in adj u &, injective (Co v) }.
  Proof.
    move => w1 w2  w1adj w2adj coeq.
    rewrite in_set in w1adj; rewrite in_set in w2adj.

    have vw1 : v != w1. {
      case: (@idP (v == w1)) => /eqP vw1.
      by rewrite -vw1 in w1adj; move: nFuv => /negP; firstorder.
      by firstorder.
    }
    have vw2 : v != w2. {
      case: (@idP (v == w2)) => /eqP vw2.
      by rewrite -vw2 in w2adj; move: nFuv => /negP; firstorder.
      by firstorder.
    }
    set x := Co v w1.
    have fxw1 := (Cor vw1).
    have fxw2 := (Cor vw2).
    rewrite -/x in fxw1.
    rewrite -coeq -/x in fxw2.

    have w1x: w1 != x by apply Feq.
    have w2x: w2 != x by apply Feq.

    have ux : u != x. {
      case: (@eqP _ u x) => ux.
      move: (Col vw1); rewrite -/x -ux Fsym.
      by move: nFuv => /negP; clear; firstorder.
      by [].
    }

    (*
      u ... w1
      .      .
      .      .
      w2 ... [v w1] = [v w2] = x
     *)

    transitivity (Co u x). {
      apply: CoUnique => //=.
      rewrite Fsym //=.
    } {
      symmetry.
      apply: CoUnique => //=.
      rewrite Fsym //=.
    }
  Qed.

  Lemma almost_regular_leq u v:
    ~~(F u v) -> deg u <= deg v.
  Proof.
    case: (@eqP _ u v) => uv fuv; [by rewrite uv leqnn |].
    move: uv => /eqP uv.
    rewrite /deg -(card_in_imset (map_adj_inj uv fuv  ));
      apply subset_leq_card.

    have ->: [set Co v x | x in adj u] \subset adj v. {
      rewrite subsetE.
      apply  /pred0P => x //=.
      case: (@idP (x \notin adj v)) => //= xNotAdj.
      apply/eqP; rewrite eqbF_neg; apply /negP.
      move=> /imsetP [w wadj xeq].
      have in_adj := (map_adj_im  fuv wadj).
      rewrite -xeq in in_adj.
      move: xNotAdj => /negP; firstorder.
    }
    by [].
  Qed.

  Lemma almost_regular_eq u v: ~~(F u v) -> deg u = deg v.
  Proof.
    move=> fuv.
    have /eqP := almost_regular_leq fuv.
    rewrite Fsym in fuv.
    have /eqP := almost_regular_leq fuv.
    ssrnat_lia.
  Qed.

  Section assume_contra.
    Context (no_hub': forall u, [exists v, ~~(F u v) && (u != v)]).

    (* sig version of no_hub'. This is usable, in contrast to no_hub'. *)
    Lemma no_hub: forall u, {v | ~~(F u v) & (u != v)}.
    Proof.
      move=>u.
      have /existsP nhu := (no_hub' u).
      move: (sigW nhu) => [v /andP [p1 p2]].
      by exists v.
    Qed.

    Lemma almost_almost_regular x u:
      T_elem != x -> ~~(F T_elem x) -> u != Co T_elem x -> deg u = k.
    Proof.
      set t := T_elem.
      set ctx := Co t x.
      move=> tx Ftx uctx.
      have degx := almost_regular_eq Ftx.
      rewrite -/k in degx.
      case: (@idP (F t u)); case: (@idP (F x u));
        [move=> fxu ftu | move=>/negP f _ |
          move=> _ /negP f  ..
        ]; try rewrite -(almost_regular_eq f) //=. {
        rewrite (CoUnique tx ftu fxu) in uctx.
        move: uctx => /eqP; firstorder.
      }
    Qed.

    Lemma regular u: deg u = k.
    Proof.
      set t := T_elem.
      have [x ftx tx] := no_hub t.

      have almost_all: forall v, v != Co t x -> deg v = k by
          move=> v; apply (almost_almost_regular tx ftx).

      case: (@idP (u != Co t x)); try apply (almost_almost_regular tx ftx  ).
      move=> /negP /negPn /eqP uco.
      rewrite -uco in almost_all.
      have [y fuy uy] := no_hub u.

      rewrite (almost_regular_eq fuy) .
      rewrite eq_sym in uy.

      exact (almost_all y uy).
    Qed.

    Lemma kge1: k >= 1.
    Proof.
      set t := T_elem.
      rewrite card_gt0 -/t; apply/set0Pn; apply: ex_of_sig.
      have [y _ ty] := no_hub t.
      exists (Co t y).
      rewrite finset.inE.
      apply (Col ty).
    Qed.

    Definition nn := #|[eta T]|.
    Definition R := algC.

    Local Open Scope ring_scope.
    Definition A : 'M[R]_nn :=
      \matrix_(i < nn, j < nn) (F (enum_val i) (enum_val j))%:R.

    Lemma A_diag i: A i i = 0.
    Proof.
      by rewrite !mxE Firr.
    Qed.

    Lemma A_tr : \tr A = 0.
    Proof.
      rewrite /mxtrace  (eq_bigr (fun=> 0)).
      by rewrite big_const_ord  GRing.iter_addr GRing.addr0 GRing.mul0rn .
      by move=> i _; rewrite A_diag.
    Qed.

    Lemma A2_diag i: (A*m A) i i = k%:R.
    Proof.

      rewrite /mulmx !mxE (eq_bigr (fun j=> if (F (enum_val i) (enum_val j))
                                            then 1
                                            else 0)) -/nn.
      rewrite (bigID (fun x=> F (enum_val i) (enum_val x))) //= -/nn.
      rewrite [in X in X + _](eq_bigr (fun=> 1)).
      rewrite [in X in _ + X](eq_bigr (fun=> 0)).
      rewrite !GRing.sumr_const GRing.mul0rn GRing.addr0 //=.
      apply: f_equal.
      rewrite -(regular (enum_val i)) /deg /adj.

      rewrite -(@card_imset _ _ enum_val _ enum_val_inj) //=.
      apply: f_equal; apply: f_equal; apply: f_equal.
      apply/setP => x.

      rewrite !inE.

      case: (@idP (F (enum_val i) x)) => Fix ; apply/idP. {
        apply /(@imsetP (ordinal_finType nn) T enum_val ).
        exists (enum_rank x).
        by rewrite /in_mem //= enum_rankK.
        by rewrite enum_rankK.
      } {
        move => /(@imsetP (ordinal_finType nn) T enum_val ) [j].
        rewrite /in_mem //= => Fij xj.
        rewrite xj in Fix.
        firstorder.
      }
      by move => j /negPf ->.
      by move => j -> . {
        move=>  j _.
        rewrite !mxE.
        case: (@idP (F (enum_val i) (enum_val j))) => Fij. {
          rewrite Fsym in Fij.
          by rewrite GRing.mul1r  Fij.
        }
        by rewrite GRing.mul0r.
      }
    Qed.

    Definition adj' u := [set w | F u w && (w != T_elem)].

    Lemma adj'_disjoint (u1 u2 : T):
      u1 \in adj T_elem -> u2 \in adj T_elem ->
      u1 != u2 -> [disjoint (adj' u1) & (adj' u2)].
    Proof.
      rewrite /disjoint /adj !inE => u1adj u2adj u12.
      apply/pred0P => x //=.
      case: (@idP (x \in adj' u1)); case: (@idP (x \in adj' u2));
        rewrite /adj' //= !inE => /andP [fu2x xt] /andP [fu1x _].
      rewrite Fsym in fu2x.
      rewrite Fsym in fu1x.
      move: u12.
      rewrite (CoUnique xt fu1x u1adj) (CoUnique xt fu2x u2adj).
      by move => /eqP.
    Qed.

    Lemma adj'_and_tU u:
      u \in adj T_elem -> (adj' u) :|: [set T_elem]  = adj u.
    Proof.
      rewrite inE -setP => fut x.
      rewrite /adj /adj' !inE.
      rewrite Fsym in fut.
      case: (@idP (x == T_elem)).
      by move=> /eqP ->; rewrite fut.
      by rewrite Bool.andb_true_r Bool.orb_false_r.
    Qed.

    Lemma adj'_and_t_disj u:
      u \in adj T_elem -> [disjoint (adj' u) & [set T_elem] ].
    Proof.
      rewrite /disjoint /adj' => uadj.
      apply/pred0P => x; rewrite !inE //=.
      by case: (x == T_elem) => //=; rewrite Bool.andb_false_r ?Bool.andb_true_r .
    Qed.

    Lemma adj'_card u:
      u \in adj T_elem -> #|adj' u| = (k-1)%N.
    Proof.
      set k' := #|adj' u|.
      move=> uadj.
      have: (k' + 1)%N = k. {
        rewrite /k' -(cards1 T_elem) -(regular u) /deg -(adj'_and_tU uadj).

        have aoue := (eq_leqif (leq_card_setU (adj' u) [set T_elem]) ).
        rewrite (adj'_and_t_disj _) in aoue.
        by move: aoue => /idP /eqP ->.
        by [].
      }
      move: k kge1 => [|k''] //=.
      ssrnat_lia.
    Qed.
    Definition adj_cover :=[set adj' u | u in adj T_elem].
    Definition dist2 := cover adj_cover.

    Lemma k_not_1 : k != 1%N.
      (* Bevis: om k = 1, är adj T_elem = {a}.
         Det finns x, x != T_elem med ~~F T_elem x.
         x != a, för att F T_elem a och ~~F T_elem x.
         Co x t är granne med t, alltså är det a.
         Co x t har kant till x, alltså har a 2 kanter, vilket motsäger att
           allt har 1 kant.
       *)
    Proof.
      case: (@idP (k != 1%N)) => //= /negP.
      rewrite Bool.negb_involutive => /eqP k1.
      have adj1 u: #|adj u| == 1%N
        by apply/eqP; rewrite -k1 -/(deg u)  (regular u).

      (*Definition adj_ := forall v, cards1P (adj1 v).*)
      move: (cards1P (adj1 T_elem)) => [a seta].
      move: (no_hub T_elem) => [x ftx tx].
      have aadj : a \in adj T_elem by rewrite seta set11.
      have fta : F T_elem a by rewrite inE in aadj.

      have xa : x != a. {
        case: (@idP (x != a)) => //= /negP.
        rewrite Bool.negb_involutive => /eqP xa.
        rewrite xa in ftx.
        by move: ftx  => /negP; rewrite fta.
      }

      set a' := Co x T_elem.
      rewrite eq_sym in tx.
      have coF := Cor tx.
      have a'adj : a' \in adj T_elem
          by rewrite inE /a'.
      have a'a: a' = a by rewrite seta in a'adj; move: a'adj => /set1P.

      have uea := Col tx.
      rewrite -/a' a'a in uea.

      have xadj : x \in adj a by rewrite inE Fsym.
      have tadj : T_elem \in adj a by rewrite inE Fsym.

      move: (cards1P (adj1 a)) => [z setz].
      rewrite setz in xadj tadj.
      move: xadj => /set1P xz.
      move: tadj => /set1P tz.
      rewrite -xz in tz.
      move: tx => /eqP tx.
      symmetry in tz.
      by move: (tx tz).
    Qed.

    Lemma card_cover:  #|adj_cover| = k.
    Proof.
      rewrite /adj_cover card_in_imset. {
        by []. } {
        move => w1 w2  w1adj w2adj coeq.
        have disjF := adj'_disjoint w1adj w2adj.
        case: (@idP (w1 == w2)) => //=. by move=> /eqP. {
          move=> /negP /disjF /setDidPl.
          rewrite coeq setDv => w20.
          have : #|adj' w2| = 0%N
            by rewrite -w20 cards0.

          rewrite (adj'_card w2adj).

          move=> k_eq.
          have k1 : k = 1%N
            by move: k  kge1 k_eq => [| k'] //=; ssrnat_lia.
          move: k_not_1; rewrite k1.
          move =>  /eqP; clear; firstorder.
        }
      }
    Qed.

    Lemma disjoint_cover : trivIset adj_cover.
    Proof.
      apply/trivIsetP => A B /imsetP [u ut] -> /imsetP [v vt] -> sets_diff.
      case: (@idP (u != v)).
      by move=> uv; exact (adj'_disjoint ut vt uv). {
        move => /idP /eqP uv.
        rewrite uv in sets_diff.
        move: sets_diff; rewrite eq_refl //=.
      }
    Qed.

    Lemma dist2_card : #|dist2| = (k*(k-1))%N.
    Proof.
      have := (eq_leqif (leq_card_cover adj_cover) ).
      rewrite disjoint_cover /dist2; move=> /eqP -> .
      rewrite (eq_bigr (fun=> (k-1)%N)). {
        rewrite big_const iter_addn_0 [in RHS]mulnC.
        apply: f_equal.
        exact card_cover.
      }
      move=> A /imsetP [v vt] ->.
      by apply: adj'_card.
    Qed.

    Lemma adjT_subs_cover: adj T_elem \subset dist2.
    Proof.
      rewrite subsetE.
      apply/pred0P => x; rewrite !inE //=.
      apply: negPf.
      apply /negP => /andP [ xd ftx].
      set y := Co T_elem x.
      have xt : T_elem != x. {
        case: (@idP (T_elem != x)) => //= /negP /negPn /eqP tx.
        by rewrite tx Firr in ftx.
      }
      have ty := Col xt.
      have xy := Cor xt.
      rewrite -/y in ty xy.
      have xadjy : x \in adj' y. {
        rewrite inE.
        rewrite eq_sym in xt.
        by rewrite xt Bool.andb_true_r Fsym.
      }
      rewrite /dist2 /cover in xd.
      move: xd => /bigcupP notin.
      apply: notin => //=.
      exists (adj' y).
      rewrite /adj_cover.
      apply /imsetP.
      exists y.
      rewrite inE.
      by [].
      by [].
      by [].
    Qed.

    Lemma adjT_cover_noT: [disjoint dist2 & [set T_elem]].
    Proof.
      rewrite disjoint_sym /dist2 /cover.
      apply /bigcup_disjointP => A /imsetP[u ut] ->.
      rewrite disjoint_sym.
      exact (adj'_and_t_disj ut).
    Qed.

    Lemma all_covered : [set: T] =  dist2 :|: [set T_elem].
    Proof.
      apply/setP => x //=.
      rewrite inE.
      symmetry.
      apply/idP.
      case: (@idP (T_elem == x)). {
        by move=> /eqP <-; rewrite set1Ur. } {
        move=> /negP tx.
        set y := Co T_elem x.
        have xy : x \in adj' y. {
          rewrite inE.
          have yx := Col tx.
          have yt := Cor tx.
          by rewrite Fsym yt Bool.andb_true_l eq_sym.
        }

        apply/setUP; left.
        rewrite /dist2 /cover.
        apply /bigcupP.
        exists (adj' y).
        rewrite /adj_cover.
        apply /imsetP.
        exists y.
        by rewrite inE (Col tx).
        by [].
        by [].
      }
    Qed.

    Lemma T_size: n = ((k*(k-1))%N + 1)%N.
    Proof.
      rewrite /n -dist2_card  -(cards1 T_elem).
      have full_card := (eq_leqif (leq_card_setU dist2 [set T_elem]) ).
      rewrite adjT_cover_noT  in full_card.
      move: full_card => /idP /eqP <-.
      by rewrite all_covered.
    Qed.

    Lemma nk: n = (k*k - k + 1)%N.
      rewrite T_size.
      move: k kge1 => [| k'] //=.
      by ssrnat_lia.
    Qed.

    Lemma A2_off_diag i j:  i != j -> (A*m A) i j = 1%:R.
    Proof.
      move=> ij.
      rewrite /mulmx !mxE /A //=
        (eq_bigr (fun α=> if (F (enum_val i) (enum_val α)) &&
                               (F (enum_val α) (enum_val j))
                          then 1
                          else 0)) -/nn.

      rewrite (bigID (fun α=> (F (enum_val i) (enum_val α)) &&
                                (F (enum_val α) (enum_val j)))) //= -/nn.
      rewrite [in X in X + _](eq_bigr (fun=> 1)).
      rewrite [in X in _ + X](eq_bigr (fun=> 0)).
      rewrite !GRing.sumr_const GRing.mul0rn GRing.addr0 //=.
      set x := enum_val i.
      set y := enum_val j.
      set z := Co (enum_val i) (enum_val j).
      have xy: x != y. {
        case: (@idP (x != y)) => //= /negP.
        rewrite Bool.negb_involutive => /eqP xy.
        rewrite (enum_val_inj xy) in ij.
        move: ij => /eqP; firstorder.
      }
      rewrite -(cards1 z).
      rewrite -(@card_imset _ _ enum_val _ enum_val_inj) //=.
      apply/f_equal /f_equal /f_equal /f_equal.
      apply/setP => t.
      rewrite !inE //=.
      have Fxz := Col xy.
      have Fyz := Cor xy.
      rewrite -/z in Fxz Fyz.
      rewrite Fsym in Fyz.

      case: (@idP (t == z)) => tz ; apply/idP. {
        apply /(@imsetP (ordinal_finType nn) T enum_val ).
        exists (enum_rank z).
        by rewrite /in_mem //= enum_rankK Fxz Fyz.
        by move: tz => /eqP ->; rewrite enum_rankK.
      } {

        move => /(@imsetP (ordinal_finType nn) T enum_val ) [jj].
        rewrite /in_mem //= => /andP [fxjj fjjy] tjj.
        rewrite Fsym in fjjy.
        have z_uniq := CoUnique xy fxjj fjjy.
        rewrite -tjj in z_uniq.
        rewrite z_uniq /z -/x -/y in tz.
        apply tz.
        by apply eq_refl.
      }
      by move => jj /negPf ->.
      by move => jj -> . {
        move=>  jj _.
        rewrite !mxE.
        case: (@idP (F (enum_val i) (enum_val jj)  && (F (enum_val jj) (enum_val j))))
            => fijj . {
          move: fijj => /andP [fijj fjji].
          rewrite fijj.
          rewrite fjji .
          by rewrite GRing.mul1r .
        }
        move: fijj  => /negP.
        rewrite negb_and => /orP some0.
        by case: some0 => /negPf ->; rewrite ?GRing.mul0r ?GRing.mulr0.
      }
    Qed.

    Lemma adj2_eq : A*m A = (const_mx 1) +
                              (k-1)%:R%:M.
    Proof.
      apply/matrixP => i j;
      case: (@eqP _ i j). {
        move=> ->.
        rewrite A2_diag !mxE .
        rewrite eq_refl GRing.mulr1n.
        move: k kge1 => [|k'] //= _.
        have -> : (k'.+1-1)%N = k' by ssrnat_lia.
        have -> : k'.+1 = (1+k')%N by ssrnat_lia.
        by rewrite GRing.natrD.
      } {
        move=> /eqP ij.
        rewrite A2_off_diag //= !mxE.
        by rewrite (introFn idP ij) GRing.mulr0n GRing.addr0.
      }
    Qed.

    Lemma n_eq: nn = n.
    Proof.
      rewrite /nn /n.
      by rewrite cardsE.
    Qed.

    Lemma cast_eq:  nn = (1+(n-1))%N.
    Proof.
      rewrite n_eq.
      by move: n nge1 => [| n'] //=; ssrnat_lia.
    Qed.

    Definition A' := (castmx (cast_eq, cast_eq) A).

    (* Can't I use the previously proven version ?! *)
    Lemma A'_tr : \tr A' = 0.
    Proof.
      rewrite tr_castmx /mxtrace (eq_bigr (fun => 0)).
      by rewrite big_const_ord  GRing.iter_addr GRing.addr0 GRing.mul0rn .
      by move=> i _; rewrite A_diag.
    Qed.

    Lemma Asqrt : is_square_root k A'.
    Proof.
      by rewrite /is_square_root /adj2  /A' -mulmx_castmx  adj2_eq
          summx_castmx castmx_const scalar_mx_castmx.
    Qed.

    Lemma k_not_2: k <> 2%N.
    Proof.
      set t := T_elem.
      (*
        The proof:
        If k = 2, |adj t| = 2.
        |adj t| is not empty, so there exists a ∈ adj t
        some lemma should give [set a] \subset adj t and
        adj t = (adj t ⧵ [set a]) ⊎ [set a] as a disjoint union.
        By disjointness and 'card', |adj t ⧵ [set a]| = 1.
        Thus |adj t ⧵ [set a]| = [set b].
        a ∉ (adj t ⧵ [set a]), therefore a ∉ [set b], therfore a ≠ b.
        Then adj t = [set b] ⊎ [set a] with a != b, so adj t = [set a, b].
        --
        We have F t a and F t b, since both are in adj t.
        It follows that a != t and b != t (we already had a != b).
        There is x ∉ adj t with x ≠ t by the 'no_hub' property.
        We have x≠a, x≠b, because otherwise we would have (e.g.) both
            F t a and ~~F t a.
        Therefore all a, b, t, x are different, I think we can prove
           uniq [a, b, c, d]
        A lemma implies #|[set a, b, c, d]| = 4.
        But by some lemma #|A : {set T}| <= #|T| = 3, so 4 <= 3.
        Contradiction!
       *)

      move=> k2.
      have n3 : n=3%N by rewrite nk k2; ssrnat_lia.
      have adj1 u: #|adj u| = 2%N (* Every |adj u| is 2. *)
        by apply/eqP; rewrite -{}k2 -/(deg u)  (regular u).
      clear Co Col Cor CoUnique.
      have : 0%N < #|adj t| by rewrite adj1.
      move=> /card_gt0P [a a_adj]. (* there is an 'a' in adj t *)
      have a_sub : [set a] \subset adj t by rewrite sub1set.

      (* adj t = (adj t ⧵ [set a]) ⊎ [set a] as a disjoint union. *)
      have adjU := setD1K a_adj.
      have adjD : [disjoint [set a] & (adj t :\ a)]
        by rewrite  disjoints1; apply/negPf; rewrite setD11.

      (* By disjointness and 'card', |adj t ⧵ [set a]| = 1. *)
      set cta := #|adj t :\ a|.
      have cta12 : (1 + cta)%N = 2%N. {
        rewrite -[in LHS](cards1 a) /cta.
        have full_card := (eq_leqif (leq_card_setU [set a] (adj t :\ a) ) ).
        rewrite adjD in full_card.
        move: full_card => /idP  /eqP /esym ->.
        by rewrite adjU adj1.
      }
      have cta1 : cta == 1%N by apply/eqP; move: cta12; ssrnat_lia.

      (* Thus |adj t ⧵ [set a]| = [set b]. *)
      move: (cards1P cta1) => [b setb].

      (* a ∉ (adj t ⧵ [set a]), therefore a ∉ [set b], therfore a ≠ b. *)
      have aNb: a \notin [set b] by rewrite -disjoints1 -setb.
      rewrite in_set1 in aNb.

      (* Then adj t = [set b] ⊎ [set a] with a != b, so adj t = [set a, b]. *)
      have tab : adj t = [set a; b] by rewrite -adjU setb.

      (* We have F t a and F t b, since both are in adj t.*)
      have badj: b \in adj t by rewrite tab set22.
      have fta : F t a by rewrite inE in a_adj.
      have ftb : F t b by rewrite inE in badj.

      have Fneq u v: F u v -> u != v. {
        case: (@idP (u != v)) => //= /negP.
        by rewrite Bool.negb_involutive => /eqP ->; rewrite Firr.
      }
      (* It follows that a != t and b != t (we already had a != b). *)
      have a_t: a != t by rewrite eq_sym (Fneq _ _ fta).
      have b_t: b != t by rewrite eq_sym (Fneq _ _ ftb).

      (* There is x ∉ adj t with x ≠ t by the 'no_hub' property. *)
      move: (no_hub t) => [x ftx tx].

      (* We have x≠a, x≠b, because otherwise we would have (for a) both
         F t a and ~~F t a.*)
      have xa: x != a. {
        case: (@idP (x != a)) => //= /negP.
        rewrite Bool.negb_involutive => /eqP xa.
        rewrite xa in ftx .
        by move: ftx => /negP; rewrite fta.
      }
      have xb: x != b. {
        case: (@idP (x != b)) => //= /negP.
        rewrite Bool.negb_involutive => /eqP xb.
        rewrite xb in ftx .
        by move: ftx => /negP; rewrite ftb.
      }

      (* a, b, x, t are unique with 'uniq' *)
      have abxt: uniq [:: a ; b; x; t]. {
        rewrite uniq_pairwise pairwise_cons; apply/andP; split. {
          rewrite //= aNb a_t.
          rewrite eq_sym in xa.
          by rewrite xa.
        } {
          rewrite pairwise_cons; apply/andP; split. {
            rewrite //= b_t.
            rewrite eq_sym in xb.
            by rewrite xb.
          }
          rewrite pairwise_cons; apply/andP; split. {
            by rewrite //= eq_sym tx.
          } by [].
        }
      }

      (*  A lemma implies #|[set a, b, c, d]| = 4. *)
      have szabxt := (card_uniqP  abxt).
      have sz4: size [:: a; b; x; t] = 4%N by [].
      rewrite sz4 in szabxt.

      (* but #|[set a, b, c, d]|  is also <= #|T| = 3
         But by lemma 'max_card' #|A : {set T}| <= #|T| = 3, so 4 <= 3.*)
      have le43: #|[:: a; b; x; t]|  <= 3 by rewrite -n3 /n cardsT max_card.

      (* Contradiction! *)
      by rewrite szabxt in le43.
    Qed.

    Lemma fls: False.
    Proof. exact (k_not_2 (k_is_2 kge1 nge1 Asqrt A'_tr nk)).
    Qed.

  End assume_contra.
  (* Just rewriting 'fls', which is ~(forall u : T, [exists v, ~~ F u v && (u != v)]).*)
  Lemma exists_hub: [exists x, forall v, (x != v) ==> F x v].
  Proof.
    have no_hub : ~~[forall u : T, exists v : T, ~~ F u v && (u != v)].  {
      apply/negP => /forallP.

      set frl_exs := forall u : T, [exists v : T, ~~ F u v && (u != v)].
      have not_fe :  ~frl_exs by exact fls.
      by [].
    }
    rewrite  negb_forall in no_hub.
    rewrite (@eq_existsb _ (fun x=> ~~ [exists v, ~~ F x v && (x != v)])
                       (fun x=>  [forall v, (x != v) ==> F x v ])
            ) in no_hub; last first. {
      move=> u.
      rewrite negb_exists .
      rewrite (@eq_forallb _ (fun v=> ~~ (~~ F u v && (u != v)))
                           (fun v=> (u != v) ==> F u v)); last first. {
        move=> v.
        by rewrite negb_and Bool.negb_involutive implybE Bool.orb_comm.
      }
      by [].
    }
    by [].
  Qed.

  Lemma exists_hub_sig: {u | forall v, (u != v) -> F u v}.
  Proof.
    move: exists_hub => /existsP /sigW [u /forallP prop].
    exists u => v unv.
    have propv := prop v.
    by rewrite unv implyTb in propv.
  Qed.

End friendship_sec.


Require Export SystemFR.Judgments.
Require Export SystemFR.ReducibilityLemmas.

Opaque reducible_values.

Lemma annotated_reducible_sub:
  forall Θ Γ t T1 T2,
    [[ Θ; Γ ⊨ T1 <: T2 ]] ->
    [[ Θ; Γ ⊨ t : T1 ]] ->
    [[ Θ; Γ ⊨ t : T2 ]].
Proof.
  unfold open_reducible, open_subtype;
    repeat step; eauto using reducible_values_exprs.
Qed.


Require Import Relations Morphisms.
Require Import Program Coq.Setoids.Setoid.
Require Import Coq.ZArith.BinInt.
Require Import List.

(*
Require Import ZArith.
Open Scope Z_scope.
*)

Require Import Arith.
Require Import Ascii.
Require Import String.
Require Import BinInt.
Require Setoid.
Require Import Le Gt Minus Bool.

Set Implicit Arguments.
Open Scope list_scope.

Delimit Scope Int_scope with I.
Local Open Scope Int_scope.

Delimit Scope string_scope with string.
Local Open Scope string_scope.

Local Open Scope list_scope.

Require prereqs.

Module Make(Import M: prereqs.T).

Inductive variable: Type :=
  | Str: string -> variable
  | Gensym: string * nat -> variable.
Check variable.

Inductive expr: Type :=
  | Var: variable -> expr
  | Universe: nat -> expr
  | Pi: variable * expr * expr  -> expr
  | Lambda: variable * expr * expr  -> expr
  | App: expr * expr -> expr.
Check expr.

Definition context := list (variable * (expr * option expr)).
Check context.

Fixpoint assoc_opt (x: variable) (ctx: list (variable * expr)) {struct ctx}: option expr :=
  match ctx with
    | nil => None
    | ((v, a) :: ctx') =>
    (match v, x with
      | Str v1, Str x1 =>
      (match (string_compare v1 x1) with
        | 0 => Some a
        | _ => assoc_opt x ctx'
      end)
      | (Gensym (v1, t1)), Gensym (v2, t2) =>
      (match (string_compare v1 v2) with
        | 0 =>
        (match nat_compare t1 t2 with
          | 0 => Some a
          | _ => assoc_opt x ctx'
        end)
        | _ => assoc_opt x ctx'
        end)
      | _, _ => assoc_opt x ctx'
      end)
  end.
Check assoc_opt.

Definition extend (x: variable) (t: expr) (t': option expr) (ctx: context) := (x, (t, t')) :: ctx.
Check extend.

Definition incr (n: nat) := S n.

Definition refresh (v: variable) :=
  let k := 0%nat in
    match v with
      | Str x => Gensym (x, incr k)
      | Gensym (x, _) =>  Gensym (x, incr k)
   end.

Fixpoint subst (s: list (variable * expr)) (e: expr) {struct e}: expr :=
    match e with
      | Var x                  =>
      (match assoc_opt x s with
        | None => Var x
        | Some a => a
      end)
      | Universe k       => Universe k
      | Pi (x, t, e)     => Pi (let x' := refresh x in (x', subst s t, subst ((x, Var x') :: s) e))
      | Lambda (x, t, e) => Lambda (let x' := refresh x in (x', subst s t, subst ((x, Var x') :: s) e))
      | App (e1, e2)     => App (subst s e1, subst s e2)
    end.
Check subst.

Fixpoint assoc_ctx_opt (x: variable) (ctx: context) {struct ctx}: (expr * option expr) :=
  match ctx with
    | nil => ((Var x), None)
    | ((v, (a, b)) :: ctx') =>
    (match v, x with
      | Str v1, Str x1 =>
      (match (string_compare v1 x1) with
        | 0 => (a , b)
        | _ => assoc_ctx_opt x ctx'
      end)
      | (Gensym (v1, t1)), Gensym (v2, t2) =>
      (match (string_compare v1 v2) with
        | 0 =>
        (match nat_compare t1 t2 with
          | 0 => (a, b)
          | _ => assoc_ctx_opt x ctx'
        end)
        | _ => assoc_ctx_opt x ctx'
        end)
      | _, _ => assoc_ctx_opt x ctx'
      end)
  end.
Check assoc_opt.

Definition lookup_ty_opt (x: variable) (ctx: context) := fst (assoc_ctx_opt x ctx).
Check lookup_ty_opt.

Definition lookup_val_opt (x: variable) (ctx: context) := snd (assoc_ctx_opt x ctx).
Check lookup_val_opt.

Fixpoint normalize (ctx: context) (e: expr) {struct e}: expr :=
  match e with
    | Var x =>
      (match lookup_val_opt x ctx with
        | None    => Var x
        | Some e' => e' (* normalize ctx e' *)
     end)
    | App (e1, e2) =>
      let u2 := normalize ctx e2 in
      let u1 := normalize ctx e1 in
    	(match u1 with
         | Lambda (x, _, e1') => (subst [(x,u2)] e1') (*normalize (subst [(x,u2)] e1')*)
         | e1 => App (e1, u2)
        end)
    | Universe k       => Universe k
    | Pi (x, t, e)     => Pi (let t' := normalize ctx t in (x, t', (normalize (extend x t' None ctx) e)))
    | Lambda (x, t, e) => Lambda (let t' := normalize ctx t in (x, t', (normalize (extend x t' None ctx) e)))
 end.
Check normalize.

Fixpoint equal (ctx: context) (e1 e2: expr): bool :=
  match e1, e2 with
    | Var x1, Var x2 =>
    (match x1, x2 with
      | Str s1, Str s2 => string_compare_b s1 s2
      | Gensym (v1, t1), Gensym (v2, t2) =>
      (match string_compare_b v1 v2 with
        | true => nat_compare_b t1 t2
        | _ => false
      end)
      | _, _ => false
    end)
    | App (e11, e12), App (e21, e22) => equal ctx e11 e21 && equal ctx e12 e22
    | Universe k1, Universe k2 => nat_compare_b k1 k2
    | Pi (x, t1, e1), Pi (y, t2, e2) =>  equal ctx t1 t2 && (equal ctx e1 (subst [(y, Var x)] e2))
    | Lambda (x, t1, e1), Lambda (y, t2, e2) => equal ctx t1 t2 && (equal ctx e1 (subst [(y, Var x)] e2))
    | (Var _ | App _ | Universe _ | Pi _ | Lambda _), _ => false
  end.
Check equal.

Definition compare_universe (e1 e2: option expr): option expr :=
  match e1, e2 with
    | Some (Universe k1), Some (Universe k2) =>
    (match (nat_compare k1 k2) with
      | 0 => Some (Universe k1)
      | 1 => Some (Universe k1)
      | _ => Some (Universe k2)
    end)
    | _, _ => None
  end.
Check compare_universe.

Fixpoint infer_type_opt (ctx: context) (e: expr) :=
  match e with
    | Var x => Some (lookup_ty_opt x ctx)
    | Universe k => Some (Universe (k + 1))
    | Pi (x, t1, t2) =>
      let k1 := infer_type_opt ctx t1 in
      let k2 := infer_type_opt (extend x t1 (None) ctx) t2 in
        (compare_universe k1 k2) (* Universe (max k1 k2) *)
    | Lambda (x, t, e) =>
      let k := infer_type_opt ctx t in
        let ctx' := (extend x t (None) ctx) in
          let te := infer_type_opt ctx' e in
          (match te with
            | Some a => Some (Pi (x, t, a))
            | _      => None
          end)
    | App (e1, e2) =>
        let t1 := infer_type_opt ctx e1 in
          (match t1 with
            | Some (Pi (x, t, e)) =>
            (let t2 := infer_type_opt ctx e2 in
              (match t2 with
                | Some b =>
                (match (equal ctx t b) with
                  | true => Some (subst [(x, e2)] e)
                  | false => None
                end)
                | _ => None
              end))
            | _ => None
           end)
   end.
Check infer_type_opt.

End Make.


Require Import BinInt.
Require Import Arith.

(* Needed to define cpo_lub *)
Require Import Classical.
Require Import ClassicalDescription.

Definition mem := nat -> Z.
Definition expr := mem -> Z.

Inductive stat :=
| Skip : stat
| Stop : stat
| Assign : nat -> expr -> stat
| Seq : stat -> stat -> stat
| If : expr -> stat -> stat -> stat
| While : expr -> stat -> stat.

Definition update (m : mem) x z y := if x =? y then z else m y.

Inductive cpo (A : Type) :=
| Bottom : cpo A
| Some : A -> cpo A.

Arguments Bottom [A].
Arguments Some [A].

Definition cpo_leq {A : Type} (u v : cpo A) := (u = Bottom) \/ (u = v).

Lemma cpo_leq_trans {A : Type} :
  forall u v w : cpo A, cpo_leq u v -> cpo_leq v w -> cpo_leq u w.
Proof.
  intros u v w H1 H2; unfold cpo_leq in *; destruct u; destruct v; destruct w; destruct H1 as [H1|H1]; destruct H2 as [H2|H2]; inversion H1; inversion H2; auto.
Qed.

Definition cpo_chain {A : Type} (f : nat -> cpo A) := forall n, cpo_leq (f n) (f (S n)).

Lemma cpo_chain_leq {A : Type} : forall (f : nat -> cpo A), cpo_chain f -> forall x y, f x <> Bottom -> x <= y -> f y = f x.
Proof.
  intros f H1 x y H2 H3. induction H3. auto. specialize (H1 m). unfold cpo_leq in *. destruct H1; congruence.
Qed.

Lemma cpo_chain_add {A : Type} (f : nat -> cpo A) (H : cpo_chain f) :
  forall n p : nat, cpo_leq (f n) (f (n + p)).
Proof.
  induction p as [|p Hp].
  - simpl; unfold cpo_leq; auto.
  - simpl. apply cpo_leq_trans with (v := f (n + p)).
    + auto.
    + rewrite <- plus_n_Sm. apply H.
Qed.

Lemma cpo_lub_lemma {A : Type} : forall (f : nat -> cpo A), cpo_chain f -> exists!x, forall y, cpo_leq x y <-> (forall n, cpo_leq (f n) y).
Proof.
  intros f H. destruct (classic (exists n, f n <> Bottom)) as [[x H1] | H1].
  - exists (f x).
    assert (H2 : forall n, f n = Bottom \/ f n = f x).
    + intros n. destruct (le_lt_dec n x) as [H2 | H2].
      * classical_right. symmetry. apply cpo_chain_leq; auto.
      * right. apply cpo_chain_leq; auto. auto using Nat.lt_le_incl.
    + split. intro y. split.
      * intros H3 n. destruct (H2 n) as [H4 | H4]; rewrite H4; [unfold cpo_leq|]; auto.
      * intros H3; auto.
      * intros x' H3.
        assert (H4 : cpo_leq (f x) x'). apply H3. unfold cpo_leq; auto.
        unfold cpo_leq in H4; destruct H4; congruence.
  - exists Bottom.
    assert (H1' : forall n, f n = Bottom) by (intro; apply NNPP; eauto).
    split.
    + intro y. split.
      * intros. rewrite H1'. auto.
      * intros. unfold cpo_leq; auto.
    + intros x H2. destruct (H2 Bottom) as [H3 H4]. destruct H4.
      intro. rewrite H1'. unfold cpo_leq; auto. auto. auto.
Qed.

Definition cpo_lub {A : Type} (f : nat -> cpo A) (H : cpo_chain f) := proj1_sig (constructive_definite_description _ (cpo_lub_lemma f H)).

Lemma cpo_lub_def : forall {A : Type} (f : nat -> cpo A) (H : cpo_chain f) (x : cpo A),
    cpo_lub f H = x <-> (forall y, cpo_leq x y <-> (forall n, cpo_leq (f n) y)).
Proof.
  intros A f Hc x.
  unfold cpo_lub.
  remember (constructive_definite_description _ (cpo_lub_lemma f Hc)) as y.
  simpl. destruct y as [y Hy].
  split.
  - intros H; subst; auto.
  - intros H. destruct (cpo_lub_lemma f Hc) as [z [Hex Hun]].
    simpl. transitivity z; [symmetry|]; apply Hun; auto.
Qed.

Lemma cpo_lub_def_eq :
  forall {A : Type} (f : nat -> cpo A) (H : cpo_chain f) (x : cpo A),
    cpo_leq (cpo_lub f H) x <-> forall n, cpo_leq (f n) x.
Proof.
  intros A f H. rewrite <- cpo_lub_def. auto.
Qed.

Lemma cpo_lub_eq_some :
  forall {A : Type} (f : nat -> cpo A) (H : cpo_chain f) (n : nat), f n <> Bottom -> cpo_lub f H = f n.
Proof.
  intros A f H1 n H2.
  apply cpo_lub_def.
  intros y. split.
  - intros H3 n1. unfold cpo_leq in H3.
    destruct H3 as [H3 | H3]; try congruence. rewrite <- H3.
    destruct (le_lt_dec n1 n) as [H4 | H4].
    + rewrite <- le_plus_minus_r with (n := n1) (m := n); auto.
      apply cpo_chain_add; auto.
    + unfold cpo_leq; classical_right. apply cpo_chain_leq; auto using Nat.lt_le_incl.
  - intros; auto.
Qed.

Lemma cpo_lub_eq :
  forall {A : Type} (f : nat -> cpo A) (H : cpo_chain f),
  exists (n : nat), cpo_lub f H = f n.
Proof.
  intros A f H.
  destruct (classic (exists n, f n <> Bottom)) as [[x H1] | H1].
  - exists x. apply cpo_lub_eq_some; auto.
  - exists 0. apply cpo_lub_def.
    assert (forall n, f n = Bottom).
    + intros n. destruct (classic (f n = Bottom)); auto.
      exfalso; apply H1; exists n; auto.
    + rewrite H0. intros y; split; intros H2.
      * intros n; rewrite H0; unfold cpo_leq; auto.
      * unfold cpo_leq; auto.
Qed.

Lemma cpo_lub_ext :
  forall {A : Type} (f1 f2 : nat -> cpo A) (H1 : cpo_chain f1) (H2 : cpo_chain f2),
    (forall n : nat, f1 n = f2 n) -> cpo_lub f1 H1 = cpo_lub f2 H2.
Proof.
  intros A f1 f2 H1 H2 Heq.
  apply cpo_lub_def. intros y. split.
  - intros H3. rewrite cpo_lub_def_eq in H3. intros; rewrite Heq; auto.
  - intros H3. rewrite cpo_lub_def_eq. intros; rewrite <- Heq; auto.
Qed.

Lemma subchain_chain :
  forall {A : Type} (f : nat -> cpo A) (H : cpo_chain f) (p : nat), cpo_chain (fun n => f (n + p)).
Proof.
  intros A f H p n. apply H.
Qed.

Lemma cpo_lub_subchain :
  forall {A : Type} (f : nat -> cpo A) (H : cpo_chain f) (p : nat),
    cpo_lub f H = cpo_lub _ (subchain_chain f H p).
Proof.
  intros A f H p. apply cpo_lub_def.
  intros y.
  split.
  - intros H2. rewrite cpo_lub_def_eq in H2.
    intros n. apply cpo_leq_trans with (v := f (n + p)).
    + apply cpo_chain_add; auto.
    + auto.
  - intros H2. apply cpo_lub_def_eq. intros; auto.
Qed.

Definition ifapply e (f1 f2 : cpo mem -> cpo mem) m :=
  match m with
  | Bottom => Bottom
  | Some m => if (e m =? 0)%Z then f2 (Some m) else f1 (Some m)
  end.

Lemma ifapply_monotone :
  forall e f1 f2 m1 m2,
    cpo_leq m1 m2 -> cpo_leq (ifapply e f1 f2 m1) (ifapply e f1 f2 m2).
Proof.
  intros e f1 f2 m1 m2 H.
  destruct m1; destruct m2; destruct H; unfold cpo_leq in *; simpl; inversion H; auto.
Qed.

Fixpoint while_n n e f :=
  match n with
  | 0 => ifapply e (fun _ => Bottom) id
  | S n => (fun m => while_n n e f (ifapply e f id m))
  end.

Lemma while_n_bottom :
  forall n e f, while_n n e f Bottom = Bottom.
Proof.
  induction n as [|n H].
  - intros; simpl; auto.
  - intros; simpl; rewrite H; auto.
Qed.

Lemma while_n_monotone :
  forall n e f m1 m2, cpo_leq m1 m2 -> cpo_leq (while_n n e f m1) (while_n n e f m2).
Proof.
  induction n as [|n H1].
  - intros e f m1 m2 H2. simpl. apply ifapply_monotone; auto.
  - intros e f m1 m2 H2. simpl. apply H1. apply ifapply_monotone; auto.
Qed.

Lemma while_n_leq :
  forall n e f m, cpo_leq (while_n n e f m) (while_n (S n) e f m).
Proof.
  induction n as [|n H].
  - intros e f m; simpl; unfold ifapply. destruct m as [|m].
    + unfold cpo_leq; auto.
    + destruct ((e m =? 0)%Z) eqn:He; repeat (simpl; rewrite He).
      * unfold cpo_leq; auto.
      * unfold cpo_leq; auto.
  - intros e f m. simpl. apply H.
Qed.

Lemma while_n_chain :
  forall e f m, cpo_chain (fun n => while_n n e f m).
Proof.
  intros e f m n. apply while_n_leq.
Qed.

Fixpoint sem s m :=
  match s, m with
  | _, Bottom | Stop, _ => Bottom
  | Skip, Some m => Some m
  | Assign x e, Some m => Some (update m x (e m))
  | Seq s1 s2, m => sem s2 (sem s1 m)
  | If e s1 s2, m => ifapply e (sem s1) (sem s2) m
  | While e s, Some m => cpo_lub (fun n => while_n n e (sem s) (Some m)) (while_n_chain e (sem s) (Some m))
  end.

Notation "[[ s ]]" := (sem s) (at level 30).

Lemma sem_bottom :
  forall s, [[s]] Bottom = Bottom.
Proof.
  intros s. destruct s; auto.
Qed.

(* Not used, but here it is anyway. *)
Lemma while_fixpoint :
  forall e s m, [[While e s]] m = [[Seq (If e s Skip) (While e s)]] m.
Proof.
  intros e s m. simpl.
  destruct m as [|m].
  - auto.
  - simpl.
    destruct (e m =? 0)%Z eqn:H.
    + auto.
    + destruct ([[s]](Some m)) eqn:H2.
      * apply cpo_lub_def. intros x; split.
        -- intros H3 n. destruct n; simpl.
           ++ rewrite H; auto.
           ++ rewrite H; simpl. rewrite H2. rewrite while_n_bottom; auto.
        -- intros; unfold cpo_leq; auto.
      * rewrite cpo_lub_subchain with (p := 1).
        apply cpo_lub_ext. intros n.
        rewrite <- plus_n_Sm. simpl. rewrite <- plus_n_O.
        rewrite H. rewrite <- H2. auto.
Qed.

Inductive HoareTripleP : (mem -> Prop) -> stat -> (mem -> Prop) -> Prop :=
| HSkip : forall phi, HoareTripleP phi Skip phi
| HStop : forall phi psi, HoareTripleP phi Stop psi
| HAssign : forall phi x e, HoareTripleP (fun m => phi (update m x (e m))) (Assign x e) phi
| HSeq : forall phi pi psi s1 s2, HoareTripleP phi s1 pi -> HoareTripleP pi s2 psi -> HoareTripleP phi (Seq s1 s2) psi
| HConseq : forall (phi1 phi2 psi1 psi2 : mem -> Prop) s, (forall m, phi1 m -> phi2 m) -> (forall m, psi2 m -> psi1 m) -> HoareTripleP phi2 s psi2 -> HoareTripleP phi1 s psi1
| HIf : forall phi psi e s1 s2, HoareTripleP (fun m => phi m /\ (e m <> 0)%Z) s1 psi -> HoareTripleP (fun m => phi m /\ (e m = 0)%Z) s2 psi -> HoareTripleP phi (If e s1 s2) psi
| HWhile : forall I e s, HoareTripleP (fun m => I m /\ (e m <> 0)%Z) s I -> HoareTripleP I (While e s) (fun m => I m /\ (e m = 0)%Z).

Notation "|- {{ phi }} s {{ psi }}" := (HoareTripleP phi s psi) (at level 90, s at next level).

Notation "m |= phi" := (phi m) (at level 80, only parsing).
Notation "m |== phi" := (match m with Bottom => True | Some m1 => m1 |= phi end) (at level 80).

Definition HoareTriple phi s psi :=
  forall m, m |= phi -> [[s]] (Some m) |== psi.

Notation "|= {{ phi }} s {{ psi }}" := (HoareTriple phi s psi) (at level 90, s at next level).

Lemma while_n_preserve :
  forall s I e n m, (|= {{ fun m => I m /\ (e m <> 0)%Z }} s {{ I }}) -> I m ->
               (while_n n e ([[s]]) (Some m) |== (fun m => I m /\ (e m = 0)%Z)).
Proof.
  intros s I e n. induction n as [|n H].
  - intros m Hinv HI. simpl.
    destruct (e m =? 0)%Z eqn:Heq; simpl.
    + split; auto. apply Z.eqb_eq; auto.
    + auto.
  - intros m Hinv HI. simpl.
    remember (if (e m =? 0)%Z then id (Some m) else ([[s]]) (Some m)) as m1.
    destruct m1 as [|m1].
    + rewrite while_n_bottom; auto.
    + apply H; auto.
      destruct (e m =? 0)%Z eqn:Heq; simpl in Heqm1.
      * unfold id in Heqm1; congruence.
      * specialize (Hinv m); simpl in *. rewrite <- Heqm1 in Hinv.
        apply Hinv; split; auto. apply Z.eqb_neq; auto.
Qed.

(* This proof was done without the termination lemma, which has not been
   formally proved.
 *)
Lemma HoareTriple_correct :
  forall s phi psi, (|- {{ phi }} s {{ psi }}) -> (|= {{ phi }} s {{ psi }}).
Proof.
  intros s phi psi H. induction H.
  - intros m; simpl; auto.
  - intros m; simpl; auto.
  - intros m; simpl; auto.
  - intros m H1; simpl.
    destruct ([[s1]] (Some m)) eqn:H2.
    + rewrite sem_bottom; auto.
    + apply IHHoareTripleP2. specialize (IHHoareTripleP1 m); rewrite H2 in *; auto.
  - intros m; simpl.
    destruct ([[s]] (Some m)) eqn:H2.
    + auto.
    + intros H3; apply H0; specialize (IHHoareTripleP m); rewrite H2 in *; auto.
  - intros m H1; simpl.
    destruct ((e m =? 0)%Z) eqn:H2.
    + apply IHHoareTripleP2; split; auto. apply Z.eqb_eq; auto.
    + apply IHHoareTripleP1; split; auto. apply Z.eqb_neq; auto.
  - intros m H1. destruct ([[While e s]] (Some m)) as [|m1] eqn:Heq; simpl.
    + auto.
    + simpl in Heq.
      destruct (cpo_lub_eq _ (while_n_chain e ([[s]]) (Some m))) as [n H2].
      rewrite H2 in Heq.
      assert (while_n n e ([[s]]) (Some m) |== (fun m => I m /\ (e m = 0)%Z)) by (apply while_n_preserve; auto).
      rewrite Heq in *; auto.
Qed.

Inductive annot (A : Type) : stat -> Type :=
| Nskip : annot A Skip
| Nstop : annot A Stop
| Nassign : forall x e, annot A (Assign x e)
| Nseq : forall s1 s2, annot A s1 -> annot A s2 -> annot A (Seq s1 s2)
| Nif : forall e s1 s2, annot A s1 -> annot A s2 -> annot A (If e s1 s2)
| Nwhile : forall e s, A -> annot A s -> annot A (While e s).

Arguments Nskip [A].
Arguments Nstop [A].
Arguments Nassign [A].
Arguments Nseq [A].
Arguments Nif [A].
Arguments Nwhile [A].

(* It would be nicer to do match s, a with | Skip, Nskip => ...,
   but Coq dependant typing faculties are not enough to handle this,
   unfortunately. *)
Fixpoint wp (s : stat) (a : annot (mem -> Prop) s) (phi : mem -> Prop) : (mem -> Prop) :=
  match a with
  | Nskip => phi
  | Nstop => fun m => True
  | Nassign x e => fun m => phi (update m x (e m))
  | Nseq s1 s2 a1 a2 => wp s1 a1 (wp s2 a2 phi)
  | Nif e s1 s2 a1 a2 => fun m => ((e m <> 0)%Z -> wp s1 a1 phi m) /\ ((e m = 0)%Z -> wp s2 a2 phi m)
  | Nwhile e s P a => fun m => P m /\ (forall m1, (e m1 <> 0)%Z -> P m1 -> wp s a P m1) /\
                           (forall m1, (e m1 = 0)%Z -> P m1 -> phi m1)
  end.

Lemma wp_imp : forall s a (phi psi : mem -> Prop), (forall m, phi m -> psi m) -> (forall m, wp s a phi m -> wp s a psi m).
Proof.
  intros s. induction a; simpl; intros phi psi H m; auto.
  - intros H1; eapply IHa1; [|apply H1]. eapply IHa2. auto.
  - intros [H1 H2]; split; intros H3.
    + eapply IHa1; eauto.
    + eapply IHa2; eauto.
  - intros [H1 [H2 H3] ]; split; auto.
Qed.

Lemma wp_and : forall s a phi psi m, psi /\ (wp s a phi) m -> wp s a (fun m => phi m /\ psi) m.
Proof.
  intros s. induction a; simpl; intros phi psi m; try tauto.
  - intros [Hpsi H]. eapply wp_imp; [|apply H].
    intros m0 H0. apply IHa2; auto.
  - intros [Hpsi [H1 H2] ]. split; intros H3.
    + apply IHa1; auto.
    + apply IHa2; auto.
  - intros [Hpsi [H1 [H2 H3] ] ]. split; auto.
Qed.

Theorem wp_correct : forall s a phi, |- {{wp s a phi}} s {{phi}}.
Proof.
  intros s. induction a.
  - simpl. intros phi. apply HSkip.
  - simpl. intros phi. apply HStop.
  - simpl. intros phi. apply HAssign.
  - simpl. intros phi. eapply HSeq; auto.
  - simpl. intros phi. apply HIf.
    + eapply HConseq with (psi2 := phi); [|auto|apply IHa1]. intros; tauto.
    + eapply HConseq with (psi2 := phi); [|auto|apply IHa2]. intros; tauto.
  - simpl. intros phi.
    eapply HConseq; [intros m H; exact H| |eapply HWhile].
    + intros m H. simpl in H. destruct H as [ [H1 [H2 H3] ] H4].
      apply H3; auto.
    + eapply HConseq; [|intros m H; exact H|apply IHa].
      intros m [ [H1 [H2 H3] ] H4]. apply wp_and. split; auto.
Qed.

Inductive assertion :=
| Top : assertion
| Bot : assertion
| Not : assertion -> assertion
| And : assertion -> assertion -> assertion
| Or : assertion -> assertion -> assertion
| Implies : assertion -> assertion -> assertion
| Zexpr : expr -> assertion
| VForall : nat -> assertion -> assertion
| VExists : nat -> assertion -> assertion
| MForall : assertion -> assertion
| MExists : assertion -> assertion
| Subst : nat -> expr -> assertion -> assertion.

Fixpoint asem (a : assertion) (m : mem) :=
  match a with
  | Top => True
  | Bot => False
  | Not a => ~(asem a m)
  | And a1 a2 => (asem a1 m) /\ (asem a2 m)
  | Or a1 a2 => (asem a1 m) \/ (asem a2 m)
  | Implies a1 a2 => (asem a1 m) -> (asem a2 m)
  | Zexpr e => (e m = 0)%Z
  | VForall n a => forall x, asem a (update m n x)
  | VExists n a => exists x, asem a (update m n x)
  | MForall a => forall m1, asem a m1
  | MExists a => exists m1, asem a m1
  | Subst n e a => asem a (update m n (e m))
  end.

Fixpoint wps (s : stat) (a : annot assertion s) (phi : assertion) :=
  match a with
  | Nskip => phi
  | Nstop => Top
  | Nassign x e => Subst x e phi
  | Nseq s1 s2 a1 a2 => wps s1 a1 (wps s2 a2 phi)
  | Nif e s1 s2 a1 a2 => And (Implies (Not (Zexpr e)) (wps s1 a1 phi)) (Implies (Zexpr e) (wps s2 a2 phi))
  | Nwhile e s P a => And P (And
       (MForall (Implies (Not (Zexpr e)) (Implies P (wps s a P))))
       (MForall (Implies (Zexpr e) (Implies P phi))))
  end.

Fixpoint amap {A B : Type} (s : stat) (a : annot A s) (f : A -> B) :=
  match a with
  | Nskip => Nskip
  | Nstop => Nstop
  | Nassign x e => Nassign x e
  | Nseq s1 s2 a1 a2 => Nseq s1 s2 (amap s1 a1 f) (amap s2 a2 f)
  | Nif e s1 s2 a1 a2 => Nif e s1 s2 (amap s1 a1 f) (amap s2 a2 f)
  | Nwhile e s P a => Nwhile e s (f P) (amap s a f)
  end.

Lemma wps_wp : forall s a phi, asem (wps s a phi) = wp s (amap s a asem) (asem phi).
Proof.
  induction a; intros; simpl; auto.
  - rewrite IHa1; rewrite IHa2; auto.
  - rewrite IHa1; rewrite IHa2; auto.
  - rewrite IHa; auto.
Qed.

Theorem wps_correct : forall s a phi, |- {{asem (wps s a phi)}} s {{asem phi}}.
Proof.
  intros. rewrite wps_wp. apply wp_correct.
Qed.

Theorem wps_correct2: forall s a phi, |= {{asem (wps s a phi)}} s {{asem phi}}.
Proof.
  intros. apply HoareTriple_correct. apply wps_correct.
Qed.

Require Extraction.
Extraction wps.

(* Note how the extracted function doesn't depend on s itself but on the
   annotation only. This is because the annotation contains all the
   information needed to reconstruct s, and we didn't use match s, a with ...
   but match a with ... only.
   Besides, it is interesting to note how the computation of precondition
   can grow to very large sizes, even for simple programs, due to the
   duplication for cases like If.
 *)


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import List.
Require Import String.
Require Import Utils.
Require Import DataRuntime.
Require Import NRA.
Require Import NRAEq.

Section NRARewrite.
  Local Open Scope nra_scope.

  Context {fruntime:foreign_runtime}.

  (* Some of algebraic equivalences for NRA *)
  (* Those are valid without type *)

  (* P1 ∧ P2 ≡ P2 ∧ P1 *)

  Lemma and_comm (p1 p2: nra) :
    p2 ∧ p1 ≡ₐ p1 ∧ p2.
  Proof.
    unfold nra_eq; intros; simpl.
    generalize (h ⊢ p1 @ₐ x ⊣ c); generalize (h ⊢ p2 @ₐ x ⊣ c); intros.
    destruct o; destruct o0; try reflexivity.
    unfold unbdbool.
    destruct d; destruct d0; try reflexivity; simpl.
    rewrite Bool.andb_comm; reflexivity.
  Qed.

  (* (P1 ⋃ P2) ⋃ P3 ≡ P1 ⋃ (P2 ⋃ P3) *)

  Lemma union_assoc (p1 p2 p3: nra):
    (p1 ⋃ p2) ⋃ p3 ≡ₐ p1 ⋃ (p2 ⋃ p3).
  Proof.
    unfold nra_eq; intros; simpl.
    generalize (h ⊢ p1 @ₐ x ⊣ c) as d1.
    generalize (h ⊢ p2 @ₐ x ⊣ c) as d2.
    generalize (h ⊢ p3 @ₐ x ⊣ c) as d3.
    intros.
    destruct d1; destruct d2; destruct d3; try reflexivity.
    destruct d; destruct d0; destruct d1; try reflexivity.
    simpl.
    autorewrite with alg.
    rewrite bunion_assoc.
    reflexivity.
    destruct (rondcoll2 bunion d d0); autorewrite with alg; reflexivity.
  Qed.

  (* σ⟨ P ⟩(P1 ⋃ P2) ≡ σ⟨ P ⟩(P1) ⋃ σ⟨ P ⟩(P2) *)

  Lemma union_select_distr (p p1 p2: nra) :
    σ⟨ p ⟩(p1 ⋃ p2) ≡ₐ σ⟨ p ⟩(p1) ⋃ σ⟨ p ⟩(p2).
  Proof.
    unfold nra_eq; intros.
    simpl.
    generalize (h ⊢ p1 @ₐ x ⊣ c) as d1.
    generalize (h ⊢ p2 @ₐ x ⊣ c) as d2.
    intros.
    destruct d1; destruct d2; try (autorewrite with alg; reflexivity).
    - destruct d; try reflexivity.
      destruct d0; simpl; try (destruct (lift_filter
         (fun x' : data =>
          match h ⊢ p @ₐ x' ⊣ c with
          | Some (dbool b) => Some b
          | _ => None
          end) l); reflexivity).
      induction l; simpl.
      destruct (lift_filter
         (fun x' : data =>
          match h ⊢ p @ₐ x' ⊣ c with
          | Some (dbool b) => Some b
          | _ => None
          end) l0); reflexivity.
      generalize(h ⊢ p @ₐ a ⊣ c); intros.
      unfold bunion.
      rewrite lift_app_filter.
      destruct o; try reflexivity.
      destruct d; try reflexivity.
      revert IHl.
      generalize ((lift_filter
            (fun x' : data =>
             match h ⊢ p @ₐ x' ⊣ c with
             | Some (dbool b0) => Some b0
             | _ => None
             end) l)).
      generalize (lift_filter
             (fun x' : data =>
              match h ⊢ p @ₐ x' ⊣ c with
              | Some (dbool b0) => Some b0
              | _ => None
              end) l0).
      intros.
      destruct o0; try reflexivity. simpl.
      destruct o; try reflexivity.
      + destruct b; autorewrite with alg; reflexivity.
      + autorewrite with alg. reflexivity.
  Qed.

  (* χ⟨ P1 ⟩( { P2 } ) ≡ { P1 ◯ P2 } *)

  Lemma map_singleton (p1 p2:nra) :
    χ⟨ p1 ⟩( ‵{| p2 |} ) ≡ₐ ‵{| p1 ◯ p2 |}.
  Proof.
    unfold nra_eq; intros; simpl.
    generalize (h ⊢ p2 @ₐ x ⊣ c); intros.
    destruct o; try reflexivity; simpl.
    generalize (h ⊢ p1 @ₐ d ⊣ c); intros; simpl.
    destruct o; reflexivity.
  Qed.

  (* [ a : ID ] ◯ P ≡ [ a : P ] *)

  Lemma compose_rec_id s p:
    ‵[| (s, ID) |] ◯ p ≡ₐ ‵[| (s, p) |].
  Proof.
    unfold nra_eq; intros; simpl.
    generalize (h ⊢ p @ₐ x ⊣ c); intros.
    destruct o; reflexivity.
  Qed.

  Lemma flatten_map_coll p1 p2 :
    ♯flatten(χ⟨ ‵{| p1 |} ⟩( p2 )) ≡ₐ χ⟨ p1 ⟩( p2 ).
  Proof.
    unfold nra_eq; intros h c _ x _; simpl.
    generalize (h ⊢ p2 @ₐ x ⊣ c); clear x p2; intros.
    destruct o; try reflexivity.
    destruct d; try reflexivity; simpl.
    induction l; try reflexivity; simpl.
    generalize (h ⊢ p1 @ₐ a ⊣ c); clear a; intros; simpl.
    destruct o; try reflexivity; simpl.
    unfold olift in *.
    revert IHl.
    generalize (lift_map
             (fun x : data =>
              match h ⊢ p1 @ₐ x ⊣ c with
              | Some x' => Some (dcoll (x' :: nil))
              | None => None
              end) l); generalize (lift_map (nra_eval h c p1) l); intros.
    unfold lift in *; simpl.
    destruct o; destruct o0; simpl; try reflexivity; try congruence.
    - simpl in *.
      unfold oflatten in *; simpl in *.
      revert IHl.
      generalize ((lift_flat_map
                     (fun x : data =>
                        match x with
                          | dcoll y => Some y
                          | _ => None
                        end) l1)); intros; simpl in *.
      destruct o; try congruence.
      inversion IHl; clear IHl H0; reflexivity.
    - simpl in *.
      unfold oflatten in *; simpl.
      revert IHl.
      generalize ((lift_flat_map
                     (fun x : data =>
                        match x with
                          | dcoll y => Some y
                          | _ => None
                        end) l0)); intros; simpl in *.
      destruct o; try congruence; reflexivity.
  Qed.

  (* [ a1 : p1; a2 : p1 ].a2 ≡ₐ p1 *)

  Lemma dot_from_duplicate_r s1 s2 p1 :
    (‵[| (s1, p1) |] ⊕ ‵[| (s2, p1) |])·s2 ≡ₐ p1.
  Proof.
    unfold nra_eq; intros ? ? _ x _; simpl.
    generalize (h ⊢ p1 @ₐ x ⊣ c); clear p1 x; intros.
    destruct o; try reflexivity.
    unfold olift; simpl.
    destruct (StringOrder.lt_dec s1 s2); try reflexivity; simpl.
    unfold edot; simpl.
    destruct (string_eqdec s2 s2); try congruence; simpl.
    destruct (StringOrder.lt_dec s1 s2); try congruence; simpl.
    destruct (StringOrder.lt_dec s2 s1); try congruence; simpl.
    unfold edot; simpl.
    destruct (string_eqdec s2 s1); try congruence; simpl.
    destruct (string_eqdec s2 s2); try congruence; simpl.
    unfold edot; simpl.
    destruct (string_eqdec s2 s2); congruence.
  Qed.

  (* [ a1 : p1; a2 : p1 ].a1 ≡ₐ p1 *)

  Lemma dot_from_duplicate_l s1 s2 p1 :
    (‵[| (s1, p1) |] ⊕ ‵[| (s2, p1) |])·s1 ≡ₐ p1.
  Proof.
    unfold nra_eq; intros ? ? _ x _; simpl.
    generalize (h ⊢ p1 @ₐ x ⊣ c); clear p1 x; intros.
    destruct o; try reflexivity.
    unfold olift; simpl.
    destruct (StringOrder.lt_dec s1 s2); try reflexivity; simpl.
    unfold edot; simpl.
    destruct (string_eqdec s1 s1); try congruence; simpl.
    destruct (string_eqdec s1 s2); try congruence; simpl.
    destruct (StringOrder.lt_dec s2 s1); try congruence; simpl.
    unfold edot; simpl.
    destruct (string_eqdec s1 s1); try congruence; simpl.
    unfold edot; simpl.
    destruct (string_eqdec s1 s2); try congruence; simpl.
    assert (StringOrder.eq s1 s2) by (apply lt_contr1; assumption).
    contradiction.
  Qed.

  (* χ⟨ { ID } ⟩( P ) ≡ { { P } }*)

  Lemma map_into_singleton p :
    χ⟨ ‵{| ID |} ⟩(‵{| p |}) ≡ₐ ‵{|‵{| p |}|}.
  Proof.
    unfold nra_eq; intros ? ? _ x _; simpl.
    generalize (h ⊢ p @ₐ x ⊣ c); clear x p; intros.
    destruct o; reflexivity.
  Qed.

  (* ♯flatten( χ⟨ { { P1 } } ⟩( P2 ) ) ≡ χ⟨ { P1 } ⟩( P2 ) *)

  Lemma flatten_over_map_into_singleton p1 p2:
    ♯flatten( χ⟨ ‵{|‵{| p1 |}|} ⟩( p2 ) ) ≡ₐ χ⟨ ‵{| p1 |} ⟩( p2 ).
  Proof.
    unfold nra_eq; intros ? ? _ ? _; simpl.
    generalize (h ⊢ p2 @ₐ x ⊣ c); clear p2 x; intros.
    destruct o; try reflexivity; simpl.
    destruct d; try reflexivity; simpl.
    induction l; try reflexivity; simpl.
    unfold olift, lift in *; simpl.
    generalize (h ⊢ p1 @ₐ a ⊣ c); clear a; intros; simpl.
    destruct o; try reflexivity; simpl.
    revert IHl.
    generalize (lift_map
              (fun x : data =>
               match
                 match h ⊢ p1 @ₐ x ⊣ c with
                 | Some x' => Some (dcoll (x'::nil))
                 | None => None
                 end
               with
               | Some x' => Some (dcoll (x'::nil))
               | None => None
               end) l);
    generalize (lift_map
            (fun x : data =>
             match h ⊢ p1 @ₐ x ⊣ c with
             | Some x' => Some (dcoll (x'::nil))
             | None => None
             end) l); intros.
    destruct o; destruct o0; try reflexivity; simpl; unfold lift_oncoll in *; simpl; try congruence.
    - unfold oflatten in *; simpl in *.
      revert IHl; generalize (lift_flat_map
                                (fun x : data =>
                                   match x with
                                     | dcoll y => Some y
                                     | _ => None
                                   end) l1); intros.
      destruct o; try reflexivity; simpl.
      inversion IHl; reflexivity.
      congruence.
    - unfold oflatten in *; simpl.
      revert IHl; generalize (lift_flat_map
                                (fun x : data =>
                                   match x with
                                     | dcoll y => Some y
                                     | _ => None
                                   end) l0); intros.
      destruct o; try reflexivity; simpl.
      congruence.
  Qed.

  (*****************)
  (* Rules Section *)
  (*****************)

  (* Composite/specialized rewrites, useful for rules optimization *)

  Lemma map_singleton_rec s1 s2 :
    χ⟨‵[| (s1, ID) |] ⟩( ‵{|(ID) · s2 |}) ≡ₐ ‵{|‵[| (s1, (ID) · s2) |] |}.
  Proof.
    apply map_singleton.
  Qed.

  (* χ⟨ ID.a ⟩( { P } ) ≡ { P.a } *)

  Lemma map_dot_singleton s p :
    χ⟨ (ID)·s ⟩( ‵{| p |} ) ≡ₐ ‵{| p·s |}.
  Proof.
    apply map_singleton.
  Qed.

  (*
     a1, a2, a3 are distinct field names
     ============================================================================
     χ⟨ ¬π[a1](ID) ⟩ ( ⋈ᵈ⟨ χ⟨ [ a2 : ID ] ⟩(ID.a1) ⟩( { [ a3 : p1; a1: { p2 } ] } )
     ≡ { [ (a3 : p1; a2 : p2 ] } *)

  Lemma unnest_singleton s1 s2 s3 p1 p2 :
    s1 <> s2 /\ s2 <> s3 /\ s3 <> s1 ->
    χ⟨ ¬π[s1](ID) ⟩(
       ⋈ᵈ⟨ χ⟨ ‵[| (s2,ID) |] ⟩((ID)·s1) ⟩( ‵{|‵[| (s3,p1) |] ⊕ ‵[| (s1,‵{| p2 |}) |]|} )
     )
     ≡ₐ ‵{|‵[| (s3, p1) |] ⊕ ‵[| (s2, p2) |]|}.
  Proof.
    intros.
    elim H; clear H; intros.
    elim H0; clear H0; intros.
    unfold nra_eq; intros ? ? _ ? _; simpl.
    generalize (h ⊢ p1 @ₐ x ⊣ c); generalize(h ⊢ p2 @ₐ x ⊣ c); clear p1 p2 x; intros.
    destruct o; try reflexivity; simpl.
    - unfold olift, olift2; simpl.
      destruct o0; try reflexivity; simpl.
      destruct (StringOrder.lt_dec s3 s1); try reflexivity; simpl.
      unfold lift; simpl.
      unfold omap_product, oncoll_map_concat; simpl.
      unfold edot; simpl.
      unfold string_eqdec.
      destruct (string_dec s1 s1); try reflexivity; simpl.
      unfold rremove; simpl.
      unfold rec_concat_sort; simpl.
      destruct (StringOrder.lt_dec s1 s2); try reflexivity; simpl.
      destruct (StringOrder.lt_dec s3 s1); simpl.
      destruct (string_dec s1 s3); simpl.
      congruence.
      destruct (string_dec s1 s1); simpl.
      destruct (StringOrder.lt_dec s3 s2); try reflexivity; simpl.
      destruct (string_dec s1 s2); try congruence.
      destruct (StringOrder.lt_dec s2 s3); try reflexivity; simpl.
      destruct (string_dec s1 s2); try congruence.
      assert (StringOrder.lt s3 s2).
      apply RelationClasses.transitivity with (y := s1); assumption.
      contradiction.
      destruct (string_dec s1 s2); simpl.
      assert False; auto; contradiction.
      assert (StringOrder.lt s3 s2).
      apply RelationClasses.transitivity with (y := s1); assumption.
      contradiction.
      congruence.
      congruence.
      destruct (StringOrder.lt_dec s3 s2); try reflexivity; try congruence; simpl.
      destruct (StringOrder.lt_dec s2 s1); try reflexivity; try congruence; simpl.
      destruct (StringOrder.lt_dec s3 s2); try reflexivity; try congruence; simpl.
      destruct (string_dec s1 s3); try congruence; simpl.
      destruct (string_dec s1 s2); try congruence; simpl.
      destruct (string_dec s1 s1); try congruence; simpl.
      destruct (StringOrder.lt_dec s3 s2); try reflexivity; try congruence; simpl.
      destruct (string_dec s1 s3); try congruence; simpl.
      destruct (string_dec s1 s2); try congruence; simpl.
      destruct (StringOrder.lt_dec s2 s3); try reflexivity; try congruence; simpl.
      destruct (StringOrder.lt_dec s2 s1); try reflexivity; try congruence; simpl.
      destruct (StringOrder.lt_dec s3 s2); try reflexivity; try congruence; simpl.
      destruct (StringOrder.lt_dec s2 s3); try reflexivity; try congruence; simpl.
      destruct (string_dec s1 s2); try congruence; simpl.
      destruct (StringOrder.lt_dec s3 s1); try reflexivity; try congruence; simpl.
      destruct (string_dec s1 s3); try congruence; simpl.
      destruct (string_dec s1 s1); try congruence; simpl.
      destruct (StringOrder.lt_dec s2 s3); try reflexivity; try congruence; simpl.
      destruct (StringOrder.lt_dec s3 s2); try reflexivity; try congruence; simpl.
      destruct (string_dec s1 s2); try congruence; simpl.
      destruct (string_dec s1 s3); try congruence; simpl.
      destruct (StringOrder.lt_dec s2 s1); try reflexivity; try congruence; simpl.
      destruct (StringOrder.lt_dec s1 s3); try reflexivity; try congruence; simpl.
      destruct (StringOrder.lt_dec s3 s1); try reflexivity; try congruence; simpl.
      destruct (StringOrder.lt_dec s2 s3); try reflexivity; try congruence; simpl.
      destruct (StringOrder.lt_dec s3 s2); try reflexivity; try congruence; simpl.
      destruct (string_dec s1 s2); try congruence; simpl.
      destruct (string_dec s1 s1); try congruence; simpl.
      destruct (StringOrder.lt_dec s3 s2); try reflexivity; try congruence; simpl.
      destruct (StringOrder.lt_dec s2 s3); try reflexivity; try congruence; simpl.
      destruct (string_dec s1 s2); try congruence; simpl.
      destruct (string_dec s1 s1); try congruence; simpl.
      destruct (StringOrder.lt_dec s3 s2); try reflexivity; try congruence; simpl.
      destruct (StringOrder.lt_dec s2 s3); try reflexivity; try congruence; simpl.
      destruct (string_dec s1 s2); try congruence; simpl.
      destruct (string_dec s1 s3); try congruence; simpl.
      destruct (StringOrder.lt_dec s3 s2); try reflexivity; try congruence; simpl.
      destruct (StringOrder.lt_dec s1 s3); try reflexivity; try congruence; simpl.
      unfold lift; simpl.
      unfold omap_product, oncoll_map_concat; simpl.
      unfold edot; simpl.
      unfold string_eqdec.
      destruct (string_dec s1 s3); try congruence; simpl.
      destruct (string_dec s1 s1); try congruence; simpl.
      unfold rremove; simpl.
      unfold rec_concat_sort; simpl.
      unfold string_eqdec.
      destruct (StringOrder.lt_dec s3 s2); try reflexivity; try congruence; simpl.
      destruct (StringOrder.lt_dec s1 s3); try reflexivity; try congruence; simpl.
      destruct (string_dec s1 s1); try congruence; simpl.
      destruct (string_dec s1 s3); try congruence; simpl.
      destruct (string_dec s1 s2); try congruence; simpl.
      unfold lift; simpl.
      unfold omap_product, oncoll_map_concat; simpl.
      unfold edot; simpl.
      destruct (string_dec s1 s1); try congruence; simpl.
      unfold rremove; simpl.
      unfold rec_concat_sort; simpl.
      unfold string_eqdec.
      destruct (StringOrder.lt_dec s1 s2); try reflexivity; try congruence; simpl.
      destruct (string_dec s1 s1); try congruence; simpl.
      destruct (string_dec s1 s2); try congruence; simpl.

      assert (StringOrder.eq s1 s3) by (apply lt_contr1; assumption).
      congruence.
      assert (StringOrder.eq s1 s3) by (apply lt_contr1; assumption).
      congruence.
      unfold lift; simpl.
      unfold omap_product, oncoll_map_concat; simpl.
      unfold edot; simpl.
      unfold string_eqdec.
      destruct (string_dec s1 s1); try congruence; simpl.
      destruct (StringOrder.lt_dec s2 s3); try reflexivity; try congruence; simpl.
      destruct (StringOrder.lt_dec s1 s3); try reflexivity; try congruence; simpl.
      destruct (string_dec s1 s1); try congruence; simpl.
      destruct (string_dec s1 s3); try congruence; simpl.
      unfold rremove; simpl.
      unfold rec_concat_sort; simpl.
      unfold string_eqdec.
      destruct (StringOrder.lt_dec s3 s2); try reflexivity; try congruence; simpl.
      destruct (StringOrder.lt_dec s2 s3); try reflexivity; try congruence; simpl.
      destruct (StringOrder.lt_dec s2 s1); try reflexivity; try congruence; simpl.
      destruct (StringOrder.lt_dec s1 s2); try reflexivity; try congruence; simpl.
      destruct (string_dec s1 s1); try congruence; simpl.
      destruct (string_dec s1 s2); try congruence; simpl.
      destruct (string_dec s1 s3); try congruence; simpl.
      destruct (string_dec s1 s2); try congruence; simpl.
      destruct (StringOrder.lt_dec s1 s3); try reflexivity; try congruence; simpl.
      destruct (string_dec s1 s1); try congruence; simpl.
      destruct (string_dec s1 s3); try congruence; simpl.
      destruct (StringOrder.lt_dec s1 s2); try reflexivity; try congruence; simpl.
      destruct (string_dec s1 s1); try congruence; simpl.
      destruct (string_dec s1 s2); try congruence; simpl.
      destruct (string_dec s1 s3); try congruence; simpl.
      destruct (string_dec s1 s2); try congruence; simpl.
      destruct (string_dec s1 s3); try congruence; simpl.
      destruct (string_dec s1 s1); try congruence; simpl.
      assert (StringOrder.eq s1 s3) by (apply lt_contr1; assumption).
      congruence.
      assert (StringOrder.eq s2 s3) by (apply lt_contr1; assumption).
      congruence.
    - destruct o0; simpl; reflexivity.
  Qed.

  (* χ⟨ [ PBIND : ID.PBIND; PDATA : ID.PDATA.WORLD ].PDATA ⟩({ p })
     ≡ { [ PBIND : p.PBIND; PDATA: p.PDATA.WORLD ].PDATA } *)

  Lemma substitute_in_bindings (p:nra) :
    χ⟨ (‵[| ("PBIND", ID·"PBIND") |] ⊕ ‵[| ("PDATA", ID·"PDATA"·"WORLD") |])·"PDATA" ⟩( ‵{| p |} )
     ≡ₐ ‵{|(‵[| ("PBIND", p·"PBIND") |] ⊕ ‵[| ("PDATA", p·"PDATA"·"WORLD") |])·"PDATA" |}.
  Proof.
    unfold nra_eq, olift; intros ? ? _ ? _; simpl.
    generalize (h ⊢ p @ₐ x ⊣ c); simpl; intros; clear p x.
    destruct o; try reflexivity.
    destruct d; try reflexivity.
    unfold olift, lift; simpl.
    generalize (edot l "PBIND"); generalize (edot l "PDATA"); intros; clear l; simpl.
    destruct o; destruct o0; try reflexivity; simpl.
    generalize (match
                   match d with
                     | drec r => edot r "WORLD"
                     | _ => None
                   end
                 with
                   | Some x' => Some (drec (("PDATA"%string, x') :: nil))
        | None => None
        end
               ); intros; simpl.
    destruct (         match o with
         | Some (drec r2) =>
             Some
               (drec
                  (SortingAdd.insertion_sort_insert rec_field_lt_dec
                     ("PBIND"%string, d0) (rec_sort r2)))
         | _ => None
         end
             ); intros; simpl.
    destruct d1; try reflexivity.
    generalize (edot l "PDATA"); clear l; intros.
    destruct o0; try reflexivity; simpl.
    reflexivity.
  Qed.

  (* [ PBIND : ID.PBIND; PDATA : ID.PBIND ].PDATA ≡ₐ ID.PBIND *)

  Lemma dot_from_duplicate_bind_r :
    (‵[| ("PBIND", (NRAUnop (OpDot "PBIND") NRAID)) |] ⊕ ‵[| ("PDATA", (NRAUnop (OpDot "PBIND") NRAID)) |])·"PDATA" ≡ₐ (NRAUnop (OpDot "PBIND") NRAID).
  Proof.
    rewrite (dot_from_duplicate_r "PBIND" "PDATA" (NRAUnop (OpDot "PBIND") NRAID)).
    reflexivity.
  Qed.

  (* [ PBIND : ID.PBIND; PDATA : ID.PBIND ].PBIND ≡ₐ ID.PBIND *)

  Lemma dot_from_duplicate_bind_l :
    (‵[| ("PBIND", (NRAUnop (OpDot "PBIND") NRAID)) |] ⊕ ‵[| ("PDATA", (NRAUnop (OpDot "PBIND") NRAID)) |])·"PBIND" ≡ₐ (NRAUnop (OpDot "PBIND") NRAID).
  Proof.
    rewrite (dot_from_duplicate_l "PBIND" "PDATA" (NRAUnop (OpDot "PBIND") NRAID)).
    reflexivity.
  Qed.

  (* [ PBIND : ID·PBIND; PDATA : ID·PBIND·WORLD ]·PDATA ≡ ID·PBIND·WORLD *)

  Lemma dot_dot_from_duplicate_bind :
    (‵[| ("PBIND", ID·"PBIND") |] ⊕ ‵[| ("PDATA", ID·"PBIND"·"WORLD") |])·"PDATA"
     ≡ₐ ID·"PBIND"·"WORLD".
  Proof.
    unfold nra_eq; intros ? ? _ ? _; simpl.
    destruct x; try reflexivity; simpl.
    generalize (edot l "PBIND"); clear l; intros.
    destruct o; try reflexivity; simpl.
    destruct d; try reflexivity; simpl.
    generalize (edot l "WORLD"); intros; simpl.
    destruct o; reflexivity.
  Qed.

  (*   [ PBIND : ID.PBIND;
         a1 : χ⟨ [ PBIND : ID.PBIND; PDATA : ID.PDATA.e ].PDATA ⟩ (
                 { [ PBIND : ID.PBIND; PDATA : ID.PBIND ] }
                 ) ]
     ≡ₐ [ PBIND : ID.PBIND; a1 : { ID.PBIND.e } ].
   *)

  Lemma big_nested_bind_simplify_one :
    ‵[| ("PBIND", ID·"PBIND") |]
     ⊕ ‵[| ("a1",
            χ⟨(‵[| ("PBIND", ID·"PBIND") |] ⊕ ‵[| ("PDATA", ID·"PDATA"·"e") |])·"PDATA"
             ⟩( ‵{|‵[| ("PBIND", ID·"PBIND") |] ⊕ ‵[| ("PDATA", ID· "PBIND") |] |}))|]
     ≡ₐ ‵[| ("PBIND", ID·"PBIND") |] ⊕ ‵[| ("a1", ‵{| ID·"PBIND"·"e" |}) |].
  Proof.
    unfold nra_eq; intros ? ? _; simpl.
    destruct x; try reflexivity; simpl.
    generalize (edot l "PBIND"); intros.
    destruct o; try reflexivity; simpl.
    unfold olift2, olift; simpl.
    destruct d; try reflexivity; simpl.
    generalize (edot l0 "e"); intros.
    destruct o; try reflexivity; simpl.
  Qed.

End NRARewrite.


Require Import ProofWeb.

Parameter A B : Prop.

Theorem c0n001 : (A -> (B -> A)).
Proof.

imp_i h1.
imp_e A.
imp_i h2.
imp_i h3.
exact h1.
exact h1.

Qed.


(****************************************************************************

          IEEE754  :  Closest2Plus

          Laurent Thery

  ******************************************************************************)
Require Export ClosestPlus.
Require Export Closest2Prop.
Section F2.
Variable b : Fbound.
Variable precision : nat.

Let radix := 2%Z.

Let FtoRradix := FtoR radix.
Local Coercion FtoRradix : float >-> R.

Theorem TwoMoreThanOne : (1 < radix)%Z.
red in |- *; simpl in |- *; auto.
Qed.
Hint Resolve TwoMoreThanOne.
Hypothesis precisionNotZero : 1 < precision.
Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision.

Theorem plusUpperBound :
 forall P,
 RoundedModeP b 2%nat P ->
 forall p q pq : float,
 P (p + q)%R pq ->
 Fbounded b p ->
 Fbounded b q -> (Rabs pq <= radix * Rmax (Rabs p) (Rabs q))%R.
intros P H' p q pq H'0 H'1 H'2.
rewrite <- (Rabs_right radix); auto with real zarith.
rewrite <- RmaxRmult; auto with real.
repeat rewrite <- Rabs_mult.
case (Rle_or_lt p q); intros Rltp.
apply RmaxAbs; auto.
apply (RoundedModeMultLess b radix) with (P := P) (r := (p + q)%R); auto.
replace (radix * FtoR radix p)%R with (p + p)%R;
 [ auto with real | unfold radix at 1; fold FtoRradix; ring].
unfold FtoRradix in |- *;
 apply (RoundedModeMult b radix) with (P := P) (r := (p + q)%R);
 auto.
replace (radix * FtoR radix q)%R with (q + q)%R;
 [ auto with real | unfold radix at 1; fold FtoRradix; ring ].
rewrite RmaxSym.
apply RmaxAbs; auto.
apply (RoundedModeMultLess b radix) with (P := P) (r := (p + q)%R); auto.
replace (radix * FtoR radix q)%R with (q + q)%R;
 [ auto with real | unfold radix at 1; fold FtoRradix; ring ].
unfold FtoRradix in |- *;
 apply (RoundedModeMult b radix) with (P := P) (r := (p + q)%R);
 auto.
replace (radix * FtoR radix p)%R with (p + p)%R;
 [ auto with real zarith | unfold radix at 1; fold FtoRradix; ring].
Qed.

Theorem plusErrorBound2 :
 forall p q r : float,
 Fbounded b p ->
 Fbounded b q ->
 Closest b radix (p + q) r ->
 ~ is_Fzero r ->
 (Rabs (r - (p + q)) < radix * / pPred (vNum b) * Rmax (Rabs p) (Rabs q))%R.
intros p q r H' H'0 H'1 H'2.
apply
 Rlt_le_trans
  with (Rabs (FtoR radix r) * / radix * (radix * / pPred (vNum b)))%R;
 auto.
unfold FtoRradix in |- *; apply plusErrorBound1 with (precision := precision);
 auto with arith.
replace (Rabs (FtoR radix r) * / radix * (radix * / pPred (vNum b)))%R with
 (radix * / pPred (vNum b) * (Rabs r * / radix))%R;
 [ idtac | fold FtoRradix; ring ].
apply Rmult_le_compat_l; auto.
replace 0%R with (radix * 0)%R; [ apply Rmult_le_compat_l | ring ].
cut (0 <= radix)%Z; auto with real zarith.
apply Rlt_le; apply Rinv_0_lt_compat; cut (0 < pPred (vNum b))%Z;
 auto with real zarith.
unfold pPred in |- *; apply Zlt_succ_pred; simpl in |- *.
apply vNumbMoreThanOne with (radix := radix) (precision := precision);
 auto with real arith.
apply Rmult_le_reg_l with (r := IZR radix); auto with real.
rewrite (Rmult_comm (Rabs r)); rewrite <- Rmult_assoc; rewrite Rinv_r;
 auto with real zarith; rewrite Rmult_1_l.
apply plusUpperBound with (P := Closest b radix); auto.
apply ClosestRoundedModeP with (precision := precision); auto.
Qed.

Theorem plusClosestLowerBoundAux1 :
 forall p q pq : float,
 (Rabs q <= p)%R ->
 Closest b radix (p + q) pq ->
 Fbounded b p -> Fbounded b q -> pq <> (p + q)%R :>R -> (/ radix * p <= pq)%R.
intros p q pq H' H'0 H'1 H'2 H'3.
cut (0 <= p)%R;
 [ intros Rl0; Casec Rl0; intros H0
 | apply Rle_trans with (2 := H'); auto with real ].
apply (FmultRadixInv b radix precision) with (5 := H'0); auto.
case (Rle_or_lt 0 q); intros Rl0.
apply Rlt_le_trans with (FtoRradix p); auto.
apply Rlt_RinvDouble; auto.
pattern (FtoRradix p) at 1 in |- *; replace (FtoRradix p) with (p + 0)%R;
 auto with real.
apply Rmult_lt_reg_l with (r := IZR radix); auto with real.
rewrite <- Rmult_assoc; rewrite Rinv_r.
rewrite Rmult_plus_distr_l.
rewrite Rmult_1_l.
apply Rplus_lt_reg_l with (r := (- (radix * p))%R).
replace (- (radix * p) + FtoR radix p)%R with (- p)%R;
 [ idtac | unfold radix at 1; unfold FtoRradix; ring].
replace (- (radix * p) + (radix * p + radix * q))%R with (radix * q)%R;
 [ idtac | simpl in |- *; ring ].
rewrite <- (Ropp_involutive (radix * q)); apply Ropp_lt_contravar.
replace (- (radix * q))%R with (radix * - q)%R; [ idtac | ring ].
case (Rle_or_lt (FtoRradix p) (radix * - q)); auto.
intros H'4; Contradict H'3.
rewrite <- (Fplus_correct radix); auto.
unfold FtoRradix in |- *; apply sym_eq; apply ClosestIdem with (b := b); auto.
replace (Fplus radix p q) with (Fminus radix p (Fopp q)).
rewrite <- Fopp_Fminus.
apply oppBounded; auto.
apply Sterbenz; auto.
apply oppBounded; auto.
apply Rmult_le_reg_l with (r := IZR radix); auto with real.
rewrite <- Rmult_assoc; rewrite Rinv_r.
rewrite Rmult_1_l; rewrite Fopp_correct; auto.
replace 0%R with (INR 0); auto with real arith.
apply Rle_trans with (FtoR 2%nat p); auto with real.
rewrite Fopp_correct; auto.
rewrite <- Faux.Rabsolu_left1; auto.
apply Rlt_le; auto.
unfold Fminus in |- *; rewrite Fopp_Fopp; auto.
apply
 (ClosestCompatible b radix (p + q)%R (FtoR radix (Fplus radix p q)) pq pq);
 auto.
apply sym_eq; unfold FtoRradix in |- *; apply Fplus_correct; auto.
apply
 RoundedModeBounded
  with (radix := radix) (P := Closest b radix) (r := (p + q)%R);
 auto.
apply ClosestRoundedModeP with (precision := precision); auto.
replace 0%R with (INR 0); auto with real arith.
rewrite <- H0; rewrite Rmult_0_r.
replace (FtoRradix pq) with (FtoRradix p); auto.
rewrite <- H0; auto with real.
unfold FtoRradix in |- *; apply ClosestIdem with (b := b); auto.
apply (ClosestCompatible b radix (p + q)%R (FtoR radix p) pq pq); auto.
replace (FtoR 2%nat p) with (FtoRradix p); auto.
fold FtoRradix; rewrite <- H0; replace (FtoRradix q) with 0%R; try ring.
generalize H'; unfold Rabs in |- *; case (Rcase_abs q); auto.
intros H'4 H'5; Contradict H'5; rewrite <- H0; auto with real.
apply Rlt_not_le; auto with real.
intros H'4 H'5; apply Rle_antisym; auto with real.
rewrite H0; auto.
apply
 RoundedModeBounded
  with (radix := radix) (P := Closest b radix) (r := (p + q)%R);
 auto.
apply ClosestRoundedModeP with (precision := precision); auto.
Qed.

Theorem plusClosestLowerBoundAux2 :
 forall p q pq : float,
 Closest b radix (p + q) pq ->
 Fbounded b p ->
 Fbounded b q ->
 pq <> (p + q)%R :>R ->
 (Rabs p <= Rabs q)%R -> (/ radix * Rabs q <= Rabs pq)%R.
intros p q pq H' H'0 H'1 H'2 H'3.
cut (Fbounded b pq);
 [ intros Fb0
 | apply
    RoundedModeBounded
     with (radix := radix) (P := Closest b radix) (r := (p + q)%R);
    auto; apply ClosestRoundedModeP with (precision := precision) ];
 auto.
case (Rle_or_lt 0 q); intros Rl2;
 [ idtac | cut (q <= 0)%R; [ intros Rl2' | apply Rlt_le; auto ] ].
repeat rewrite Rabs_right; auto with real.
apply plusClosestLowerBoundAux1 with (q := p); auto.
rewrite <- (Rabs_right q); auto with real.
apply (ClosestCompatible b radix (p + q)%R (q + p)%R pq pq); auto; try ring.
rewrite Rplus_comm; auto with real.
apply Rle_ge; unfold FtoRradix in |- *;
 apply
  RleRoundedR0
   with
     (b := b)
     (precision := precision)
     (P := Closest b radix)
     (r := (p + q)%R); auto.
apply ClosestRoundedModeP with (precision := precision); auto.
case (Rle_or_lt 0 p); intros Rl3;
 [ idtac | cut (p <= 0)%R; [ intros Rl3' | apply Rlt_le; auto ] ];
 auto with real.
replace 0%R with (0 + 0)%R; auto with real.
apply Rplus_le_reg_l with (r := (- p)%R).
replace (- p + 0)%R with (- p)%R; [ idtac | ring ].
replace (- p + (p + q))%R with (FtoRradix q); [ idtac | ring ].
rewrite <- (Faux.Rabsolu_left1 (FtoRradix p)); auto with real.
rewrite <- (Rabs_right (FtoRradix q)); auto with real.
repeat rewrite Faux.Rabsolu_left1; auto with real.
unfold FtoRradix in |- *; repeat rewrite <- (Fopp_correct 2%nat); auto.
apply plusClosestLowerBoundAux1 with (q := Fopp p); auto.
unfold FtoRradix in |- *; repeat rewrite Fopp_correct; rewrite Rabs_Ropp;
 rewrite <- Faux.Rabsolu_left1; auto with real.
apply
 (ClosestCompatible b radix (- (p + q))%R (Fopp q + Fopp p)%R (
    Fopp pq) (Fopp pq)); auto.
apply ClosestOpp; auto.
unfold FtoRradix in |- *; repeat rewrite Fopp_correct; ring.
apply oppBounded; auto.
apply oppBounded; auto.
apply oppBounded; auto.
unfold FtoRradix in |- *; repeat rewrite Fopp_correct; Contradict H'2.
unfold FtoRradix in |- *; rewrite <- (Ropp_involutive (FtoR radix pq));
 rewrite H'2; ring.
unfold FtoRradix in |- *;
 apply
  RleRoundedLessR0
   with
     (b := b)
     (precision := precision)
     (P := Closest b radix)
     (r := (p + q)%R); auto.
apply ClosestRoundedModeP with (precision := precision); auto.
case (Rle_or_lt 0 p); intros Rl3;
 [ idtac | cut (p <= 0)%R; [ intros Rl3' | apply Rlt_le; auto ] ];
 auto with real.
apply Rplus_le_reg_l with (r := (- q)%R).
replace (- q + 0)%R with (- q)%R; [ idtac | ring ].
replace (- q + (p + q))%R with (FtoRradix p); [ idtac | ring ].
rewrite <- (Rabs_right (FtoRradix p)); auto with real.
rewrite <- (Rabs_left (FtoRradix q)); auto with real.
replace 0%R with (0 + 0)%R; auto with real.
Qed.

Theorem plusClosestLowerBound :
 forall p q pq : float,
 Closest b radix (p + q) pq ->
 Fbounded b p ->
 Fbounded b q ->
 pq <> (p + q)%R :>R -> (/ radix * Rmax (Rabs p) (Rabs q) <= Rabs pq)%R.
intros p q pq H' H'0 H'1 H'2.
cut (Fbounded b pq);
 [ intros Fb0
 | apply
    RoundedModeBounded
     with (radix := radix) (P := Closest b radix) (r := (p + q)%R);
    auto; apply ClosestRoundedModeP with (precision := precision) ];
 auto.
unfold Rmax in |- *.
case (Rle_dec (Rabs p) (Rabs q)); intros Rl1.
apply plusClosestLowerBoundAux2 with (p := p); auto.
apply plusClosestLowerBoundAux2 with (p := q); auto.
apply (ClosestCompatible b radix (p + q)%R (q + p)%R pq pq); auto; try ring.
rewrite Rplus_comm; auto.
case (Rle_or_lt (Rabs q) (Rabs p)); auto; intros H'3; Contradict Rl1;
 apply Rlt_le; auto.
Qed.
End F2.


(* Set Typeclasses Strict Resolution. *)
(* Set Typeclasses Unique Solutions. *)

Require Import UniDB.Spec.Core.
Require Import UniDB.Spec.Subst.
Require Import UniDB.Morph.Depth.
Require Import UniDB.Morph.Weaken.

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

Inductive Shift : Type :=
  shift (ξ : Depth Weaken).

Instance iLkShift {T : Type} {vrT : Vr T} : Lk T Shift :=
  fun ξ i => let (ξ') := ξ in vr T (lk Ix (Depth Weaken) ξ' i).

Instance iUpShift : Up Shift := fun ξ δ =>
  let (ξ') := ξ in shift (up (Depth Weaken) ξ' δ).

Instance iWkmShift : Wkm Shift := fun δ =>
  shift (wkm _ δ).

Instance iIdmWeaken : Idm Shift :=
  shift (idm _ ).

Instance iUpHomShift : UpHom Shift.
Proof.
  constructor; intro ξ; destruct ξ; cbn; intros;
    now rewrite ?up_suc, ?up_zero.
Qed.

Instance iLkRenWeaken {T : Type} {vrT : Vr T} : LkRen T Shift := {}.
Proof. intros; destruct ξ; auto. Qed.

Instance iLkWkmShift {T : Type} {vrT : Vr T} : LkWkm T Shift := {}.
Proof.
  intros; apply (f_equal (vr T)).
  rewrite lk_wkm.
  reflexivity.
Qed.

Instance iLkUpShift {T : Type} `{WkVr T} : LkUp T Shift.
Proof.
  apply make_lkup_inst_ren; intro ξ; destruct ξ; cbn; intros;
    repeat change (up ?Ξ ?ξ 1) with (up₁ Ξ ξ);
    now rewrite ?lk_up₁_zero, ?lk_up₁_suc.
Qed.

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


Require Import ZArith.
Require Import Lia.
Require Import List.
Import ListNotations.
Require Import LibTactics.

Require Import Instr Memory.
Require Import Lattices.
Require Import Concrete.
Require Import CodeGen.
Require Import CodeSpecs.
Require Import CodeTriples.

Local Open Scope Z_scope.

Section fix_cblock.

Variable cblock : block privilege.
Variable stamp_cblock : Mem.stamp cblock = Kernel.
Variable table : CSysTable.

(* Lattice-dependent parameters *)
Class ConcreteLattice (T: Type) :=
{ labToVal :  T -> val privilege -> memory -> Prop
; valToLab :  val privilege -> memory -> T
; genBot : list Instr
; genJoin : list Instr
; genFlows : list Instr
}.

Local Open Scope Z_scope.

Instance TMUHL : ConcreteLattice Lab :=
{
  labToVal l z m :=
    match l with
      | L => Vint (boolToZ false) = z
      | H => Vint (boolToZ true) = z
    end

  ;valToLab z m :=
    match z with
      | Vint 0 => L
      | _ => H
    end

  ;genBot := genFalse

  ;genJoin := genOr

  ;genFlows := genImpl
}.

Definition mem_def_on_cache (m : memory) : Prop :=
  exists fr, Mem.get_frame m cblock = Some fr.

Lemma extends_mem_def_on_cache : forall m m',
                                   mem_def_on_cache m ->
                                   extends m m' ->
                                   mem_def_on_cache m'.
Proof.
  intros m m' H EXT.
  destruct H.
  econstructor; apply EXT; eauto.
Qed.

Inductive mem_eq_except_cache (m m' : memory) : Prop :=
| meec_intro :
    mem_def_on_cache m ->
    kernel_memory_extension cblock m m' ->
    mem_eq_except_cache m m'.

Class WfConcreteLattice (T: Type) (L : JoinSemiLattice T) (CL: ConcreteLattice T) :=
{ labToVal_cache : forall l z m m', labToVal l z m -> mem_eq_except_cache m m' -> labToVal l z m'
; labToVal_inj : forall l1 l2 z m, labToVal l1 z m -> labToVal l2 z m -> l1 = l2
; labToVal_valToLab_id : forall l z m, labToVal l z m -> valToLab z m = l
; labToVal_extension_comp : forall m1 m2 l z,  labToVal l z m1 -> extends m1 m2 ->
                                             mem_def_on_cache m1 ->
                                             labToVal l z m2
; genBot_spec: forall m0 (Hm0: mem_def_on_cache m0) (Q:memory->stack->Prop),
   HT cblock table genBot
      (fun m s => extends m0 m /\
                  (forall m1 z t, extends m m1 -> labToVal bot z m1 -> Q m1 ((z,t):::s)))
      Q
; genJoin_spec:
    forall m0 (Hm0: mem_def_on_cache m0) (Q: memory-> stack->Prop),
       HT cblock table genJoin
         (fun m s =>
          exists s0 l z t l' z' t',
             s = (z, t) ::: (z', t') ::: s0 /\
             extends m0 m /\
             labToVal l z m /\ labToVal l' z' m /\
             (forall m1 zz' t, extends m m1 -> labToVal (l \_/ l') zz' m1 ->
                         Q m1 ((zz', t) ::: s0)))
         Q

  (* NC: we could discharge this by implementing [genFlows] in terms of
   [genJoin], and using the fact that [flows l l' = true <-> join l l' = l']. *)
; genFlows_spec: forall m0 (Hm0: mem_def_on_cache m0) (Q: memory -> stack -> Prop),
                   HT  cblock table genFlows
                       (fun m s =>
                          exists l l' z z' t t' s0,
                            extends m0 m /\
                            labToVal l z m /\ labToVal l' z' m /\
                            s = (z,t):::(z',t'):::s0 /\
                            forall t'',
                              Q m ((Vint (boolToZ(flows l l')),t''):::s0))
                       Q
}.

Section Spec_alt.

Context {T: Type}
        {Latt: JoinSemiLattice T}
        {CLatt: ConcreteLattice T}
        {WfCLatt: WfConcreteLattice T Latt CLatt}.

Lemma genBot_spec': forall I m0 (Hm0: mem_def_on_cache m0)
                      (Hext: extension_comp I),
                 HT cblock table genBot
                    (fun m s => extends m0 m /\ I m s)
                    (fun m s =>
                       match s with
                           | CData (z,t)::tl => extends m0 m /\
                             I m tl /\ labToVal bot z m
                           | _ => False
                       end).
Proof.
  intros.
  eapply HT_strengthen_premise.
  eapply genBot_spec with (m1 := m0); eauto.
  intros. simpl.
  destruct H.
  intuition eauto.
  unfold extends; eauto.
Qed.

Lemma genJoin_spec': forall l l' I m0 (Hmem0: mem_def_on_cache m0)
                       (Hext: extension_comp I),
                  HT  cblock table genJoin
                      (fun m s =>
                         match s with
                             | CData (z,t)::CData (z',t')::tl =>
                               labToVal l z m /\ labToVal l' z' m /\
                               extends m0 m /\ I m tl
                             | _ => False
                         end)
                      (fun m s =>
                         match s with
                             | CData (zz', t) :: tl =>
                               labToVal (join l l') zz' m /\
                               extends m0 m /\ I m tl
                             | _ => False
                         end).
Proof.
  intros.
  eapply HT_strengthen_premise.
  eapply genJoin_spec; eauto.
  go_match. do 7 eexists; intuition; eauto.
  unfold extends; eauto.
Qed.

Lemma genFlows_spec' : forall l l' I m0 (Hmem0: mem_def_on_cache m0)
                        (Hext: extension_comp I),
                   HT  cblock table genFlows
                       (fun m s =>
                          match s with
                            | CData (z,t)::CData (z',t')::tl =>
                              labToVal l z m /\ labToVal l' z' m /\
                              extends m0 m /\ I m tl
                            | _ => False
                          end)
                       (fun m s =>
                          match s with
                            | CData (Vint z, t) :: tl =>
                              boolToZ (flows l l') = z /\
                              extends m0 m /\ I m tl
                            | _ => False
                          end).
Proof.
  intros.
  eapply HT_strengthen_premise.
  eapply genFlows_spec; eauto.
  go_match. do 7 eexists; intuition; eauto.
Qed.

Section Glue.

Import Vector.VectorNotations.

Local Open Scope nat_scope.

Definition nth_labToVal {n:nat} (vls: Vector.t T n) (s:nat) : val privilege -> memory -> Prop :=
  fun z m =>
    match le_lt_dec n s with
      | left _ => z = dontCare
      | right p => labToVal (Vector.nth_order vls p) z m
  end.

Lemma of_nat_lt_proof_irrel:
  forall (m n: nat) (p q: m < n),
    Fin.of_nat_lt p = Fin.of_nat_lt q.
Proof.
  induction m; intros.
    destruct n.
      false; lia.
      reflexivity.
    destruct n.
      false; lia.
      simpl; erewrite IHm; eauto.
Qed.

(* NC: this took a few tries ... *)
Lemma nth_order_proof_irrel:
  forall (m n: nat) (v: Vector.t T n) (p q: m < n),
    Vector.nth_order v p = Vector.nth_order v q.
Proof.
  intros.
  unfold Vector.nth_order.
  erewrite of_nat_lt_proof_irrel; eauto.
Qed.

Lemma nth_order_valid: forall (n:nat) (vls: Vector.t T n) m,
  forall (lt: m < n),
  nth_labToVal vls m = labToVal (Vector.nth_order vls lt).
Proof.
  intros.
  unfold nth_labToVal.
  destruct (le_lt_dec n m).
  false; lia.
  (* NC: Interesting: here we have two different proofs [m < n0] being
  used as arguments to [nth_order], and we need to know that the
  result of [nth_order] is the same in both cases.  I.e., we need
  proof irrelevance! *)
  erewrite nth_order_proof_irrel; eauto.
Qed.

Definition labsToVals {n:nat} (vls :Vector.t T n) (m: memory) :
  (val privilege * val privilege * val privilege) -> Prop :=
fun z0z1z2 =>
  let '(z0,z1,z2) := z0z1z2 in
  nth_labToVal vls 0 z0 m /\
  nth_labToVal vls 1 z1 m /\
  nth_labToVal vls 2 z2 m.

Lemma extension_comp_nth_labToVal : forall m1 m2 (n m:nat) (vls: Vector.t T n) z,
    nth_labToVal vls m z m1 ->
    extends m1 m2 ->
    mem_def_on_cache m1 ->
    nth_labToVal vls m z m2.
Proof.
  unfold nth_labToVal; intros.
  destruct (le_lt_dec n m); eauto.
  eapply labToVal_extension_comp; eauto.
Qed.

Lemma labsToVals_extension_comp :
  forall m1 m2 n (vls : Vector.t _ n) ts
         (Hvls : labsToVals vls m1 ts)
         (EXT : extends m1 m2)
         (DEF : mem_def_on_cache m1),
    labsToVals vls m2 ts.
Proof.
  unfold labsToVals.
  intros m1 m2 n vls [[t1 t2] t3].
  intuition;
  eapply extension_comp_nth_labToVal; eauto.
Qed.
Hint Resolve labsToVals_extension_comp : core.

Lemma labsToVals_cache :
  forall m1 m2 n (vls : Vector.t _ n) ts
         (Hvls : labsToVals vls m1 ts)
         (EQ : mem_eq_except_cache m1 m2),
  labsToVals vls m2 ts.
Proof.
  unfold labsToVals, nth_labToVal.
  intros.
  destruct ts as [[t1 t2] t3].
  destruct Hvls as (H1 & H2 & H3).
  repeat split;
  repeat match goal with
           | H : context[le_lt_dec n ?m] |- context[le_lt_dec n ?m] =>
             destruct (le_lt_dec n m); trivial
         end;
  eauto using labToVal_cache.
Qed.
Hint Resolve labsToVals_cache : core.

End Glue.

End Spec_alt.

End fix_cblock.


From Coq Require Import
  Ascii
  Decimal
  Lia
  List
  String.
From FunProofs.Lib Require Import
  Tactics.
Import ListNotations.

Open Scope string.

Fixpoint tostr' (n : uint) : string :=
  match n with
  | Nil => EmptyString
  | D0 n' => String "0" (tostr' n')
  | D1 n' => String "1" (tostr' n')
  | D2 n' => String "2" (tostr' n')
  | D3 n' => String "3" (tostr' n')
  | D4 n' => String "4" (tostr' n')
  | D5 n' => String "5" (tostr' n')
  | D6 n' => String "6" (tostr' n')
  | D7 n' => String "7" (tostr' n')
  | D8 n' => String "8" (tostr' n')
  | D9 n' => String "9" (tostr' n')
  end%char.
Definition tostr (n : nat) : string := tostr' (Nat.to_uint n).

Definition digits := ["0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"]%char.

Lemma to_little_uint_not_nil n : forall acc,
  acc <> Nil -> Nat.to_little_uint n acc <> Nil.
Proof.
  induction n; cbn; intros; auto.
  apply IHn; now destruct acc.
Qed.

Lemma revapp_not_nil n : forall m, n <> Nil \/ m <> Nil -> revapp n m <> Nil.
Proof. induction n; cbn; intros; try apply IHn; intuition easy. Qed.

Corollary to_uint_not_nil n : Nat.to_uint n <> Nil.
Proof. now apply revapp_not_nil; left; apply to_little_uint_not_nil. Qed.

Lemma tostr'_length_pos n : n <> Nil -> 0 < String.length (tostr' n).
Proof. induction n; cbn; intros; solve [easy | lia]. Qed.

Corollary tostr_length_pos n : 0 < String.length (tostr n).
Proof. apply tostr'_length_pos, to_uint_not_nil. Qed.

#[local] Definition digits' := Eval cbn in map Some digits.

Lemma tostr'_all_digits n (s := tostr' n) : forall m,
  m < String.length s -> In (get m s) digits'.
Proof.
  subst s; induction n; cbn; intros;
    solve [easy | destruct m; [intuition auto | apply IHn; lia]].
Qed.

Corollary tostr_all_digits n (s := tostr n) : forall m,
  m < String.length s -> In (get m s) digits'.
Proof. apply tostr'_all_digits. Qed.

Corollary tostr_hd_digits n (s := tostr n) : In (get 0 s) digits'.
Proof. apply tostr_all_digits, tostr_length_pos. Qed.