(* *********************************************************************)
(*                                                                     *)
(*              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       *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Constructions of semi-lattices. *)

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

(* To avoid useless definitions of inductors in extracted code. *)
Local Unset Elimination Schemes.
Local Unset Case Analysis Schemes.

(** * 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.
  rewrite PTree.beq_correct in H. generalize (H p).
  destruct (t0!p); destruct (t1!p); intuition.
  apply L.beq_correct; auto.
  apply L.eq_refl.
  red; intro; simpl.
  rewrite PTree.beq_correct in H. generalize (H p).
  destruct (t0!p); destruct (t1!p); intuition.
  apply L.beq_correct; auto.
  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.

(** * Option semi-lattice *)

(** This lattice adds a top element (represented by [None]) to a given
  semi-lattice (whose elements are injected via [Some]). *)

Module LOption(L: SEMILATTICE) <: SEMILATTICE_WITH_TOP.

Definition t: Type := option L.t.

Definition eq (x y: t) : Prop :=
  match x, y with
  | None, None => True
  | Some x1, Some y1 => L.eq x1 y1
  | _, _ => False
  end.

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

Lemma eq_sym: forall x y, eq x y -> eq y x.
Proof.
  unfold eq; intros; destruct x; destruct y; auto. 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; destruct x; destruct y; destruct z; auto.
  eapply L.eq_trans; eauto.
  contradiction.
Qed.

Definition beq (x y: t) : bool :=
  match x, y with
  | None, None => true
  | Some x1, Some y1 => L.beq x1 y1
  | _, _ => false
  end.

Lemma beq_correct: forall x y, beq x y = true -> eq x y.
Proof.
  unfold beq, eq; intros; destruct x; destruct y.
  apply L.beq_correct; auto.
  discriminate. discriminate. auto.
Qed.

Definition ge (x y: t) : Prop :=
  match x, y with
  | None, _ => True
  | _, None => False
  | Some x1, Some y1 => L.ge x1 y1
  end.

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

Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
Proof.
  unfold ge; intros; destruct x; destruct y; destruct z; auto.
  eapply L.ge_trans; eauto. contradiction.
Qed.

Definition bot : t := Some L.bot.

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

Definition lub (x y: t) : t :=
  match x, y with
  | None, _ => None
  | _, None => None
  | Some x1, Some y1 => Some (L.lub x1 y1)
  end.

Lemma ge_lub_left: forall x y, ge (lub x y) x.
Proof.
  unfold ge, lub; intros; destruct x; destruct y; auto. apply L.ge_lub_left.
Qed.

Lemma ge_lub_right: forall x y, ge (lub x y) y.
Proof.
  unfold ge, lub; intros; destruct x; destruct y; auto. apply L.ge_lub_right.
Qed.

Definition top : t := None.

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

End LOption.


(* ************************************************************************** *)
(** * Basic tactics *)
(* ************************************************************************** *)

(** This file collects a number of basic tactics for better proof automation,
    structuring large proofs, or rewriting.  Many of the definitions have been
    ported from ss-reflect. *)

(** Symbols starting with [hahn__] are internal. *)

Require Import Bool Arith ZArith String.
Require ClassicalFacts.
Require Export ClassicalDescription FunctionalExtensionality.

Open Scope bool_scope.
Open Scope list_scope.

Set Implicit Arguments.
Unset Strict Implicit.

(** Set up hint databases *)
Create HintDb hahn discriminated.      (* General stuff, used by done *)
Create HintDb hahn_refl discriminated. (* Decidable equalities *)
Create HintDb hahn_full discriminated. (* Expensive lemmas *)

(** Shorthand for applying functional extensionality. *)

Ltac exten := apply functional_extensionality.

(* ************************************************************************** *)
(** ** Coersion of [bool] into [Prop] *)
(* ************************************************************************** *)

(** Coersion of bools into Prop *)
Coercion is_true (b : bool) : Prop := b = true.

(** Hints for auto *)
Lemma hahn__true_is_true : true.
Proof. reflexivity. Qed.

Lemma hahn__not_false_is_true : ~ false.
Proof. discriminate. Qed.

Hint Resolve hahn__true_is_true hahn__not_false_is_true.

(* ************************************************************************** *)
(** ** Very basic automation *)
(* ************************************************************************** *)

(** Set up for basic simplification *)

(** Adaptation of the ss-reflect "[done]" tactic. *)

Ltac hahn__basic_done :=
  solve [trivial with hahn | simple apply sym_equal; trivial | discriminate | contradiction].

Ltac done := trivial with hahn; hnf; intros;
  solve [try hahn__basic_done; split;
         try hahn__basic_done; split;
         try hahn__basic_done; split;
         try hahn__basic_done; split;
         try hahn__basic_done; split; hahn__basic_done
    | match goal with H : ~ _ |- _ => solve [case H; trivial] end].

(** A variant of the ssr "done" tactic that performs "eassumption". *)

Ltac edone := try eassumption; trivial; hnf; intros;
  solve [try eassumption; try hahn__basic_done; split;
         try eassumption; try hahn__basic_done; split;
         try eassumption; try hahn__basic_done; split;
         try eassumption; try hahn__basic_done; split;
         try eassumption; try hahn__basic_done; split;
         try eassumption; hahn__basic_done
    | match goal with H : ~ _ |- _ => solve [case H; trivial] end].

Tactic Notation "by"  tactic(tac) := (tac; done).
Tactic Notation "eby" tactic(tac) := (tac; edone).

(* ************************************************************************** *)
(** ** Equality types *)
(* ************************************************************************** *)

Module Equality.

  Definition axiom T (e : T -> T -> bool) :=
    forall x y, reflect (x = y) (e x y).

  Structure mixin_of T := Mixin {op : T -> T -> bool; _ : axiom op}.
  Notation class_of := mixin_of (only parsing).

  Section ClassDef.

    Structure type := Pack {sort; _ : class_of sort; _ : Type}.

    Definition class cT' :=
      match cT' return class_of (sort cT') with @Pack _ c _ => c end.

    Definition pack (T: Type) c := @Pack T c T.

  End ClassDef.

  Module Exports.
    Coercion sort : type >-> Sortclass.
    Notation eqType := type.
    Notation EqMixin := Mixin.
    Notation EqType T m := (@pack T m).
  End Exports.

End Equality.
Export Equality.Exports.

Definition eq_op T := Equality.op (Equality.class T).
Arguments eq_op {T}.

Lemma eqE : forall T x, eq_op x = Equality.op (Equality.class T) x.
Proof. done. Qed.

Lemma eqP : forall T, Equality.axiom (@eq_op T).
Proof. by unfold eq_op; destruct T as [? []]. Qed.
Arguments eqP [T] x y.

(*
Notation "x == y" := (eq_op x y)
  (at level 70, no associativity) : bool_scope.
Notation "x == y :> T" := ((x : T) == (y : T))
  (at level 70, y at next level) : bool_scope.
Notation "x != y" := (negb (x == y))
  (at level 70, no associativity) : bool_scope.
Notation "x != y :> T" := (negb (x == y :> T))
  (at level 70, y at next level) : bool_scope.
*)

Lemma hahn__internal_eqP :
  forall (T: eqType) (x y : T), reflect (x = y) (eq_op x y).
Proof. apply eqP. Qed.

Lemma neqP : forall (T: eqType) (x y: T), reflect (x <> y) (negb (eq_op x y)).
Proof. intros; case eqP; constructor; auto. Qed.

Lemma beq_refl : forall (T : eqType) (x : T), eq_op x x.
Proof. by intros; case eqP. Qed.

Lemma beq_sym : forall (T : eqType) (x y : T), (eq_op x y) = (eq_op y x).
Proof. intros; do 2 case eqP; congruence. Qed.

Hint Resolve beq_refl : hahn.
Hint Rewrite beq_refl : hahn_trivial.

Notation eqxx := beq_refl.

(** Comparison for [nat] *)

Fixpoint eqn_rec (x y: nat) {struct x} :=
   match x, y with
     | O, O => true
     | S x, S y => eqn_rec x y
     | _, _ => false
   end.

Definition eqn := match tt with tt => eqn_rec end.

Lemma eqnP: forall x y, reflect (x = y) (eqn x y).
Proof.
  induction x; destruct y; try (constructor; done).
  change (eqn (S x) (S y)) with (eqn x y).
  case IHx; constructor; congruence.
Qed.

Canonical Structure nat_eqMixin := EqMixin eqnP.
Canonical Structure nat_eqType := Eval hnf in EqType nat nat_eqMixin.

Lemma eqnE : eqn = (@eq_op _).
Proof. done. Qed.

(* ************************************************************************** *)
(** ** Basic simplification tactics *)
(* ************************************************************************** *)

Lemma hahn__negb_rewrite : forall b, negb b -> b = false.
Proof. by intros []. Qed.

Lemma hahn__andb_split : forall b1 b2, b1 && b2 -> b1 /\ b2.
Proof. by intros [] []. Qed.

Lemma hahn__nandb_split : forall b1 b2, b1 && b2 = false -> b1 = false \/ b2 = false.
Proof. intros [] []; auto. Qed.

Lemma hahn__orb_split : forall b1 b2, b1 || b2 -> b1 \/ b2.
Proof. intros [] []; auto. Qed.

Lemma hahn__norb_split : forall b1 b2, b1 || b2 = false -> b1 = false /\ b2 = false.
Proof. intros [] []; auto. Qed.

Lemma hahn__eqb_split : forall b1 b2 : bool, (b1 -> b2) -> (b2 -> b1) -> b1 = b2.
Proof. intros [] [] H H'; unfold is_true in *; auto using sym_eq. Qed.

Lemma hahn__beq_rewrite : forall (T : eqType) (x1 x2 : T), eq_op x1 x2 -> x1 = x2.
Proof. by intros *; case eqP. Qed.

(** Set up for basic simplification: database of reflection lemmas *)

Hint Resolve hahn__internal_eqP neqP : hahn_refl.

Ltac hahn__complaining_inj f H :=
  let X := fresh in
  (match goal with | [|- ?P ] => set (X := P) end);
  injection H; clear H; intros; subst X;
  try subst.

Ltac hahn__clarify1 :=
  try subst;
  repeat match goal with
  | [H: is_true (andb _ _) |- _] =>
      let H' := fresh H in case (hahn__andb_split H); clear H; intros H' H
  | [H: is_true (negb ?x) |- _] => rewrite (hahn__negb_rewrite H) in *
  | [H: is_true ?x        |- _] => rewrite H in *
  | [H: ?x = true         |- _] => rewrite H in *
  | [H: ?x = false        |- _] => rewrite H in *
  | [H: is_true (eq_op _ _)  |- _] => generalize (hahn__beq_rewrite H); clear H; intro H
  | [H: @existT _ _ _ _ = @existT _ _ _ _ |- _] => apply inj_pair2 in H; try subst
  | [H: ?f _             = ?f _             |- _] => hahn__complaining_inj f H
  | [H: ?f _ _           = ?f _ _           |- _] => hahn__complaining_inj f H
  | [H: ?f _ _ _         = ?f _ _ _         |- _] => hahn__complaining_inj f H
  | [H: ?f _ _ _ _       = ?f _ _ _ _       |- _] => hahn__complaining_inj f H
  | [H: ?f _ _ _ _ _     = ?f _ _ _ _ _     |- _] => hahn__complaining_inj f H
  | [H: ?f _ _ _ _ _ _   = ?f _ _ _ _ _ _   |- _] => hahn__complaining_inj f H
  | [H: ?f _ _ _ _ _ _ _ = ?f _ _ _ _ _ _ _ |- _] => hahn__complaining_inj f H
  end; try done.

(** Perform injections & discriminations on all hypotheses *)

Ltac clarify :=
  hahn__clarify1;
  repeat match goal with
    | H1: ?x = Some _, H2: ?x = None   |- _ => rewrite H2 in H1; discriminate
    | H1: ?x = Some _, H2: ?x = Some _ |- _ => rewrite H2 in H1; hahn__clarify1
  end; (* autorewrite with hahn_trivial; *) try done.

(** Kill simple goals that require up to two econstructor calls. *)

Ltac vauto :=
  (clarify; try edone;
   try [> econstructor; (solve [edone | [> econstructor; edone]])]).

Ltac inv x := inversion x; clarify.
Ltac simpls  := simpl in *; try done.
Ltac ins := simpl in *; try done; intros.

Ltac hahn__clarsimp1 :=
  clarify; (autorewrite with hahn_trivial hahn in * );
  (autorewrite with hahn_trivial in * ); try done;
  clarify; auto 1 with hahn.

Ltac clarsimp := intros; simpl in *; hahn__clarsimp1.

Ltac autos   := clarsimp; auto with hahn.

Tactic Notation "econs" := econstructor.
Tactic Notation "econs" int_or_var(x) := econstructor x.

(* ************************************************************************** *)
(** Destruct but give useful names *)
(* ************************************************************************** *)

Definition  NW (P: unit -> Prop) : Prop := P tt.

Notation "\u27ea x : t \u27eb" := (NW (fun x => t)) (at level 80, x ident, no associativity).
Notation "<< x : t >>" := (NW (fun x => t))
  (at level 80, x ident, no associativity, only parsing).
Notation "\u27ea t \u27eb" := (NW (fun _ => t)) (at level 79, no associativity, format "\u27ea t \u27eb").

Ltac unnw := unfold NW in *.
Ltac rednw := red; unnw.

Hint Unfold NW.

Ltac splits :=
  intros; unfold NW;
  repeat match goal with
  | [ |- _ /\ _ ] => split
  end.

Ltac esplits :=
  intros; unfold NW;
  repeat match goal with
  | [ |- @ex _ _ ] => eexists
  | [ |- _ /\ _ ] => split
  | [ |- @sig _ _ ] => eexists
  | [ |- @sigT _ _ ] => eexists
  | [ |- @prod _  _ ] => split
  end.

(** Destruct, but no case split *)
Ltac desc :=
  repeat match goal with
    | H: is_true (eq_op _ _) |- _ => generalize (hahn__beq_rewrite H); clear H; intro H
    | H : exists x, NW (fun y => _) |- _ =>
      let x' := fresh x in let y' := fresh y in destruct H as [x' y']; red in y'
    | H : exists x, ?p |- _ =>
      let x' := fresh x in destruct H as [x' H]
    | H : ?p /\ ?q |- _ =>
      let x' := match p with | NW (fun z => _) => fresh z | _ => H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in
      destruct H as [x' y'];
      match p with | NW _ => red in x' | _ => idtac end;
      match q with | NW _ => red in y' | _ => idtac end
    | H : is_true (_ && _) |- _ =>
          let H' := fresh H in case (hahn__andb_split H); clear H; intros H H'
    | H : (_ || _) = false |- _ =>
          let H' := fresh H in case (hahn__norb_split H); clear H; intros H H'
    | H : ?x = ?x   |- _ => clear H

(*    | H: is_true ?x |- _ => eapply elimT in H; [|solve [trivial with hahn_refl]]
    | H: ?x = true  |- _ => eapply elimT in H; [|solve [trivial with hahn_refl]]
    | H: ?x = false |- _ => eapply elimFn in H; [|solve [trivial with hahn_refl]]
    | H: ?x = false |- _ => eapply elimF in H; [|solve [trivial with hahn_refl]]  *)
  end.

Ltac des :=
  repeat match goal with
    | H: is_true (eq_op _ _) |- _ => generalize (hahn__beq_rewrite H); clear H; intro H
    | H : exists x, NW (fun y => _) |- _ =>
      let x' := fresh x in let y' := fresh y in destruct H as [x' y']; red in y'
    | H : exists x, ?p |- _ =>
      let x' := fresh x in destruct H as [x' H]
    | H : ?p /\ ?q |- _ =>
      let x' := match p with | NW (fun z => _) => fresh z | _ => H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in
      destruct H as [x' y'];
      match p with | NW _ => red in x' | _ => idtac end;
      match q with | NW _ => red in y' | _ => idtac end
    | H : is_true (_ && _) |- _ =>
        let H' := fresh H in case (hahn__andb_split H); clear H; intros H H'
    | H : (_ || _) = false |- _ =>
        let H' := fresh H in case (hahn__norb_split H); clear H; intros H H'
    | H : ?x = ?x |- _ => clear H
    | H : ?p <-> ?q |- _ =>
      let x' := match p with | NW (fun z => _) => fresh z | _ => H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in
      destruct H as [x' y'];
      match p with | NW _ => unfold NW at 1 in x'; red in y' | _ => idtac end;
      match q with | NW _ => unfold NW at 1 in y'; red in x' | _ => idtac end
    | H : ?p \/ ?q |- _ =>
      let x' := match p with | NW (fun z => _) => fresh z | _ => H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => H end in
      destruct H as [x' | y'];
      [ match p with | NW _ => red in x' | _ => idtac end
      | match q with | NW _ => red in y' | _ => idtac end]
    | H : is_true (_ || _) |- _ => case (hahn__orb_split H); clear H; intro H
    | H : (_ && _) = false |- _ => case (hahn__nandb_split H); clear H; intro H
  end.

Ltac cdes H :=
  let H' := fresh H in assert (H' := H); red in H'; desc.

Ltac des_if_asm :=
  clarify;
  repeat
    match goal with
      | H: context[ match ?x with _ => _ end ] |- _ =>
        match (type of x) with
          | { _ } + { _ } => destruct x; clarify
          | bool =>
            let Heq := fresh "Heq" in
            let P := fresh in
            evar(P: Prop);
            assert (Heq: reflect P x) by (subst P; trivial with hahn_refl);
            subst P; destruct Heq as [Heq|Heq]
          | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify
        end
    end.

Ltac des_if_goal :=
  clarify;
  repeat
    match goal with
      | |- context[match ?x with _ => _ end] =>
        match (type of x) with
          | { _ } + { _ } => destruct x; clarify
          | bool =>
            let Heq := fresh "Heq" in
            let P := fresh in
            evar(P: Prop);
            assert (Heq: reflect P x) by (subst P; trivial with hahn_refl);
            subst P; destruct Heq as [Heq|Heq]
          | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify
        end
    end.

Ltac des_if :=
  clarify;
  repeat
    match goal with
      | |- context[match ?x with _ => _ end] =>
        match (type of x) with
          | { _ } + { _ } => destruct x; clarify
          | bool =>
            let Heq := fresh "Heq" in
            let P := fresh in
            evar(P: Prop);
            assert (Heq: reflect P x) by (subst P; trivial with hahn_refl);
            subst P; destruct Heq as [Heq|Heq]
          | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify
        end
      | H: context[ match ?x with _ => _ end ] |- _ =>
        match (type of x) with
          | { _ } + { _ } => destruct x; clarify
          | bool =>
            let Heq := fresh "Heq" in
            let P := fresh in
            evar(P: Prop);
            assert (Heq: reflect P x) by (subst P; trivial with hahn_refl);
            subst P; destruct Heq as [Heq|Heq]
          | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify
        end
    end.

Ltac des_eqrefl :=
  match goal with
    | H: context[match ?X with _ => _ end Logic.eq_refl] |- _ =>
    let EQ := fresh "EQ" in
    let id' := fresh "x" in
    revert H;
    generalize (Logic.eq_refl X); generalize X at 1 3;
    intros id' EQ; destruct id'; intros H
    | |- context[match ?X with _ => _ end Logic.eq_refl] =>
    let EQ := fresh "EQ" in
    let id' := fresh "x" in
    generalize (Logic.eq_refl X); generalize X at 1 3;
    intros id' EQ; destruct id'
  end.

Ltac desf_asm := clarify; des; des_if_asm.

Ltac desf := clarify; des; des_if.

Ltac clarassoc := clarsimp; autorewrite with hahn_trivial hahn hahnA in *; try done.

Ltac hahn__hacksimp1 :=
   clarsimp;
   match goal with
     | H: _ |- _ => solve [rewrite H; clear H; clarsimp
                         |rewrite <- H; clear H; clarsimp]
     | _ => solve [f_equal; clarsimp]
   end.

Ltac hacksimp :=
   clarsimp;
   try match goal with
   | H: _ |- _ => solve [rewrite H; clear H; clarsimp
                              |rewrite <- H; clear H; clarsimp]
   | |- context[match ?p with _ => _ end] => solve [destruct p; hahn__hacksimp1]
   | _ => solve [f_equal; clarsimp]
   end.

Ltac clarify_not :=
  repeat (match goal with
  | H : ~ False |- _ => clear H
  | H : ~ ~ _ |- _ => apply NNPP in H
  | H : ~ _ |- _ => apply imply_to_and in H; desc
  | H : ~ _ |- _ => apply not_or_and in H; desc
  | H : ~ _ |- _ => apply not_and_or in H; des
  | H : ~ _ |- _ => apply not_all_ex_not in H; desc
  end; clarify).

Tactic Notation "tertium_non_datur" constr(P) :=
  destruct (classic P); clarify_not.

Tactic Notation "tertium_non_datur" constr(P) "as" simple_intropattern(pattern) :=
  destruct (classic P) as pattern; clarify_not.

(* ************************************************************************** *)
(** ** Unification helpers *)
(* ************************************************************************** *)

Tactic Notation "pattern_lhs" uconstr(term) :=
  match goal with
    |- _ ?lhs _ =>
    let P := fresh in
    pose (P := lhs); pattern term in P; change lhs with P; subst P
  end.

Tactic Notation "pattern_rhs" uconstr(term) :=
  match goal with
    |- _ _ ?rhs =>
    let P := fresh in
    pose (P := rhs); pattern term in P; change rhs with P; subst P
  end.

(* ************************************************************************** *)
(** ** Exploiting a hypothesis *)
(* ************************************************************************** *)

Tactic Notation "forward" tactic1(tac) :=
  let foo := fresh in
  evar (foo : Prop); cut (foo); subst foo; cycle 1; [tac|].

Tactic Notation "forward" tactic1(tac) "as" simple_intropattern(H) :=
  let foo := fresh in
  evar (foo : Prop); cut (foo); subst foo; cycle 1; [tac|intros H].

Tactic Notation "specialize_full" ident(H) :=
  let foo := fresh in
  evar (foo : Prop); cut (foo); subst foo; cycle 1; [eapply H|try clear H; intro H].

(** Exploit an assumption (adapted from CompCert). *)

Ltac exploit x :=
    refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _) _)
 || refine ((fun x y => y x) (x _ _) _)
 || refine ((fun x y => y x) (x _) _).


Require Export prosa.model.task.concept.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq path fintype bigop.

(** Throughout this file, we assume ideal uni-processor schedules. *)
Require Import prosa.model.processor.ideal.

(** * Definitions for Abstract Response-Time Analysis *)
(** In this module, we propose a set of definitions for the general framework for response-time analysis (RTA)
    of uni-processor scheduling of real-time tasks with arbitrary arrival models. *)
Section AbstractRTADefinitions.

  (** In this section, we introduce all the abstract notions required by the analysis. *)
  Section Definitions.

    (** Consider any type of job associated with any type of tasks... *)
    Context {Job : JobType}.
    Context {Task : TaskType}.
    Context `{JobTask Job Task}.

    (** ... with arrival times and costs. *)
    Context `{JobArrival Job}.
    Context `{JobCost Job}.

    (** Consider any kind of processor state model. *)
    Context {PState : Type}.
    Context `{ProcessorState Job PState}.

    (** Consider any arrival sequence... *)
    Variable arr_seq : arrival_sequence Job.

    (** ... and any schedule of this arrival sequence. *)
    Variable sched : schedule PState.

    (** Let [tsk] be any task that is to be analyzed *)
    Variable tsk : Task.

    (** For simplicity, let's define some local names. *)
    Let job_scheduled_at := scheduled_at sched.
    Let job_completed_by := completed_by sched.

    (** Recall that a job [j] is pending_earlier_and_at a time instant [t] iff job
       [j] arrived before time [t] and is still not completed by time [t]. *)
    Let job_pending_earlier_and_at := pending_earlier_and_at sched.

    (** We are going to introduce two main variables of the analysis:
       (a) interference, and (b) interfering workload. *)

    (** a) Interference *)
    (** Execution of a job may be postponed by the environment and/or the system due to different
       factors (preemption by higher-priority jobs, jitter, black-out periods in hierarchical
       scheduling, lack of budget, etc.), which we call interference.

       Besides, note that even the subsequent activation of a task can suffer from interference at
       the beginning of its busy interval (despite the fact that this job hasn’t even arrived
       at that moment!). Thus, it makes more sense (at least for the current busy-interval
       analysis) to think about interference of a job as any interference within the
       corresponding busy interval, and not after release of the job.

       Based on that, assume a predicate that expresses whether a job [j] under consideration
       incurs interference at a given time [t] (in the context of the schedule under consideration).
       This will be used later to upper-bound job [j]'s response time. Note that a concrete
       realization of the function may depend on the schedule, but here we do not require this
       for the sake of simplicity and generality. *)
    Variable interference : Job -> instant -> bool.

    (** b) Interfering Workload *)
    (** In addition to interference, the analysis assumes that at any time [t], we know an upper
       bound on the potential cumulative interference that can be incurred in the future by any
       job (i.e., the total remaining potential delays). Based on that, assume a function
       interfering_workload that indicates for any job [j], at any time [t], the amount of potential
       interference for job [j] that is introduced into the system at time [t]. This function will be
       later used to upper-bound the length of the busy window of a job.
       One example of workload function is the "total cost of jobs that arrive at time [t] and
       have higher-or-equal priority than job j". In some task models, this function expresses
       the amount of the potential interference on job [j] that "arrives" in the system at time [t]. *)
    Variable interfering_workload : Job -> instant -> duration.

    (** In order to bound the response time of a job, we must to consider the cumulative
       interference and cumulative interfering workload. *)
    Definition cumul_interference j t1 t2 := \sum_(t1 <= t < t2) interference j t.
    Definition cumul_interfering_workload j t1 t2 := \sum_(t1 <= t < t2) interfering_workload j t.

    (** Definition of Busy Interval *)
    (** Further analysis will be based on the notion of a busy interval. The overall idea of the
       busy interval is to take into account the workload that cause a job under consideration to
       incur interference. In this section, we provide a definition of an abstract busy interval. *)
    Section BusyInterval.

      (** We say that time instant [t] is a quiet time for job [j] iff two conditions hold.
         First, the cumulative interference at time [t] must be equal to the cumulative
         interfering workload, to indicate that the potential interference seen so far
         has been fully "consumed" (i.e., there is no more higher-priority work or other
         kinds of delay pending). Second, job [j] cannot be pending at any time earlier
         than [t] _and_ at time instant [t] (i.e., either it was pending earlier but is no
         longer pending now, or it was previously not pending and may or may not be
         released now), to ensure that the busy window captures the execution of job [j]. *)
      Definition quiet_time (j : Job) (t : instant) :=
        cumul_interference j 0 t = cumul_interfering_workload j 0 t /\
        ~~ job_pending_earlier_and_at j t.

      (** Based on the definition of quiet time, we say that interval <<[t1, t2)>> is
         a (potentially unbounded) busy-interval prefix w.r.t. job [j] iff the
         interval (a) contains the arrival of job j, (b) starts with a quiet
         time and (c) remains non-quiet. *)
      Definition busy_interval_prefix (j : Job) (t1 t2 : instant) :=
        t1 <= job_arrival j < t2 /\
        quiet_time j t1 /\
        (forall t, t1 < t < t2 -> ~ quiet_time j t).

      (** Next, we say that an interval <<[t1, t2)>> is a busy interval iff
         [t1, t2) is a busy-interval prefix and t2 is a quiet time. *)
      Definition busy_interval (j : Job) (t1 t2 : instant) :=
        busy_interval_prefix j t1 t2 /\
        quiet_time j t2.

      (** Note that the busy interval, if it exists, is unique. *)
      Lemma busy_interval_is_unique:
        forall j t1 t2 t1' t2',
          busy_interval j t1 t2 ->
          busy_interval j t1' t2' ->
          t1 = t1' /\ t2 = t2'.
      Proof.
        intros ? ? ? ? ? BUSY BUSY'.
        have EQ: t1 = t1'.
        { apply/eqP.
          apply/negPn/negP; intros CONTR.
          move: BUSY => [[IN [QT1 NQ]] _].
          move: BUSY' => [[IN' [QT1' NQ']] _].
          move: CONTR; rewrite neq_ltn; move => /orP [LT|GT].
          { apply NQ with t1'; try done; clear NQ.
            apply/andP; split; first by done.
            move: IN IN' => /andP [_ T1] /andP [T2 _].
              by apply leq_ltn_trans with (job_arrival j).
          }
          { apply NQ' with t1; try done; clear NQ'.
            apply/andP; split; first by done.
            move: IN IN' => /andP [T1 _] /andP [_ T2].
              by apply leq_ltn_trans with (job_arrival j).
          }
        } subst t1'.
        have EQ: t2 = t2'.
        { apply/eqP.
          apply/negPn/negP; intros CONTR.
          move: BUSY => [[IN [_ NQ]] QT2].
          move: BUSY' => [[IN' [_ NQ']] QT2'].
          move: CONTR; rewrite neq_ltn; move => /orP [LT|GT].
          { apply NQ' with t2; try done; clear NQ'.
            apply/andP; split; last by done.
            move: IN IN' => /andP [_ T1] /andP [T2 _].
              by apply leq_ltn_trans with (job_arrival j).
          }
          { apply NQ with t2'; try done; clear NQ.
            apply/andP; split; last by done.
            move: IN IN' => /andP [T1 _] /andP [_ T2].
              by apply leq_ltn_trans with (job_arrival j).
          }
        } by subst t2'.
      Qed.

    End BusyInterval.

    (** In this section, we introduce some assumptions about the
       busy interval that are fundamental for the analysis. *)
    Section BusyIntervalProperties.

      (** We say that a schedule is "work_conserving" iff for any job [j] from task [tsk] and
         at any time [t] within a busy interval, there are only two options:
         either (a) interference(j, t) holds or (b) job [j] is scheduled at time [t]. *)
      Definition work_conserving :=
        forall j t1 t2 t,
          arrives_in arr_seq j ->
          job_task j = tsk ->
          job_cost j > 0 ->
          busy_interval j t1 t2 ->
          t1 <= t < t2 ->
          ~ interference j t <-> job_scheduled_at j t.

      (** Next, we say that busy intervals of task [tsk] are bounded by [L] iff, for any job [j] of task
         [tsk], there exists a busy interval with length at most L. Note that the existence of such a
         bounded busy interval is not guaranteed if the schedule is overloaded with work.
         Therefore, in the later concrete analyses, we will have to introduce an additional
         condition that prevents overload. *)
      Definition busy_intervals_are_bounded_by L :=
        forall j,
          arrives_in arr_seq j ->
          job_task j = tsk ->
          job_cost j > 0 ->
          exists t1 t2,
            t1 <= job_arrival j < t2 /\
            t2 <= t1 + L /\
            busy_interval j t1 t2.

      (** Although we have defined the notion of cumulative interference of a job, it cannot be used in
         a response-time analysis because of the variability of job parameters. To address this
         issue, we define the notion of an interference bound. Note that according to the definition of
         a work conserving schedule, interference does _not_ include execution of a job itself. Therefore,
         an interference bound is not obliged to take into account the execution of this job. We say that
         the job interference is bounded by an interference_bound_function ([IBF]) iff for any job [j] of
         task [tsk] the cumulative interference incurred by [j] in the sub-interval [t1, t1 + delta) of busy
         interval [t1, t2) does not exceed [interference_bound_function(tsk, A, delta)], where [A] is a
         relative arrival time of job [j] (with respect to time [t1]). *)
      Definition job_interference_is_bounded_by (interference_bound_function: Task -> duration -> duration -> duration) :=
        (** Let's examine this definition in more detail. *)
        forall t1 t2 delta j,
          (** First, we require [j] to be a job of task [tsk]. *)
          arrives_in arr_seq j ->
          job_task j = tsk ->
          (** Next, we require the IBF to bound the interference only within the interval <<[t1, t1 + delta)>>. *)
          busy_interval j t1 t2 ->
          t1 + delta < t2 ->
          (** Next, we require the IBF to bound the interference only until the job is
             completed, after which the function can behave arbitrarily. *)
          ~~ job_completed_by j (t1 + delta) ->
          (** And finally, the IBF function might depend not only on the length
             of the interval, but also on the relative arrival time of job [j] (offset). *)
          (** While the first three conditions are needed for discarding excessive cases, offset adds
             flexibility to the IBF, which is important, for instance, when analyzing EDF scheduling. *)
          let offset := job_arrival j - t1 in
          cumul_interference j t1 (t1 + delta) <= interference_bound_function tsk offset delta.

    End BusyIntervalProperties.

  End Definitions.

End AbstractRTADefinitions.


Require Import aes.api_specs.
Require Import aes.spec_encryption_LL.
Require Import aes.bitfiddling.
Local Open Scope Z.

Definition encryption_loop_body : statement :=
   ltac:(find_statement_in_body
       f_mbedtls_aes_encrypt
       reassociate_stmt
       ltac:(fun body => match body with
              context [  Sloop
                       (Ssequence
                         (Sifthenelse (Ebinop Ogt (Etempvar _i _) (Econst_int (Int.repr 0) _)  _)
                             Sskip  Sbreak)
                       ?S) _ ] => S
      end)).

Definition encryption_loop_body_proof_statement :=
 forall
  (Espec : OracleKind)
  (ctx input output : val)
  (ctx_sh in_sh out_sh : share)
  (plaintext exp_key : list Z)
  (gv : globals)
  (H : Zlength plaintext = 16)
  (H0 : Zlength exp_key = 60)
  (SH : readable_share ctx_sh)
  (SH0 : readable_share in_sh)
  (SH1 : writable_share out_sh)
  (buf : list Z)
  (Heqbuf : buf = exp_key ++ repeat 0 8)
  (Fctx : field_compatible t_struct_aesctx [StructField _buf] ctx)
  (LenBuf : Zlength buf = 68)
  (Eq : forall i : Z,
     0 <= i < 60 ->
     force_val
       (sem_add_ptr_int tuint Signed
          (field_address t_struct_aesctx [ArraySubsc i; StructField _buf] ctx)
          (Vint (Int.repr 1))) =
     field_address t_struct_aesctx [ArraySubsc (i + 1); StructField _buf] ctx)
  (S12 S0 : four_ints)
  (HeqS0 : S0 = mbed_tls_initial_add_round_key plaintext buf)
  (HeqS12 : S12 = mbed_tls_enc_rounds 12 S0 buf 4)
  (i : Z)
  (H1 : 0 < i <= 6),
semax (func_tycontext f_mbedtls_aes_encrypt Vprog Gprog nil)
  (PROP ( )
   LOCAL (temp _i (Vint (Int.repr i));
   temp _RK
     (field_address t_struct_aesctx
        [ArraySubsc (52 - i * 8); StructField _buf] ctx);
   temp _X3
     (Vint (col 3 (mbed_tls_enc_rounds (12 - 2 * Z.to_nat i) S0 buf 4)));
   temp _X2
     (Vint (col 2 (mbed_tls_enc_rounds (12 - 2 * Z.to_nat i) S0 buf 4)));
   temp _X1
     (Vint (col 1 (mbed_tls_enc_rounds (12 - 2 * Z.to_nat i) S0 buf 4)));
   temp _X0
     (Vint (col 0 (mbed_tls_enc_rounds (12 - 2 * Z.to_nat i) S0 buf 4)));
   temp _output output;
   gvars gv)
   SEP (data_at_ out_sh (tarray tuchar 16) output;
   data_at Ews t_struct_tables
     (map Vint FSb,
     (map Vint FT0,
     (map Vint FT1,
     (map Vint FT2,
     (map Vint FT3,
     (map Vint RSb,
     (map Vint RT0,
     (map Vint RT1, (map Vint RT2, (map Vint RT3, map Vint RCON))))))))))
     (gv _tables);
   data_at in_sh (tarray tuchar 16) (map Vint (map Int.repr plaintext)) input;
   data_at ctx_sh t_struct_aesctx
     (Vint (Int.repr Nr),
     (field_address t_struct_aesctx [ArraySubsc 0; StructField _buf] ctx,
     map Vint (map Int.repr buf))) ctx))
  encryption_loop_body
  (normal_ret_assert
     (EX a : Z,
      PROP (0 < a <= 6)
      LOCAL (temp _i (Vint (Int.repr a));
      temp _RK
        (field_address t_struct_aesctx
           [ArraySubsc (52 - (a - 1) * 8); StructField _buf] ctx);
      temp _X3
        (Vint
           (col 3 (mbed_tls_enc_rounds (12 - 2 * Z.to_nat (a - 1)) S0 buf 4)));
      temp _X2
        (Vint
           (col 2 (mbed_tls_enc_rounds (12 - 2 * Z.to_nat (a - 1)) S0 buf 4)));
      temp _X1
        (Vint
           (col 1 (mbed_tls_enc_rounds (12 - 2 * Z.to_nat (a - 1)) S0 buf 4)));
      temp _X0
        (Vint
           (col 0 (mbed_tls_enc_rounds (12 - 2 * Z.to_nat (a - 1)) S0 buf 4)));
      temp _output output; gvars gv)
      SEP (data_at_ out_sh (tarray tuchar 16) output;
      data_at Ews t_struct_tables
        (map Vint FSb,
        (map Vint FT0,
        (map Vint FT1,
        (map Vint FT2,
        (map Vint FT3,
        (map Vint RSb,
        (map Vint RT0,
        (map Vint RT1, (map Vint RT2, (map Vint RT3, map Vint RCON))))))))))
        (gv _tables);
      data_at in_sh (tarray tuchar 16) (map Vint (map Int.repr plaintext))
        input;
      data_at ctx_sh t_struct_aesctx
        (Vint (Int.repr Nr),
        (field_address t_struct_aesctx [ArraySubsc 0; StructField _buf] ctx,
        map Vint (map Int.repr buf))) ctx))%assert).

(* previous version used loop1_ret_assert, for the same proof
Definition encryption_loop_body_proof_statement :=
 forall
  (Espec : OracleKind)
  (DS: PTree.t funspec)
  (ctx input output : val)
  (ctx_sh in_sh out_sh : share)
  (plaintext exp_key : list Z)
  (tables : val)
  (H : Zlength plaintext = 16)
  (H0 : Zlength exp_key = 60)
  (SH : readable_share ctx_sh)
  (SH0 : readable_share in_sh)
  (SH1 : writable_share out_sh)
  (buf : list Z)
  (Heqbuf : buf = exp_key ++ repeat 0 8)
  (Fctx : field_compatible t_struct_aesctx [StructField _buf] ctx)
  (LenBuf : Zlength buf = 68)
  (Eq : forall i : Z,
     0 <= i < 60 ->
     force_val
       (sem_add_pi tuint
          (field_address t_struct_aesctx [ArraySubsc i; StructField _buf] ctx)
          (Vint (Int.repr 1))) =
     field_address t_struct_aesctx [ArraySubsc (i + 1); StructField _buf] ctx)
  (S12 S0 : four_ints)
  (HeqS0 : S0 = mbed_tls_initial_add_round_key plaintext buf)
  (HeqS12 : S12 = mbed_tls_enc_rounds 12 S0 buf 4)
  (i : Z)
  (H1 : 0 < i <= 6),
semax (encryption_loop_body_Delta DS)
  (PROP ( )
   LOCAL (temp _i (Vint (Int.repr i));
   temp _RK
     (field_address t_struct_aesctx
        [ArraySubsc (52 - i * 8); StructField _buf] ctx);
   temp _X3
     (Vint (col 3 (mbed_tls_enc_rounds (12 - 2 * Z.to_nat i) S0 buf 4)));
   temp _X2
     (Vint (col 2 (mbed_tls_enc_rounds (12 - 2 * Z.to_nat i) S0 buf 4)));
   temp _X1
     (Vint (col 1 (mbed_tls_enc_rounds (12 - 2 * Z.to_nat i) S0 buf 4)));
   temp _X0
     (Vint (col 0 (mbed_tls_enc_rounds (12 - 2 * Z.to_nat i) S0 buf 4)));
   temp _output output;
   gvar _tables tables)
   SEP (data_at_ out_sh (tarray tuchar 16) output;
   data_at Ews t_struct_tables
     (map Vint FSb,
     (map Vint FT0,
     (map Vint FT1,
     (map Vint FT2,
     (map Vint FT3,
     (map Vint RSb,
     (map Vint RT0,
     (map Vint RT1, (map Vint RT2, (map Vint RT3, map Vint RCON))))))))))
     tables;
   data_at in_sh (tarray tuchar 16) (map Vint (map Int.repr plaintext)) input;
   data_at ctx_sh t_struct_aesctx
     (Vint (Int.repr Nr),
     (field_address t_struct_aesctx [ArraySubsc 0; StructField _buf] ctx,
     map Vint (map Int.repr buf))) ctx))
  encryption_loop_body
  (loop1_ret_assert
     (EX i0 : Z,
      PROP (0 < i0 <= 6)
      LOCAL (temp _i (Vint (Int.repr i0));
      temp _RK
        (field_address t_struct_aesctx
           [ArraySubsc (52 - (i0 - 1) * 8); StructField _buf] ctx);
      temp _X3
        (Vint
           (col 3 (mbed_tls_enc_rounds (12 - 2 * Z.to_nat (i0 - 1)) S0 buf 4)));
      temp _X2
        (Vint
           (col 2 (mbed_tls_enc_rounds (12 - 2 * Z.to_nat (i0 - 1)) S0 buf 4)));
      temp _X1
        (Vint
           (col 1 (mbed_tls_enc_rounds (12 - 2 * Z.to_nat (i0 - 1)) S0 buf 4)));
      temp _X0
        (Vint
           (col 0 (mbed_tls_enc_rounds (12 - 2 * Z.to_nat (i0 - 1)) S0 buf 4)));
      temp _output output;
      gvar _tables tables)
      SEP (data_at_ out_sh (tarray tuchar 16) output;
      tables_initialized tables;
      data_at in_sh (tarray tuchar 16) (map Vint (map Int.repr plaintext))
        input;
      data_at ctx_sh t_struct_aesctx
        (Vint (Int.repr Nr),
        (field_address t_struct_aesctx [ArraySubsc 0; StructField _buf] ctx,
        map Vint (map Int.repr buf))) ctx))%assert
     (normal_ret_assert
        (PROP ( )
         LOCAL (temp _RK
                  (field_address t_struct_aesctx
                     [ArraySubsc 52; StructField _buf] ctx);
         temp _X3 (Vint (col 3 S12)); temp _X2 (Vint (col 2 S12));
         temp _X1 (Vint (col 1 S12)); temp _X0 (Vint (col 0 S12));
         temp _output output;
         gvar _tables tables)
         SEP (data_at_ out_sh (tarray tuchar 16) output;
         tables_initialized tables;
         data_at in_sh (tarray tuchar 16) (map Vint (map Int.repr plaintext))
           input;
         data_at ctx_sh t_struct_aesctx
           (Vint (Int.repr Nr),
           (field_address t_struct_aesctx [ArraySubsc 0; StructField _buf]
              ctx, map Vint (map Int.repr buf))) ctx)))).*)
Local Hint Resolve Z0 : inhabited.

Lemma encryption_loop_body_proof: encryption_loop_body_proof_statement.
Proof.
  unfold encryption_loop_body_proof_statement. intros.
  unfold encryption_loop_body.
  abbreviate_semax.
  pose proof masked_byte_range.
  assert (H2': forall i, 0 <= Int.unsigned (Int.and i (Int.repr 255)) < 256). {
    clear.  intros. rewrite Int.and_commut.
    pose proof (Int.and_le (Int.repr 255) i).
    rewrite Int.unsigned_repr in H by computable.
    pose proof (Int.unsigned_range (Int.and (Int.repr 255) i)). lia.
  }

  do 2 forward. simpl (temp _RK _). rewrite Eq by lia. do 6 forward. deadvars!.
  do 2 forward. simpl (temp _RK _). rewrite Eq by lia. do 6 forward. deadvars!.
  do 2 forward. simpl (temp _RK _). rewrite Eq by lia. do 6 forward. deadvars!.
  do 2 forward. simpl (temp _RK _). rewrite Eq by lia. do 6 forward. deadvars!.

  replace (52 - i * 8 + 1 + 1 + 1 + 1) with (52 - i * 8 + 4) by lia.
  replace (52 - i * 8 + 1 + 1 + 1)     with (52 - i * 8 + 3) by lia.
  replace (52 - i * 8 + 1 + 1)         with (52 - i * 8 + 2) by lia.

  pose (S' := mbed_tls_fround (mbed_tls_enc_rounds (12-2*Z.to_nat i) S0 buf 4) buf (52-i*8)).

  match goal with |- context [temp _Y0 (Vint ?E0)] =>
    match goal with |- context [temp _Y1 (Vint ?E1)] =>
      match goal with |- context [temp _Y2 (Vint ?E2)] =>
        match goal with |- context [temp _Y3 (Vint ?E3)] =>
          assert (S' = (E0, (E1, (E2, E3)))) as Eq2
        end
      end
    end
  end.
  {
    subst S'.
    rewrite (split_four_ints (mbed_tls_enc_rounds (12 - 2 * Z.to_nat i) S0 buf 4)).
    simpl. unfold mbed_tls_fround_col, byte0, byte1, byte2, byte3, Int.and. simpl.
    rewrite !Int.unsigned_repr by computable.
    rewrite !Int.unsigned_repr by
     match goal with |- context [Z.land ?A] => clear - H2; specialize (H2 A); rep_lia end.
    reflexivity.
  }
  apply split_four_ints_eq in Eq2. destruct Eq2 as [EqY0 [EqY1 [EqY2 EqY3]]].
  rewrite EqY0. rewrite EqY1. rewrite EqY2. rewrite EqY3.
  clear EqY0 EqY1 EqY2 EqY3.

  do 2 forward. simpl (temp _RK _). rewrite Eq by lia. do 6 forward. deadvars!.
  do 2 forward. simpl (temp _RK _). rewrite Eq by lia. do 6 forward. deadvars!.
  do 2 forward. simpl (temp _RK _). rewrite Eq by lia. do 6 forward. deadvars!.
  do 2 forward. simpl (temp _RK _). rewrite Eq by lia. do 6 forward.

  pose (S'' := mbed_tls_fround S' buf (52-i*8+4)).

  replace (52 - i * 8 + 4 + 1 + 1 + 1 + 1) with (52 - i * 8 + 4 + 4) by lia.
  replace (52 - i * 8 + 4 + 1 + 1 + 1)     with (52 - i * 8 + 4 + 3) by lia.
  replace (52 - i * 8 + 4 + 1 + 1)         with (52 - i * 8 + 4 + 2) by lia.

  match goal with |- context [temp _X0 (Vint ?E0)] =>
    match goal with |- context [temp _X1 (Vint ?E1)] =>
      match goal with |- context [temp _X2 (Vint ?E2)] =>
        match goal with |- context [temp _X3 (Vint ?E3)] =>
          assert (S'' = (E0, (E1, (E2, E3)))) as Eq2
        end
      end
    end
  end.
  {
    subst S''.
    rewrite (split_four_ints S').
    simpl. unfold mbed_tls_fround_col, byte0, byte1, byte2, byte3, Int.and. simpl.
    rewrite !Int.unsigned_repr by computable.
    rewrite !Int.unsigned_repr by
     match goal with |- context [Z.land ?A] => clear - H2; specialize (H2 A); rep_lia end.
    reflexivity.
  }
  apply split_four_ints_eq in Eq2. destruct Eq2 as [EqX0 [EqX1 [EqX2 EqX3]]].
  rewrite EqX0. rewrite EqX1. rewrite EqX2. rewrite EqX3.
  clear EqX0 EqX1 EqX2 EqX3.

  Exists i.
  replace (52 - i * 8 + 4 + 4) with (52 - (i - 1) * 8) by lia.
  subst S' S''.
  assert (
    (mbed_tls_fround
      (mbed_tls_fround
         (mbed_tls_enc_rounds (12 - 2 * Z.to_nat i) S0 buf 4)
         buf
         (52 - i * 8))
      buf
      (52 - i * 8 + 4))
  = (mbed_tls_enc_rounds (12 - 2 * Z.to_nat (i - 1)) S0 buf 4)) as Eq2. {
    replace (12 - 2 * Z.to_nat (i - 1))%nat with (S (S (12 - 2 * Z.to_nat i))).
    - unfold mbed_tls_enc_rounds (*at 2*). fold mbed_tls_enc_rounds.
      f_equal.
      * f_equal.
        rewrite Nat2Z.inj_sub. {
          change (Z.of_nat 12) with 12.
          rewrite Nat2Z.inj_mul.
          change (Z.of_nat 2) with 2.
          rewrite Z2Nat.id; lia.
        }
        assert (Z.to_nat i <= 6)%nat. {
          change 6%nat with (Z.to_nat 6).
          apply Z2Nat.inj_le; lia.
        }
        lia.
      * rewrite Nat2Z.inj_succ.
        change 2%nat with (Z.to_nat 2) at 2.
        rewrite <- Z2Nat.inj_mul; [ | lia | lia ].
        change 12%nat with (Z.to_nat 12).
        rewrite <- Z2Nat.inj_sub; [ | lia ].
        rewrite Z2Nat.id; lia.
    - rewrite Z2Nat.inj_sub; [ | lia ].
      change (Z.to_nat 1) with 1%nat.
      assert (Z.to_nat i <= 6)%nat. {
        change 6%nat with (Z.to_nat 6).
        apply Z2Nat.inj_le; lia.
      }
      assert (0 < Z.to_nat i)%nat. {
        change 0%nat with (Z.to_nat 0).
        apply Z2Nat.inj_lt; lia.
      }
      lia.
  }
  rewrite Eq2. clear Eq2.
  remember (mbed_tls_enc_rounds (12 - 2 * Z.to_nat (i - 1)) S0 buf 4) as S''.
  remember (mbed_tls_fround (mbed_tls_enc_rounds (12 - 2 * Z.to_nat i) S0 buf 4) buf (52 - i * 8)) as S'.
  replace (52 - i * 8 + 4 + 4) with (52 - (i - 1) * 8) by lia.
  entailer!.
Time Qed.
(* On Andrew's ThinkPad T440p, April 13, 2017, to do Qed:
  With deadvar-elim:  37.6 seconds, 0.934GB
  Without deadvar-elim: 47.8 seconds, 1.073 GB
  (This computer seems to be same speed as Sam's Ubuntu laptop *)


(* The lattice structure of the reals. *)

Require Import Setoid Morphisms.
Require Import QArith.
Require Import Qminmax.

Require Import Cut MiscLemmas Additive Multiplication Order.

Local Open Scope R_scope.

(** A hack to be able to have proof-relevant unfinished constructions.
    When this file is cleaned up, remove this axiom and the tactic. *)
Axiom unfinished : forall (A : Type), A.
Ltac todo := apply unfinished.

Definition Rmin : R -> R -> R.
Proof.
  intros x y.
  refine {| lower := (fun q => lower x q /\ lower y q) ;
            upper := (fun q => upper x q \/ upper y q) |}.
  - intros ? ? E. rewrite E ; tauto.
  - intros ? ? E. rewrite E ; tauto.
  - destruct (lower_bound x) as [q qmaj].
    destruct (lower_bound y) as [r rmaj].
    exists (Qmin q r).
    split.
    + destruct (Q.min_spec q r) as [[G H]|[G H]].
      * setoid_rewrite H ; assumption.
      * setoid_rewrite H. auto using (lower_le x r q).
    + destruct (Q.min_spec q r) as [[G H]|[G H]].
      * setoid_rewrite H. auto using (lower_lower y q r).
      * setoid_rewrite H ; assumption.
  - destruct (upper_bound y) as [r ?].
    exists r.
    right.
    assumption.
  - intros q r H [A B].
    assert (C:=(lower_lower x q r H A)).
    assert (D:=(lower_lower y q r H B)).
    auto.
  - intros q [A B].
    assert (C:=(lower_open x q A)).
    destruct C as [r [T U]].
    assert (D:=(lower_open y q B)).
    destruct D as [s [M P]].
    exists (Qmin s r).
    repeat split.
    + destruct (Q.min_spec s r) as [[G H]|[G H]].
      * setoid_rewrite H ; assumption.
      * setoid_rewrite H ; assumption.
    + destruct (Q.min_spec s r) as [[G H]|[G H]].
      * setoid_rewrite H.
        assert (C:=(lower_lower x s r G U)).
        assumption.
      * setoid_rewrite H ; assumption.
    + destruct (Q.min_spec s r) as [[G H]|[G H]].
      * setoid_rewrite H ; assumption.
      * setoid_rewrite H.
        assert (K:=(Qle_lteq r s)).
        rewrite K in G.
        destruct G as [G1 | G2].
        clear K.
        assert (C:=(lower_lower y r s G1 P)).
        assumption.
        clear K.
        setoid_rewrite G2.
        assumption.
  - intros q r H [A | B].
    assert (C:=(upper_upper x q r H A)).
    left.
    assumption.
    assert (D:=(upper_upper y q r H B)).
    right.
    assumption.
  - intros r [A | B].
    + assert (C:=(upper_open x r A)).
      destruct C as [q [T U]].
      exists q.
      split.
      assumption.
      left ; assumption.
    + assert (C:=(upper_open y r B)).
      destruct C as [q [T U]].
      exists q.
      split.
      assumption.
      right ; assumption.
  - intro.
    apply neg_false.
    split.
    + intros [[lx ly] [ux | uy]].
      auto using (disjoint x q).
      auto using (disjoint y q).
    + tauto.
  - intros q r T.
    assert (H:=(located x q r T)).
    assert (K:=(located y q r T)).
    tauto.
Defined.

Definition Rmax : R -> R -> R.
Proof.
  intros x y.
  refine {| lower := (fun q => lower x q \/ lower y q) ;
            upper := (fun q => upper x q /\ upper y q) |}.
  - intros ? ? E. rewrite E ; tauto.
  - intros ? ? E. rewrite E ; tauto.
  - destruct (lower_bound x) as [q ?].
    exists q.
    left ; assumption.
  - destruct (upper_bound x) as [q qmaj].
    destruct (upper_bound y) as [r rmaj].
    exists (Qmax q r).
    split.
    + destruct (Q.max_spec q r) as [[G H]|[G H]].
      * setoid_rewrite H. auto using (upper_upper x q r).
      * setoid_rewrite H ; assumption.
    + destruct (Q.max_spec q r) as [[G H]|[G H]].
      * setoid_rewrite H ; assumption.
      * setoid_rewrite H. auto using (upper_le y r q).
  - intros q r H [A | B].
    + assert (C:=(lower_lower x q r H A)).
      left ; assumption.
    + assert (D:=(lower_lower y q r H B)).
      right ; assumption.
  - intros q [A | B].
    + assert (C:=(lower_open x q A)).
      destruct C as [r0 [T U]].
      exists r0.
      split.
      assumption.
      left ; assumption.
    + assert (C:=(lower_open y q B)).
      destruct C as [r0 [T U]].
      exists r0.
      split.
      assumption.
      right ; assumption.
  - intros q r H [A B].
    assert (C:=(upper_upper x q r H A)).
    assert (D:=(upper_upper y q r H B)).
    auto.
  - intros r [A B].
    assert (C:=(upper_open x r A)).
    destruct C as [q [T U]].
    assert (D:=(upper_open y r B)).
    destruct D as [s [M P]].
    exists (Qmax s q).
    repeat split.
    + destruct (Q.max_spec s q) as [[G H]|[G H]].
      * setoid_rewrite H ; assumption.
      * setoid_rewrite H ; assumption.
    + destruct (Q.max_spec s q) as [[G H]|[G H]].
      * setoid_rewrite H ; assumption.
      * setoid_rewrite H.
        auto using (upper_le x q s U G).
    + destruct (Q.max_spec s q) as [[G H]|[G H]].
      * setoid_rewrite H.
        auto using (upper_upper y s q G P).
      * setoid_rewrite H ; assumption.
  - intro.
    apply neg_false.
    split.
    + intros [[lx | ly] [ux  uy]].
      auto using (disjoint x q).
      auto using (disjoint y q).
    + tauto.
  - intros q r T.
    assert (H:=(located x q r T)).
    assert (K:=(located y q r T)).
    tauto.
Qed.

(** The lattice structure of [R] with respect to [Rmin] and [Rmax]. *)

Theorem Rmin_spec (x y z : R) : z <= Rmin x y <-> z <= x /\ z <= y.
Proof.
unfold Rle.
split.
- intro.
split.
+ intros q A.
assert (C:=(H q A)).
destruct C.
assumption.
+ intros q A.
assert (C:=(H q A)).
destruct C.
assumption.
- intros [H1 H2].
intros q A.
assert (C1:=(H1 q A)).
assert (C2:=(H2 q A)).
firstorder.
Qed.

Theorem Rmin_lower_l (x y : R) : Rmin x y <= x.
Proof.
  destruct (proj1 (Rmin_spec x y (Rmin x y)) (Rle_refl _)) ; assumption.
Qed.

Theorem Rmin_lower_r (x y : R) : Rmin x y <= y.
Proof.
  destruct (proj1 (Rmin_spec x y (Rmin x y)) (Rle_refl _)) ; assumption.
Qed.

Theorem Rmin_idempotent (x : R) : Rmin x x == x.
Proof.
  split.
  - apply Rmin_lower_l.
  - apply Rmin_spec ; split ; apply Rle_refl.
Qed.

Theorem Rmin_comm (x y : R) : Rmin x y == Rmin y x.
Proof.
  split ; apply Rmin_spec ; auto using Rmin_lower_l, Rmin_lower_r.
Qed.

Theorem Rmin_assoc (x y z : R) : Rmin x (Rmin y z) == Rmin (Rmin x y) z.
Proof.
  firstorder.
Qed.

Theorem Rmax_spec (x y z : R) : Rmax x y <= z <-> x <= z /\ y <= z.
Proof.
  todo.
Qed.

Theorem Rmax_upper_l (x y : R) : x <= Rmax x y.
Proof.
  apply (Rmax_spec x y  (Rmax x y)), Rle_refl.
Qed.

Theorem Rmax_upper_r (x y : R) : y <= Rmax x y.
Proof.
  apply (Rmax_spec x y (Rmax x y)), Rle_refl.
Qed.

Theorem Rmax_idempotent (x : R) : Rmax x x == x.
Proof.
  split.
  - apply (Rmax_spec x x x) ; split ; apply Rle_refl.
  - apply Rmax_upper_l.
Qed.

Theorem Rmax_comm (x y : R) : Rmax x y == Rmax y x.
Proof.
  split ; apply Rmax_spec ; auto using Rmax_upper_l, Rmax_upper_r.
Qed.

Theorem Rmax_assoc (x y z : R) : Rmax x (Rmax y z) == Rmax (Rmax x y) z.
Proof.
  split.
  - apply Rmax_spec.
    split.
    + assert(A:=(Rmax_upper_l x y)).
      assert(B:=(Rmax_upper_l (Rmax x y) z)).
      assert(C:=(Rle_trans x (Rmax x y) (Rmax (Rmax x y) z) A B)).
      assumption.
    + apply Rmax_spec ; split.
      * assert(A:=(Rmax_upper_r x y)).
        assert(B:=(Rmax_upper_l (Rmax x y) z)).
        assert(C:=(Rle_trans y (Rmax x y) (Rmax (Rmax x y) z) A B)).
        assumption.
      * assert(A:=(Rmax_upper_r (Rmax x y) z)) ; assumption.
  - apply Rmax_spec ; split.
    + apply Rmax_spec ; split.
      * assert(A:=(Rmax_upper_l x (Rmax y z))) ; assumption.
      * assert(A:=(Rmax_upper_l y z)).
        assert(B:=(Rmax_upper_r x (Rmax y z))).
        assert(C:=(Rle_trans y (Rmax y z) (Rmax x (Rmax y z) ) A B)).
        assumption.
    + assert(A:=(Rmax_upper_r y z)).
      assert(B:=(Rmax_upper_r x (Rmax y z))).
      assert(C:=(Rle_trans z (Rmax y z) (Rmax x (Rmax y z)) A B)).
      assumption.
Qed.

(* Distributivity of + over min and max. *)

Theorem Rmin_plus_distr_r (x y z : R) : Rmin (x + z) (y + z) == Rmin x y + z.
Proof.
  todo.
Qed.

Theorem Rmin_plus_distr_l (x y z : R) : Rmin (x + y) (x + z) == x + Rmin y z.
Proof.
  todo.
Qed.

Theorem Rmax_plus_distr_r (x y z : R) : Rmax (x + z) (y + z) == Rmax x y + z.
Proof.
  todo.
Qed.

Theorem Rmax_plus_distr_l (x y z : R) : Rmax (x + y) (x + z) == x + Rmax y z.
Proof.
  todo.
Qed.

(* Distributivity of * over min and max. *)

Theorem Rmin_mult_distr_r (x y z : R) : 0 < z -> Rmin (x * z) (y * z) == Rmin x y * z.
Proof.
  todo.
Qed.

Theorem Rmin_mult_distr_l (x y z : R) : 0 < x -> Rmin (x * y) (x * z) == x * Rmin y z.
Proof.
  todo.
Qed.

Theorem Rmax_mult_distr_r (x y z : R) : 0 < z -> Rmax (x * z) (y * z) == Rmax x y * z.
Proof.
  todo.
Qed.

Theorem Rmax_mult_distr_l (x y z : R) : 0 < x -> Rmax (x * y) (x * z) == x * Rmax y z.
Proof.
  todo.
Qed.

(* Opposite in relation to min and max. *)

Theorem Ropp_min (x y : R) : Rmin (-x) (-y) == - (Rmax x y).
Proof.
  todo.
Qed.

Theorem Ropp_max (x y : R) : Rmax (-x) (-y) == - (Rmin x y).
Proof.
  todo.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D I : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ B D /\ (wd_ A D /\ (wd_ C D /\ (wd_ B I /\ (wd_ I C /\ (wd_ B C /\ (wd_ A I /\ (col_ A B C /\ (col_ B I C /\ (col_ A D I /\ col_ B C D))))))))))))) -> col_ A C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q A Aprime Cprime : Universe, ((wd_ P Q /\ (wd_ P Aprime /\ (wd_ P A /\ (wd_ P Cprime /\ (wd_ A Aprime /\ (col_ P Q Aprime /\ (col_ P Q A /\ col_ P Q Cprime))))))) -> col_ A Aprime P)).
Proof.
  time tac.
Qed.

End FOFProblem.