Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import syntax_ott
               rules_inf.

Require Import List. Import ListNotations.
Require Import Strings.String.

Definition irred e : Prop := forall b, ~(step e b).

Notation "Γ ⊢ E ⇒ A" := (Typing Γ E Inf A) (at level 45).
Notation "Γ ⊢ E ⇐ A" := (Typing Γ E Chk A) (at level 45).

Notation "[ z ~> u ] e" := (subst_exp u z e) (at level 0).
Notation "t ^^ u"       := (open_exp_wrt_exp t u) (at level 67).

Notation "v ~-> A v'" := (TypedReduce v A v') (at level 68).

Notation "t ->** r" := (steps t r) (at level 68).

Lemma stars_one:
forall a b, step a (e_exp b) -> steps a (e_exp b).
Proof.
eauto using steps.
Qed.

Lemma stars_trans:
forall a b, steps a (e_exp b) -> forall c, steps b (e_exp c) -> steps a (e_exp c).
Proof.
  introv H.
  inductions H; eauto using steps.
Qed.

Lemma stars_transb:
forall a b l bb, steps a (e_exp b) -> steps b (e_blame l bb) -> steps a (e_blame l bb).
Proof.
  introv H.
  inductions H; eauto using steps.
Qed.

Lemma sstars_one:
forall a b, step a (e_exp b) -> ssteps a (e_exp b).
Proof.
eauto using steps.
Qed.

Lemma sstars_trans:
forall a b, ssteps a (e_exp b) -> forall c, ssteps b (e_exp c) -> ssteps a (e_exp c).
Proof.
  introv H.
  inductions H; eauto using steps.
Qed.

Lemma sstars_transb:
forall a b l bb, steps a (e_exp b) -> ssteps b (e_blame l bb) -> ssteps a (e_blame l bb).
Proof.
  introv H.
  inductions H; eauto using steps.
Qed.

Lemma starn_one:
forall a b, step a (e_exp b) -> sstep_sz a (e_exp b) 1.
Proof.
eauto using steps.
Qed.

Lemma starn_trans:
forall a b n1, sstep_sz a (e_exp b) n1 -> forall c n2, sstep_sz b (e_exp c) n2 -> sstep_sz a (e_exp c) (n1 + n2).
Proof.
  introv H.
  inductions H; eauto using step.
  intros.
  forwards*: IHsstep_sz H1.
  eapply ssteps_n; eauto.
Qed.

Lemma starn_transb:
forall a b l bb n m, sstep_sz a (e_exp b) n -> sstep_sz b (e_blame l bb) m -> sstep_sz a (e_blame l bb) (n+m).
Proof.
  introv H.
  inductions H; eauto using steps.
  intros.
  forwards*: IHsstep_sz H1.
  eapply ssteps_nb; eauto.
Qed.

Hint Resolve starn_one starn_trans starn_transb stars_one stars_trans stars_transb sstars_one sstars_trans sstars_transb:core.

Notation "x '#' E" := (x \notin (dom E)) (at level 67) : env_scope.

Definition env := list (atom * exp).

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : list (var * typ) => dom x) in
  let D := gather_atoms_with (fun x : exp => fv_exp x) in
  let E := gather_atoms_with (fun x : ctx => dom x) in
  let F := gather_atoms_with (fun x : env => dom x) in
  let G := gather_atoms_with (fun x : term => fv_term x) in
  constr:(A `union` B `union` C `union` D `union` F `union` G).

Lemma value_lc : forall v,
    value v -> lc_exp v.
Proof.
  intros v H.
  induction* H.
Qed.

Lemma walue_lc : forall v,
    walue v -> lc_exp v.
Proof.
  intros v H.
  induction* H.
Qed.

Lemma walue_value: forall v,
 walue v ->
 value v.
Proof.
  introv val.
  inductions val; eauto.
  eapply value_fanno; eauto.
  reflexivity.
Qed.

Lemma nlam_not_exist: forall e,
  nlam e ->
  not(exists e' l b, e = (e_abs e' l b)).
Proof.
  introv nl.
  inductions nl;
  try solve[unfold not; intros nt; inverts* nt; inverts H; inverts H0;
  inverts H].
Qed.

Lemma nlam_exist: forall e,
  not(nlam e) ->
  (exists e' l b, e = (e_abs e' l b)).
Proof.
  introv nl.
  inductions e; try solve[exfalso; apply nl; eauto];eauto.
Qed.

Hint Resolve walue_value  value_lc walue_lc nlam_not_exist nlam_exist: core.

Lemma step_not_value: forall (v:exp),
    value v -> irred v.
Proof.
  introv.
  unfold irred.
  inductions v; introv H;
  inverts* H;
  unfold not;intros;
  try solve[inverts* H;destruct E; unfold fill in H0; inverts* H0];
  try solve[inverts* H;destruct E; unfold fill in H0; inverts* H0;
  inverts* H3;destruct E; unfold fill in H; inverts* H];
  try solve[inverts* H3;destruct E; unfold fill in H; inverts* H].
Qed.

Lemma step_not_walue: forall (v:exp),
    walue v -> irred v.
Proof.
  introv.
  unfold irred.
  inductions v; introv H;
  inverts* H;
  unfold not;intros;
  try solve[inverts* H;destruct E; unfold fill in H0; inverts* H0];
  try solve[inverts* H;destruct E; unfold fill in H0; inverts* H0;
  inverts* H3;destruct E; unfold fill in H; inverts* H];
  try solve[inverts* H3;destruct E; unfold fill in H; inverts* H].
Qed.

Lemma step_not_nlam: forall e e',
    step e (e_exp e') -> nlam e'.
Proof.
  introv red.
  inductions red; eauto;
  try solve[destruct E; unfold fill in *; eauto].
  inverts* H0.
Qed.

Lemma multi_rred_app : forall v t t' l b A B,
    (principal_type v) = (t_arrow A B) ->
     value v -> t ->** (e_exp t') -> (e_app v l b t) ->** (e_exp (e_app v l b t')).
Proof.
  introv ty Val Red.
  inductions Red; eauto.
  forwards*: IHRed.
  assert(wellformed (appCtxR v l b)). eauto.
  forwards*: do_step H1 H.
Qed.

Lemma multi_bblame_app : forall v t l1 b1 l2 b2 A B,
(principal_type v) = (t_arrow A B) ->
    value v -> t ->** (e_blame l1 b1) -> (e_app v l2 b2 t) ->** (e_blame l1 b1).
Proof.
  introv ty Val Red.
  inductions Red; eauto.
  eapply step_nb.
  assert(wellformed (appCtxR v l2 b2)). eauto.
  forwards*: do_step H0 H.
  simpl. forwards*: IHRed.
  apply step_b.
  assert(wellformed (appCtxR v l2 b2 )). eauto.
  forwards*: blame_step H0 H.
Qed.

Lemma multi_bblame_appv : forall v t l1 b1,
    value v -> t ->** (e_blame l1 b1) -> (e_appv v t) ->** (e_blame l1 b1).
Proof.
  introv Val Red.
  inductions Red; eauto.
  eapply step_nb.
  assert(wellformed (appvCtxR v)). eauto.
  forwards*: do_step H0 H.
  simpl. forwards*: IHRed.
  apply step_b.
  assert(wellformed (appvCtxR v)). eauto.
  forwards*: blame_step H0 H.
Qed.

Lemma multi_rred_appv : forall v t t',
     value v -> t ->** (e_exp t') -> (e_appv v t) ->** (e_exp (e_appv v t')).
Proof.
  introv Val Red.
  inductions Red; eauto.
  forwards*: IHRed.
  assert(wellformed (appvCtxR v)). eauto.
  forwards*: do_step H1 H.
Qed.

Lemma multi_rred_appv2 : forall t1 t2 t1' ,
    lc_exp t2 -> t1 ->** (e_exp t1') -> (e_appv t1 t2) ->** (e_exp (e_appv t1' t2)).
Proof.
  introv Val Red.
  inductions Red; eauto.
  assert(wellformed (appvCtxL t2)). eauto.
  forwards*: do_step H0 H.
Qed.

Lemma multi_bblame_appv2 : forall t1 t2 l1 b1,
    lc_exp t2 -> t1 ->** e_blame l1 b1 -> (e_appv t1 t2) ->** e_blame l1 b1.
Proof.
  introv Val Red.
  inductions Red; eauto.
  eapply step_nb.
  assert(wellformed (appvCtxL t2 )). eauto.
  forwards*: do_step H0 H.
  simpl. forwards*: IHRed.
  apply step_b.
  assert(wellformed (appvCtxL t2)). eauto.
  forwards*: blame_step H0 H.
Qed.

Lemma multi_rred_app2 : forall t1 t2 t1' l b,
    lc_exp t2 -> t1 ->** (e_exp t1') -> (e_app t1 l b t2) ->** (e_exp (e_app t1' l b t2)).
Proof.
  introv Val Red.
  inductions Red; eauto.
  assert(wellformed (appCtxL t2 l b)). eauto.
  forwards*: do_step H0 H.
Qed.

Lemma multi_bblame_app2 : forall t1 t2 l1 b1 l2 b2,
    lc_exp t2 -> t1 ->** e_blame l1 b1 -> (e_app t1 l2 b2 t2) ->** e_blame l1 b1.
Proof.
  introv Val Red.
  inductions Red; eauto.
  eapply step_nb.
  assert(wellformed (appCtxL t2 l2 b2 )). eauto.
  forwards*: do_step H0 H.
  simpl. forwards*: IHRed.
  apply step_b.
  assert(wellformed (appCtxL t2 l2 b2 )). eauto.
  forwards*: blame_step H0 H.
Qed.

Lemma multi_rred_anno : forall t t' A l b ,
    t ->** (e_exp t') -> (e_anno t l b A) ->** (e_exp (e_anno t' l b A )).
Proof.
  introv Red.
  inductions Red; eauto.
  assert(wellformed (annoCtx l b A)). eauto.
  forwards*: do_step H0 H.
Qed.

Lemma multi_bblame_anno : forall t A l0 b0 l b,
    t ->** e_blame l b -> (e_anno t l0 b0 A) ->** e_blame l b.
Proof.
  introv Red.
  inductions Red; eauto.
  eapply step_nb.
  assert(wellformed (annoCtx l0 b0 A)). eauto.
  forwards*: do_step H0 H.
  simpl. forwards*: IHRed.
  apply step_b.
  assert(wellformed (annoCtx l0 b0 A)). eauto.
  forwards*: blame_step H0 H.
Qed.

Lemma step_nlam: forall e e2,
  step e (e_exp e2) ->
  not(exists e3 l b , e2 = (e_abs e3 l b)).
Proof.
  introv red.
  inductions red;try solve[
  unfold not; intros nt; inverts* nt;inverts H0; inverts H1;inverts* H0];
  try solve[
  unfold not; intros nt; inverts* nt;inverts* H0];
  try solve[
  unfold not; intros nt; inverts* nt;inverts* H;inverts H0;inverts H];
  try solve[
  unfold not; intros nt; inverts* nt;inverts H1;inverts* H2;inverts H1].
  destruct E; unfold fill in *;
  unfold not; intros nt; inverts* nt; try solve[inverts H0; inverts H1; inverts H0].
  unfold not; intros nt; inverts* nt.
  inverts H2. inverts H3. inverts H0. inverts H7.
  unfold not; intros nt; inverts* nt; try solve[inverts H3;inverts H4;inverts H3].
  unfold not; intros nt; inverts* nt; try solve[inverts H3;inverts H4;inverts H3].
Qed.

Lemma steps_nlam: forall e e2,
  not(exists e1 l b, e = (e_abs e1 l b)) ->
  e ->** e_exp e2 ->
  not(exists e3 l2 b2 , e2 = (e_abs e3 l2 b2)).
Proof.
  introv ne red.
  inductions red; eauto.
  assert(not (exists ee ll2 bb2, e' = (e_abs ee ll2 bb2))).
  inductions H; try solve[
  unfold not; intros nt; inverts* nt;inverts* H1;inverts H2; inverts* H1];
  try solve[
  unfold not; intros nt; inverts* nt;inverts* H0;inverts H; inverts* H0];
  try solve[
  unfold not; intros nt; inverts* nt;inverts* H;inverts* H0;inverts* H];
  try solve[
  unfold not; intros nt; inverts* nt;inverts* H3;inverts* H4;inverts* H3].
  destruct E; unfold fill in *;
  unfold not; intros nt; inverts* nt; inverts H1;inverts H2;inverts H1.
  unfold not; intros nt; inverts* nt. inverts H2.
  inverts H3. inverts* H0.
  inverts H7.
  unfold not; intros nt; inverts* nt.
Qed.

Lemma steps_not_nlam: forall e e',
    nlam e ->
    e ->** (e_exp e') ->
    nlam e'.
Proof.
  introv nl red.
  inductions red; eauto.
  forwards*: step_not_nlam H.
Qed.

Lemma fillb_cast: forall v A p b B,
  (trm_cast v A p b B) = (fillb (castCtxb A p b B )  v).
Proof.
  introv.
  eauto.
Qed.

Lemma fill_app: forall e1 e2 p b,
  (e_app e1  p b e2) = (fill (appCtxL e2 p b)  e1).
Proof.
  introv.
  eauto.
Qed.

Lemma fill_appv: forall e1 e2,
  (e_appv e1  e2) = (fill (appvCtxL e2 )  e1).
Proof.
  introv.
  eauto.
Qed.

Lemma fill_anno: forall e t l b ,
  (e_anno e l b t) = (fill (annoCtx l b t)  e).
Proof.
  introv.
  unfold fill; eauto.
Qed.

Lemma fill_appl: forall e1 e2 l b,
  (e_app e1 l b e2) = (fill (appCtxL e2 l b)  e1).
Proof.
  introv.
  unfold fill; eauto.
Qed.

Lemma fill_appr: forall e1 e2 l b,
  (e_app e1 l b e2) = (fill (appCtxR e1 l b)  e2).
Proof.
  introv.
  unfold fill; eauto.
Qed.

Lemma fill_appvr: forall e1 e2,
  (e_appv e1 e2) = (fill (appvCtxR e1)  e2).
Proof.
  introv.
  unfold fill; eauto.
Qed.

Lemma smulti_rred_app : forall v t t' l b A B,
    (principal_type v) = (t_arrow A B) ->
     value v -> ssteps t  (e_exp t') -> ssteps (e_app v l b t) (e_exp (e_app v l b t')).
Proof.
  introv ty Val Red.
  inductions Red; eauto.
  rewrite fill_appr.
  rewrite fill_appr.
  apply sstep_refl.
  apply do_step;eauto.
  forwards*: IHRed.
  assert(wellformed (appCtxR v l b)). eauto.
  forwards*: do_step H1 H.
Qed.

Lemma smulti_bblame_app : forall v t l1 b1 l2 b2 A B,
(principal_type v) = (t_arrow A B) ->
    value v -> ssteps t (e_blame l1 b1) -> ssteps (e_app v l2 b2 t) (e_blame l1 b1).
Proof.
  introv ty Val Red.
  inductions Red; eauto.
  eapply sstep_nb.
  assert(wellformed (appCtxR v l2 b2)). eauto.
  forwards*: do_step H0 H.
  simpl. forwards*: IHRed.
  apply sstep_b.
  assert(wellformed (appCtxR v l2 b2 )). eauto.
  forwards*: blame_step H0 H.
Qed.

Lemma smulti_bblame_appv : forall v t l1 b1,
    value v -> ssteps t (e_blame l1 b1) -> ssteps (e_appv v t) (e_blame l1 b1).
Proof.
  introv Val Red.
  inductions Red; eauto.
  eapply sstep_nb.
  assert(wellformed (appvCtxR v)). eauto.
  forwards*: do_step H0 H.
  simpl. forwards*: IHRed.
  apply sstep_b.
  assert(wellformed (appvCtxR v)). eauto.
  forwards*: blame_step H0 H.
Qed.

Lemma smulti_rred_appv : forall v t t',
     value v -> ssteps t (e_exp t') -> ssteps (e_appv v t) (e_exp (e_appv v t')).
Proof.
  introv Val Red.
  inductions Red; eauto.
  rewrite fill_appvr.
  rewrite fill_appvr.
  apply sstep_refl.
  apply do_step;eauto.
  assert(wellformed (appvCtxR v)). eauto.
  forwards*: do_step H0 H.
Qed.

Lemma smulti_rred_appv2 : forall t1 t2 t1' ,
    lc_exp t2 -> ssteps t1 (e_exp t1') -> ssteps (e_appv t1 t2) (e_exp (e_appv t1' t2)).
Proof.
  introv Val Red.
  inductions Red; eauto.
  rewrite fill_appv.
  rewrite fill_appv.
  apply sstep_refl.
  apply do_step;eauto.
  assert(wellformed (appvCtxL t2)). eauto.
  forwards*: do_step H0 H.
Qed.

Lemma smulti_bblame_appv2 : forall t1 t2 l1 b1,
    lc_exp t2 -> ssteps t1 (e_blame l1 b1) -> ssteps  (e_appv t1 t2) (e_blame l1 b1).
Proof.
  introv Val Red.
  inductions Red; eauto.
  eapply sstep_nb.
  assert(wellformed (appvCtxL t2 )). eauto.
  forwards*: do_step H0 H.
  simpl. forwards*: IHRed.
  apply sstep_b.
  assert(wellformed (appvCtxL t2)). eauto.
  forwards*: blame_step H0 H.
Qed.

Lemma smulti_rred_app2 : forall t1 t2 t1' l b,
    lc_exp t2 -> ssteps t1 (e_exp t1') -> ssteps (e_app t1 l b t2) (e_exp (e_app t1' l b t2)).
Proof.
  introv Val Red.
  inductions Red; eauto.
  rewrite fill_app.
  rewrite fill_app.
  apply sstep_refl.
  apply do_step;eauto.
  assert(wellformed (appCtxL t2 l b)). eauto.
  forwards*: do_step H0 H.
Qed.

Lemma smulti_bblame_app2 : forall t1 t2 l1 b1 l2 b2,
    lc_exp t2 -> ssteps t1 (e_blame l1 b1) -> ssteps (e_app t1 l2 b2 t2) (e_blame l1 b1).
Proof.
  introv Val Red.
  inductions Red; eauto.
  eapply sstep_nb.
  assert(wellformed (appCtxL t2 l2 b2 )). eauto.
  forwards*: do_step H0 H.
  simpl. forwards*: IHRed.
  apply sstep_b.
  assert(wellformed (appCtxL t2 l2 b2 )). eauto.
  forwards*: blame_step H0 H.
Qed.

Lemma smulti_rred_anno : forall t t' A l b ,
ssteps t (e_exp t') -> ssteps (e_anno t l b A) (e_exp (e_anno t' l b A )).
Proof.
  introv Red.
  inductions Red; eauto.
  assert(wellformed (annoCtx l b A)). eauto.
  forwards*: do_step H0 H.
  assert(wellformed (annoCtx l b A)). eauto.
  forwards*: do_step H0 H.
Qed.

Lemma smulti_bblame_anno : forall t A l0 b0 l b,
    ssteps t (e_blame l b) -> ssteps (e_anno t l0 b0 A) (e_blame l b).
Proof.
  introv Red.
  inductions Red; eauto.
  eapply sstep_nb.
  assert(wellformed (annoCtx l0 b0 A)). eauto.
  forwards*: do_step H0 H.
  simpl. forwards*: IHRed.
  apply sstep_b.
  assert(wellformed (annoCtx l0 b0 A)). eauto.
  forwards*: blame_step H0 H.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the 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. *)

From CompCert Require Import Coqlib
                             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.

  Parameter t: Type.
  Parameter eq: t -> t -> Prop.
  Axiom eq_refl: forall x, eq x x.
  Axiom eq_sym: forall x y, eq x y -> eq y x.
  Axiom eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
  Parameter beq: t -> t -> bool.
  Axiom beq_correct: forall x y, beq x y = true -> eq x y.
  Parameter ge: t -> t -> Prop.
  Axiom ge_refl: forall x y, eq x y -> ge x y.
  Axiom ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Parameter bot: t.
  Axiom ge_bot: forall x, ge x bot.
  Parameter lub: t -> t -> t.
  Axiom ge_lub_left: forall x y, ge (lub x y) x.
  Axiom 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 SEMILATTICE.
  Parameter top: t.
  Axiom ge_top: forall x, ge top x.

End SEMILATTICE_WITH_TOP.

(** * Semi-lattice over maps *)

Set Implicit Arguments.

(** Given a semi-lattice (without 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 [L.bot].  Bottom elements are not smashed. *)

Module LPMap1(L: SEMILATTICE) <: SEMILATTICE.

Definition t := PTree.t L.t.

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

Definition set (p: positive) (v: L.t) (x: t) : t :=
  if L.beq v L.bot
  then PTree.remove p x
  else PTree.set p v x.

Lemma gsspec:
  forall p v x q,
  L.eq (get q (set p v x)) (if peq q p then v else get q x).
Proof.
  intros. unfold set, get.
  destruct (L.beq v L.bot) eqn:EBOT.
  rewrite PTree.grspec. unfold PTree.elt_eq. destruct (peq q p).
  apply L.eq_sym. apply L.beq_correct; auto.
  apply L.eq_refl.
  rewrite PTree.gsspec. destruct (peq q p); apply L.eq_refl.
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 := PTree.beq L.beq x y.

Lemma beq_correct: forall x y, beq x y = true -> eq x y.
Proof.
  unfold beq; intros; red; intros. unfold get.
  rewrite PTree.beq_correct in H. specialize (H p).
  destruct (x!p); destruct (y!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 : t := PTree.empty _.

Lemma get_bot: forall p, get p bot = L.bot.
Proof.
  unfold bot, get; 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.

(** 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 lub (x y: t) : t :=
  combine
    (fun a b =>
       match a, b with
       | Some u, Some v => Some (L.lub u v)
       | None, _ => b
       | _, None => a
       end)
    x y.

Lemma gcombine_bot:
  forall f t1 t2 p,
  f None None = None ->
  L.eq (get p (combine f t1 t2))
       (match f t1!p t2!p with Some x => x | None => L.bot end).
Proof.
  intros. unfold get. 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.
  unfold ge, lub; intros.
  eapply L.ge_trans. apply L.ge_refl. apply gcombine_bot; auto.
  unfold get. destruct x!p. destruct y!p.
  apply L.ge_lub_left.
  apply L.ge_refl. apply L.eq_refl.
  apply L.ge_bot.
Qed.

Lemma ge_lub_right:
  forall x y, ge (lub x y) y.
Proof.
  unfold ge, lub; intros.
  eapply L.ge_trans. apply L.ge_refl. apply gcombine_bot; auto.
  unfold get. destruct y!p. destruct x!p.
  apply L.ge_lub_right.
  apply L.ge_refl. apply L.eq_refl.
  apply L.ge_bot.
Qed.

End LPMap1.

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

Module LPMap(L: SEMILATTICE_WITH_TOP) <: SEMILATTICE_WITH_TOP.

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

Definition t: Type := t'.

Definition get (p: positive) (x: t) : L.t :=
  match x with
  | Bot => L.bot
  | 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 => Bot
  | Top_except m =>
      if L.beq v L.bot
      then Bot
      else Top_except (if L.beq v L.top then PTree.remove p m else PTree.set p v m)
  end.

Lemma gsspec:
  forall p v x q,
  x <> Bot -> ~L.eq v L.bot ->
  L.eq (get q (set p v x)) (if peq q p then v else get q x).
Proof.
  intros. unfold set. destruct x. congruence.
  destruct (L.beq v L.bot) eqn:EBOT.
  elim H0. apply L.beq_correct; auto.
  destruct (L.beq v L.top) eqn:ETOP; simpl.
  rewrite PTree.grspec. unfold PTree.elt_eq. destruct (peq q p).
  apply L.eq_sym. apply L.beq_correct; auto.
  apply L.eq_refl.
  rewrite PTree.gsspec. destruct (peq q p); apply L.eq_refl.
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, Bot => true
  | 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.
  apply 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.

Lemma get_bot: forall p, get p bot = L.bot.
Proof.
  unfold bot; intros; simpl. 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.

Module LM := LPMap1(L).

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, _ => y
  | _, Bot => x
  | Top_except m, Top_except n =>
      Top_except
        (LM.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 (LM.combine f t1 t2)))
       (match f t1!p t2!p with Some x => x | None => L.top end).
Proof.
  intros. simpl. generalize (LM.gcombine f H t1 t2 p). unfold LM.opt_eq.
  destruct ((LM.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.
  unfold ge, lub; intros. destruct x; destruct y.
  rewrite get_bot. apply L.ge_bot.
  rewrite get_bot. apply L.ge_bot.
  apply L.ge_refl. apply L.eq_refl.
  eapply L.ge_trans. apply L.ge_refl. apply gcombine_top; auto.
  unfold get. destruct t0!p. destruct t1!p.
  unfold opt_lub. destruct (L.beq (L.lub t2 t3) L.top) eqn:E.
  apply L.ge_top. apply L.ge_lub_left.
  apply L.ge_top.
  apply L.ge_top.
Qed.

Lemma ge_lub_right:
  forall x y, ge (lub x y) y.
Proof.
  unfold ge, lub; intros. destruct x; destruct y.
  rewrite get_bot. apply L.ge_bot.
  apply L.ge_refl. apply L.eq_refl.
  rewrite get_bot. apply L.ge_bot.
  eapply L.ge_trans. apply L.ge_refl. apply gcombine_top; auto.
  unfold get. destruct t0!p; destruct t1!p.
  unfold opt_lub. destruct (L.beq (L.lub t2 t3) L.top) eqn:E.
  apply L.ge_top. apply L.ge_lub_right.
  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 := (@eq_refl t).
Definition eq_sym: forall x y, eq x y -> eq y x := (@eq_sym t).
Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@eq_trans 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 := (@eq_refl t).
Definition eq_sym: forall x y, eq x y -> eq y x := (@eq_sym t).
Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@eq_trans 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.