From Coq Require Import ssreflect ssrbool ssrfun Eqdep_dec FunctionalExtensionality.
From mathcomp Require Import ssrnat eqtype seq.
From Dialectica Require Import Rlist.

Set Bullet Behavior "None".
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Open Scope seq_scope.

(** * Basic definitions *)

(** We shall allow universal and existential quantification over arbitrary inhabited types.
   The usual interpretation allows quantification over the natural numbers (and possibly
   functionals over the natural numbers), which are of course inhabited. *)

Record Inhabited := inhabit { ty :> Set; member : ty }.

(** The inhabited natural numbers. *)

Definition N := inhabit 0.

(** The inductive type [prp] is a "deep embedding" of the abstract syntax of
   the object language that we shall interpret into Coq. We admit only decidable primitive
   predicates, as is usual in the basic Dialectica variant.

   Our embedding allows us to express "exotic" propositional functions [p : ty -> prp] in
   which the logical structure of [p x] may depend on [x]. Because of this phenomenon we
   will be forced later on to introduce certain type dependencies where there are none in:
   the usual Dialectica interpretation. *)

Inductive prp : Type :=
  | atm : bool -> prp
  | pls (A B : prp)
  | tns (A B : prp)
  | bng (A : prp)
  | opp (A : prp)
  | unv : forall {ty : Inhabited}, (ty -> prp) -> prp.

Definition neg A := opp (bng A).
Definition wth A B := opp (pls (opp A) (opp B)).
Definition arr A B := opp (tns A (opp B)).
Definition ext {ty : Inhabited} (f: ty -> prp) : prp := opp (@unv ty (opp \o f)).
Definition whn A := opp (bng (opp A)).

(** Convenient notation for the object language. *)

Notation "'[' p ']'" := (atm p).
Notation "¬ x" := (neg x) (at level 70, no associativity).
Notation "x ＆ y" := (wth x y) (at level 74, left associativity).
Notation "x ⊕ y" := (pls x y) (at level 76, left associativity).
Notation "x ⊗ y" := (tns x y) (at level 76, left associativity).
Notation "x ⊸ y" := (arr x y) (at level 78, right associativity).
Notation "x ⇒ y" := (arr (bng x) y) (at level 78, right associativity).
Notation "! x" := (bng x) (at level 1, format "! x").
Notation "? x" := (whn x) (at level 1, format "? x").
Notation "∀ x : t , p" :=  (@unv t (fun x => p)) (at level 80, x at level 99).
Notation "∃ x : t , p" :=  (@ext t (fun x => p)) (at level 80, x at level 99).

(** With each proposition [p] we associate the types [W p] and [C p] of "witnesses" and
   "counters", respectively. Think of them as moves in a game between a player [W] and an
   opponent [C]. We make two changes to the standard Dialectica representation.

   First, we use sum for counters of conjunctions, where normally a product is used. This
   gives us symmetry between conjunction and disjunction, simplifies the notorious
   conjunction contraction [and_contr], but complicates the adjunction between implication
   and conjunction. Thomas Streicher pointed out that the change is inessential in the
   sense that we could prove a separate lemma which allows us to pass from counters for [p
   and q] as pairs to counters as elements of a sum (such a lemma relies in decidability
   of the [rel] relation defined below).

   Second, because we allow the structure of a propositional function to depend on the
   argument, we are forced to introduce type dependency into [W p] and [C p] when [p] is a
   quantified statement. This is not a big surprise, but what is a little more surprising
   is that the counters for existentials, [C (existential ty p')], involve a dependency
   not only on [ty] but also on [W (p' x)]. The dependency is needed in the rule
   [exists_elim]. The rest of Dialectica interpetation is not influenced by this change,
   with the exception of the Independence of Premise where we have to impose a condition
   that is not required in the usual interpretation.

   These type-dependencies clearly towards an even more type-dependent Dialectica variant.
   Indeed, we are going to investigate it in a separate file. For now we are just trying
   to faithfully represent the Dialectica interpretation. *)

Inductive ctx := ctx_intro of list ctx.

Fixpoint W (p : prp) : Type :=
  match p with
    | atm p => unit
    | pls p1 p2 => W p1 + W p2
    | tns p1 p2 => W p1 * W p2
    | bng p => W p
    | opp p => C p
    | unv ty p' => forall x : ty, W (p' x)
  end

with C p :=
  match p with
    | atm p => ctx
    | pls p1 p2 => C p1 * C p2
    | tns p1 p2 => (W p1 -> C p2) * (W p2 -> C p1)
    | bng p => Rlist.t (W p) (C p)
    | opp p => W p
    | unv ty p' => { x : ty & C (p' x) }
  end.

Notation "⊢ A" := (W A) (at level 89).
Notation "⊣ A" := (C A) (at level 89).

Fixpoint run {A : prp} : W A -> C A -> ctx.
Proof.
case: A=>//=.
- by move=>A B; case=>?[??]; [apply: (run A)|apply: (run B)].
- move=>??[u v][? hr].
  by apply: (run _ u (hr v)).
- by move=>? u z; apply/ctx_intro/(seq.map (run _ u))/(Rlist.run z u).
- by move=>A ??; apply: (run A).
by move=>? p ?[t ?]; apply: (run (p t)).
Defined.

(** The relation [rel p w c] is what is usually written as [p_D] in the Dialectica
   interpretation, i.e., the matrix of the interpreted formula.

   In terms of games, [rel p w c] tells whether the player move [w] wins against the
   opponent move [c] in the game determined by the proposition [p].
*)

Definition rel_bng {A} (R : forall x, W x -> C x -> Prop) (u : W A) (z : Rlist (W A) (C A)) :=
  Rlist.fold_right (fun x P u => R A u x /\ P u) (fun _ => True) z u.

Definition rel_bng_node {A} (R : forall x, W x -> C x -> Prop) (u : W A) (z : Rnode (W A) (C A)) :=
  Rlist.fold_right_node (fun x P u => R A u x /\ P u) (fun _ => True) z u.

Lemma rel_bng_simpl {A R} : forall (u : W A) (z : W A -> Rnode (W A) (C A)),
  rel_bng R u (Rlist.rnode z) = @rel_bng_node A R u (z u).
Proof. by []. Qed.

Lemma rel_bng_nil {A R}: forall (u : W A),
  rel_bng_node R u rnil = True.
Proof. by []. Qed.

Lemma rel_bng_cons {A R} : forall (u : W A) (x : C A) (z : Rlist (W A) (C A)),
  rel_bng_node R u (Rlist.rcons x z) = (R A u x /\ rel_bng R u z).
Proof. by []. Qed.

Lemma rel_bng_inv {A} {R : forall x, W x -> C x -> Prop} : forall (u : W A) (z : Rlist (W A) (C A)),
  (forall v : C A, @R (opp (opp A)) u v -> @R A u v) -> @rel_bng (opp (opp A)) R u z -> rel_bng R u z
with rel_bng_node_inv {A} {R : forall x, W x -> C x -> Prop} : forall (u : W A) (z : Rnode (W A) (C A)),
  (forall v : C A, @R (opp (opp A)) u v -> @R A u v) -> @rel_bng_node (opp (opp A)) R u z -> rel_bng_node R u z.
Proof.
- by move=>?[?]; apply: rel_bng_node_inv.
move=>?; case.
- by rewrite !rel_bng_nil.
move=>?? H.
by rewrite !rel_bng_cons; case=>??; split; [apply: H | apply: rel_bng_inv].
Qed.

Lemma rel_bng_cat {A R} : forall (u : W A) (zl zr : Rlist (W A) (C A)),
  rel_bng R u (cat zl zr) <-> rel_bng R u zl /\ rel_bng R u zr
with rel_bng_app_node {A R} : forall (u : W A) (nl : Rnode (W A) (C A)) (zr : Rlist (W A) (C A)),
  rel_bng_node R u (cat_node nl zr u) <-> rel_bng_node R u nl /\ rel_bng R u zr.
Proof.
- move=>/= ?[?]?.
  by rewrite !rel_bng_simpl; exact: rel_bng_app_node.
move=>u; case=>/=.
- by case=>r; rewrite rel_bng_nil rel_bng_simpl; split=>// [[]].
move=>???; rewrite !rel_bng_cons rel_bng_cat.
by apply: iff_sym; exact: and_assoc.
Qed.

Fixpoint rel (A : prp) : W A -> C A -> Prop :=
  match A return W A -> C A -> Prop with
    | atm p => fun _ _ => p
    | pls X Y => fun w z => match w with
                 | inl u => rel u z.1
                 | inr v => rel v z.2
                 end
    | tns X Y => fun w z => match w, z with
                 | (u, v), (zl, zr) => rel u (zr v) /\ rel v (zl u)
                 end
    | bng X => @rel_bng X rel
    | opp X => fun x u => ~ rel u x
    | unv T X => fun w z => match z with
                 | existT t u => rel (w t) u
                 end
  end.

(** The [rel] relation is decidable. *)

Definition relb_bng {A} (R : forall x, W x -> C x -> bool) (u : W A) (z : Rlist (W A) (C A)) :=
  Rlist.fold_right (fun x P u => R A u x && P u) (fun _ => true) z u.

Definition relb_bng_node {A} (R : forall x, W x -> C x -> bool) (u : W A) (z : Rnode (W A) (C A)) :=
  Rlist.fold_right_node (fun x P u => R A u x && P u) (fun _ => true) z u.

Lemma relb_bng_simpl {A R} : forall (u : W A) (z : W A -> Rnode (W A) (C A)),
  relb_bng R u (Rlist.rnode z) = @relb_bng_node A R u (z u).
Proof. by []. Qed.

Lemma relb_bng_nil {A R}: forall (u : W A),
  relb_bng_node R u rnil = true.
Proof. by []. Qed.

Lemma relb_bng_cons {A R} : forall (u : W A) (x : C A) (z : Rlist (W A) (C A)),
  relb_bng_node R u (Rlist.rcons x z) = R A u x && relb_bng R u z.
Proof. by []. Qed.

Fixpoint relb (A : prp) : W A -> C A -> bool :=
  match A return W A -> C A -> bool with
    | atm p => fun _ _ => p
    | pls X Y => fun w z => match w with
                 | inl u => relb u z.1
                 | inr v => relb v z.2
                 end
    | tns X Y => fun w z => match w, z with
                 | (u, v), (zl, zr) => relb u (zr v) && relb v (zl u)
                 end
    | bng X => @relb_bng X relb
    | opp X => fun x u => ~~ relb u x
    | unv T X => fun w z => match z with
                 | existT t u => relb (w t) u
                 end
  end.

Lemma relbngP (p : prp) (a : W p) (b : Rlist (W p) (C p)) :
  (forall c : C p, reflect (rel a c) (relb a c)) -> reflect (rel_bng rel a b) (relb_bng relb a b)
with relbngnodeP (p : prp) (a : W p) (b : Rnode (W p) (C p)) :
  (forall c : C p, reflect (rel a c) (relb a c)) -> reflect (rel_bng_node rel a b) (relb_bng_node relb a b).
Proof.
- move=>?; case: b=>?; rewrite rel_bng_simpl relb_bng_simpl.
  by apply: relbngnodeP.
move=>H; case: b.
- by rewrite rel_bng_nil relb_bng_nil; exact: ReflectT.
move=>??.
rewrite rel_bng_cons relb_bng_cons.
case: relbngP=>//; last by rewrite andbC /= =>?; apply: ReflectF; case.
move=>?; case: H=>/= ?; last by apply: ReflectF; case.
by apply: ReflectT.
Qed.

Theorem relP (p : prp) (a : W p) (b : C p) : reflect (rel a b) (relb a b).
Proof.
elim: p a b=>/=.
- by move=>? _ _; exact: idP.
- by move=>? H1 ? H2; case=>??; [exact: H1|exact: H2].
- move=>? H1 ? H2 [??][??] /=; case: H1=>/=; last by move=>?; apply: ReflectF; case.
  by case: H2=>??; [apply: ReflectT | apply: ReflectF; case].
- by move=>????; apply: relbngP.
- by move=>? H ??; case: H=>/= ?; [apply: ReflectF|apply: ReflectT].
by move=>?? H ?[??] /=; apply: H.
Qed.

(** Of course, a decidable proposition is stable for double negation. *)

Lemma rel_not_not {A} (u : W A) (x : C A) : ~ ~ rel u x -> rel u x.
Proof. by move/classicP=>H; apply/relP/H => /relP. Qed.

Lemma rel_bng_not_not {A} (u : W A) (v : Rlist (W A) (C A)) : ~ ~ rel_bng rel u v -> rel_bng rel u v.
Proof.
pose R:=relP u.
move/classicP=>H.
by apply: relbngP=>//; apply: H=>/relbngP; apply.
Qed.

Lemma rel_arr {A B}: forall (w : W (A ⊸ B)) (z : C (A ⊸ B)),
  rel w z <-> (rel z.1 (w.2 z.2) -> rel (w.1 z.1) z.2).
Proof.
move=>/= [??][??]; split=>/= H.
- by move=>?; apply: rel_not_not=>?; apply: H.
by move=>[?]; apply; apply: H.
Qed.

(** The predicate [valid p] is the Dialectica interpretation of [p]. It says that there is
   [w] such that [rel p w c] holds for any [c]. In terms of games semantics this means
   that [W] has a winning strategy (which amounts to a winning move [w]). *)

Structure Valid {X} (w : ⊢ X) := V { valid_spec : forall c : ⊣ X, rel w c }.

Definition app {X Y} : ⊢ X ⊸ Y -> ⊢ X -> ⊢ Y.
Proof. by move=>/= []. Defined.

Lemma Valid_app {X Y} : forall (f : ⊢ X ⊸ Y) x, Valid f -> Valid x -> Valid (app f x).
Proof.
move=>/=[??] x [Hf][?] /=; split=>b.
by move: (Hf (x,b)); rewrite rel_arr /=; apply.
Qed.

Definition identity {X} : ⊢ X ⊸ X.
Proof. by []. Defined.

Lemma Valid_id {X}: Valid (@identity X).
Proof. by split=>/= [[??]]; case. Qed.

Definition compose {X Y Z}: ⊢ X ⊸ Y -> ⊢ Y ⊸ Z -> ⊢ X ⊸ Z.
Proof.
move=>/=[fl fr][gl gr].
by split=>/=?; [apply/gl/fl|apply/fr/gr].
Defined.

Lemma Valid_compose {X Y Z}: forall (f : ⊢ X ⊸ Y) (g : ⊢ Y ⊸ Z),
  Valid f -> Valid g -> Valid (compose f g).
Proof.
move=>/=[fl ?][? gr][Hf][Hg]; split=>/= [[u z]].
move: (Hg (fl u, z)); move: (Hf (u, gr z)); rewrite !rel_arr /= =>H1 H2 [?]; apply.
by apply/H2/H1.
Qed.

Notation "t ; u" := (compose t u) (at level 60).

Lemma compose_id_l {X Y}: forall (f : ⊢ X ⊸ Y), identity; f = f.
Proof. by move=>/= []. Qed.

Lemma compose_id_r {X Y}: forall (f : ⊢ X ⊸ Y), f; identity = f.
Proof. by move=>/= []. Qed.

Lemma compose_assoc {P Q R S}: forall (f : ⊢ P ⊸ Q) (g : ⊢ Q ⊸ R) (h : ⊢ R ⊸ S),
  f; g; h = f; (g ; h).
Proof. by move=>/=[??][??][??]. Qed.

(** Tensoriality *)

Definition tns_fun {P Q R S}: ⊢ P ⊸ Q -> ⊢ R ⊸ S -> ⊢ P ⊗ R ⊸ Q ⊗ S.
Proof.
move=>/=[fl fr][gl gr]; split.
- by move=>[??]; split; [apply: fl|apply: gl].
by move=>[hl hr]; split=>?; [apply/gr/hl/fl|apply/fr/hr/gl].
Defined.

Lemma Valid_tns_fun {P Q R S}: forall (f : ⊢ P ⊸ Q) (g : ⊢ R ⊸ S),
  Valid f -> Valid g -> Valid (tns_fun f g).
Proof.
move=>/=[fl ?][gl ?][Hf][Hg]; split=>/=[[[u v][hl hr]]].
move: (Hf (u, hr (gl v))); move: (Hg (v, hl (fl u))); rewrite !rel_arr /= =>H1 H2 [[??]]; apply.
by split; [apply: H2|apply:H1].
Qed.

Definition tns_assoc {X Y Z} : ⊢ X ⊗ Y ⊗ Z ⊸ X ⊗ (Y ⊗ Z).
Proof.
split=>/=.
- by move=>[[??]?].
move=>[hl hr]; do!split.
- by move=>[??]; case: hl=>// +?; apply.
- by move=>?; case: hl=>// ?; apply.
by move=>?; apply: hr.
Defined.

Lemma Valid_tns_assoc {X Y Z}: Valid (@tns_assoc X Y Z).
Proof.
split=>/= [[[[u ?]?][hl ?]]] /=.
by case: (hl u)=>??[[[??]?]]; apply.
Qed.

Definition tns_comm {X Y} : ⊢ X ⊗ Y ⊸ Y ⊗ X.
Proof. by split=>/=; case. Defined.

Lemma Valid_tns_comm {X Y}: Valid (@tns_comm X Y).
Proof. by split=>/=[[[??][??]]][[??]]; apply. Qed.

Definition idl {X} : ⊢ [true] ⊗ X ⊸ X.
Proof.
split=>/=; first by case.
move=>?; split=>//.
by move=>_; exact: (ctx_intro [::]).
Defined.

Lemma Valid_idl {X}: Valid (@idl X).
Proof. by split=>/=[[[[]??]]][[]]. Qed.

(** *)

Definition lam {X Y Z}: ⊢ X ⊗ Y ⊸ Z -> ⊢ X ⊸ Y ⊸ Z.
Proof.
move=>/=[fl fr]; split.
- move=>?; split=>?; first by apply: fl.
  by case: fr=>// +?; apply.
by move=>[??]; case: fr=>// ?; apply.
Defined.

Lemma Valid_lam {X Y Z}: forall (f : ⊢ X ⊗ Y ⊸ Z), Valid f -> Valid (lam f).
Proof.
move=>/=[? fr][Hf].
split=>/=[[u [v z]]].
move: (Hf (u,v,z)); rewrite !rel_arr /=.
case: (fr z)=>?? H [?]; apply; case=>?; apply.
by apply: H.
Qed.

Lemma natural_lam {P Q R S}: forall (f : ⊢ P ⊸ Q) (g : ⊢ Q ⊗ R ⊸ S),
  f; lam g = lam (tns_fun f identity; g).
Proof.
move=>/=[??][? gr] /=; f_equal.
- apply: functional_extensionality=>?; f_equal.
  apply: functional_extensionality=>?; f_equal.
  by case: (gr _).
apply: functional_extensionality; case=>??; f_equal.
by case: (gr _).
Qed.

Definition eval {X Y} : ⊢ (X ⊸ Y) ⊗ X ⊸ Y.
Proof.
split=>/=.
- by move=>[[]].
by move=>?; do!split=>// [[?]]; apply.
Defined.

Lemma Valid_eval {X Y} : Valid (@eval X Y).
Proof.
split=>/= [[[[??]??]]][[H1 ?]?].
by apply: H1.
Qed.

(** Cartesian structure *)

Definition prd {X Y Z}: ⊢ Z ⊸ X -> ⊢ Z ⊸ Y -> ⊢ Z ⊸ X ＆ Y.
Proof.
move=>/=[fl fr][gl gr]; split.
- by move=>?; split; [apply: fl|apply: gl].
by case.
Defined.

Lemma Valid_prd {X Y Z}: forall (f : ⊢ Z ⊸ X) (g : ⊢ Z ⊸ Y),
  Valid f -> Valid g -> Valid (prd f g).
Proof.
move=>/=[fl ?][gl ?][Hf][Hg] /=; split.
case; rewrite -/W -/C =>z; case=>[x|y]; rewrite rel_arr /=.
- by move: (Hf (z,x)) => /= H ??; apply: H.
by move: (Hg (z,y)) => /= H ??; apply: H.
Qed.

Definition projl {X Y}: ⊢ X ＆ Y ⊸ X.
Proof. by split=>/=; [case|left]. Defined.

Lemma Valid_projl {X Y}: Valid (@projl X Y).
Proof. by split=>/=[[[??]?]][]. Qed.

Definition projr {X Y}: ⊢ X ＆ Y ⊸ Y.
Proof. by split=>/=; [case|right]. Defined.

Lemma Valid_projr {X Y}: Valid (@projr X Y).
Proof. by split=>/=[[[??]?]][]. Qed.

(** Exponentials *)

Definition whn_opp {X}: ⊢ ¬!X ⊸ ?(¬X).
Proof. by []. Defined.

Lemma Valid_whn_opp {X}: Valid (@whn_opp X).
Proof.
split=>/=[[??]][H]; apply=>?; apply: H.
apply: rel_bng_inv=>//= ?.
by apply: rel_bng_not_not.
Qed.

Definition bng_fun {X Y}: ⊢ X ⊸ Y -> ⊢ !X ⊸ !Y.
Proof.
move=>/=[fl fr]; split=>//.
by move=>?; apply/(Rlist.set fl)/(Rlist.map fr).
Defined.

Lemma rel_set_map {X Y} (fl : W X -> W Y) (fr : C Y -> C X) (u : W X) (g : Rlist (W Y) (C Y)) :
  (forall c : C (X ⊸ Y), @rel (X ⊸ Y) (fl,fr) c) ->
  rel_bng rel u (set fl (map fr g)) ->
  rel_bng rel (fl u) g
with relnode_set_map {X Y} (fl : W X -> W Y) (fr : C Y -> C X) (u : W X) (g : Rnode (W Y) (C Y)) :
  (forall c : C (X ⊸ Y), @rel (X ⊸ Y) (fl,fr) c) ->
  rel_bng_node rel u (set_node fl (map_node fr g)) ->
  rel_bng_node rel (fl u) g.
Proof.
- move=>?; case: g=>?/=; rewrite !rel_bng_simpl /=.
  by exact: relnode_set_map.
move=>H; case: g=>/=; first by rewrite !rel_bng_nil.
move=>x ?; rewrite !rel_bng_cons =>[[??]]; split.
- apply: rel_not_not=>?.
  by move: (H (u,x))=>/=; apply.
by apply: rel_set_map.
Qed.

Lemma Valid_bng_fun {X Y} : forall (f : ⊢ X ⊸ Y),
  Valid f -> Valid (bng_fun f).
Proof.
move=>/=[??][?]; split=>/= [[??]][?]; apply.
by apply: rel_set_map.
Qed.

Lemma compose_bng_fun {X Y Z} : forall (f : ⊢ X ⊸ Y) (g : ⊢ Y ⊸ Z),
  bng_fun (f; g) = bng_fun f; bng_fun g.
Proof.
move=>/=[??][??]/=; rewrite pair_equal_spec; split=>//.
by apply: functional_extensionality=>?; rewrite map_set set_set map_map.
Qed.

Lemma id_bng_fun {X}: bng_fun (@identity X) = identity.
Proof.
rewrite /identity /= pair_equal_spec; split=>//.
by apply: functional_extensionality=>?; rewrite map_id set_id.
Qed.

Definition bng_mon {X Y} : ⊢ !X ⊗ !Y ⊸ !(X ⊗ Y).
Proof.
split=>//= z; split.
- move=>u.
  apply: (set (fun v => (u,v))).
  apply: (map (fun '(fl,_) => fl u)).
  by exact: z.
move=>v.
apply: (set (fun u => (u,v))).
apply: (map (fun '(_,fr) => fr v)).
by exact: z.
Defined.

Lemma rel_set_map_pair {X Y} (u : W X) (v : W Y) (z : Rlist (W X * W Y) ((W X -> C Y) * (W Y -> C X))) :
  rel_bng rel v (set (fun v => (u,v)) (map (fun '(fl, _) => fl u) z)) ->
  rel_bng rel u (set (fun u => (u,v)) (map (fun '(_, fr) => fr v) z)) ->
  @rel_bng (X ⊗ Y) rel (u,v) z
with relnode_set_map_pair {X Y} (u : W X) (v : W Y) (z : Rnode (W X * W Y) ((W X -> C Y) * (W Y -> C X))) :
  rel_bng_node rel v (set_node (fun v => (u,v)) (map_node (fun '(fl, _) => fl u) z)) ->
  rel_bng_node rel u (set_node (fun u => (u,v)) (map_node (fun '(_, fr) => fr v) z)) ->
  @rel_bng_node (X ⊗ Y) rel (u,v) z.
Proof.
- case: z=>? /=; rewrite !rel_bng_simpl.
  by apply: relnode_set_map_pair.
case: z=>/=; first by rewrite !rel_bng_nil.
move=>[??]?; rewrite !rel_bng_cons=>[[??][??]]; split=>//=.
by apply: rel_set_map_pair.
Qed.

Lemma Valid_bng_mon {X Y} : Valid (@bng_mon X Y).
Proof.
split=>/=[[[??]?]][[??]]; apply.
by apply: rel_set_map_pair.
Qed.

Lemma natural_bng_mon {P Q R S}: forall (f : ⊢ P ⊸ R) (g : ⊢ Q ⊸ S),
  tns_fun (bng_fun f) (bng_fun g); bng_mon = bng_mon; bng_fun (tns_fun f g).
Proof.
move=>/=[??][??]/=; rewrite pair_equal_spec; split=>//.
apply: functional_extensionality=>?; rewrite pair_equal_spec.
by split;
(apply: functional_extensionality=>?;
 rewrite !map_set !set_set !map_map;
 do!f_equal; apply: functional_extensionality; case).
Qed.

Definition bng_true : ⊢ [true] ⊸ ![true].
Proof.
split=>//= z.
by apply/ctx_intro/(Rlist.run z tt).
Defined.

Lemma rel_tt (l : Rlist unit ctx): @rel_bng [true] rel tt l
with relnode_tt (n : Rnode unit ctx): @rel_bng_node [true] rel tt n.
Proof.
- case: l=>?; rewrite !rel_bng_simpl.
  by apply: relnode_tt.
case: n=>/=; first by rewrite !rel_bng_nil.
by move=>??; rewrite rel_bng_cons.
Qed.

Lemma Valid_bng_true : Valid bng_true.
Proof.
split=>/=[[[]?]][_]; apply.
by exact: rel_tt.
Qed.

Definition der {X} : ⊢ !X ⊸ X.
Proof.
split=>//= x.
by exact: (lift x).
Defined.

Lemma Valid_der {X} : Valid (@der X).
Proof.
split=>/= [[??]][].
by rewrite rel_bng_simpl rel_bng_cons; case.
Qed.

Lemma natural_der {X Y}: forall (f : ⊢ X ⊸ Y),
  der; f = bng_fun f; der.
Proof. by move=>/=[]. Qed.

Definition dig {X} : ⊢ !X ⊸ !!X.
Proof. by split=>//= ?; apply: concat. Defined.

Lemma rel_concat {X} (u : W X) (v : Rlist (W X) (Rlist (W X) (C X))) :
 rel_bng rel u (concat v) -> @rel_bng !X rel u v
with relnode_concat {X} (u : W X) (v : Rnode (W X) (Rlist (W X) (C X))) :
 rel_bng_node rel u (concat_node v u) -> @rel_bng_node !X rel u v.
Proof.
- case: v=>?/=; rewrite !rel_bng_simpl.
  by exact: relnode_concat.
case: v=>/=; first by rewrite !rel_bng_nil.
move=>[n]z/=; rewrite rel_bng_cons /= rel_bng_simpl.
case: (n u)=>/=.
- rewrite rel_bng_nil=>H; split=>//.
  case: z H=>? /=; rewrite rel_bng_simpl.
  by exact: relnode_concat.
move=>??; rewrite !rel_bng_cons=>[[?]] /rel_bng_cat [??]; do!split=>//.
by apply: rel_concat.
Qed.

Lemma Valid_dig {X} : Valid (@dig X).
Proof.
split=>/=[[??]][?]; apply.
by apply: rel_concat.
Qed.

Lemma natural_dig {X Y}: forall (f : ⊢ X ⊸ Y),
  dig; bng_fun (bng_fun f) = bng_fun f; dig.
Proof.
move=>/=[??]/=; rewrite pair_equal_spec; split=>//.
apply: functional_extensionality=>?.
by rewrite map_concat set_concat -map_map.
Qed.

Lemma dig_der_id_1 {X}: @dig X; der = identity.
Proof.
rewrite /= pair_equal_spec; split=>//.
apply: functional_extensionality=>[[?]] /=.
by under eq_rnode=>? do rewrite cat_id_r_node.
Qed.

Lemma dig_der_id_2 {X}: @dig X; bng_fun der = identity.
Proof.
rewrite /= pair_equal_spec; split=>//.
apply: functional_extensionality=>l.
by rewrite set_id; apply: concat_lift.
Qed.

Lemma dig_assoc {X}: @dig X; dig = dig; bng_fun dig.
Proof.
rewrite /= pair_equal_spec; split=>//.
apply: functional_extensionality=>?.
by rewrite set_id concat_map.
Qed.

Lemma der_mon {X Y}: @bng_mon X Y; der = tns_fun der der.
Proof.
rewrite /= pair_equal_spec; split;
by apply: functional_extensionality=>[[]].
Qed.

Lemma dig_mon {X Y}: @bng_mon X Y; dig = tns_fun dig dig; bng_mon; bng_fun bng_mon.
Proof.
rewrite /= pair_equal_spec; split; first by apply: functional_extensionality=>[[]].
apply: functional_extensionality=>?; rewrite pair_equal_spec; split;
by apply: functional_extensionality=>?; rewrite map_concat set_concat map_set !map_map set_id.
Qed.

Definition wkn {X} : ⊢ !X ⊸ [true].
Proof.
split=>//=.
move=>?; exact: nil.
Defined.

Lemma Valid_wkn {X} : Valid (@wkn X).
Proof. by split=>/= [[??]][]. Qed.

Lemma natural_wkn {X Y}: forall (f : ⊢ X ⊸ Y), bng_fun f; (@wkn Y) = wkn.
Proof. by move=>/=[]. Qed.

Definition dup {X} : ⊢ !X ⊸ !X ⊗ !X.
Proof.
split=>//= [[xl xr]].
by exact: (cat (collapse xl) (collapse xr)).
Defined.

Lemma Valid_dup {X} : Valid (@dup X).
Proof.
split=>/=[[u [xl xr]]][]; rewrite /collapse rel_bng_simpl.
case: (xl u)=>? /=.
rewrite rel_bng_simpl=>/rel_bng_app_node [?]; rewrite rel_bng_simpl.
by case: (xr u)=>??; apply.
Qed.

Lemma natural_dup {X Y}: forall (f : ⊢ X ⊸ Y),
  bng_fun f; dup = dup; tns_fun (bng_fun f) (bng_fun f).
Proof.
move=>/=[fl fr]/=; rewrite pair_equal_spec; split=>//.
apply: functional_extensionality=>[[xl xr]] /=; apply: eq_rnode=>r.
rewrite /collapse /= map_cat_node set_cat_node /=.
case: (xl (fl r))=>/= ?; f_equal; apply: eq_rnode=>q /=.
by case: (xr (fl q)).
Qed.

Lemma dig_comon {X}: @dig X; dup = dup; tns_fun dig dig.
Proof.
rewrite /= pair_equal_spec; split=>//.
apply: functional_extensionality=>[[fl fr]]/=.
apply: eq_rnode=>r; rewrite /collapse concat_cat_node /=.
case: (fl r)=>? /=; f_equal; apply: eq_rnode=>q.
by case: (fr q).
Qed.

Definition dup_mon_comm {P Q R S} : ⊢ (P ⊗ Q) ⊗ (R ⊗ S) ⊸ (P ⊗ R) ⊗ (Q ⊗ S).
Proof.
split=>/=.
- by move=>[[??][??]].
by move=>[zl zr]; split; move=>[??]; (split=>?; [case: zl| case: zr]=>//);
[move=>+?|move=>+?|move=>?|move=>?]; apply.
Defined.

Lemma dup_mon {X Y}:
  @bng_mon X Y; dup = tns_fun dup dup; dup_mon_comm; tns_fun bng_mon bng_mon.
Proof.
rewrite /= pair_equal_spec; split=>//.
- by apply: functional_extensionality=>[[]].
apply: functional_extensionality=>[[fl fr]]/=.
rewrite pair_equal_spec; split=>//;
apply: functional_extensionality=>u; apply: eq_rnode=>v;
rewrite /collapse /= map_cat_node set_cat_node /=.
- case: (fl (u,v))=>? /=; f_equal; apply: eq_rnode=>w /=.
  by case: (fr (u,w)).
case: (fl (v,u))=>? /=; f_equal; apply: eq_rnode=>w /=.
by case: (fr (w,u)).
Qed.

(** Quantifiers *)

Definition forall_intro {ty : Inhabited} (A : prp) (B : ty -> prp) :
  (forall x : ty, ⊢ A ⊸ B x) -> ⊢ A ⊸ ∀ x : ty, B x.
Proof.
move=>p; split=>/=.
- by move=>u ?; apply/app/u.
by move=>[x ?]; move: (p x)=>/=[?]; apply.
Defined.

Lemma Valid_forall_intro {ty A B f}:
  (forall t, Valid (f t)) -> Valid (@forall_intro ty A B f).
Proof.
move=>Hf; split=>/= [[u [x y]]]; move: (Hf x)=>[].
move: (f x)=>/=[??]H[? /= ?].
by apply: (H (u,y)).
Qed.

Definition forall_elim {ty : Inhabited} (t : ty) (A : ty -> prp) :
  ⊢ (∀ t : ty, A t) ⊸ A t.
Proof. by split=>//= ?; exists t. Defined.

Lemma Valid_forall_elim {ty t A}: Valid (@forall_elim ty t A).
Proof. by split=>/= [[??]][]. Qed.

Definition exists_intro {ty : Inhabited} (t : ty) (A : ty -> prp) :
  ⊢ A t ⊸ ∃ x : ty, A x.
Proof. by split=>//= ?; exists t. Defined.

Lemma Valid_exists_intro {ty t A} : Valid (@exists_intro ty t A).
Proof. by split=>/= [[??]][?]; apply. Qed.

(** This is the rule in which we need the dependency of counters in existential statements. *)

Definition exists_elim {ty : Inhabited} (A : prp) (B : ty -> prp)
                       (f : forall x : ty, ⊢ B x ⊸ A) :
  ⊢ (∃ x : ty, B x) ⊸ A.
Proof.
split=>/=.
- by move=>[x ?]; move: (f x)=>/= [+?]; apply.
by move=>? x; move: (f x)=>/= [?]; apply.
Defined.

Lemma Valid_exists_elim {ty A B f} :
  (forall x, Valid (f x)) -> Valid (@exists_elim ty A B f).
Proof.
move=>Hf; split=>/= [[[x v] u]]; move: (Hf x)=>[].
move: (f x)=>/= [??] H [??].
apply: (H (v,u)); split=>//.
by apply: rel_not_not.
Qed.

Lemma exists_id {ty : Inhabited} (A : ty -> prp) (B : prp) (t : ty)
                (f : forall t : ty, ⊢ A t ⊸ B) :
  @exists_intro ty t A; @exists_elim ty B A f = f t.
Proof. by move=>/=; move: (f t)=>/=[]. Qed.

Definition Exists_elim {ty : Inhabited} (A : prp) (B : ty -> prp)
                       (f : forall x : ty, ⊢ !(B x) ⊸ A) :
  ⊢ (∃ x : ty, !(B x)) ⊸ A.
Proof.
split=>/=.
- by move=>[x ?]; move: (f x)=>/=[+?]; apply.
by move=>? x; move: (f x)=>/=[?]; apply.
Defined.

Lemma Valid_Exists_elim {ty A B f}:
  (forall x, Valid (f x)) -> Valid (@Exists_elim ty A B f).
Proof.
move=>Hf; split=>/= [[[x v] u]]; move: (Hf x)=>[].
move: (f x)=>/=[??] H [??].
apply: (H (v,u)); split=>//.
by apply: rel_bng_not_not.
Qed.


Require Import Iron.Language.SystemF2Effect.Type.Operator.SubstTT.
Require Import Iron.Language.SystemF2Effect.Type.Operator.LiftTT.
Require Import Iron.Language.SystemF2Effect.Type.Relation.WfT.

(********************************************************************)
(* Type Enviroments *)
Definition tyenv := list ty.
Hint Unfold tyenv.

(* Lift type indices in type environments. *)
Definition liftTE d te    := map (liftTT 1 d) te.
Hint Unfold liftTE.

(* Substitution of types in type environments. *)
Definition substTE d t te := map (substTT d t) te.
Hint Unfold substTE.

(********************************************************************)
Lemma length_liftTE
 :  forall d te
 ,  length te = length (liftTE d te).
Proof.
 induction te; burn.
Qed.

Lemma liftTE_liftTE
 :  forall n n' te
 ,  liftTE n              (liftTE (n + n') te)
 =  liftTE (1 + (n + n')) (liftTE n te).
Proof.
 intros. induction te; rip.
  unfold liftTE.
  simpl. rewrite liftTT_liftTT_11.
  f_equal. burn.
Qed.

Lemma substTE_liftTE
 :  forall d te t2
 ,  substTE d t2 (liftTE d te) = te.
Proof.
 intros.
 unfold substTE. unfold liftTE.
 lists.
 induction te; simpl; burn.
Qed.

Lemma liftTE_substTE
 :  forall n n' t2 te
 ,  liftTE n (substTE (n + n') t2 te)
 =  substTE (1 + n + n') (liftTT 1 n t2) (liftTE n te).
Proof.
 intros. induction te; rip.
  unfold substTE. unfold liftTE.
   simpl. rewrite liftTT_substTT.
   unfold liftTE  in IHte.
   unfold substTE in IHte. rewrite IHte. auto.
Qed.

Lemma liftTE_closedT_id
 :  forall n se
 ,  Forall ClosedT se
 -> liftTE n se = se.
Proof.
 intros.
 unfold liftTE.
 induction se; rip.
  inverts H. snorm.
  rewritess.
  rrwrite (liftTT 1 n a = a).
  auto.
Qed.
Hint Resolve liftTE_closedT_id.

Lemma substTE_closedT_id
 :  forall n t2 se
 ,  Forall ClosedT se
 -> substTE n t2 se = se.
Proof.
 intros.
 unfold substTE.
 induction se; rip.
  inverts H. snorm.
  rewritess.
  rrwrite (substTT n t2 a = a).
  auto.
Qed.
Hint Resolve substTE_closedT_id.


(* --------------------------------------------------------------------
 * Copyright (c) - 2017--2021 - Xavier Allamigeon <xavier.allamigeon at inria.fr>
 * Copyright (c) - 2017--2021 - Ricardo D. Katz <katz@cifasis-conicet.gov.ar>
 * Copyright (c) - 2019--2021 - Pierre-Yves Strub <pierre-yves@strub.nu>
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint.
Require Import extra_misc.

Import Order.
Import Order.Theory.

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

Local Open Scope order_scope.

(* -------------------------------------------------------------------- *)
Section Misc.
Context (d : unit) (T : latticeType d).

Lemma leIU (x y : T) : meet x y <= join x y.
Proof. exact: (le_trans (leIl _ _) (leUl _ _)). Qed.
End Misc.

(* -------------------------------------------------------------------- *)
Module MeetBTFinMixin.
Section MeetBTFinMixin.
Context (d : unit) (T : finPOrderType d).

Record of_ := Build {
  top    : T;
  bottom : T;
  meet   : T -> T -> T;
  le_def : forall x y : T, x <= y = (meet x y == x);
  meetC  : commutative meet;
  meetA  : associative meet;
  meetxx : idempotent meet;
  le0x   : forall x, bottom <= x;
  lex1   : forall x, x <= top;
}.

Variable (m : of_).

Local Lemma meet1x : left_id (top m) (meet m).
Proof. by move=> x; rewrite (rwP eqP) meetC -le_def lex1. Qed.

Local Lemma meetx1 : right_id (top m) (meet m).
Proof. by move=> x; rewrite meetC meet1x. Qed.

Local Canonical meet_monoid := Monoid.Law (meetA m) meet1x meetx1.
Local Canonical meet_comoid := Monoid.ComLaw (meetC m).

Definition join (x y : T) : T :=
  \big[meet m/top m]_(z : T | (x <= z) && (y <= z)) z.

Lemma joinC : commutative join.
Proof. by move=> x y; apply: eq_bigl => z; rewrite andbC. Qed.

Lemma joinKI (y x : T) : meet m x (join x y) = x.
Proof.
rewrite (rwP eqP) -le_def /join; elim/big_ind: _.
+ by rewrite lex1.
+ by move=> x' y'; rewrite !(le_def m) meetA => /eqP-> /eqP->.
+ by move=> z /andP[].
Qed.

Lemma meetKU (y x : T) : join x (meet m x y) = x.
Proof.
rewrite /join (bigD1 x) /=; last first.
+ by rewrite !(le_def m) /= -meetA [meet _ y x]meetC meetA !meetxx !eqxx.
rewrite (rwP eqP) -le_def; elim/big_ind: _.
+ by rewrite lex1.
+ by move=> x' y'; rewrite !(le_def m) meetA => /eqP-> /eqP->.
+ by move=> z /andP[/andP[]].
Qed.

Lemma ge_joinL a b x : (x >= join a b) -> x >= a.
Proof.
rewrite /join => /(le_trans _); apply; elim: index_enum.
+ by rewrite big_nil lex1.
move=> y ys ih; rewrite big_cons; case: ifP => //.
case/andP=> le_ay _; rewrite !(le_def m) in le_ay, ih |- *.
by rewrite meetA (eqP le_ay) (eqP ih).
Qed.

Lemma ge_joinP a b x : (x >= join a b) = (x >= a) && (x >= b).
Proof.
apply/idP/andP; last first.
+ case=> le_ax le_bx; rewrite /join (bigD1 x) ?(le_ax, le_bx) //=.
  set y := (X in meet m x X); rewrite (le_def m) /=.
  by rewrite -meetA meetC -meetA meetxx meetC.
+ move=> h; split; first by apply: (ge_joinL h).
  by rewrite joinC in h; apply: (ge_joinL h).
Qed.

Lemma joinA : associative join.
Proof.
move=> y x z; pose P t := [&& x <= t, y <= t & z <= t].
rewrite [X in X = _]/join (eq_bigl P); last first.
+ by move=> t; rewrite ge_joinP andbCA.
apply/esym; rewrite [X in X = _]/join [in LHS](eq_bigl P) //.
+ by move=> t; rewrite ge_joinP -andbA andbCA.
Qed.

Definition latticeMixin : latticePOrderRelMixin T :=
  @LatticePOrderMixin d T (meet m) join
                      (meetC m) joinC (meetA m) joinA joinKI meetKU (le_def m).

Definition bottomMixin : bottomRelMixin T := @BottomMixin d T _ (le0x m).

Definition topMixin : topRelMixin T := @TopMixin d T _ (lex1 m).

End MeetBTFinMixin.

Module Exports.
Notation meetBTFinMixin := of_.
Notation MeetBTFinMixin := Build.
Coercion latticeMixin : meetBTFinMixin >-> latticePOrderRelMixin.
Coercion bottomMixin : meetBTFinMixin >-> bottomRelMixin.
Coercion topMixin : meetBTFinMixin >-> topRelMixin.
End Exports.
End MeetBTFinMixin.

(* -------------------------------------------------------------------- *)
Module GradedFinLattice.
Section ClassDef.

Record mixin_of d (T : finTBLatticeType d) := Mixin {
  rank : T -> nat;
  _ : rank bottom = 0%N;
  _ : forall x y : T, x < y -> (rank x < rank y)%N;
  _ : forall x y : T, x <= y -> ((rank x).+1 < rank y)%N -> exists z, x < z < y
}.

Record class_of (T : Type) := Class {
  base  : FinTBLattice.class_of T;
  mixin_disp : unit;
  mixin : mixin_of (FinTBLattice.Pack mixin_disp base)
}.

Local Coercion base : class_of >-> FinTBLattice.class_of.

Structure type (disp : unit) := Pack { sort; _ : class_of sort }.

Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (disp : unit) (cT : type disp).

Definition class := let: Pack _ c as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack disp T c.
Definition clone_with disp' c of phant_id class c := @Pack disp' T c.
Let xT := let: Pack T _ := cT in T.
Notation xclass := (class : class_of xT).

Definition pack disp0 (T0 : finTBLatticeType disp0) (m0 : mixin_of T0) :=
  fun bT b & phant_id (@FinTBLattice.class disp bT) b =>
  fun m    & phant_id m0 m => Pack disp (@Class T b disp0 m).

Definition eqType := @Equality.Pack cT xclass.
Definition choiceType := @Choice.Pack cT xclass.
Definition countType := @Countable.Pack cT xclass.
Definition finType := @Finite.Pack cT xclass.
Definition porderType := @POrder.Pack disp cT xclass.
Definition bPOrderType := @BPOrder.Pack disp cT xclass.
Definition tPOrderType := @TPOrder.Pack disp cT xclass.
Definition tbPOrderType := @TBPOrder.Pack disp cT xclass.
Definition finPOrderType := @FinPOrder.Pack disp cT xclass.
Definition finBPOrderType := @FinBPOrder.Pack disp cT xclass.
Definition finTPOrderType := @FinTPOrder.Pack disp cT xclass.
Definition finTBPOrderType := @FinTBPOrder.Pack disp cT xclass.
Definition meetSemilatticeType := @MeetSemilattice.Pack disp cT xclass.
Definition bMeetSemilatticeType := @BMeetSemilattice.Pack disp cT xclass.
Definition tMeetSemilatticeType := @TMeetSemilattice.Pack disp cT xclass.
Definition tbMeetSemilatticeType := @TBMeetSemilattice.Pack disp cT xclass.
Definition joinSemilatticeType := @JoinSemilattice.Pack disp cT xclass.
Definition bJoinSemilatticeType := @BJoinSemilattice.Pack disp cT xclass.
Definition tJoinSemilatticeType := @TJoinSemilattice.Pack disp cT xclass.
Definition tbJoinSemilatticeType := @TBJoinSemilattice.Pack disp cT xclass.
Definition latticeType := @Lattice.Pack disp cT xclass.
Definition bLatticeType := @BLattice.Pack disp cT xclass.
Definition tLatticeType := @TLattice.Pack disp cT xclass.
Definition tbLatticeType := @TBLattice.Pack disp cT xclass.
Definition finLatticeType := @FinLattice.Pack disp cT xclass.
Definition finTBLatticeType := @FinTBLattice.Pack disp cT xclass.
End ClassDef.

Module Exports.
Coercion base : class_of >-> FinTBLattice.class_of.
Coercion sort : type >-> Sortclass.
Coercion eqType : type >-> Equality.type.
Coercion choiceType : type >-> Choice.type.
Coercion countType : type >-> Countable.type.
Coercion finType : type >-> Finite.type.
Coercion porderType : type >-> POrder.type.
Coercion bPOrderType : type >-> BPOrder.type.
Coercion tPOrderType : type >-> TPOrder.type.
Coercion tbPOrderType : type >-> TBPOrder.type.
Coercion finPOrderType : type >-> FinPOrder.type.
Coercion finBPOrderType : type >-> FinBPOrder.type.
Coercion finTPOrderType : type >-> FinTPOrder.type.
Coercion finTBPOrderType : type >-> FinTBPOrder.type.
Coercion meetSemilatticeType : type >-> MeetSemilattice.type.
Coercion bMeetSemilatticeType : type >-> BMeetSemilattice.type.
Coercion tMeetSemilatticeType : type >-> TMeetSemilattice.type.
Coercion tbMeetSemilatticeType : type >-> TBMeetSemilattice.type.
Coercion joinSemilatticeType : type >-> JoinSemilattice.type.
Coercion bJoinSemilatticeType : type >-> BJoinSemilattice.type.
Coercion tJoinSemilatticeType : type >-> TJoinSemilattice.type.
Coercion tbJoinSemilatticeType : type >-> TBJoinSemilattice.type.
Coercion latticeType : type >-> Lattice.type.
Coercion bLatticeType : type >-> BLattice.type.
Coercion tLatticeType : type >-> TLattice.type.
Coercion tbLatticeType : type >-> TBLattice.type.
Coercion finLatticeType : type >-> FinLattice.type.
Coercion finTBLatticeType : type >-> FinTBLattice.type.
Canonical eqType.
Canonical choiceType.
Canonical countType.
Canonical finType.
Canonical porderType.
Canonical bPOrderType.
Canonical tPOrderType.
Canonical tbPOrderType.
Canonical finPOrderType.
Canonical finBPOrderType.
Canonical finTPOrderType.
Canonical finTBPOrderType.
Canonical meetSemilatticeType.
Canonical bMeetSemilatticeType.
Canonical tMeetSemilatticeType.
Canonical tbMeetSemilatticeType.
Canonical joinSemilatticeType.
Canonical bJoinSemilatticeType.
Canonical tJoinSemilatticeType.
Canonical tbJoinSemilatticeType.
Canonical latticeType.
Canonical bLatticeType.
Canonical tLatticeType.
Canonical tbLatticeType.
Canonical finLatticeType.
Canonical finTBLatticeType.
Notation gradedFinLatticeType  := type.
Notation gradedFinLatticeMixin := mixin_of.
Notation GradedFinLatticeMixin := Mixin.
Notation GradedFinLatticeType T m := (@pack T _ _ _ m _ _ id _ id).
Notation "[ 'gradedFinLatticeType' 'of' T 'for' cT ]" := (@clone T _ cT _ id)
  (at level 0, format "[ 'gradedFinLatticeType'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'gradedFinLatticeType' 'of' T 'for' cT 'with' disp ]" :=
  (@clone_with T _ cT disp _ id)
  (at level 0, format "[ 'gradedFinLatticeType'  'of'  T  'for'  cT  'with'  disp ]") :
  form_scope.
Notation "[ 'gradedFinLatticeType' 'of' T ]" := [gradedFinLatticeType of T for _]
  (at level 0, format "[ 'gradedFinLatticeType'  'of'  T ]") : form_scope.
Notation "[ 'gradedFinLatticeType' 'of' T 'with' disp ]" :=
  [gradedFinLatticeType of T for _ with disp]
  (at level 0, format "[ 'gradedFinLatticeType'  'of'  T  'with' disp ]") : form_scope.
End Exports.
End GradedFinLattice.
Export GradedFinLattice.Exports.

Section GradedDef.
Context {disp : unit}.
Local Notation gradedFinLatticeType := (gradedFinLatticeType disp).
Context {T : gradedFinLatticeType}.
Definition rank : T -> nat := GradedFinLattice.rank
  (GradedFinLattice.mixin (GradedFinLattice.class T)). (* FIXME *)
End GradedDef.

(* -------------------------------------------------------------------- *)
Section GradedTheory.
Context (d : unit) (L : gradedFinLatticeType d).

Lemma rank0 : rank (0 : L) = 0%N.
Proof. by case: L => [? [? ? []]]. Qed.

Lemma homo_rank : {homo (@rank d L) : x y / x < y >-> (x < y)%N}.
Proof. by case: L => [? [? ? []]]. Qed.

Lemma le_homo_rank : {homo (@rank d L) : x y / x <= y >-> (x <= y)%N}.
Proof. by apply: (ltW_homo homo_rank). Qed.

Lemma graded_rank (x y : L) : x <= y -> ((rank x).+1 < rank y)%N -> exists z, x < z < y.
Proof. by case: L x y => [? [? ? []]]. Qed.

Lemma rank_eq0 (x : L) : (rank x == 0) = (x == 0).
Proof.
apply/eqP/eqP=> [zrk|->]; last by rewrite rank0.
apply/contra_eq: zrk; rewrite -!(lt0x, lt0n).
by move/homo_rank; rewrite rank0.
Qed.

Lemma rank_eq1 (x : L) : (rank x == rank ((1 : L))%O) = (x == 1).
Proof.
apply/eqP/idP=> [eqrk|/eqP ->//].
have := lex1 x; rewrite le_eqVlt => /orP[] //.
by move/homo_rank; rewrite eqrk ltnn.
Qed.

Lemma rank_gt0 (x : L) : (0 < rank x)%N = (0 < x).
Proof.
apply/idP/idP => [gt0_rank|/homo_rank]; last by rewrite rank0.
by rewrite lt_neqAle le0x eq_sym -rank_eq0 andbT -lt0n.
Qed.

Lemma rank_le1 (x : L) : (rank x <= rank (1%O : L))%N.
Proof. by apply/le_homo_rank/lex1. Qed.

Lemma rank_gt1 (x : L) : (rank x < rank (1 : L)%O)%N = (x < 1).
Proof.
apply/idP/idP => [lt1_rank|/homo_rank //].
by rewrite lt_neqAle lex1 andbT -rank_eq1 ltn_eqF.
Qed.

Lemma rankI (x y : L) : (rank (x `&` y) <= minn (rank x) (rank y))%N.
Proof. by rewrite leq_min !le_homo_rank // (leIl, leIr). Qed.
End GradedTheory.

(* -------------------------------------------------------------------- *)
Section RankInd.
Context (d : unit) (L : gradedFinLatticeType d) (P : L -> Prop).

Hypothesis PH :
  forall x, (forall y, (rank y < rank x)%N -> P y) -> P x.

Lemma rank_ind x : P x.
Proof.
move: {2}(rank x) (leqnn (rank x)) => n; elim: n x => [|n ih] x.
+ by rewrite leqn0 rank_eq0 => /eqP->; apply: PH => y; rewrite rank0.
rewrite leq_eqVlt=> /orP[]; last by rewrite ltnS => /ih.
by move/eqP => rkx; apply: PH => y; rewrite rkx ltnS => /ih.
Qed.
End RankInd.

(* -------------------------------------------------------------------- *)
Section GradedRankS.
Context (d : unit) (L : gradedFinLatticeType d).

Lemma graded_rankS (x : L) :
  (0 < rank x)%N -> exists2 y : L, y < x & (rank y).+1 = rank x.
Proof.
rewrite lt0n rank_eq0 => nz_x; case/boolP: (rank x < 2)%N.
+ rewrite ltnS leq_eqVlt ltnS leqn0 rank_eq0 (negbTE nz_x) orbF.
  by move=> /eqP->; exists 0; rewrite ?(lt0x) // rank0.
rewrite -leqNgt => gt1_rkx; case: (graded_rank (le0x x)).
+ by rewrite rank0.
move=> y; move: {2}(rank x - rank y) (leqnn (rank x - rank y)).
move=> n; elim: n y => [|n ih] y.
+ rewrite leqn0  subn_eq0 => le_rk_xy.
  by case/andP=> _ /homo_rank; rewrite ltnNge le_rk_xy.
rewrite leq_eqVlt => /orP[]; last by rewrite ltnS => /ih.
move=> h; have {h}: rank x = ((rank y).+1 + n)%N.
+ have: rank x - rank y != 0 by rewrite (eqP h).
  rewrite subn_eq0 -ltnNge => lt_rk_yx.
  by rewrite addSnnS -(eqP h) addnC subnK // ltnW.
case: (n =P 0)%N => [{ih}-> rkxE /andP[_ lt_yx]|].
+ by exists y => //; rewrite rkxE addn0.
move=> /eqP nz_n rkxE /andP[gt0_y lt_yx]; case: (graded_rank (ltW lt_yx)).
+ by rewrite rkxE -[X in (X < _)%N]addn0 ltn_add2l lt0n.
move=> z /andP[lt_yz lt_zx]; case: (ih z).
+ by rewrite rkxE leq_subCl addnK; apply: homo_rank.
+ by rewrite (lt_trans gt0_y lt_yz) lt_zx.
by move=> t lt_tx <-; exists t.
Qed.
End GradedRankS.

(* -------------------------------------------------------------------- *)
Module OMorphism.
Section ClassDef.

Context (dL dG : unit) (L : latticeType dL) (G : latticeType dG).

Definition axiom (f : L -> G) :=
     {morph f : x y / meet x y}
  /\ {morph f : x y / join x y}.

Structure map (phLG : phant (L -> G)) := Pack {apply; _ : axiom apply}.
Local Coercion apply : map >-> Funclass.

Context (phLG : phant (L -> G)) (f g : L -> G) (cF : map phLG).

Definition class := let: Pack _ c as cF' := cF return axiom cF' in c.
Definition clone fA of phant_id g (apply cF) & phant_id fA class :=
  @Pack phLG f fA.
End ClassDef.

Module Exports.
Notation omorphism f := (axiom f).
Coercion apply : map >-> Funclass.
Notation OMorphism fM := (Pack (Phant _) fM).
Notation "{ 'omorphism' fLG }" := (map (Phant fLG))
  (at level 0, format "{ 'omorphism'  fLG }") : order_scope.
Notation "[ 'omorphism' 'of' f 'as' g ]" := (@clone _ _ _ f g _ _ idfun id)
  (at level 0, format "[ 'omorphism'  'of'  f  'as'  g ]") : form_scope.
Notation "[ 'omorphism' 'of' f ]" := (@clone _ _ _ f f _ _ id id)
  (at level 0, format "[ 'omorphism'  'of'  f ]") : form_scope.
End Exports.
End OMorphism.

Include OMorphism.Exports.

(* -------------------------------------------------------------------- *)
Section OMorphismP.
Context (dL dG : unit) (L : latticeType dL) (G : latticeType dG).

Lemma omorphismP (f : L -> G) :
     {morph f : x y / Order.meet x y}
  -> {morph f : x y / Order.join x y}
  -> omorphism f.
Proof. by move=> *; do! split. Qed.
End OMorphismP.

(* -------------------------------------------------------------------- *)
Section OMorphismTheory.
Context (dL dG : unit) (L : latticeType dL) (G : latticeType dG).
Context (f : {omorphism L -> G}).

Lemma omorphI : {morph f : x y / meet x y}.
Proof. by case: (OMorphism.class f). Qed.

Lemma omorphU : {morph f : x y / join x y}.
Proof. by case: (OMorphism.class f). Qed.

Lemma omorph_homo : {homo f : x y / x <= y}.
Proof. by move=> x y; rewrite !leEmeet -omorphI => /eqP->. Qed.

Lemma omorph_mono : injective f -> {mono f : x y / x <= y}.
Proof.
move=> inj_f x y; apply/idP/idP => [|/omorph_homo //].
by rewrite !leEmeet -omorphI => /eqP /inj_f ->.
Qed.
End OMorphismTheory.

(* -------------------------------------------------------------------- *)
Section OMorphismRank.
Context (dL dG : unit) (L : gradedFinLatticeType dL) (G : gradedFinLatticeType dG).

Lemma can_omorphism (f : L -> G) (g : G -> L) :
  cancel f g -> cancel g f -> omorphism f -> omorphism g.
Proof.
move=> fK gK [hD hM]; split.
+ by move=> x y; apply: (can_inj fK); rewrite gK hD !gK.
+ by move=> x y; apply: (can_inj fK); rewrite gK hM !gK.
Qed.

Lemma rank_morph (f : L -> G) x :
  omorphism f -> injective f -> (rank x <= rank (f x))%N.
Proof.
move=> morph_f inj_f; elim/rank_ind: x => x ih.
case: (x =P 0) => [->|]; first by rewrite rank0.
move/eqP; rewrite -rank_eq0 -lt0n => /graded_rankS.
case=> y lt_yx <-; apply: (leq_ltn_trans (ih _ _)).
+ by apply: homo_rank.
+ pose cf := OMorphism morph_f.
  by apply/homo_rank/(inj_homo_lt inj_f (omorph_homo cf)).
Qed.
End OMorphismRank.

(* -------------------------------------------------------------------- *)
Section OMorphismBijRank.
Context (dL dG : unit) (L : gradedFinLatticeType dL) (G : gradedFinLatticeType dG).

Lemma rank_morph_bij (f : L -> G) x :
  omorphism f -> bijective f -> rank (f x) = rank x.
Proof.
move=> morph_f bij_f; rewrite (rwP eqP) eqn_leq.
rewrite rank_morph // ?andbT; last by apply/bij_inj.
case: bij_f => g fK gK; pose morph_g := can_omorphism fK gK morph_f.
by apply: (leq_trans (rank_morph (f x) morph_g (can_inj gK))); rewrite fK.
Qed.
End OMorphismBijRank.

(* -------------------------------------------------------------------- *)
Section OMorphismComp.
Context (dL dG dH : unit).
Context (L : latticeType dL).
Context (G : latticeType dG).
Context (H : latticeType dH).
Context (fLG : {omorphism L -> G}) (fGH : {omorphism G -> H}).

Lemma comp_is_omorphism : omorphism (fGH \o fLG).
Proof. by apply/omorphismP=> x y /=; rewrite !(omorphI, omorphU). Qed.

Canonical comp_omorphism := OMorphism comp_is_omorphism.
End OMorphismComp.

(* -------------------------------------------------------------------- *)
Section OMorphismInv.
Context (dL dG : unit) (L : latticeType dL) (G : latticeType dG).
Context (f : L -> G) (fI : G -> L) (fK : cancel f fI) (Kf : cancel fI f).

Lemma inv_is_omorphism : omorphism f -> omorphism fI.
Proof. case=> hfI hfU; split=> x y.
+ by rewrite -{1}[x]Kf -{1}[y]Kf -hfI fK.
+ by rewrite -{1}[x]Kf -{1}[y]Kf -hfU fK.
Qed.
End OMorphismInv.

(* -------------------------------------------------------------------- *)
Module BOMorphism.
Section ClassDef.
Context (dL dG : unit) (L : bLatticeType dL) (G : bLatticeType dG).

Definition mixin_of (f : L -> G) := f 0 = 0.

Record class_of f : Prop := Class {base : omorphism f; mixin : mixin_of f}.
Local Coercion base : class_of >-> omorphism.

Structure map (phLG : phant (L -> G)) := Pack {apply; _ : class_of apply}.
Local Coercion apply : map >-> Funclass.
Variables (phLG : phant (L -> G)) (f g : L -> G) (cF : map phLG).

Definition class := let: Pack _ c as cF' := cF return class_of cF' in c.

Definition clone f0 of phant_id g (apply cF) & phant_id f0 class :=
  @Pack phLG f f0.

Definition pack (f0 : mixin_of f) :=
  fun (bF : OMorphism.map phLG) fO & phant_id (OMorphism.class bF) fO =>
  Pack phLG (Class fO f0).

Canonical omorphism := OMorphism.Pack phLG class.
End ClassDef.

Module Exports.
Notation bottom_compat f := (mixin_of f).
Notation bomorphism f := (class_of f).
Coercion base : bomorphism >-> OMorphism.axiom.
Coercion mixin : bomorphism >-> bottom_compat.
Coercion apply : map >-> Funclass.
Notation BOMorphism fM := (Pack (Phant _) fM).
Notation AddBOMorphism fM := (pack fM id).
Notation "{ 'bomorphism' fLG }" := (map (Phant fLG))
  (at level 0, format "{ 'bomorphism'  fLG }") : order_scope.
Notation "[ 'bomorphism' 'of' f 'as' g ]" := (@clone _ _ _ f g _ _ idfun id)
  (at level 0, format "[ 'bomorphism'  'of'  f  'as'  g ]") : form_scope.
Notation "[ 'bomorphism' 'of' f ]" := (@clone _ _ _ f f _ _ id id)
  (at level 0, format "[ 'bomorphism'  'of'  f ]") : form_scope.
Coercion omorphism : map >-> OMorphism.map.
Canonical omorphism.
End Exports.
End BOMorphism.

Include BOMorphism.Exports.

(* -------------------------------------------------------------------- *)
Section BOMorphismP.
Context (dL dG : unit) (L : bLatticeType dL) (G : bLatticeType dG).

Lemma bomorphismP (f : L -> G) :
     f 0 = 0
  -> {morph f : x y / Order.meet x y}
  -> {morph f : x y / Order.join x y}
  -> bomorphism f.
Proof. by move=> *; do! split. Qed.
End BOMorphismP.

(* -------------------------------------------------------------------- *)
Section BOMorphismTheory.
Context (dL dG : unit) (L : bLatticeType dL) (G : bLatticeType dG).
Context (f : {bomorphism L -> G}).

Lemma omorph0 : f 0 = 0.
Proof. by case: (BOMorphism.class f). Qed.
End BOMorphismTheory.

(* -------------------------------------------------------------------- *)
Section BOMorphismComp.
Context (dL dG dH : unit).
Context (L : bLatticeType dL).
Context (G : bLatticeType dG).
Context (H : bLatticeType dH).
Context (fLG : {bomorphism L -> G}) (fGH : {bomorphism G -> H}).

Lemma comp_is_bomorphism : bomorphism (fGH \o fLG).
Proof.
apply: bomorphismP => /=; first by rewrite !omorph0.
+ by apply: omorphI. + by apply: omorphU.
Qed.

Canonical comp_bomorphism := BOMorphism comp_is_bomorphism.
End BOMorphismComp.

(* -------------------------------------------------------------------- *)
Module TBOMorphism.
Section ClassDef.
Context (dL dG : unit) (L : tbLatticeType dL) (G : tbLatticeType dG).

Definition mixin_of (f : L -> G) := f 1 = 1.

Record class_of f : Prop := Class {base : bomorphism f; mixin : mixin_of f}.
Local Coercion base : class_of >-> bomorphism.

Structure map (phLG : phant (L -> G)) := Pack {apply; _ : class_of apply}.
Local Coercion apply : map >-> Funclass.
Variables (phLG : phant (L -> G)) (f g : L -> G) (cF : map phLG).

Definition class := let: Pack _ c as cF' := cF return class_of cF' in c.

Definition clone f1 of phant_id g (apply cF) & phant_id f1 class :=
  @Pack phLG f f1.

Definition pack (f1 : mixin_of f) :=
  fun (bF : BOMorphism.map phLG) fO & phant_id (BOMorphism.class bF) fO =>
  Pack phLG (Class fO f1).

Canonical omorphism := OMorphism.Pack phLG class.
Canonical bomorphism := BOMorphism.Pack phLG class.
End ClassDef.

Module Exports.
Notation top_compat f := (mixin_of f).
Notation tbomorphism f := (class_of f).
Coercion base : tbomorphism >-> BOMorphism.class_of.
Coercion mixin : tbomorphism >-> top_compat.
Coercion apply : map >-> Funclass.
Notation TBOMorphism fM := (Pack (Phant _) fM).
Notation AddTBOMorphism fM := (pack fM id).
Notation "{ 'tbomorphism' fLG }" := (map (Phant fLG))
  (at level 0, format "{ 'tbomorphism'  fLG }") : order_scope.
Notation "[ 'tbomorphism' 'of' f 'as' g ]" := (@clone _ _ _ f g _ _ idfun id)
  (at level 0, format "[ 'tbomorphism'  'of'  f  'as'  g ]") : form_scope.
Notation "[ 'tbomorphism' 'of' f ]" := (@clone _ _ _ f f _ _ id id)
  (at level 0, format "[ 'tbomorphism'  'of'  f ]") : form_scope.
Coercion omorphism : map >-> OMorphism.map.
Canonical omorphism.
Coercion bomorphism : map >-> BOMorphism.map.
Canonical bomorphism.
End Exports.
End TBOMorphism.

Include TBOMorphism.Exports.

(* -------------------------------------------------------------------- *)
Section TBOMorphismP.
Context (dL dG : unit) (L : tbLatticeType dL) (G : tbLatticeType dG).

Lemma tbomorphismP (f : L -> G) :
     f 0 = 0
  -> f 1 = 1
  -> {morph f : x y / Order.meet x y}
  -> {morph f : x y / Order.join x y}
  -> tbomorphism f.
Proof. by move=> *; do! split. Qed.
End TBOMorphismP.

(* -------------------------------------------------------------------- *)
Section TBOMorphismTheory.
Context (dL dG : unit) (L : tbLatticeType dL) (G : tbLatticeType dG).
Context (f : {tbomorphism L -> G}).

Lemma omorph1 : f 1 = 1.
Proof. by case: (TBOMorphism.class f). Qed.
End TBOMorphismTheory.

(* -------------------------------------------------------------------- *)
Section TBOMorphismComp.
Context (dL dG dH : unit).
Context (L : tbLatticeType dL).
Context (G : tbLatticeType dG).
Context (H : tbLatticeType dH).
Context (fLG : {tbomorphism L -> G}) (fGH : {tbomorphism G -> H}).

Lemma comp_is_tbomorphism : tbomorphism (fGH \o fLG).
Proof.
apply: tbomorphismP => /=; rewrite ?(omorph0, omorph1) //.
+ by apply: omorphI. + by apply: omorphU.
Qed.

Canonical comp_tbomorphism := TBOMorphism comp_is_tbomorphism.
End TBOMorphismComp.

(* -------------------------------------------------------------------- *)
Section BijOMorphismB.
Context (d : unit) (L G : bLatticeType d) (f : L -> G).

Lemma bij_omorphism_bomorphism : bijective f -> omorphism f -> bomorphism f.
Proof.
case=> [fI fK Kf] mF; case: (mF) => [hfI hfU]; apply/bomorphismP => //.
rewrite (rwP eqP) eq_le le0x andbT; have mFI := inv_is_omorphism fK Kf mF.
by rewrite -(omorph_mono (f := OMorphism mFI) (can_inj Kf)) /= fK le0x.
Qed.
End BijOMorphismB.

(* -------------------------------------------------------------------- *)
Section BijOMorphismTB.
Context (d : unit) (L G : tbLatticeType d) (f : L -> G).

Lemma bij_omorphism_tbomorphism : bijective f -> omorphism f -> tbomorphism f.
Proof.
case=> [fI fK Kf] mF; case: (mF) => [hfI hfU]; apply/tbomorphismP => //.
+ have mbF := bij_omorphism_bomorphism (Bijective fK Kf) mF.
  by have := (omorph0 (BOMorphism mbF)).
rewrite (rwP eqP) eq_le lex1 /=; have mFI := inv_is_omorphism fK Kf mF.
by rewrite -(omorph_mono (f := OMorphism mFI) (can_inj Kf)) /= fK lex1.
Qed.
End BijOMorphismTB.

(* -------------------------------------------------------------------- *)
Section LatticeClosed.
Context (d : unit) (L : latticeType d).

Definition lattice_closed (p : {pred L}) :=
  [/\ {in p &, forall x y, x `&` y \in p}
    & {in p &, forall x y, x `|` y \in p}].
End LatticeClosed.

(* -------------------------------------------------------------------- *)
Module LatticePred.
Structure lattice d (L : latticeType d) S :=
  Lattice { lattice_key : pred_key S; _ : @lattice_closed d L S }.

Section Extensionality.
Lemma lattice_ext d (G : latticeType d) S k (kS : @keyed_pred G S k) :
  lattice_closed kS -> lattice_closed S.
Proof.
case=> [hI hU]; split=> x y; rewrite -!(keyed_predE kS);
  by [apply hI | apply hU].
Qed.
End Extensionality.

Module Default.
Definition lattice d (L : latticeType d) S lctS :=
  @Lattice d L S (DefaultPredKey S) lctS.
End Default.

Module Exports.
Notation lattice_closed := lattice_closed.
Coercion lattice_key : lattice >-> pred_key.
Notation latticePred := lattice.
Definition LatticePred d (L : latticeType d) S k kS NkS :=
  Lattice k (@lattice_ext d L S k kS NkS).
End Exports.
End LatticePred.

Import LatticePred.Exports.

Module DefaultLatticePred.
Canonical LatticePred.Default.lattice.
End DefaultLatticePred.

Section LatticePredFacts.
Context (d : unit) (L : latticeType d) (S : {pred L}).
Context (ltcS : latticePred S) (kS : keyed_pred ltcS).

Lemma lpredIU : lattice_closed kS.
Proof.
split=> x y; rewrite !keyed_predE.
+ by case: ltcS => _ [h _]; apply: h.
+ by case: ltcS => _ [_ h]; apply: h.
Qed.

Lemma lpredI : {in kS &, forall x y, x `&` y \in kS}.
Proof. by case: lpredIU. Qed.

Lemma lpredU : {in kS &, forall x y, x `|` y \in kS}.
Proof. by case: lpredIU. Qed.
End LatticePredFacts.

(* -------------------------------------------------------------------- *)
Module SubLattices.
Section Def.
Context (d : unit) (V : latticeType d) (S : {pred V}).
Context (subS : latticePred S) (kS : keyed_pred subS).
Context (U : subType (mem kS)).

Let inU v Sv : U := Sub v Sv.

Let meetU (u1 u2 : U) := inU (lpredI (valP u1) (valP u2)).
Let joinU (u1 u2 : U) := inU (lpredU (valP u1) (valP u2)).

Fact meetC : commutative meetU.
Proof. by move=> x y; apply: val_inj; rewrite !SubK meetC. Qed.

Fact meetA : associative meetU.
Proof. by move=> x y z; apply: val_inj; rewrite !SubK meetA. Qed.

Fact joinC : commutative joinU.
Proof. by move=> x y; apply: val_inj; rewrite !SubK joinC. Qed.

Fact joinA : associative joinU.
Proof. by move=> x y z; apply: val_inj; rewrite !SubK joinA. Qed.

Fact joinKI (y x : U) : meetU x (joinU x y) = x.
Proof. by apply: val_inj; rewrite !SubK joinKI. Qed.

Fact meetKU (y x : U) : joinU x (meetU x y) = x.
Proof. by apply: val_inj; rewrite !SubK meetKU. Qed.

Fact le_def (x y : U) : (x <= y) = (meetU x y == x).
Proof. by rewrite -val_eqE !SubK -leEmeet leEsub. Qed.

Definition latticeMixin of phant U :=
  @LatticePOrderMixin d _ _ _ meetC joinC meetA joinA joinKI meetKU le_def.

Canonical sub_meetSemilatticeType :=
  Eval hnf in MeetSemilatticeType U (latticeMixin (Phant U)).

Canonical sub_joinSemilatticeType :=
  Eval hnf in JoinSemilatticeType U (latticeMixin (Phant U)).

(* FIXME: the head constant of (U : Type) is sub_sort. Thus, the above        *)
(*        declarations are redundant with Order.SubOrder.                     *)
(* Canonical sub_latticeType := [latticeType of U]. *)
End Def.

Module Exports.
Notation "[ 'latticeMixin' 'of' U 'by' <: ]" := (latticeMixin (Phant U))
  (at level 0, format "[ 'latticeMixin'  'of'  U  'by'  <: ]") : form_scope.
End Exports.
End SubLattices.

Import SubLattices.Exports.

(* -------------------------------------------------------------------- *)
Reserved Notation "'[< a ; b >]"
  (at level 2, a, b at level 8, format "''[<' a ;  b '>]'").

Reserved Notation "'[< a ; b >]_ R"
  (at level 2, a, b at level 8, format "''[<' a ;  b '>]_' R").

Section Interval.
Context (d : unit) (L : latticeType d).

Definition interval (a b : L) := fun x => a <= x <= b.

Notation "'[< a ; b >]" := (interval a b).

Lemma intervalP (a b x : L) :
  reflect (a <= x /\ x <= b) (x \in '[< a; b >]).
Proof. by apply: (iffP andP). Qed.

Lemma intervalPL (a b x : L) :
  x \in '[< a; b >] -> a <= x.
Proof. by case/intervalP. Qed.

Lemma intervalPR (a b x : L) :
  x \in '[< a; b >] -> x <= b.
Proof. by case/intervalP. Qed.

Lemma intervalE (a b x : L) :
  (x \in '[< a; b >]) = (a <= x <= b).
Proof. by []. Qed.

Lemma intervalL (a b : L) : a <= b -> a \in '[< a; b >].
Proof. by rewrite intervalE lexx. Qed.

Lemma intervalR (a b : L) : a <= b -> b \in '[< a; b >].
Proof. by rewrite intervalE lexx andbT. Qed.

Lemma interval_is_lclosed a b : lattice_closed (interval a b).
Proof.
split=> x y /intervalP[le_ax le_xb] /intervalP[le_ay le_yb].
+ by rewrite intervalE !lexI !(le_ax, le_ay) /= leIxl.
+ by rewrite intervalE !leUx (le_xb, le_yb) lexUl.
Qed.

Fact interval_key a b : pred_key (interval a b). Proof. by []. Qed.
Canonical interval_keyed a b := KeyedPred (interval_key a b).

Canonical interval_lclosed a b :=
  LatticePred (interval_is_lclosed a b).
End Interval.

(* -------------------------------------------------------------------- *)
Section IntervalLattice.
Context (d : unit) (L : latticeType d) (a b : L) (a_le_b : expose (a <= b)).

Inductive interval_of : predArgType :=
  Interval x & x \in interval a b.

Definition interval_val r := let: Interval x _ := r in x.

Canonical interval_subType := Eval hnf in [subType for interval_val].
Definition interval_eqMixin := Eval hnf in [eqMixin of interval_of by <:].
Canonical interval_eqType := Eval hnf in EqType interval_of interval_eqMixin.
Definition interval_choiceMixin := [choiceMixin of interval_of by <:].
Canonical interval_choiceType := Eval hnf in ChoiceType interval_of interval_choiceMixin.
Definition interval_porderMixin := [porderMixin of interval_of by <:].
Canonical interval_porderType := Eval hnf in POrderType d interval_of interval_porderMixin.

Let bottom := Interval (intervalL a_le_b).
Let top    := Interval (intervalR a_le_b).

Fact le0R x : bottom <= x.
Proof. by rewrite leEsub /=; case/intervalP: (valP x). Qed.

Fact leR1 x : x <= top.
Proof. by rewrite leEsub /=; case/intervalP: (valP x). Qed.

Definition interval_bottomMixin := BottomMixin le0R.
Definition interval_topMixin := TopMixin leR1.

Canonical interval_bPOrderType :=
  Eval hnf in BPOrderType interval_of interval_bottomMixin.
Canonical interval_tPOrderType :=
  Eval hnf in TPOrderType interval_of interval_topMixin.
Canonical interval_tbPOrderType := [tbPOrderType of interval_of].

Definition interval_latticeMixin := [latticeMixin of interval_of by <:].

Canonical interval_meetSemilatticeType :=
  Eval hnf in MeetSemilatticeType interval_of interval_latticeMixin.
Canonical interval_bMeetSemilatticeType :=
  [bMeetSemilatticeType of interval_of].
Canonical interval_tMeetSemilatticeType :=
  [tMeetSemilatticeType of interval_of].
Canonical interval_tbMeetSemilatticeType :=
  [tbMeetSemilatticeType of interval_of].

Canonical interval_joinSemilatticeType :=
  Eval hnf in JoinSemilatticeType interval_of interval_latticeMixin.
Canonical interval_bJoinSemilatticeType :=
  [bJoinSemilatticeType of interval_of].
Canonical interval_tJoinSemilatticeType :=
  [tJoinSemilatticeType of interval_of].
Canonical interval_tbJoinSemilatticeType :=
  [tbJoinSemilatticeType of interval_of].

Canonical interval_latticeType := [latticeType of interval_of].
Canonical interval_bLatticeType := [bLatticeType of interval_of].
Canonical interval_tLatticeType := [tLatticeType of interval_of].
Canonical interval_tbLatticeType := [tbLatticeType of interval_of].

Lemma interval_val_is_omorphism : omorphism interval_val.
Proof. by []. Qed.

Canonical interval_omorphism := OMorphism interval_val_is_omorphism.
End IntervalLattice.

Notation "'[< a ; b >]" := (interval_of a b).
Notation "'[< a ; b >]_ R" := (@interval_of _ R a b) (only parsing).

Global Instance expose_le0x (disp : unit) (L : bPOrderType disp) (x : L) :
  expose (0 <= x) := Expose (le0x x).
Global Instance expose_lex1 (disp : unit) (L : tPOrderType disp) (x : L) :
  expose (x <= 1) := Expose (lex1 x).

(* -------------------------------------------------------------------- *)
Section IntervalFinLattice.
Context (d : unit) (L : finLatticeType d) (a b : L) (a_le_b : expose (a <= b)).

Definition interval_countMixin := [countMixin of '[< a; b >] by <:].
Canonical interval_countType := Eval hnf in CountType '[< a; b >] interval_countMixin.
Canonical interval_subCountType := [subCountType of '[< a; b >]].

Definition interval_finMixin := [finMixin of '[< a; b >] by <:].
Canonical interval_finType := Eval hnf in FinType '[< a; b >] interval_finMixin.
Canonical interval_subFinType := [subFinType of '[< a; b >]].

Canonical interval_finPOrderType := Eval hnf in [finPOrderType of '[< a; b >]].
Canonical interval_finBPOrderType := Eval hnf in [finBPOrderType of '[< a; b >]].
Canonical interval_finTPOrderType := Eval hnf in [finTPOrderType of '[< a; b >]].
Canonical interval_finTBPOrderType := Eval hnf in [finTBPOrderType of '[< a; b >]].
Canonical interval_finLatticeType := Eval hnf in [finLatticeType of '[< a; b >]].
Canonical interval_finTBLatticeType := Eval hnf in [finTBLatticeType of '[< a; b >]].
End IntervalFinLattice.

(* -------------------------------------------------------------------- *)
Section IntervalGradedLattice.
Context (d : unit) (L : gradedFinLatticeType d) (a b : L) (a_le_b : expose (a <= b)).

Definition vrank (x : '[< a; b >]) := rank (val x) - rank a.

Lemma intv_rankL (x : '[< a; b >]) : (rank a <= rank (val x))%N.
Proof. by apply/(ltW_homo (@homo_rank _ _)); case/intervalP: (valP x). Qed.

Lemma intv_rankR (x : '[< a; b >]) : (rank (val x) <= rank b)%N.
Proof. by apply/(ltW_homo (@homo_rank _ _)); case/intervalP: (valP x). Qed.

Lemma vrank0 : vrank 0 = 0.
Proof. by rewrite /vrank subnn. Qed.

Lemma homo_intv_rank (x y : '[< a; b >]) : x < y -> (vrank x < vrank y)%N.
Proof.
rewrite ltEsub /vrank => /homo_rank h; rewrite ltn_sub2r //.
by rewrite (leq_trans _ h) // ltnS intv_rankL.
Qed.

Lemma graded_intv_rank (x y : '[< a; b >]) :
  x <= y -> ((vrank x).+1 < vrank y)%N -> exists z : '[< a; b >], x < z < y.
Proof.
rewrite /vrank -subSn ?intv_rankL // ltn_subLR; last first.
+ by rewrite (leq_trans (intv_rankL x)).
rewrite subnKC ?intv_rankL // => /graded_rank h /h [z rg_z].
exists (insubd (0 : '[< a; b >]) z).
rewrite !ltEsub /insubd insubT //= intervalE.
rewrite (le_trans (intervalPL (valP x))) //=; last by apply: ltW; case/andP: rg_z.
by rewrite (le_trans _ (intervalPR (valP y))) //= ltW //; case/andP: rg_z.
Qed.

Definition interval_gradedFinLatticeMixin :=
  GradedFinLatticeMixin vrank0 homo_intv_rank graded_intv_rank.
Canonical interval_gradedFinLatticeType :=
  Eval hnf in GradedFinLatticeType '[< a; b >] interval_gradedFinLatticeMixin.
End IntervalGradedLattice.

(* -------------------------------------------------------------------- *)
Section InIntvExpose.
Context (d : unit) (L : latticeType d) (a b : L).
Context (x : L) (hx0 : expose (a <= x)) (hx1 : expose (x <= b)).

Local Lemma in_interval : x \in interval a b.
Proof. by rewrite intervalE !(hx0, hx1). Qed.

Definition intv_inject := Interval in_interval.
End InIntvExpose.

Global Instance expose_ltW
  (disp : unit) (L : tbLatticeType disp) (x y : L) (h : expose (x < y))
: expose (x <= y)%O := Expose (ltW h).

Notation "x %:I_[< a ; b >]" := (@intv_inject _ _ a b x _ _)
  (at level 2, only parsing).

Notation "x %:I" := x%:I_[< _; _ >]
  (at level 2, format "x %:I").

(* -------------------------------------------------------------------- *)
Section IntvWiddenL.
Context (d : unit) (L : latticeType d) (a b : L).
Context (a' : L) (le_a : expose (a' <= a)) (x : '[< a; b >]).

Local Lemma in_intervalL : val x \in interval a' b.
Proof.
rewrite intervalE (intervalPR (valP x)) andbT.
by rewrite (le_trans le_a) // (intervalPL (valP x)).
Qed.

Definition intv_widdenL := Interval in_intervalL.
End IntvWiddenL.

Notation "x %:I_[< a <~ a' ; b >]" := (@intv_widdenL _ _ a b a' _ x)
 (at level 2, format "x %:I_[< a <~ a' ;  b >]").

Notation "x %:I_[< <~ a' ; >]" := (x %:I_[< _ <~ a' ;  _ >])
 (at level 2, format "x %:I_[<  <~  a' ;  >]").

(* -------------------------------------------------------------------- *)
Section IntvWiddenR.
Context (d : unit) (L : latticeType d) (a b : L).
Context (b' : L) (le_b : expose (b <= b')) (x : '[< a; b >]).

Local Lemma in_intervalR : val x \in interval a b'.
Proof.
rewrite intervalE (intervalPL (valP x)) /=.
by rewrite (le_trans _ le_b) // (intervalPR (valP x)).
Qed.

Definition intv_widdenR := Interval in_intervalR.
End IntvWiddenR.

Notation "x %:I_[< a ; b' ~> b >]" := (@intv_widdenR _ _ a b b' _ x)
 (at level 2, format "x %:I_[< a ;  b' ~> b  >]").

Notation "x %:I_[< ; b' ~> >]" := (x %:I_[< _ ; b' ~> _ >])
 (at level 2, format "x %:I_[<  ;  b' ~>  >]").

(* -------------------------------------------------------------------- *)
Section WiddenLMorph.
Context (d : unit) (L : latticeType d) (a b : L).
Context (a' : L) (le_b : expose (a' <= a)).

Let wd (z : '[< a; b >]) := z%:I_[< <~ a'; >].

Lemma widdenLI (z1 z2 : '[<a; b>]) : wd (z1 `&` z2) = wd z1 `&` wd z2.
Proof. by apply: val_inj. Qed.

Lemma widdenLU (z1 z2 : '[<a; b>]) : wd (z1 `|` z2) = wd z1 `|` wd z2.
Proof. by apply: val_inj. Qed.
End WiddenLMorph.

(* -------------------------------------------------------------------- *)
Section WiddenRMorph.
Context (d : unit) (L : latticeType d) (a b : L).
Context (b' : L) (le_b : expose (b <= b')).

Let wd (z : '[< a; b >]) := z%:I_[< ; b' ~> >].

Lemma widdenRI (z1 z2 : '[<a; b>]) : wd (z1 `&` z2) = wd z1 `&` wd z2.
Proof. by apply: val_inj. Qed.

Lemma widdenRU (z1 z2 : '[<a; b>]) : wd (z1 `|` z2) = wd z1 `|` wd z2.
Proof. by apply: val_inj. Qed.
End WiddenRMorph.

(* -------------------------------------------------------------------- *)
Section IntvRankE.
Context (d : unit) (L : gradedFinLatticeType d) (a b : L) (le_ab: expose (a <= b)).
Context (x : '[< a ; b >]).

Lemma intv_rankE : rank x = (rank (val x) - rank a)%N.
Proof. by []. Qed.
End IntvRankE.

(* -------------------------------------------------------------------- *)
Section FullIntvMorphism.
Context (d : unit) (L : tbLatticeType d).

Let ival := (@val L _ [subType of '[< 0%O; 1%O >]_L]).

Lemma bij_full_intv_val : bijective ival.
Proof.
exists (insubd (0%O : '[< 0%O; 1%O >]_L)); first by apply: valKd.
by move=> x; apply: insubdK; rewrite intervalE le0x lex1.
Qed.

Lemma omorph_full_intv_val : tbomorphism ival.
Proof. by apply/tbomorphismP. Qed.
End FullIntvMorphism.

(* -------------------------------------------------------------------- *)
Section Atomic.
Context (d : unit) (L : finTBLatticeType d).

Definition atom (a : L) :=
  (0 < a) && ~~ [exists x : L, 0 < x < a].

Definition coatom (a : L) :=
  (a < 1) && ~~ [exists x : L, a < x < 1].

Definition atomistic (a : L) :=
  [exists S : {set L},
     [forall x in S, atom x] && (a == \join_(x in S) x)].

Definition coatomistic (a : L) :=
  [exists S : {set L},
     [forall x in S, coatom x] && (a == \meet_(x in S) x)].
End Atomic.

(* -------------------------------------------------------------------- *)
Section CoatomAtom.
Lemma coatom_atom (d : unit) (L : finTBLatticeType d) (a : L) :
  coatom a -> atom (a : L^d).
Proof.
case/andP=> gt0_a /existsPn h; apply/andP.
split; first by apply: gt0_a.
by apply/existsPn => /= x; rewrite andbC h.
Qed.

Lemma coatom_atom_V (d : unit) (L : finTBLatticeType d) (a : L) :
  coatom (a : L^d) -> atom a.
Proof. exact/coatom_atom. Qed.
End CoatomAtom.

(* -------------------------------------------------------------------- *)
Section AtomCoatom.
Lemma atom_coatom (d : unit) (L : finTBLatticeType d) (a : L) :
  atom a -> coatom (a : L^d).
Proof.
case/andP=> gt0_a /existsPn h; apply/andP.
split; first by apply: gt0_a.
by apply/existsPn => /= x; rewrite andbC h.
Qed.

Lemma atom_coatom_V (d : unit) (L : finTBLatticeType d) (a : L) :
  atom (a : L^d) -> coatom a.
Proof. exact/atom_coatom. Qed.
End AtomCoatom.

(* -------------------------------------------------------------------- *)
Section AtomicTheory.
Context (d : unit) (L : finTBLatticeType d).

Lemma atomP (a : L) : 0 < a ->
  reflect (forall x, x != 0 -> ~ (x < a)) (atom a).
Proof.
move=> gt0_a; apply: (iffP andP).
+ case=> _ /existsPn h x nz_x; move/(_ x): h.
  by rewrite negb_and lt_neqAle eq_sym nz_x le0x /= (rwP negP).
+ move=> ata; split=> //; apply/negP => /existsP[x].
  by case/andP=> gt0_x; apply/ata; rewrite gt_eqF.
Qed.

Lemma atom0n : ~ (atom (0 : L)).
Proof. by case/andP; rewrite ltxx. Qed.

Lemma atomisticP (a : L) :
  reflect
    (exists2 S : {set L},
       (forall x, x \in S -> atom x) & a = \join_(x in S) x)
    (atomistic a).
Proof. apply: (iffP idP).
+ case/existsP=> /= S /andP[/forallP h /eqP->].
  by exists S=> // x; have/implyP := h x.
+ case=> S atx ->; apply/existsP; exists S; apply/andP; split=> //.
  by apply/forallP => x; apply/implyP=> /atx.
Qed.
End AtomicTheory.

(* -------------------------------------------------------------------- *)
Section CoatomicTheory.
Context (d : unit) (L : finTBLatticeType d).

Lemma coatom1n : ~ (coatom (1 : L)).
Proof. by move=> /coatom_atom /atom0n. Qed.

Lemma coatomP (a : L) : a < 1 ->
  reflect (forall x, x != 1 -> ~ (a < x)) (coatom a).
Proof.
move=> gt1_a; apply: (iffP idP).
+ by move/coatom_atom/atomP=> -/(_ gt1_a); apply.
move=> h; apply/atom_coatom_V/andP; split.
- by apply: gt1_a.
apply/existsPn=> /= x; apply/negP=> /andP[gt0_x].
by move/h; apply; rewrite lt_eqF.
Qed.

Lemma coatomisticP (a : L) :
  reflect
    (exists2 S : {set L},
       (forall x, x \in S -> coatom x) & a = \meet_(x in S) x)
    (coatomistic a).
Proof.
apply: (iffP existsP) => /= -[S].
+ move=> /andP [/forallP h /eqP->]; exists S => //.
  by move=> x; move/(_ x): h => /implyP.
+ move=> h ->; exists S; rewrite eqxx andbT.
  by apply/forallP=> x; apply/implyP=> /h.
Qed.
End CoatomicTheory.

(* -------------------------------------------------------------------- *)
Section GradedAtomicTheory.
Context (d : unit) (L : gradedFinLatticeType d).

Lemma atomE (a : L) : (atom a) = (rank a == 1%N).
Proof.
apply/idP/eqP.
+ case: (posxP a) => [-> /atom0n //|gt0_a /atomP -/(_ gt0_a) h].
  rewrite (rwP eqP) eqn_leq rank_gt0 gt0_a andbT.
  rewrite leqNgt; apply/negP; rewrite -[0%N](@rank0 _ L).
  by case/(graded_rank (le0x _)) => x /andP[]; rewrite lt0x => /h.
+ move=> eq1_rk; have gt0_a: 0 < a by rewrite -rank_gt0 eq1_rk.
  apply/atomP=> // x nz_x /homo_rank; rewrite eq1_rk ltnS.
  by rewrite leqn0 rank_eq0 (negbTE nz_x).
Qed.
End GradedAtomicTheory.
(* -------------------------------------------------------------------- *)
Section GradedCoAtomicTheory.
Context (d : unit) (L : gradedFinLatticeType d).

Lemma coatomE (a : L) : (coatom a) = (rank (1 : L) == (rank a).+1%N).
Proof.
apply/idP/eqP.
+ have := lex1 a; rewrite le_eqVlt => /orP[/eqP-> /coatom1n //|].
  move=> lt1_a /coatomP -/(_ lt1_a) h; move/homo_rank: lt1_a.
  rewrite (rwP eqP) eqn_leq => ->; rewrite andbT leqNgt.
  apply/negP => /(graded_rank (lex1 _)) [x].
  by rewrite andbC lt_neqAle -andbA => /and3P[/h].
+ move=> h; have lt1_a: a < 1 by rewrite -rank_gt1 h.
  apply/coatomP=> // x neq1_x /homo_rank; rewrite -ltnS -h.
  by apply/negP; rewrite -leqNgt rank_gt1 lt_neqAle neq1_x lex1.
Qed.
End GradedCoAtomicTheory.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* $Id: LegacyArithRing.v 14641 2011-11-06 11:59:10Z herbelin $ *)

(* Instantiation of the Ring tactic for the naturals of Arith $*)

Require Import Bool.
Require Export LegacyRing.
Require Export Arith.
Require Import Eqdep_dec.

Open Local Scope nat_scope.

Unboxed Fixpoint nateq (n m:nat) {struct m} : bool :=
  match n, m with
  | O, O => true
  | S n', S m' => nateq n' m'
  | _, _ => false
  end.

Lemma nateq_prop : forall n m:nat, Is_true (nateq n m) -> n = m.
Proof.
  simple induction n; simple induction m; intros; try contradiction.
  trivial.
  unfold Is_true in H1.
  rewrite (H n1 H1).
  trivial.
Qed.

Hint Resolve nateq_prop: arithring.

Definition NatTheory : Semi_Ring_Theory plus mult 1 0 nateq.
  split; intros; auto with arith arithring.
(*  apply (fun n m p:nat => plus_reg_l m p n) with (n := n).
  trivial.*)
Defined.

Add Legacy Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ].

Goal forall n:nat, S n = 1 + n.
intro; reflexivity.
Save S_to_plus_one.

(* Replace all occurrences of (S exp) by (plus (S O) exp), except when
   exp is already O and only for those occurrences than can be reached by going
   down plus and mult operations  *)
Ltac rewrite_S_to_plus_term t :=
  match constr:t with
  | 1 => constr:1
  | (S ?X1) =>
      let t1 := rewrite_S_to_plus_term X1 in
      constr:(1 + t1)
  | (?X1 + ?X2) =>
      let t1 := rewrite_S_to_plus_term X1
      with t2 := rewrite_S_to_plus_term X2 in
      constr:(t1 + t2)
  | (?X1 * ?X2) =>
      let t1 := rewrite_S_to_plus_term X1
      with t2 := rewrite_S_to_plus_term X2 in
      constr:(t1 * t2)
  | _ => constr:t
  end.

(* Apply S_to_plus on both sides of an equality *)
Ltac rewrite_S_to_plus :=
  match goal with
  |  |- (?X1 = ?X2) =>
      try
       let t1 :=
       (**)  (**)
       rewrite_S_to_plus_term X1
       with t2 := rewrite_S_to_plus_term X2 in
       change (t1 = t2) in |- *
  |  |- (?X1 = ?X2) =>
      try
       let t1 :=
       (**)  (**)
       rewrite_S_to_plus_term X1
       with t2 := rewrite_S_to_plus_term X2 in
       change (t1 = t2) in |- *
  end.

Ltac ring_nat := rewrite_S_to_plus; ring.


Require Export D.

Theorem loop_never_stops : forall st st',
  ~(st =[ loop ]=> st').
Proof.
  exact FILL_IN_HERE.
Qed.


From Hammer Require Import Hammer.

Require Import Coq.Strings.String.
From VFA Require Import Perm.
Require Import FunctionalExtensionality.

From VFA Require Import Maps.

Module SectionExample1.
Definition mymap (V: Type) := list (nat*V).
Definition empty (V: Type) : mymap V := nil.
Fixpoint lookup (V: Type) (default: V) (x: nat) (m: mymap V) : V :=
match m with
| (a,v)::al => if x =? a then v else lookup V default x al
| nil => default
end.
Theorem lookup_empty (V: Type) (default: V):
forall x, lookup V default x (empty V) = default.
Proof. hammer_hook "SearchTree" "SearchTree.SectionExample1.lookup_empty". reflexivity. Qed.
End SectionExample1.

Module SectionExample2.
Section MAPS.
Variable V : Type.
Variable default: V.

Definition mymap  := list (nat*V).
Definition empty : mymap := nil.
Fixpoint lookup (x: nat) (m: mymap) : V :=
match m with
| (a,v)::al => if x =? a then v else lookup x al
| nil => default
end.
Theorem lookup_empty:
forall x, lookup x empty = default.
Proof. hammer_hook "SearchTree" "SearchTree.SectionExample2.lookup_empty". reflexivity. Qed.
End MAPS.
End SectionExample2.

Goal SectionExample1.empty = SectionExample2.empty.
Proof. reflexivity.
Qed.

Goal SectionExample1.lookup = SectionExample2.lookup.
Proof.
unfold SectionExample1.lookup, SectionExample2.lookup.
try reflexivity.

extensionality V; extensionality default; extensionality x.
extensionality m; simpl.
induction m as [| [? ?] ]; auto.
destruct (x=?n); auto.
Qed.

Section TREES.
Variable V : Type.
Variable default: V.

Definition key := nat.

Inductive tree : Type :=
| E : tree
| T: tree -> key -> V -> tree -> tree.

Definition empty_tree : tree := E.

Fixpoint lookup (x: key) (t : tree) : V :=
match t with
| E => default
| T tl k v tr => if x <? k then lookup x tl
else if k <? x then lookup x tr
else v
end.

Fixpoint insert (x: key) (v: V) (s: tree) : tree :=
match s with
| E => T E x v E
| T a y v' b => if  x <? y then T (insert x v a) y v' b
else if y <? x then T a y v' (insert x v b)
else T a x v b
end.

Fixpoint elements' (s: tree) (base: list (key*V)) : list (key * V) :=
match s with
| E => base
| T a k v b => elements' a ((k,v) :: elements' b base)
end.

Definition elements (s: tree) : list (key * V) := elements' s nil.

Section EXAMPLES.
Variables v2 v4 v5 : V.
Eval compute in insert 5 v5 (insert 2 v2 (insert 4 v5 empty_tree)).

Eval compute in lookup 5 (T (T E 2 v2 E) 4 v5 (T E 5 v5 E)).

Eval compute in lookup 3 (T (T E 2 v2 E) 4 v5 (T E 5 v5 E)).

Eval compute in elements (T (T E 2 v2 E) 4 v5 (T E 5 v5 E)).

End EXAMPLES.

Check t_update_eq.
Check t_update_neq.
Check t_update_shadow.
Check t_update_same.
Check t_update_permute.
Check t_apply_empty.

Definition example_tree (v2 v4 v5 : V) :=
T (T E 2 v2 E) 4 v4 (T E 5 v5 E).

Definition example_map (v2 v4 v5: V) : total_map V
. Admitted.

Definition combine {A} (pivot: key) (m1 m2: total_map A) : total_map A :=
fun x => if x <? pivot  then m1 x else m2 x.

Inductive Abs:  tree -> total_map V -> Prop :=
| Abs_E: Abs E (t_empty default)
| Abs_T: forall a b l k v r,
Abs l a ->
Abs r b ->
Abs (T l k v r)  (t_update (combine k a b) k v).

Lemma check_example_map:
forall v2 v4 v5, Abs (example_tree v2 v4 v5) (example_map v2 v4 v5).
Proof. hammer_hook "SearchTree" "SearchTree.check_example_map".
intros.
unfold example_tree.
evar (m: total_map V).
replace (example_map v2 v4 v5) with m; subst m.
repeat constructor.
extensionality x.

Admitted.

Lemma check_too_clever: forall v2 v4 v5: V, True.
Proof. hammer_hook "SearchTree" "SearchTree.check_too_clever".
intros.
evar (m: total_map V).
assert (Abs (example_tree v2 v4 v5) m).
repeat constructor.
(change m with (example_map v2 v4 v5) in H || auto);

fail "Did you use copy-and-paste, from your check_example_map proof,
into your example_map definition?  If so, very clever.
Please try it again with an example_map definition that
you make up from first principles.  Or, to skip that,
uncomment the (* auto; *) above.".
Qed.

Theorem empty_tree_relate: Abs empty_tree (t_empty default).
Proof. hammer_hook "SearchTree" "SearchTree.empty_tree_relate".
constructor.
Qed.

Theorem lookup_relate:
forall k t cts ,
Abs t cts -> lookup k t =  cts k.
Proof. hammer_hook "SearchTree" "SearchTree.lookup_relate".
Admitted.

Theorem insert_relate:
forall k v t cts,
Abs t cts ->
Abs (insert k v t) (t_update cts k v).
Proof. hammer_hook "SearchTree" "SearchTree.insert_relate".
Admitted.

Fixpoint list2map (el: list (key*V)) : total_map V :=
match el with
| nil => t_empty default
| (i,v)::el' => t_update (list2map el') i v
end.

Theorem elements_relate:
forall t cts,  Abs t cts -> list2map (elements t) = cts.
Proof. hammer_hook "SearchTree" "SearchTree.elements_relate".

Abort.

Definition manual_grade_for_elements_relate_informal : option (prod nat string) := None.

Theorem not_elements_relate:
forall v, v <> default ->
~ (forall t cts,  Abs t cts -> list2map (elements t) = cts).
Proof. hammer_hook "SearchTree" "SearchTree.not_elements_relate".
intros.
intro.
pose (bogus := T (T E 3 v E) 2 v E).
pose (m := t_update (t_empty default) 2 v).
pose (m' := t_update
(combine 2
(t_update (combine 3 (t_empty default) (t_empty default)) 3 v)
(t_empty default)) 2 v).
assert (Paradox: list2map (elements bogus) = m /\ list2map (elements bogus) <> m).
split.

Admitted.

Fixpoint forall_nodes (t: tree) (P: tree->key->V->tree->Prop) : Prop :=
match t with
| E => True
| T l k v r => P l k v r /\ forall_nodes l P /\ forall_nodes r P
end.

Definition SearchTreeX (t: tree) :=
forall_nodes t
(fun l k v r =>
forall_nodes l (fun _ j _ _ => j<k) /\
forall_nodes r (fun _ j _ _ => j>k)).

Lemma example_SearchTree_good:
forall v2 v4 v5, SearchTreeX (example_tree v2 v4 v5).
Proof. hammer_hook "SearchTree" "SearchTree.example_SearchTree_good".
intros.
hnf. simpl.
repeat split; auto.
Qed.

Lemma example_SearchTree_bad:
forall v, ~SearchTreeX (T (T E 3 v E) 2 v E).
Proof. hammer_hook "SearchTree" "SearchTree.example_SearchTree_bad".
intros.
intro.
hnf in H; simpl in H.
do 3 destruct H.
omega.
Qed.

Theorem elements_relate_second_attempt:
forall t cts,
SearchTreeX t ->
Abs t cts ->
list2map (elements t) = cts.
Proof. hammer_hook "SearchTree" "SearchTree.elements_relate_second_attempt".

Abort.

Inductive SearchTree' : key -> tree -> key -> Prop :=
| ST_E : forall lo hi, lo <= hi -> SearchTree' lo E hi
| ST_T: forall lo l k v r hi,
SearchTree' lo l k ->
SearchTree' (S k) r hi ->
SearchTree' lo (T l k v r) hi.

Inductive SearchTree: tree -> Prop :=
| ST_intro: forall t hi, SearchTree' 0 t hi -> SearchTree t.

Lemma SearchTree'_le:
forall lo t hi, @SearchTree' lo t hi -> lo <= hi.
Proof. hammer_hook "SearchTree" "SearchTree.SearchTree'_le".
induction 1; omega.
Qed.

Fixpoint slow_elements (s: tree) : list (key * V) :=
match s with
| E => nil
| T a k v b => slow_elements a ++ [(k,v)] ++ slow_elements b
end.

Theorem elements_slow_elements: elements = slow_elements.
Proof. hammer_hook "SearchTree" "SearchTree.elements_slow_elements".
extensionality s.
unfold elements.
assert (forall base, elements' s base = slow_elements s ++ base).
Admitted.

Lemma slow_elements_range:
forall k v lo t hi,
SearchTree' lo t hi ->
In (k,v) (slow_elements t) ->
lo <= k < hi.
Proof. hammer_hook "SearchTree" "SearchTree.slow_elements_range".
Admitted.

Lemma In_decidable:
forall (al: list (key*V)) (i: key),
(exists v, In (i,v) al) \/ (~exists v, In (i,v) al).
Proof. hammer_hook "SearchTree" "SearchTree.In_decidable".
intros.
induction al as [ | [k v]].
right; intros [w H]; inv H.
destruct IHal as [[w H] | H].
left; exists w; right; auto.
bdestruct (k =? i).
subst k.
left; eauto.
exists v; left; auto.
right. intros [w H1].
destruct H1. inv H1. omega.
apply H; eauto.
Qed.

Lemma list2map_app_left:
forall (al bl: list (key*V)) (i: key) v,
In (i,v) al -> list2map (al++bl) i = list2map al i.
Proof. hammer_hook "SearchTree" "SearchTree.list2map_app_left".
intros.
revert H; induction al as [| [j w] al]; intro; simpl; auto.
inv H.
destruct H. inv H.
unfold t_update.
bdestruct (i=?i); [ | omega].
auto.
unfold t_update.
bdestruct (j=?i); auto.
Qed.

Lemma list2map_app_right:
forall (al bl: list (key*V)) (i: key),
~(exists v, In (i,v) al) -> list2map (al++bl) i = list2map bl i.
Proof. hammer_hook "SearchTree" "SearchTree.list2map_app_right".
intros.
revert H; induction al as [| [j w] al]; intro; simpl; auto.
unfold t_update.
bdestruct (j=?i).
subst j.
contradiction H.
exists w; left; auto.
apply IHal.
contradict H.
destruct H as [u ?].
exists u; right; auto.
Qed.

Lemma list2map_not_in_default:
forall (al: list (key*V)) (i: key),
~(exists v, In (i,v) al) -> list2map al i = default.
Proof. hammer_hook "SearchTree" "SearchTree.list2map_not_in_default".
intros.
induction al as [| [j w] al].
reflexivity.
simpl.
unfold t_update.
bdestruct (j=?i).
subst.
contradiction H.
exists w; left; auto.
apply IHal.
intros [v ?].
apply H. exists v; right; auto.
Qed.

Theorem elements_relate:
forall t cts,
SearchTree t ->
Abs t cts ->
list2map (elements t) = cts.
Proof. hammer_hook "SearchTree" "SearchTree.elements_relate".
rewrite elements_slow_elements.
intros until 1. inv H.
revert cts; induction H0; intros.
*
inv H0.
reflexivity.
*
inv H.
specialize (IHSearchTree'1 _ H5). clear H5.
specialize (IHSearchTree'2 _ H6). clear H6.
unfold slow_elements; fold slow_elements.
subst.
extensionality i.
destruct (In_decidable (slow_elements l) i)  as [[w H] | Hleft].
rewrite list2map_app_left with (v:=w); auto.
pose proof (slow_elements_range _ _ _ _ _ H0_ H).
unfold combine, t_update.
bdestruct (k=?i); [ omega | ].
bdestruct (i<?k); [ | omega].
auto.
Admitted.

Theorem empty_tree_SearchTree:  SearchTree empty_tree.
Proof. hammer_hook "SearchTree" "SearchTree.empty_tree_SearchTree".
clear default.
Admitted.

Theorem insert_SearchTree:
forall k v t,
SearchTree t -> SearchTree (insert k v t).
Proof. hammer_hook "SearchTree" "SearchTree.insert_SearchTree".
clear default.
Admitted.

Check lookup_relate.

Check elements_relate.

Lemma lookup_relate':
forall (k : key) (t : tree) (cts : total_map V),
SearchTree t -> Abs t cts -> lookup k t = cts k.

Proof. hammer_hook "SearchTree" "SearchTree.lookup_relate'".
intros.
apply lookup_relate.
apply H0.
Qed.

Theorem insert_relate':
forall k v t cts,
SearchTree t ->
Abs t cts ->
Abs (insert k v t) (t_update cts k v).
Proof. hammer_hook "SearchTree" "SearchTree.insert_relate'". intros. apply insert_relate; auto.
Qed.

Print Abs.

Remark abstraction_of_bogus_tree:
forall v2 v3,
Abs (T (T E 3 v3 E) 2 v2 E) (t_update (t_empty default) 2 v2).
Proof. hammer_hook "SearchTree" "SearchTree.abstraction_of_bogus_tree".
intros.
evar (m: total_map V).
replace  (t_update (t_empty default) 2 v2) with m; subst m.
repeat constructor.
extensionality x.
unfold t_update, combine, t_empty.
bdestruct (2 =? x).
auto.
bdestruct (x <? 2).
bdestruct (3 =? x).

omega.
bdestruct (x <? 3).
auto.
auto.
auto.
Qed.

Lemma can_relate:
forall t,  SearchTree t -> exists cts, Abs t cts.
Proof. hammer_hook "SearchTree" "SearchTree.can_relate".
Admitted.

Lemma unrealistically_strong_can_relate:
forall t,  exists cts, Abs t cts.
Proof. hammer_hook "SearchTree" "SearchTree.unrealistically_strong_can_relate".
Admitted.

Definition AbsX (t: tree) (m: total_map V) : Prop :=
list2map (elements t) = m.

Theorem elements_relateX:
forall t cts,
SearchTree t ->
AbsX t cts ->
list2map (elements t) = cts.
Proof. hammer_hook "SearchTree" "SearchTree.elements_relateX".
intros.
apply H0.
Qed.

Theorem naive_lookup_relateX:
forall k t cts ,
AbsX t cts -> lookup k t =  cts k.
Abort.

Theorem not_naive_lookup_relateX:
forall v, default <> v ->
~ (forall k t cts , AbsX t cts -> lookup k t =  cts k).
Proof. hammer_hook "SearchTree" "SearchTree.not_naive_lookup_relateX".
unfold AbsX.
intros v H.
intros H0.
pose (bogus := T (T E 3 v E) 2 v E).
pose (m := t_update (t_update (t_empty default) 2 v) 3 v).
assert (list2map (elements bogus) = m).
reflexivity.
assert (~ lookup 3 bogus = m 3). {
unfold bogus, m, t_update, t_empty.
simpl.
apply H.
}

apply H2.
apply H0.
apply H1.
Qed.

Theorem lookup_relateX:
forall k t cts ,
SearchTree t -> AbsX t cts -> lookup k t =  cts k.
Proof. hammer_hook "SearchTree" "SearchTree.lookup_relateX".
intros.
unfold AbsX in H0. subst cts.
inv H. remember 0 as lo in H0.
clear - H0.
rewrite elements_slow_elements.

Admitted.

End TREES.