(** * [inequality_chains.v]
Authors:
  - Jim Portegies
  - Jelle Wemmenhove
Creation date: 17 June 2021

A module to write and use chains of inequalities such as
  (& 3 &<= 4 &< 7 &= 3 + 4 &< 8)  or
  (& 8 &> 3 + 4 &= 7 &> 4 &>= 3).
The combination of <- and > symbols in the same chain is syntactically valid,
but the kernel does not know how their combination should be interpreted.
When used in a proof, this results in an error that informs the user about the missing interpretation,
the error can be hard to understand without knowle3dge of the underlying implementation.

We use type classes to overload the chain link symbols like '&=' and '&<'.

--------------------------------------------------------------------------------

This file is part of Waterproof-lib.

Waterproof-lib is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

Waterproof-lib is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with Waterproof-lib.  If not, see <https://www.gnu.org/licenses/>.
*)

(* Abstract representations for =, <, ≤, > and ≥ symbols.*)
Inductive EqualRel := | chain_eq.
Inductive LessRel := | chain_lt | chain_le.
Inductive GreaterRel := | chain_gt | chain_ge.

(* Types of chains. *)
(* Only contains =-relations. *)
Inductive EqualChain (T : Type) :=
| base_ec : T -> EqualRel * T -> EqualChain T
| link_ec_eq : EqualChain T -> EqualRel * T -> EqualChain T.
Inductive LessChain (T : Type) :=
| base_lc : T -> LessRel * T -> LessChain T
| link_ec_less : EqualChain T -> LessRel  * T -> LessChain T  (* link < or ≤ and term to equality chain *)
| link_lc_eq   : LessChain T  -> EqualRel * T -> LessChain T  (* link term to chain with =-relation*)
| link_lc_less : LessChain T  -> LessRel  * T -> LessChain T. (* link term to chain with <- or ≤-relation*)
Inductive GreaterChain (T : Type) :=
| base_gc : T -> GreaterRel * T -> GreaterChain T
| link_ec_grtr : EqualChain T   -> GreaterRel * T -> GreaterChain T (* link > or ≥ and term to equality chain *)
| link_gc_eq   : GreaterChain T -> EqualRel   * T -> GreaterChain T (* link term to chain with =-relation*)
| link_gc_grtr : GreaterChain T -> GreaterRel * T -> GreaterChain T. (* link term to chain with >- or ≥-relation*)

(* Type classes for linking new terms to chains.
   Type classes are used for notation overloading of link function 'chain_link' *)
Class ChainLink (A B C : Type) := chain_link : A -> B -> C.
#[export] Instance link_ec_eq_inst   (T : Type) : ChainLink (EqualChain T) (EqualRel * T) (EqualChain T) := link_ec_eq T.
#[export] Instance link_ec_less_inst (T : Type) : ChainLink (EqualChain T) (LessRel  * T) (LessChain T) := link_ec_less T.
#[export] Instance link_lc_eq_inst   (T : Type) : ChainLink (LessChain  T) (EqualRel * T) (LessChain T) := link_lc_eq T.
#[export] Instance link_lc_less_inst (T : Type) : ChainLink (LessChain  T) (LessRel  * T) (LessChain T) := link_lc_less T.
#[export] Instance link_ec_grtr_inst (T : Type) : ChainLink (EqualChain   T) (GreaterRel * T) (GreaterChain T) := link_ec_grtr T.
#[export] Instance link_gc_eq_inst   (T : Type) : ChainLink (GreaterChain T) (EqualRel   * T) (GreaterChain T) := link_gc_eq T.
#[export] Instance link_gc_grtr_inst (T : Type) : ChainLink (GreaterChain T) (GreaterRel * T) (GreaterChain T) := link_gc_grtr T.
Class ChainBase (A B C : Type) := chain_base : A -> B -> C.
#[export] Instance base_ec_inst (T : Type) : ChainBase T (EqualRel   * T) (EqualChain   T) := base_ec T.
#[export] Instance base_lc_inst (T : Type) : ChainBase T (LessRel    * T) (LessChain    T) := base_lc T.
#[export] Instance base_gc_inst (T : Type) : ChainBase T (GreaterRel * T) (GreaterChain T) := base_gc T.

(*
(* Type classes for linking new terms to chains.
   Type classes are used for notation overloading of link symbols like '&=' *)
Class EqLink (A B C: Type) := eq_link : A -> B -> C. (*notation: _ &= _ *)
#[export] Instance eq_base (T : Type) : EqLink T T (EqualChain T) := ec_base T.
#[export] Instance ec_eq_link (T : Type) : EqLink (EqualChain T) T (EqualChain T) := ec_link T.
#[export] Instance lc_eq_link (T : Type) : EqLink (LessChain T) T (LessChain T) := lc_link2 T.
#[export] Instance gc_eq_link (T : Type) : EqLink (GreaterChain T) T (GreaterChain T) := gc_link2 T.

Class LtLink (A B C : Type) := lt_link : A -> B -> C. (*notation: _ &< _ *)
#[export] Instance lt_base (T : Type) : LtLink  T T (LessChain T) :=
  fun x => lc_base T x rel_lt.
#[export] Instance ec_lt_link (T : Type) : LtLink (EqualChain T) T (LessChain T) :=
  fun c1 => lc_link1 T c1 rel_lt.
#[export] Instance lc_lt_link (T : Type) : LtLink (LessChain T) T (LessChain T) :=
  fun c1 => lc_link3 T c1 rel_lt.

Class LeLink (A B C : Type) := le_link : A -> B -> C. (*notation: _ &≤ _ *)
#[export] Instance le_base (T : Type) : LeLink T T (LessChain T) :=
  fun x => lc_base T x rel_le.
#[export] Instance ec_le_link (T : Type) : LeLink (EqualChain T) T (LessChain T) :=
  fun c1 => lc_link1 T c1 rel_le.
#[export] Instance lc_le_link (T : Type) : LeLink (LessChain T) T (LessChain T) :=
  fun c1 => lc_link3 T c1 rel_le.

Class GtLink (A B C : Type) := gt_link : A -> B -> C. (*notation: _ &> _ *)
#[export] Instance gt_base (T : Type) : GtLink  T T (GreaterChain T) :=
  fun x => gc_base T x rel_gt.
#[export] Instance ec_gt_link (T : Type) : GtLink (EqualChain T) T (GreaterChain T) :=
  fun c1 => gc_link1 T c1 rel_gt.
#[export] Instance gc_gt_link (T : Type) : GtLink (GreaterChain T) T (GreaterChain T) :=
  fun c1 => gc_link3 T c1 rel_gt.

Class GeLink (A B C : Type) := ge_link : A -> B -> C. (*notation: _ &≥ _ *)
#[export] Instance ge_base (T : Type) : GeLink T T (GreaterChain T) :=
  fun x => gc_base T x rel_ge.
#[export] Instance ec_ge_link (T : Type) : GeLink (EqualChain T) T (GreaterChain T) :=
  fun c1 => gc_link1 T c1 rel_ge.
#[export] Instance gc_ge_link (T : Type) : GeLink (GreaterChain T) T (GreaterChain T) :=
  fun c1 => gc_link3 T c1 rel_ge.
*)

(** Helper functions *)

(* Head: first term in a chain *)
Fixpoint ec_head {T : Type} (c : EqualChain T) : T :=
match c with
| base_ec _ x y => x
| link_ec_eq _ ec z => ec_head ec
end.
Fixpoint lc_head {T : Type} (c : LessChain T) : T :=
match c with
| base_lc _ x _       => x
| link_ec_less _ ec _ => ec_head ec
| link_lc_eq _ lc _   => lc_head lc
| link_lc_less _ lc _ => lc_head lc
end.
Fixpoint gc_head {T : Type} (c : GreaterChain T) : T :=
match c with
| base_gc _ x _       => x
| link_ec_grtr _ ec _ => ec_head ec
| link_gc_eq _ gc _   => gc_head gc
| link_gc_grtr _ gc _ => gc_head gc
end.

(* Tail: last term in a chain *)
Definition ec_tail {T : Type} (c : EqualChain T) : T :=
match c with
| base_ec _ _ (_,y)    => y
| link_ec_eq _ _ (_,z) => z
end.
Definition lc_tail {T : Type} (c : LessChain T) : T :=
match c with
| base_lc _ _ (_,y)      => y
| link_ec_less _ _ (_,z) => z
| link_lc_eq _ _ (_,z)   => z
| link_lc_less _ _ (_,z) => z
end.
Definition gc_tail {T : Type} (c : GreaterChain T) : T :=
match c with
| base_gc _ x (_,y)      => y
| link_ec_grtr _ _ (_,z) => z
| link_gc_eq _ _ (_,z)   => z
| link_gc_grtr _ _ (_,z) => z
end.

(* Chains contain multiple meanings:
    the global statement of (0 < 1 <= 2) is (0 < 2),
    the weak global statement            is (0 <= 2),
    the total statement                  is (0 < 1 /\ 1 <= 2)

   Again a type class is used such that we can use the same terms and notations
    for all three types of chains. *)
Class InterpretableChain (T : Type) (C : Type -> Type) :=
  { global_statement : C T -> Prop
  ; weak_global_statement : C T -> Prop
  ; total_statement : C T -> Prop
  }.

(* Notations for link type classes *)
Declare Scope chain_scope.
Delimit Scope chain_scope with chain.
Notation "< y" :=  (chain_lt, y) (at level 69, y at next level) : chain_scope.
Notation "<= y" := (chain_le, y) (at level 69, y at next level) : chain_scope.
Notation "≤ y" :=  (chain_le, y) (at level 69, y at next level) : chain_scope.
Notation "= y" :=  (chain_eq, y) (at level 69, y at next level) : chain_scope.
Notation "> y" :=  (chain_gt, y) (at level 69, y at next level) : chain_scope.
Notation ">= y" := (chain_ge, y) (at level 69, y at next level) : chain_scope.
Notation "≥ y" :=  (chain_ge, y) (at level 69, y at next level) : chain_scope.
(* Full chain *)
Notation "& x ly lz .. lw" := (total_statement (chain_link .. (chain_link (chain_base x ly%chain) lz%chain) .. lw%chain))
  (at level 70, x at next level, ly at next level, lw at next level).

(* Functions to turn the abstract [EqualRel] relation into their concrete interpretations,
   which could as a use case also be a setoid inpterpretation.
   We use type classes to be able to use the same name for these functions across types that implement them.
  *)
Class EqualInterpretation (T : Type) :=
  { eq_rel_to_pred : EqualRel -> T -> T -> Prop
  }.

(* Particular instance of the ordinary Leibniz equality as an EqualInterpretation.
*)
#[export] Instance equal_interpretation (T : Type) : EqualInterpretation T :=
  { eq_rel_to_pred rel x y := x = y
  }.

(** Global & total statement - EqualChain *)
Definition ec_global_statement (T : Type) `{! EqualInterpretation T} (c : EqualChain T) : Prop :=
  eq_rel_to_pred chain_eq (ec_head c) (ec_tail c).
Fixpoint ec_total_statement (T : Type) `{! EqualInterpretation T} (c : EqualChain T) : Prop :=
match c with
| base_ec _ x (_,y)     => eq_rel_to_pred chain_eq x y
| link_ec_eq _ ec (_,z) => (ec_total_statement _ ec) /\ (eq_rel_to_pred chain_eq (ec_tail ec) z)
end.

#[export] Instance ec_interpretable (T : Type) `{! EqualInterpretation T}: InterpretableChain T EqualChain :=
  { global_statement := ec_global_statement T
  ; weak_global_statement := ec_global_statement T
  ; total_statement := ec_total_statement T
  }.

(** Helper functions specific to Less- and GreaterChain. *)
(* The global relation resulting from a combination of relations [rel1] and [rel2]. *)
Definition less_relation_flow (rel1 rel2 : LessRel) : LessRel :=
match rel1 with
| chain_lt => chain_lt
| chain_le => rel2
end.
Definition grtr_relation_flow (rel1 rel2 : GreaterRel) : GreaterRel :=
match rel1 with
| chain_gt => chain_gt
| chain_ge => rel2
end.
(* Returns the global relation of a LessChain. *)
Fixpoint global_less_rel {T : Type} (c : LessChain T) : LessRel :=
match c with
| base_lc _ _ (rel,_)       => rel
| link_ec_less _ _ (rel,_)  => rel
| link_lc_eq _ lc _         => global_less_rel lc
| link_lc_less _ lc (rel,_) => less_relation_flow (global_less_rel lc) rel
end.
(* Returns the global relation of a GreaterChain. *)
Fixpoint global_grtr_rel {T : Type} (c : GreaterChain T) : GreaterRel :=
match c with
| base_gc _ _ (rel,_)       => rel
| link_ec_grtr _ _ (rel,_)  => rel
| link_gc_eq _ gc _         => global_grtr_rel gc
| link_gc_grtr _ gc (rel,_) => grtr_relation_flow (global_grtr_rel gc) rel
end.

(* Functions to turn the abstract [LessRel] and [GreaterRel] relations into their concrete interpretations.
   We again use type classes to be able to use the same name for these functions across types that implement them.
  *)
Class OrderInterpretation (T : Type) :=
  { less_rel_to_pred : LessRel -> T -> T -> Prop
  ; grtr_rel_to_pred : GreaterRel -> T -> T -> Prop
  }.

(** Global & total statement - LessChain *)
Definition lc_global_statement (T : Type) `{! OrderInterpretation T} (c : LessChain T) : Prop :=
  less_rel_to_pred (global_less_rel c) (lc_head c) (lc_tail c).
Definition lc_weak_global_statement (T : Type) `{! OrderInterpretation T} (c : LessChain T) : Prop :=
  less_rel_to_pred chain_le (lc_head c) (lc_tail c).
Fixpoint lc_total_statement (T : Type) `{! OrderInterpretation T} (c : LessChain T) : Prop :=
match c with
| base_lc _ x (rel,y) => less_rel_to_pred rel x y
| link_ec_less _ ec (rel,z) => (ec_total_statement _ ec) /\ less_rel_to_pred rel (ec_tail ec) z
| link_lc_eq _ lc (_,z)     => (lc_total_statement _ lc) /\ (lc_tail lc = z)
| link_lc_less _ lc (rel,z) => (lc_total_statement _ lc) /\ less_rel_to_pred rel (lc_tail lc) z
end.
#[export] Instance lc_interpretable (T : Type) `{! OrderInterpretation T} : InterpretableChain T LessChain :=
  { global_statement := lc_global_statement T
  ; weak_global_statement := lc_weak_global_statement T
  ; total_statement := lc_total_statement T
  }.

(** Global & total statement - GreaterChain *)
Definition gc_global_statement (T : Type) `{! OrderInterpretation T} (c : GreaterChain T) : Prop :=
  grtr_rel_to_pred (global_grtr_rel c) (gc_head c) (gc_tail c).
Definition gc_weak_global_statement (T : Type) `{! OrderInterpretation T} (c : GreaterChain T) : Prop :=
  grtr_rel_to_pred chain_ge (gc_head c) (gc_tail c).
Fixpoint gc_total_statement (T : Type) `{! OrderInterpretation T} (c : GreaterChain T) : Prop :=
match c with
| base_gc _ x (rel,y) => grtr_rel_to_pred rel x y
| link_ec_grtr _ ec (rel,z) => (ec_total_statement _ ec) /\ grtr_rel_to_pred rel (ec_tail ec) z
| link_gc_eq _ gc (_,z) => (gc_total_statement _ gc) /\ (gc_tail gc = z)
| link_gc_grtr _ gc (rel,z) => (gc_total_statement _ gc) /\ grtr_rel_to_pred rel (gc_tail gc) z
end.
#[export] Instance gc_interpretable (T : Type) `{! OrderInterpretation T} : InterpretableChain T GreaterChain :=
  { global_statement := gc_global_statement T
  ; weak_global_statement := gc_weak_global_statement T
  ; total_statement := gc_total_statement T
  }.

(* Interpretations of [LessRel] and [GreaterRel] for the naturals. *)
#[export] Instance order_interpretation_nat : OrderInterpretation nat :=
  { less_rel_to_pred rel x y := match rel with | chain_lt => (x < y) | chain_le => (x <= y) end
  ; grtr_rel_to_pred rel x y := match rel with | chain_gt => (x > y) | chain_ge => (x >= y) end
  }.

(* Interpretations of [LessRel] and [GreaterRel] for the reals. *)
Require Import Reals.
Open Scope R_scope.
#[export] Instance order_interpretation_R : OrderInterpretation R :=
  { less_rel_to_pred rel x y := match rel with | chain_lt => (x < y) | chain_le => (x <= y) end
  ; grtr_rel_to_pred rel x y := match rel with | chain_gt => (x > y) | chain_ge => (x >= y) end
  }.
Close Scope R_scope.

(*
(* tests *)
Check (& 0 < 1 = 2 - 1 < 2).
Goal (& 0 < 1 = 2 - 1 < 2).
Proof. unfold total_statement; cbv.
Abort.
Check (& 0 < 1 = 2 - 1 > 1). (* No typeclass inference found. *)

Check (& INR 0 < 1 = 1). (* No typeclass inference found. *)
*)

(* Because the typeclasses used for the link-symbols '&=' are so general,
   they are unable to automatically make use of coercions,
   e.g. the chain (& INR 0 < 1 = 1) is not accepted, Coq says it is unable to find
   an interpretation for (EqLink R nat ?C).

   We thus have to add all these cases manually.
*)

(* Helper functions: functorality of chain types. *)
Fixpoint ec_map {A B : Type} (f : A -> B) (c : EqualChain A) : EqualChain B :=
match c with
| base_ec _ x (rel,y)     => base_ec _ (f x) (rel,f y)
| link_ec_eq _ ec (rel,z) => link_ec_eq _ (ec_map f ec) (rel, f z)
end.
Fixpoint lc_map {A B : Type} (f : A -> B) (c : LessChain A) : LessChain B :=
match c with
| base_lc _ x (rel,y) => base_lc _ (f x) (rel, f y)
| link_ec_less _ ec (rel,z) => link_ec_less _ (ec_map f ec) (rel, f z)
| link_lc_eq _ lc (rel,z)   => link_lc_eq _ (lc_map f lc) (rel, f z)
| link_lc_less _ lc (rel,z) => link_lc_less _ (lc_map f lc) (rel, f z)
end.
Fixpoint gc_map {A B : Type} (f : A -> B) (c : GreaterChain A) : GreaterChain B :=
match c with
| base_gc _ x (rel,y) => base_gc _ (f x) (rel, f y)
| link_ec_grtr _ ec (rel,z) => link_ec_grtr _ (ec_map f ec) (rel, f z)
| link_gc_eq _ gc (rel,z)   => link_gc_eq _ (gc_map f gc) (rel, f z)
| link_gc_grtr _ gc (rel,z) => link_gc_grtr _ (gc_map f gc) (rel, f z)
end.

Definition snd_map {A B C : Type} (f : B -> C) (z : A * B) : A * C := (fst z, f (snd z)).

(* embedding INR : nat -> R *)
(* EqualChain *)
#[export] Instance base_ec_nat_R : ChainBase nat (EqualRel * R) (EqualChain R) := fun n lx => base_ec R (INR n) lx.
#[export] Instance base_ec_R_nat : ChainBase R (EqualRel * nat) (EqualChain R) := fun x ln => base_ec R x (snd_map INR ln).
#[export] Instance link_ec_eq_nat_R : ChainLink (EqualChain nat) (EqualRel * R) (EqualChain R) :=
  fun ecn lx => link_ec_eq R (ec_map INR ecn) lx.
#[export] Instance link_ec_eq_R_nat : ChainLink (EqualChain R) (EqualRel * nat) (EqualChain R) :=
  fun ecx ln => link_ec_eq R ecx (snd_map INR ln).
(* LessChain *)
#[export] Instance base_lc_nat_R : ChainBase nat (LessRel * R) (LessChain R) := fun n lx => base_lc R (INR n) lx.
#[export] Instance base_lc_R_nat : ChainBase R (LessRel * nat) (LessChain R) := fun x ln => base_lc R x (snd_map INR ln).
#[export] Instance link_ec_less_nat_R : ChainLink (EqualChain nat) (LessRel * R) (LessChain R) :=
  fun ecn lx => link_ec_less R (ec_map INR ecn) lx.
#[export] Instance link_ec_less_R_nat : ChainLink (EqualChain R) (LessRel * nat) (LessChain R) :=
  fun ecx ln => link_ec_less R ecx (snd_map INR ln).
#[export] Instance link_lc_eq_nat_R : ChainLink (LessChain nat) (EqualRel * R) (LessChain R) :=
  fun lcn x => link_lc_eq R (lc_map INR lcn) x.
#[export] Instance link_lc_eq_R_nat : ChainLink (LessChain R) (EqualRel * nat) (LessChain R) :=
  fun lcx ln => link_lc_eq R lcx (snd_map INR ln).
#[export] Instance link_lc_less_nat_R : ChainLink (LessChain nat) (LessRel * R) (LessChain R) :=
  fun lcn lx => link_lc_less R (lc_map INR lcn) lx.
#[export] Instance link_lc_less_R_nat : ChainLink (LessChain R) (LessRel * nat) (LessChain R) :=
  fun lcx ln => link_lc_less R lcx (snd_map INR ln).
(* GreaterChain *)
#[export] Instance base_gc_nat_R : ChainBase nat (GreaterRel * R) (GreaterChain R) := fun n lx => base_gc R (INR n) lx.
#[export] Instance base_gc_R_nat : ChainBase R (GreaterRel * nat) (GreaterChain R) := fun x ln => base_gc R x (snd_map INR ln).
#[export] Instance link_ec_grtr_nat_R : ChainLink (EqualChain nat) (GreaterRel * R) (GreaterChain R) :=
  fun ecn lx => link_ec_grtr R (ec_map INR ecn) lx.
#[export] Instance link_ec_grtr_R_nat : ChainLink (EqualChain R) (GreaterRel * nat) (GreaterChain R) :=
  fun ecx ln => link_ec_grtr R ecx (snd_map INR ln).
#[export] Instance link_gc_eq_nat_R : ChainLink (GreaterChain nat) (EqualRel * R) (GreaterChain R) :=
  fun gcn x => link_gc_eq R (gc_map INR gcn) x.
#[export] Instance link_gc_eq_R_nat : ChainLink (GreaterChain R) (EqualRel * nat) (GreaterChain R) :=
  fun gcx ln => link_gc_eq R gcx (snd_map INR ln).
#[export] Instance link_gc_grtr_nat_R : ChainLink (GreaterChain nat) (GreaterRel * R) (GreaterChain R) :=
  fun gcn lx => link_gc_grtr R (gc_map INR gcn) lx.
#[export] Instance link_gc_grtr_R_nat : ChainLink (GreaterChain R) (GreaterRel * nat) (GreaterChain R) :=
  fun gcx ln => link_gc_grtr R gcx (snd_map INR ln).

(*
(* test *)
Check (& INR 0 < 1 = 1).
*)

(* embedding IZR : Z -> R *)
(* EqualChain *)
#[export] Instance base_ec_Z_R : ChainBase Z (EqualRel * R) (EqualChain R) := fun n lx => base_ec R (IZR n) lx.
#[export] Instance base_ec_R_Z : ChainBase R (EqualRel * Z) (EqualChain R) := fun x ln => base_ec R x (snd_map IZR ln).
#[export] Instance link_ec_eq_Z_R : ChainLink (EqualChain Z) (EqualRel * R) (EqualChain R) :=
  fun ecn lx => link_ec_eq R (ec_map IZR ecn) lx.
#[export] Instance link_ec_eq_R_Z : ChainLink (EqualChain R) (EqualRel * Z) (EqualChain R) :=
  fun ecx ln => link_ec_eq R ecx (snd_map IZR ln).
(* LessChain *)
#[export] Instance base_lc_Z_R : ChainBase Z (LessRel * R) (LessChain R) := fun n lx => base_lc R (IZR n) lx.
#[export] Instance base_lc_R_Z : ChainBase R (LessRel * Z) (LessChain R) := fun x ln => base_lc R x (snd_map IZR ln).
#[export] Instance link_ec_less_Z_R : ChainLink (EqualChain Z) (LessRel * R) (LessChain R) :=
  fun ecn lx => link_ec_less R (ec_map IZR ecn) lx.
#[export] Instance link_ec_less_R_Z : ChainLink (EqualChain R) (LessRel * Z) (LessChain R) :=
  fun ecx ln => link_ec_less R ecx (snd_map IZR ln).
#[export] Instance link_lc_eq_Z_R : ChainLink (LessChain Z) (EqualRel * R) (LessChain R) :=
  fun lcn x => link_lc_eq R (lc_map IZR lcn) x.
#[export] Instance link_lc_eq_R_Z : ChainLink (LessChain R) (EqualRel * Z) (LessChain R) :=
  fun lcx ln => link_lc_eq R lcx (snd_map IZR ln).
#[export] Instance link_lc_less_Z_R : ChainLink (LessChain Z) (LessRel * R) (LessChain R) :=
  fun lcn lx => link_lc_less R (lc_map IZR lcn) lx.
#[export] Instance link_lc_less_R_Z : ChainLink (LessChain R) (LessRel * Z) (LessChain R) :=
  fun lcx ln => link_lc_less R lcx (snd_map IZR ln).
(* GreaterChain *)
#[export] Instance base_gc_Z_R : ChainBase Z (GreaterRel * R) (GreaterChain R) := fun n lx => base_gc R (IZR n) lx.
#[export] Instance base_gc_R_Z : ChainBase R (GreaterRel * Z) (GreaterChain R) := fun x ln => base_gc R x (snd_map IZR ln).
#[export] Instance link_ec_grtr_Z_R : ChainLink (EqualChain Z) (GreaterRel * R) (GreaterChain R) :=
  fun ecn lx => link_ec_grtr R (ec_map IZR ecn) lx.
#[export] Instance link_ec_grtr_R_Z : ChainLink (EqualChain R) (GreaterRel * Z) (GreaterChain R) :=
  fun ecx ln => link_ec_grtr R ecx (snd_map IZR ln).
#[export] Instance link_gc_eq_Z_R : ChainLink (GreaterChain Z) (EqualRel * R) (GreaterChain R) :=
  fun gcn x => link_gc_eq R (gc_map IZR gcn) x.
#[export] Instance link_gc_eq_R_Z : ChainLink (GreaterChain R) (EqualRel * Z) (GreaterChain R) :=
  fun gcx ln => link_gc_eq R gcx (snd_map IZR ln).
#[export] Instance link_gc_grtr_Z_R : ChainLink (GreaterChain Z) (GreaterRel * R) (GreaterChain R) :=
  fun gcn lx => link_gc_grtr R (gc_map IZR gcn) lx.
#[export] Instance link_gc_grtr_R_Z : ChainLink (GreaterChain R) (GreaterRel * Z) (GreaterChain R) :=
  fun gcx ln => link_gc_grtr R gcx (snd_map IZR ln).


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path.
Require Import Eqdep.
From fcsl
Require Import pred prelude ordtype pcm finmap unionmap automap heap.

Set Implicit Arguments.

Unset Strict Implicit.
Unset Printing Implicit Defensive.

(***************************************************)
(*        Some useful facts about lists            *)
(***************************************************)

Lemma rem_neq {T: eqType} (x y : T) (ls : seq T) :
  x != y -> x \in ls -> x \in seq.rem y ls.
Proof.
move=>N; elim: ls=>//h ls Hi.
rewrite inE; case/orP=>//=.
- by move/eqP=>Z; subst h; move/negbTE: N=>->; rewrite inE eqxx.
by case: ifP=>//=N' /Hi; rewrite inE orbC=>->.
Qed.

Lemma rem_neq_notin {T: eqType} (x y : T) (ls : seq T) :
  x != y -> x \notin ls -> x \notin seq.rem y ls.
Proof.
move=>N; elim: ls=>//h ls Hi.
rewrite inE; case/norP=>//=.
move=>Neq Ni; specialize (Hi Ni); case: ifP=>//=.
by move=>Hy; rewrite inE; apply/norP; rewrite Hi.
Qed.

Lemma in_seq {T : eqType} (x : T) (xs : seq T) :
  x \in xs -> exists fs ls, xs = fs ++ x :: ls.
Proof.
move=>H. elim: xs H; first done.
move=>h t Hi; rewrite in_cons; move/orP; case.
by move/eqP=>->; exists [::], t.
by move=>H; move: (Hi H); move=>[fs] [ls]=>->; exists (h :: fs), ls.
Qed.

Lemma in_seq_neq {T : eqType} (x : T) (xs : seq T) :
  x \in xs -> exists fs ls, xs = fs ++ x :: ls /\ x \notin fs.
Proof.
move=>H. elim: xs H; first done.
move=>h t Hi; rewrite in_cons; move/orP; case.
by move/eqP=>->; exists [::], t.
move=>H; move: (Hi H); move=>[fs][ls][->]G.
case E: (x == h); last first.
- by exists (h :: fs), ls; split; rewrite ?cat_cons// inE E G.
by exists [::], (fs ++ x :: ls); split; move/eqP:E=>->.
Qed.

Lemma in_seq_excl {T : eqType} (x y : T) (xs : seq T) :
  x \in xs -> y \notin xs -> x != y.
Proof.
elim: xs=>[|h tl Hi]//.
rewrite !in_cons; case/orP=> H; case/norP=>H0.
by move/eqP in H; subst h=>_; rewrite eq_sym.
by move=> H'; apply (Hi H H').
Qed.

Lemma rem_elem {T: eqType} (p : T) xs ys :
  p \notin xs-> seq.rem p (xs ++ p :: ys) = xs ++ ys.
Proof.
elim: xs=>//=; first by rewrite eqxx.
move=>x xs Hi; rewrite inE=>/norP[H1 H2].
by move/negbTE: H1; rewrite eq_sym=>->; rewrite (Hi H2).
Qed.

Lemma in_rem_msg {T: eqType} p0 p ms (hs : seq T) :
  p0 \in hs -> p0 <> p ->
  p0 \in ms ++ seq.rem p hs.
Proof.
move=>iF0 E; rewrite mem_cat orbC; apply/orP; left.
suff N : (p0 != p) by rewrite (rem_neq N iF0).
by apply/negP=>/eqP Z; subst p0.
Qed.

Lemma dom_ord1 {K: ordType} {T} (j : K) (w : T) m :
  valid (j \\-> w \+ m) ->
  path ord j (dom m) ->
  dom (j \\-> w \+ m) = j :: (dom m).
Proof.
elim/um_indf: m=>/=[||k v m Hi V' P' V P].
- by case: validUn=>//=_; rewrite valid_undef.
- by rewrite unitR dom0 domPtK.
rewrite -joinCA in V; move: (Hi (validR V))=>{Hi}Hi.
have A: antisymmetric ord by move=>???/andP[]H1 H2; move: (nsym H1 H2).
apply: (eq_sorted (@trans K) (A K))=>//=.
rewrite joinCA in V.
apply: uniq_perm=>/=; rewrite ?dom_uniq ?[_&&true]andbC//=.
- case: validUn V=>//_ _/(_ j).
  by rewrite domPtK inE eqxx uniq_dom=>/(_ is_true_true) ? ?; apply/andP.
move=>z; rewrite !inE !domUn !inE V domPtK inE (eq_sym z k).
by rewrite (validR V)/= domPtUn V'/= domPtK !inE.
Qed.

Lemma path_ord_sorted {K: ordType} z j (l : seq K) :
  sorted ord l -> path ord j l -> z \in l -> ord j z.
Proof.
elim: l z=>//h l Hi z/=P/andP[O _].
rewrite inE; case/orP; first by move/eqP=>->.
move=>I; apply: Hi=>//; first by apply:(path_sorted P).
clear I z; case: l O P=>//=x xs O/andP[O' ->]; rewrite andbC/=.
by apply: (@trans K _ _ _ O O').
Qed.

Lemma dom_ord2 {K: ordType} {T} (j k : K) (w v : T) m:
  valid (k \\-> v \+ (j \\-> w \+ m)) ->
  path ord j (dom m) ->
  dom (pts j w \+ (k \\-> v \+ m)) =
  if ord j k then j :: dom (k \\-> v \+ m) else k :: j :: (dom m).
Proof.
case: totalP=> [k_lt_j V P | /eqP-> | j_lt_k V P].
- by rewrite joinCA !dom_ord1 ?(validX V) //= k_lt_j P.
- by rewrite validPtUn /= domPtUn inE eqxx /= andbT andbN.
rewrite -[pts j w]/(j \\-> w) dom_ord1 ?(validX V) //.
rewrite path_min_sorted //; apply/allP=> z.
rewrite domUn inE; case/andP=>[_]/orP[].
- by rewrite domPtK inE => /eqP->.
by move=> F; rewrite (path_ord_sorted (sorted_dom m)).
Qed.

Lemma dom_insert {K: ordType} {T} (k : K) (v : T) m :
  valid (k \\-> v \+ m) ->
  exists ks1 ks2, dom m = ks1 ++ ks2 /\
                  dom (k \\-> v \+ m) = ks1 ++ k :: ks2.
Proof.
move=>V; elim/um_indf: m V=>//[||j w m' Hi V' P V].
- by case: validUn=>//=_; rewrite valid_undef.
- by rewrite unitR dom0 domPtK; exists [::], [::].
move: (V); rewrite -joinCA=>/validR/Hi[ks1][ks2][E1]E2.
(* So, j < (dom m'), hence it goes at the head *)
rewrite (dom_ord1 V' P) E1 (dom_ord2 V P) !E1 E2.
case: ifP=>_; first by exists (j :: ks1), ks2.
by exists [::], (j :: ks1 ++ ks2).
Qed.


Require Export XR_R.
Require Export XR_R0.
Require Export XR_R1.
Require Export XR_Rmult.
Require Export XR_Rinv.
Require Export XR_Rinv_l.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rinv_l_sym : forall r, r <> R0 -> R1 = / r * r.
Proof.
  intros x h.
  symmetry.
  apply Rinv_l.
  exact h.
Qed.


From Coq Require Import ZArith Psatz Bool String List FMaps.
From CDF Require Import Sequences IMP.

Local Open Scope string_scope.
Local Open Scope Z_scope.

(** * 5.  Static analysis by abstract interpretation, simplified version *)

(** ** 5.1.  Interface of abstract domains *)

(** The analyzer computes over abstract values: approximations of sets
    of integer values.  The type of abstract values and the associated
    operations are grouped in a Coq module, whose interface follows. *)

Module Type VALUE_ABSTRACTION.

(** The type of abstract values. *)
  Parameter t: Type.

(** [In n N] holds if integer [n] belongs to the set represented by
    abstract value [N].  This is equivalent to the concretization
    function [γ] : [In n N] means [n ∈ γ(N)]. *)
  Parameter In: Z -> t -> Prop.

(** Abstract values are ordered by inclusion of the sets they represent. *)
  Definition le (N1 N2: t) : Prop := forall n, In n N1 -> In n N2.

(** [ble] is a Boolean-valued function that decides the [le] relation. *)
  Parameter ble: t -> t -> bool.
  Axiom ble_1: forall N1 N2, ble N1 N2 = true -> le N1 N2.
  Axiom ble_2: forall N1 N2, le N1 N2 -> ble N1 N2 = true.

(** [const n] is the abstract value for the singleton set [{n}]. *)
  Parameter const: Z -> t.
  Axiom const_1: forall n, In n (const n).

(** [bot] represents the empty set. *)
  Parameter bot: t.
  Axiom bot_1: forall n, ~(In n bot).

(** [top] represents the set of all integers. *)
  Parameter top: t.
  Parameter top_1: forall n, In n top.

(** [join] computes an upper bound of its two arguments. *)
  Parameter join: t -> t -> t.
  Axiom join_1: forall n N1 N2, In n N1 -> In n (join N1 N2).
  Axiom join_2: forall n N1 N2, In n N2 -> In n (join N1 N2).

(** Abstract operators for addition and subtraction. *)
  Parameter add: t -> t -> t.
  Axiom add_1:
    forall n1 n2 N1 N2, In n1 N1 -> In n2 N2 -> In (n1+n2) (add N1 N2).

  Parameter sub: t -> t -> t.
  Axiom sub_1:
    forall n1 n2 N1 N2, In n1 N1 -> In n2 N2 -> In (n1-n2) (sub N1 N2).

End VALUE_ABSTRACTION.

(** Store abstractions are defined in the same style: a module
    that defines a type [t] of abstract stores and the associated
    abstract operations.  Here is the interface of this module. *)

Module Type STORE_ABSTRACTION.

(** A value abstraction for integer values. *)
  Declare Module V: VALUE_ABSTRACTION.

(** The type of abstract stores. *)
  Parameter t: Type.

(** [get x S] is the abstract value associated with [x] in [S]. *)
  Parameter get: ident -> t -> V.t.

(** Whether a concrete store belongs to an abstract store. *)
  Definition In (s: store) (S: t) : Prop :=
    forall x, V.In (s x) (get x S).

(** Abstract assignment to a variable. *)
  Parameter set: ident -> V.t -> t -> t.
  Axiom set_1:
    forall x n N s S, V.In n N -> In s S -> In (update x n s) (set x N S).

(** The order between abstract stores. *)
  Definition le (S1 S2: t) : Prop := forall s, In s S1 -> In s S2.

  Parameter ble: t -> t -> bool.
  Axiom ble_1: forall S1 S2, ble S1 S2 = true -> le S1 S2.

(** Smallest and greatest abstract stores. *)
  Parameter bot: t.
  Axiom bot_1: forall s, ~(In s bot).

  Parameter top: t.
  Parameter top_1: forall s, In s top.

(** [join] computes an upper bound of its two arguments. *)
  Parameter join: t -> t -> t.
  Axiom join_1: forall s S1 S2, In s S1 -> In s (join S1 S2).
  Axiom join_2: forall s S1 S2, In s S2 -> In s (join S1 S2).

End STORE_ABSTRACTION.

(** ** 5.2.  The generic analyzer *)

(** The analyzer is presented as a module parameterized by a store abstraction,
    the latter containing a value abstraction. *)

Module Analysis (ST: STORE_ABSTRACTION).

Module V := ST.V.

(** *** Computing post-fixed points *)

(** We follow the same approach as in the 3rd lecture, module [Optim]:
    a fixed point iteration that starts from [bot] and stops as soon
    a post-fixed point is found, or when the maximal number of
    iterations is reached.  In the latter case, the result is [top]. *)

Section FIXPOINT.

Variable F: ST.t -> ST.t.

Fixpoint iter (n: nat) (S: ST.t) : ST.t :=
  match n with
  | O => ST.top
  | S n' => let S' := F S in
            if ST.ble S' S then S else iter n' S'
  end.

Definition niter := 10%nat.

Definition postfixpoint : ST.t := iter niter ST.bot.

Lemma postfixpoint_sound:
  ST.le (F postfixpoint) postfixpoint.
Proof.
  unfold postfixpoint. generalize niter ST.bot.
  induction n; intros S; cbn.
- red; intros; apply ST.top_1.
- destruct (ST.ble (F S) S) eqn:B.
  + apply ST.ble_1; auto.
  + apply IHn.
Qed.

End FIXPOINT.

(** *** Abstract interpretation of arithmetic operations. *)

Fixpoint Aeval (a: aexp) (S: ST.t) : V.t :=
  match a with
  | CONST n => V.const n
  | VAR x => ST.get x S
  | PLUS a1 a2 => V.add (Aeval a1 S) (Aeval a2 S)
  | MINUS a1 a2 => V.sub (Aeval a1 S) (Aeval a2 S)
  end.

(** This abstract interpretation is sound with respect to the concrete
    semantics of expressions. *)

Lemma Aeval_sound:
  forall s S a,
  ST.In s S -> V.In (aeval a s) (Aeval a S).
Proof.
  induction a; cbn; intros.
- apply V.const_1.
- apply H.
- apply V.add_1; auto.
- apply V.sub_1; auto.
Qed.

(** *** Abstract interpretation of commands. *)

(** The abstract interpretation of a command [c] is a function
    [ST.t -> ST.t] that computes the abstract store "after" the
    execution of [c] as a function of the abstract store "before".
    Owing to abstraction, this computation always terminates
    and can be defined as a function. *)

Fixpoint Cexec (c: com) (S: ST.t) : ST.t :=
  match c with
  | SKIP => S
  | ASSIGN x a => ST.set x (Aeval a S) S
  | SEQ c1 c2 => Cexec c2 (Cexec c1 S)
  | IFTHENELSE b c1 c2 => ST.join (Cexec c1 S) (Cexec c2 S)
  | WHILE b c => postfixpoint (fun X => ST.join S (Cexec c X))
  end.

(** This abstract interpretation is sound with respect to the IMP
    operational semantics. *)

Theorem Cexec_sound:
  forall c s s' S,
  ST.In s S -> cexec s c s' -> ST.In s' (Cexec c S).
Proof.
Opaque niter.
  induction c; intros s s' S PRE EXEC; cbn.
- (* SKIP *)
  inversion EXEC; subst. auto.
- (* ASSIGN *)
  inversion EXEC; subst. apply ST.set_1; auto. apply Aeval_sound; auto.
- (* SEQ *)
  inversion EXEC; subst. eauto.
- (* IFTHENELSE *)
  inversion EXEC; subst. destruct (beval b s).
  apply ST.join_1; eauto.
  apply ST.join_2; eauto.
- (* WHILE *)
  set (F := fun X => ST.join S (Cexec c X)).
  set (X := postfixpoint F).
  assert (L : ST.le (F X) X) by (apply postfixpoint_sound).
  assert (REC: forall s1 c1 s2,
               cexec s1 c1 s2 ->
               c1 = WHILE b c ->
               ST.In s1 X ->
               ST.In s2 X).
  { induction 1; intro EQ; inversion EQ; subst; intros.
  - (* WHILE done *)
    auto.
  - (* WHILE loop *)
    apply IHcexec2; auto. apply L. unfold F. apply ST.join_2. eapply IHc; eauto.
  }
  eapply REC; eauto. apply L. unfold F. apply ST.join_1. auto.
Qed.

End Analysis.

(** ** 5.3.  An abstract domain for stores *)

(** We now build an abstract domain for stores that can be used
    for all non-relational analyses, in particular all value analyses. *)

(** Morally, abstract stores are functions [ident -> V.t]
    from identifiers to abstract values.  However, the order between
    abstract stores must be decidable, which is not the case if
    abstract stores are arbitrary functions over the infinite type [ident].
    Therefore, we use finite partial functions from [ident] to [V.t],
    implemented using the "maps" provided by Coq's standard library,
    and consider that any identifier not in the domain of the finite
    function is mapped to [V.top]. *)

(** As in file [Optim], we equip the type of identifiers with a decidable
    equality, then instantiate the standard library modules for maps
    on this type. *)

Module Ident_Decidable <: DecidableType with Definition t := ident.
  Definition t := ident.
  Definition eq (x y: t) := x = y.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.
  Definition eq_dec := string_dec.
End Ident_Decidable.

Module IdentMap := FMapWeakList.Make(Ident_Decidable).
Module IMFact := FMapFacts.WFacts(IdentMap).
Module IMProp := FMapFacts.WProperties(IdentMap).

(** The domain of abstract stores is parameterized by a module [VA]
    defining the abstract values. *)

Module StoreAbstr (VA: VALUE_ABSTRACTION) <: STORE_ABSTRACTION.

Module V := VA.

(** An abstract store is either [Bot], associating [V.bot] to all
    variables, or [Top_except m], associating [V.top] to the variables
    that are not described in the map [m]. *)

Inductive abstr_state : Type :=
  | Bot
  | Top_except (m: IdentMap.t V.t).

Definition t := abstr_state.

Definition get (x: ident) (S: t) : V.t :=
  match S with
  | Bot => V.bot
  | Top_except m =>
      match IdentMap.find x m with
      | None => V.top
      | Some N => N
      end
  end.

Definition In (s: store) (S: t) : Prop :=
  forall x, V.In (s x) (get x S).

Definition set (x: ident) (N: V.t) (S: t): t :=
  if V.ble N V.bot then Bot else
  match S with
  | Bot => Bot
  | Top_except m => Top_except (IdentMap.add x N m)
  end.

Lemma set_1:
  forall x n N s S,
  V.In n N -> In s S -> In (update x n s) (set x N S).
Proof.
  unfold In, get, set; intros.
  destruct (V.ble N V.bot) eqn:BLE; [ | destruct S ].
- apply V.ble_1 in BLE. apply BLE in H. elim (V.bot_1 n); auto.
- elim (V.bot_1 (s "")). auto.
- rewrite IMFact.add_o. change IdentMap.E.eq_dec with string_dec. unfold update.
  destruct (string_dec x x0); auto.
Qed.

(** The inclusion order between abstract stores. *)

Definition le (S1 S2: t) : Prop :=
  forall s, In s S1 -> In s S2.

Definition ble (S1 S2: t) : bool :=
  match S1, S2 with
  | Bot, _ => true
  | _, Bot => false
  | Top_except m1, Top_except m2 =>
      IMProp.for_all (fun x v => V.ble (get x S1) v) m2
  end.

Lemma ble_1: forall S1 S2, ble S1 S2 = true -> le S1 S2.
Proof.
  unfold ble, le; intros.
  destruct S1 as [ | m1].
- elim (V.bot_1 (s "")). apply H0.
- destruct S2 as [ | m2]. discriminate.
  red; cbn; intros. destruct (IdentMap.find x m2) as [N2|] eqn:F2.
  + apply IdentMap.find_2 in F2. eapply IMProp.for_all_iff in H; eauto.
    apply V.ble_1 in H. apply H. apply H0.
    hnf. intros; subst x0. hnf; intros. subst x0. auto.
  + apply V.top_1.
Qed.

(** The lattice operations. *)

Definition bot: t := Bot.

Lemma bot_1: forall s, ~(In s bot).
Proof.
  unfold In; cbn. intros s IN. apply (V.bot_1 (s "")). apply IN.
Qed.

Definition top: t := Top_except (IdentMap.empty V.t).

Lemma top_1: forall s, In s top.
Proof.
  unfold In, top, get; cbn. intros. apply V.top_1.
Qed.

Definition join_aux (ov1 ov2: option V.t) : option V.t :=
  match ov1, ov2 with
  | Some v1, Some v2 => Some (V.join v1 v2)
  | _, _ => None
  end.

Definition join (S1 S2: t) : t :=
  match S1, S2 with
  | Bot, _ => S2
  | _, Bot => S1
  | Top_except m1, Top_except m2 => Top_except (IdentMap.map2 join_aux m1 m2)
  end.

Lemma join_1:
  forall s S1 S2, In s S1 -> In s (join S1 S2).
Proof.
  unfold join; intros.
  destruct S1 as [ | m1]. elim (bot_1 s); auto.
  destruct S2 as [ | m2]. auto.
- red; unfold get; intros. rewrite IMFact.map2_1bis; auto.
  unfold join_aux. specialize (H x). unfold get in H.
  destruct (IdentMap.find x m1).
  + destruct (IdentMap.find x m2).
    * apply V.join_1; auto.
    * apply V.top_1.
  + apply V.top_1.
Qed.

Lemma join_2:
  forall s S1 S2, In s S2 -> In s (join S1 S2).
Proof.
  unfold join; intros.
  destruct S1 as [ | m1]. auto.
  destruct S2 as [ | m2]. elim (bot_1 s); auto.
- red; unfold get; intros. rewrite IMFact.map2_1bis; auto.
  unfold join_aux. specialize (H x). unfold get in H.
  destruct (IdentMap.find x m1).
  + destruct (IdentMap.find x m2).
    * apply V.join_2; auto.
    * apply V.top_1.
  + apply V.top_1.
Qed.

End StoreAbstr.

(** ** 5.4.  An application: constant propagation analysis *)

(** *** The "flat" abstract domain of integers. *)

Module FlatInt <: VALUE_ABSTRACTION.

(** The abstract values: empty set, singleton set, or [Z] as a whole. *)

  Inductive abstr_value : Type := Bot | Just (n: Z) | Top.
  Definition t := abstr_value.

(** Membership and inclusion. *)

  Definition In (n: Z) (N: t) : Prop :=
    match N with
    | Bot => False
    | Just m => n = m
    | Top => True
    end.

  Definition le (N1 N2: t) : Prop :=
    forall n, In n N1 -> In n N2.

  Definition ble (N1 N2: t) : bool :=
    match N1, N2 with
    | Bot, _ => true
    | _, Top => true
    | Just n1, Just n2 => n1 =? n2
    | _, _ => false
    end.

  Lemma ble_1: forall N1 N2, ble N1 N2 = true -> le N1 N2.
  Proof.
    unfold ble, le, In; intros.
    destruct N1; try contradiction; destruct N2; try discriminate; auto.
    apply Z.eqb_eq in H. lia.
  Qed.

  Lemma ble_2: forall N1 N2, le N1 N2 -> ble N1 N2 = true.
  Proof.
    unfold ble, le, In; intros.
    destruct N1; auto.
  - specialize (H n refl_equal). destruct N2. contradiction. apply Z.eqb_eq; auto. auto.
  - destruct N2. elim (H 0); auto. specialize (H (n + 1)); lia. auto.
  Qed.

(** [const n] is the abstract value for the singleton set [{n}]. *)
  Definition const (n: Z) : t := Just n.

  Lemma const_1: forall n, In n (const n).
  Proof.
    intros; cbn; auto.
  Qed.

(** The lattice operations: [bot], [top], [join]. *)

  Definition bot: t := Bot.

  Lemma bot_1: forall n, ~(In n bot).
  Proof.
    intros. cbn. tauto.
  Qed.

  Definition top: t := Top.

  Lemma top_1: forall n, In n top.
  Proof.
    intros. cbn; auto.
  Qed.

  Definition join (N1 N2: t) : t :=
    match N1, N2 with
    | Bot, _ => N2
    | _, Bot => N1
    | Top, _ => Top
    | _, Top => Top
    | Just n1, Just n2 => if n1 =? n2 then Just n1 else Top
    end.

  Lemma join_1:
    forall n N1 N2, In n N1 -> In n (join N1 N2).
  Proof.
    unfold In, join; intros; cbn.
    destruct N1, N2; try tauto.
    destruct (Z.eqb_spec n0 n1); auto.
  Qed.

  Lemma join_2:
    forall n N1 N2, In n N2 -> In n (join N1 N2).
  Proof.
    unfold In, join; intros; cbn.
    destruct N1, N2; try tauto.
    destruct (Z.eqb_spec n0 n1); auto. congruence.
  Qed.

(** The abstract arithmetic operations *)

  Definition lift (f: Z -> Z -> Z) : t -> t -> t :=
    fun N1 N2 =>
      match N1, N2 with
      | Bot, _ => Bot
      | _, Bot => Bot
      | Just n1, Just n2 => Just (f n1 n2)
      | _, _ => Top
    end.

  Lemma lift_1:
    forall f n1 n2 N1 N2, In n1 N1 -> In n2 N2 -> In (f n1 n2) (lift f N1 N2).
  Proof.
    unfold In, lift; intros. destruct N1, N2; try tauto. congruence.
  Qed.

  Definition add := lift Z.add.

  Lemma add_1:
    forall n1 n2 N1 N2, In n1 N1 -> In n2 N2 -> In (n1+n2) (add N1 N2).
  Proof (lift_1 Z.add).

  Definition sub := lift Z.sub.

  Lemma sub_1:
    forall n1 n2 N1 N2, In n1 N1 -> In n2 N2 -> In (n1-n2) (sub N1 N2).
  Proof (lift_1 Z.sub).

End FlatInt.

(** *** The constant propagation analysis *)

(** We just have to instantiate the analyzer on the flat domain of integers
    and on the corresponding store domain. *)

Module SConstProp := StoreAbstr(FlatInt).
Module AConstProp := Analysis(SConstProp).

(** A sample program:
<<
    x := 0; y := 100; z := x + y;
    if x = 0
    then y := x + 10; x := 1
    else y := 10
>>
*)

Definition prog1 :=
  ASSIGN "x" (CONST 0) ;;
  ASSIGN "y" (CONST 100) ;;
  ASSIGN "z" (PLUS (VAR "x") (VAR "y")) ;;
  IFTHENELSE (EQUAL (VAR "x") (CONST 0))
    (ASSIGN "y" (PLUS (VAR "x") (CONST 10)) ;; ASSIGN "x" (CONST 1))
    (ASSIGN "y" (CONST 10)).

Compute (let S := AConstProp.Cexec prog1 SConstProp.top in
         (SConstProp.get "x" S, SConstProp.get "y" S, SConstProp.get "z" S)).

(** Analysis result:
<<
     = (FlatInt.Top, FlatInt.Just 10, FlatInt.Just 100)
>>
In other words: [x] is unknown, [y] is 10, and [z] is 100.
*)

(*** Exercise (3 stars) *)

(** Write an abstract domain for sign analysis.
    For each variable, we'd like to know if its value is always
    positive or zero, or always negative, or of unknown sign. *)

Module Sign (* <: VALUE_ABSTRACTION *) .

  Inductive sign : Type :=
    | Bot
    | Pos          (**r nonnegative (positive or zero) *)
    | Neg          (**r negative (and not zero) *)
    | Top.
  Definition t := sign.

  Definition In (n: Z) (N: t) : Prop :=
    match N with
    | Bot => False
    | Pos => 0 <= n
    | Neg => n < 0
    | Top => True
    end.

  (* FILL IN HERE *)

End Sign.